diff --git a/AOD_PM_ml.f90 b/AOD_PM_ml.f90 index da880ff..3896f1c 100644 --- a/AOD_PM_ml.f90 +++ b/AOD_PM_ml.f90 @@ -53,7 +53,7 @@ module AOD_PM_ml !// subroutines public :: AOD_calc - real, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: kext + real :: kext contains @@ -83,7 +83,6 @@ subroutine AOD_calc (i,j,debug) AOD(i,j) = 0.0 - kext(i,j,:) = 0.0 do k = KCHEMTOP, KMAX_MID !_______________ vertical layer loop @@ -97,26 +96,27 @@ subroutine AOD_calc (i,j,debug) !..=> xn_2d(ispec,k) * species(ispec)%molwt * 1.e6 / AVOG [g/m3] !.. =========================================================================== - do n = 1, size(AOD_GROUP) + kext = 0.0 + do n = 1, size(AOD_GROUP) itot = AOD_GROUP(n) - kext(i,j,k) = kext(i,j,k) + & + kext= kext + & xn_2d(itot,k) * species(itot)%molwt * species(itot)%ExtC enddo - kext(i,j,k) = kext(i,j,k) * 1.0e6 / AVOG + kext = kext * 1.0e6 / AVOG ! if(debug .and. (k == 18 .or. k == KMAX_MID) ) & -! write(6,'(a17,i4,es15.3)') '> Ext. coeff', k, kext(i,j,k) +! write(6,'(a17,i4,es15.3)') '> Ext. coeff', k, kext !.. Aerosol extinction optical depth : integral over all vertical layers !.. [1/m} * [m] - AOD(i,j) = AOD(i,j) + kext(i,j,k) * (z_bnd(i,j,k)-z_bnd(i,j,k+1)) + AOD(i,j) = AOD(i,j) + kext * (z_bnd(i,j,k)-z_bnd(i,j,k+1)) ! if(debug .and. (k == 18 .or. k == KMAX_MID) ) & ! write(6,'(a25,i4,2es15.4,2f8.1)') '>> Kext AOD for layer', k, & -! kext(i,j,k), AOD(i,j), z_bnd(i,j,k), z_bnd(i,j,k+1) +! kext, AOD(i,j), z_bnd(i,j,k), z_bnd(i,j,k+1) enddo !_______________ vertical layer loop diff --git a/AOTnPOD_ml.f90 b/AOTnPOD_ml.f90 index 351fa44..ce7929e 100644 --- a/AOTnPOD_ml.f90 +++ b/AOTnPOD_ml.f90 @@ -145,9 +145,13 @@ subroutine Calc_AOTx(iO3cl,iLC, aot, debug_flag, debug_txt ) return end if - !If night, or outside growing season, we simply exit with aot=0 - if ( vego3_outputs(iO3cl)%defn == "EU" .and. (current_date%hour < 9 .or. & - current_date%hour > 21 )) then ! 8-20 CET, assuming summertime + ! If night, or outside growing season, we simply exit with aot=0 + ! EU AOT for 8:00 -- 20:00 CET, is really 8:00 -- 19:59 CET + ! Or: 7:00 -- 18:59 UTC + ! (nb hour is integer value) + + if ( vego3_outputs(iO3cl)%defn == "EU" .and. & + (current_date%hour < 7 .or. current_date%hour > 18 )) then return else if ( Grid%izen >= AOT_HORIZON ) then !UN or MM use daylight diff --git a/Advection_ml.f90 b/Advection_ml.f90 index 17888ab..50bf5c6 100644 --- a/Advection_ml.f90 +++ b/Advection_ml.f90 @@ -70,7 +70,7 @@ Module Advection_ml use CheckStop_ml, only : CheckStop use Convection_ml, only : convection_pstar use GridValues_ml, only : GRIDWIDTH_M,xm2,xmd,xm2ji,xmdji, & - carea,xm_i, Pole_included,dA,dB + carea,xm_i, Pole_Singular,dA,dB use Io_ml, only : datewrite use ModelConstants_ml, only : KMAX_BND,KMAX_MID,NMET, nstep, nmax, & dt_advec, dt_advec_inv, PT,KCHEMTOP, NPROCX,NPROCY,NPROC, & @@ -89,7 +89,7 @@ Module Advection_ml INCLUDE 'mpif.h' INTEGER STATUS(MPI_STATUS_SIZE) - real :: MPIbuff(KMAX_MID*max(gimax,gjmax)) + real,allocatable :: MPIbuff(:) integer, private, parameter :: NADVS = 3 real, private, save, dimension(KMAX_BND) :: dhs1, dhs1i, dhs2i @@ -98,9 +98,9 @@ Module Advection_ml real, private, save, dimension(9,2:KMAX_MID,0:1) :: alfnew real, private, save, dimension(3) :: alfbegnew,alfendnew - real, private,save, dimension(MAXLJMAX,KMAX_MID,NMET) :: uw,ue + real, private,save,allocatable, dimension(:,:,:) :: uw,ue - real, private,save, dimension(MAXLIMAX,KMAX_MID,NMET) :: vs,vn + real, private,save,allocatable, dimension(:,:,:) :: vs,vn integer, public, parameter :: ADVEC_TYPE = 1 ! Divides by advected p* ! integer, public, parameter :: ADVEC_TYPE = 2 ! Divides by "meteorologically" @@ -108,6 +108,7 @@ Module Advection_ml public :: assign_dtadvec public :: assign_nmax + public :: alloc_adv_arrays public :: vgrid public :: advecdiff public :: advecdiff_poles @@ -163,6 +164,8 @@ subroutine assign_dtadvec(GRIDWIDTH_M) if(me==0)write(*,fmt="(a,F8.1,a)")' advection time step (dt_advec) set to: ',dt_advec,' seconds' + call alloc_adv_arrays!should be moved elsewhere + end subroutine assign_dtadvec !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> @@ -176,7 +179,9 @@ subroutine assign_nmax(metstep) call CheckStop(mod(3600*metstep,nint(dt_advec)).ne.0, "3600*metstep/dt_advec must be an integer") - nmax = (3600*metstep)/dt_advec + ! Use nint for safety anyway: + + nmax = nint( (3600*metstep)/dt_advec ) if (me .eq. 0) then ! write(6,*) @@ -684,8 +689,13 @@ subroutine advecdiff_poles call Code_timer(tim_before) if(firstcall)then - if(NPROCY>2.and.me==0.and.Pole_included==1)write(*,*)& + if(NPROCY>2.and.me==0.and.Pole_Singular>1)then + write(*,*)& 'COMMENT: Advection routine will work faster if NDY = 2 (or 1)' + elseif(NPROCY>1.and.me==0.and.Pole_Singular==1)then + write(*,*)& + 'COMMENT: Advection routine will work faster if NDY = 1' + endif endif if(KCHEMTOP==2)then @@ -1394,16 +1404,6 @@ subroutine advvk(xn_adv,ps3d,sdot,dt_s) fc3 = fc1*fc2 n1k = 0 if(fc1.lt.0)n1k=1 -!pw bug corrected 29/8-2002 (emep1.2beta): -! zzfl1 = alfnew(1,k,n1k)*fc1 & -! + alfnew(2,k,n1k)*fc2 & -! + alfnew(3,k,n1k)*fc3 -! zzfl2 = alfnew(4,k,n1k)*fc1 & -! + alfnew(5,k,n1k)*fc2 & -! + alfnew(6,k,n1k)*fc3 -! zzfl3 = alfnew(7,k,n1k)*fc1 & -! + alfnew(8,k,n1k)*fc2 & -! + alfnew(9,k,n1k)*fc3 zzfl1 = alfnew(1,k+1,n1k)*fc1 & + alfnew(2,k+1,n1k)*fc2 & + alfnew(3,k+1,n1k)*fc3 @@ -3545,4 +3545,16 @@ end subroutine adv_int ! moved to Convection_ml.f90 + + subroutine alloc_adv_arrays + + !allocate the arrays once + allocate(MPIbuff(KMAX_MID*max(gimax,gjmax))) + allocate(uw(MAXLJMAX,KMAX_MID,NMET),ue(MAXLJMAX,KMAX_MID,NMET)) + allocate(vs(MAXLIMAX,KMAX_MID,NMET),vn(MAXLIMAX,KMAX_MID,NMET)) + + + end subroutine alloc_adv_arrays + + end module Advection_ml diff --git a/Aero_Vds_ml.f90 b/Aero_Vds_ml.f90 index 74d0e70..4f9c678 100644 --- a/Aero_Vds_ml.f90 +++ b/Aero_Vds_ml.f90 @@ -3,7 +3,7 @@ module Aero_Vds_ml !============================================================================== use PhysicalConstants_ml, only : FREEPATH, VISCO, BOLTZMANN, PI, GRAV, ROWATER use My_Aerosols_ml, only : NSIZE - use ModelConstants_ml, only : DEBUG_VDS + use ModelConstants_ml, only : DEBUG_VDS, MasterProc ! DESCRIPTION ! Calculates laminar sub-layer resistance (rb) and gravitational settling @@ -44,6 +44,13 @@ module Aero_Vds_ml public :: RuijgrokWetSO4 public :: Wesely1985 + real, public, parameter, dimension(NSIZE) :: & + ! diam = (/ 0.33e-6, 4.0e-6, 8.5e-6 /), & + !Mc: diam = (/ 0.33e-6, 1.7e-6, 8.5e-6 /), & + diam = (/ 0.33e-6, 3.0e-6, 4.0e-6, 4.5e-6 ,22e-6 /), & + ! sigma = (/ 1.8, 2.0, 2.2 /), & + sigma = (/ 1.8, 2.0, 2.0, 2.2 ,2.0/), & + PMdens = (/ 1600.0, 2200.0, 2200.0, 2600.0, 800.0/) ! kg/m3 contains !------------------------------------------------------------------------ @@ -62,13 +69,13 @@ function SettlingVelocity(tsK,roa) result(Vs) ! and dp=1.7 for coarse ! Extra 'giant' size is used for sea salt only - real, parameter, dimension(NSIZE) :: & - ! diam = (/ 0.33e-6, 4.0e-6, 8.5e-6 /), & - !Mc: diam = (/ 0.33e-6, 1.7e-6, 8.5e-6 /), & - diam = (/ 0.33e-6, 2.5e-6, 8.5e-6 /), & - ! sigma = (/ 1.8, 2.0, 2.2 /), & - sigma = (/ 1.8, 1.8, 2.2 /), & - PMdens = (/ 1600.0, 2200.0, 2200.0 /) ! kg/m3 +! real, parameter, dimension(NSIZE) :: & +! ! diam = (/ 0.33e-6, 4.0e-6, 8.5e-6 /), & +! !Mc: diam = (/ 0.33e-6, 1.7e-6, 8.5e-6 /), & +! diam = (/ 0.33e-6, 2.5e-6, 4.0e-6, 4.5e-6 ,22e-6 /), & +! ! sigma = (/ 1.8, 2.0, 2.2 /), & +! sigma = (/ 1.8, 1.8, 2.0, 2.2 ,2.0/), & +! PMdens = (/ 1600.0, 1600.0, 2200.0, 2600.0, 800.0/) ! kg/m3 real, parameter :: one2three = 1.0/3.0 integer :: imod real :: lnsig2, dg, & @@ -95,7 +102,11 @@ function SettlingVelocity(tsK,roa) result(Vs) !... Settling velocity for poly-disperse vs(imod) = vs_help*(exp(8.0*lnsig2)+1.246*knut*exp(3.5*lnsig2)) ! A31, k=3 - if (DEBUG_VDS) write(6,'(a19,i3,f8.3)') "** Settling Vd **",imod,vs(imod)*100.0 + if (DEBUG_VDS.and.MasterProc ) & + write(6,'(a,i3,es12.3,f10.3,5es12.3,3f9.2,f9.3)') & + "** Settling Vd ** ", imod, roa, tsK, & + dg,knut,Di_help,vs_help,Di, lnsig2, & + 1.0e6*diam(imod), PMdens(imod), sigma(imod), vs(imod)*100.0 end do !imod end function SettlingVelocity diff --git a/AirEmis_ml.f90 b/AirEmis_ml.f90 index fe7c795..26cbbb9 100644 --- a/AirEmis_ml.f90 +++ b/AirEmis_ml.f90 @@ -46,7 +46,7 @@ module AirEmis_ml implicit none private - real, public, dimension(KCHEMTOP:KMAX_MID,MAXLIMAX,MAXLJMAX), save :: & + real, public, dimension(:,:,:), save,allocatable :: & airn & ! aircraft NOx emissions ,airlig ! lightning NOx emissions @@ -90,7 +90,7 @@ subroutine lightning() ! molecules/cm3/s - character*20 fname + character(len=20) :: fname data ygrdum / 85.76058712, 80.26877907, 74.74454037, & 69.21297617, 63.67863556, 58.14295405, & @@ -113,6 +113,11 @@ subroutine lightning() secmonth = 1. flux(:,:,:) = 0. + + if(.not.allocated(airlig))then + allocate(airlig(KCHEMTOP:KMAX_MID,MAXLIMAX,MAXLJMAX)) + endif + ! --- Read Emission data received from DLR if(me == 0)then diff --git a/Aqueous_n_WetDep_ml.f90 b/Aqueous_n_WetDep_ml.f90 index 477dbca..0537d0a 100644 --- a/Aqueous_n_WetDep_ml.f90 +++ b/Aqueous_n_WetDep_ml.f90 @@ -1,9 +1,9 @@ ! -!*****************************************************************************! -!* +!*****************************************************************************! +!* !* Copyright (C) 2007-2011 met.no -!* +!* !* Contact information: !* Norwegian Meteorological Institute !* Box 43 Blindern @@ -11,26 +11,26 @@ !* NORWAY !* email: emep.mscw@met.no !* http://www.emep.int -!* +!* !* 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 Aqueous_ml !----------------------------------------------------------------------- ! Aqueous scavenging and cloud-processing routines. ! -! The scavenging of soluble compounds is based upon the work of Berge +! The scavenging of soluble compounds is based upon the work of Berge ! and Jakobsen (1998) and Eliassen and Saltbones (1983). ! Simple scavenging coefficients are used. A distinction is made ! between in-cloud and sub-cloud scavenging. @@ -57,133 +57,129 @@ module Aqueous_ml ! model. Atm. Env. Vol. 33, pp.2853-2879. !----------------------------------------------------------------------- - use My_Derived_ml, only : WDEP_WANTED ! Which outputs wanted! - - use CheckStop_ml, only : CheckStop - use ChemChemicals_ml, only: species + use My_Derived_ml, only: WDEP_WANTED ! Which outputs wanted! + use CheckStop_ml, only: CheckStop + use ChemChemicals_ml, only: species_adv use ChemSpecs_tot_ml use ChemSpecs_adv_ml ! IXADV_SO2, IXADV_SO4, etc. - use ChemGroups_ml, only : ChemGroups, INDEX_WDEP_SOX_GROUP, & - INDEX_WDEP_RDN_GROUP, INDEX_WDEP_OXN_GROUP - use DerivedFields_ml, only : f_2d, d_2d ! Contains Wet deposition fields - use GridValues_ml, only : gridwidth_m,xm2,dA,dB - use Io_ml, only : IO_DEBUG, datewrite - use MassBudget_ml, only : wdeploss,totwdep - use ModelConstants_ml, only: & - CHEMTMIN, CHEMTMAX & ! -> range of temperature - ,MasterProc & - ,DEBUG => DEBUG_AQUEOUS & ! - ,atwS, atwN, DEBUG_MY_WETDEP & - ,KMAX_MID & ! -> ground, k=20 - ,KUPPER & ! -> top of cloud-chemistry, k=6 - ,KCHEMTOP & ! -> top of chemistry, now k=2 - ,dt => dt_advec & ! -> model timestep - ,IOU_INST & ! Index: instantaneous values + use ChemSpecs_shl_ml, only: NSPEC_SHL + use ChemGroups_ml, only: ChemGroups, INDEX_WDEP_SOX_GROUP, & + INDEX_WDEP_RDN_GROUP, INDEX_WDEP_OXN_GROUP + use DerivedFields_ml, only: f_2d, d_2d ! Contains Wet deposition fields + use GridValues_ml, only: gridwidth_m,xm2,dA,dB + use Io_ml, only: IO_DEBUG, datewrite + use MassBudget_ml, only : wdeploss,totwdep + use ModelConstants_ml,only: & + CHEMTMIN, CHEMTMAX & ! -> range of temperature + ,MasterProc & + ,DEBUG => DEBUG_AQUEOUS, DEBUG_MY_WETDEP, DEBUG_pH & + ,KMAX_MID & ! -> ground, k=20 + ,KUPPER & ! -> top of cloud-chemistry, k=6 + ,KCHEMTOP & ! -> top of chemistry, now k=2 + ,dt => dt_advec & ! -> model timestep + ,IOU_INST & ! Index: instantaneous values ,ATWAIR ! -> atw. air - use MetFields_ml, only : pr, roa, z_bnd, cc3d, lwc - use MetFields_ml, only : ps - use OrganicAerosol_ml, only: ORGANIC_AEROSOLS - use OwnDataTypes_ml, only : depmap, typ_i3 ! has adv, calc, vg - use PhysicalConstants_ml, only: GRAV & - ,AVOG & ! Avogadro's No. - ,RGAS_ATML ! Gas-constant - use Setup_1dfields_ml, only : xn_2d, amk, Fpart, Fgas & - ,temp & ! temperature (K) - ,itemp ! temperature (K) - use SmallUtils_ml, only : find_index - - - + use MetFields_ml, only: pr, roa, z_bnd, cc3d, lwc,cw + use MetFields_ml, only: ps + use OrganicAerosol_ml, only: ORGANIC_AEROSOLS + use OwnDataTypes_ml, only: depmap ! has adv, calc, vg + use Par_ml, only: limax,ljmax, me,li0,li1,lj0,lj1 + use PhysicalConstants_ml,only: GRAV,AVOG, & ! "g" & Avogadro's No. + RGAS_ATML,RGAS_J ! Gas-constant + use Setup_1dfields_ml, only: xn_2d, amk, Fpart, Fgas, & + temp, itemp ! temperature (K) + use SmallUtils_ml, only: find_index + use Units_ml, only: Group_Scale,group_umap implicit none private ! Subroutines: - - public :: Init_WetDep ! Call from Unimod - public :: WetDep_Budget ! called here - - public :: init_aqueous - public :: Setup_Clouds ! characterises clouds and calls - ! WetDeposition if rain - public :: WetDeposition ! simplified setup_wetdep - private :: tabulate_aqueous - private :: get_frac - private :: setup_aqurates + public :: Init_WetDep ! Call from Unimod + public :: WetDep_Budget ! called here + public :: init_aqueous + public :: Setup_Clouds ! characterises clouds and calls WetDeposition if rain + public :: WetDeposition ! simplified setup_wetdep + private:: tabulate_aqueous + private:: get_frac + private:: setup_aqurates ! Outputs: - logical, public, save, dimension(KUPPER:KMAX_MID) :: & - incloud ! True for in-cloud k values - - + incloud ! True for in-cloud k values ! Variables used in module: - real, private, save, dimension(KUPPER:KMAX_MID) :: & - pr_acc ! Accumulated precipitation + pr_acc ! Accumulated precipitation +!hf NEW (here for debugging) + real, private, save, dimension(KUPPER:KMAX_MID) :: & + pH,so4_aq,no3_aq,nh4_aq,nh3_aq,hso3_aq,so2_aq,so32_aq,co2_aq,hco3_aq ! pH in cloud integer, private, save :: kcloudtop ! k-level of highest-cloud integer, private, save :: ksubcloud ! k-level just below cloud real, private, parameter :: & ! Define limits for "cloud" - PR_LIMIT = 1.0e-7 & ! for accumulated precipitation - ,CW_LIMIT = 1.0e-10 & ! for cloud water, kg(H2O)/kg(air) - ,B_LIMIT = 1.0e-3 ! for cloud cover (fraction) + PR_LIMIT = 1.0e-7, & ! for accumulated precipitation + CW_LIMIT = 1.0e-10, & ! for cloud water, kg(H2O)/kg(air) + B_LIMIT = 1.0e-3 ! for cloud cover (fraction) - real, private, save :: & ! Set in init below - INV_Hplus & ! = 1.0/Hplus (1/H+) - ,INV_Hplus0p4 ! = INV_Hplus**0.4 (1/H+)**0.4 +!hf real, private, save :: & ! Set in init below +!hf INV_Hplus & ! = 1.0/Hplus (1/H+) +!hf ,INV_Hplus0p4 ! = INV_Hplus**0.4 (1/H+)**0.4 ! The Henry's law coefficients, K, given in units of M or M atm-1, ! are calculated as effective. A factor K1fac = 1+K1/H+ is defined ! here also. integer, public, parameter :: & - NHENRY = 3, & ! No. of species with Henry's law applied - NK1 = 1, & ! No. of species needing effective Henry's calc. - IH_SO2 = 1, & - IH_H2O2 = 2, & - IH_O3 = 3 - +!hf pH + NHENRY = 5, & ! No. of species with Henry's law applied + NK1 = 1, & ! No. of species needing effective Henry's calc. + IH_SO2 = 1, & + IH_H2O2 = 2, & + IH_O3 = 3, & + IH_NH3 = 4, & !hf pH + IH_CO2 = 5 ! Aqueous fractions: - - real, public, dimension ( NHENRY, KUPPER:KMAX_MID ), save :: frac_aq - real, private, dimension (NHENRY, CHEMTMIN:CHEMTMAX), save :: H - real, private, dimension (NK1,CHEMTMIN:CHEMTMAX), save :: K1fac - + real, public, dimension(NHENRY,KUPPER:KMAX_MID), save :: frac_aq + real, private, dimension(NHENRY,CHEMTMIN:CHEMTMAX), save :: H + real, private, dimension(NK1,CHEMTMIN:CHEMTMAX), save :: K1fac +!hf NEW + real, private, dimension(CHEMTMIN:CHEMTMAX), save :: & + K1, & ! K for SO2->HSO3- + K2, & ! HSO3->SO32- + Knh3, & ! NH3+H20-> NH4+ + Kw, & ! K for water + Kco2 ! Aqueous reaction rates for usage in gas-phase chemistry: + integer, private, parameter :: & + NAQUEOUS = 4, & ! No. aqueous rates + NAQRC = 3 ! No. constant rates - integer, private, parameter :: NAQUEOUS = 4 ! No. aqueous rates - integer, private, parameter :: NAQRC = 3 ! No. constant rates - - real, public, dimension(NAQUEOUS,KCHEMTOP:KMAX_MID), save :: aqrck - + real, public, dimension(NAQUEOUS,KCHEMTOP:KMAX_MID), save :: aqrck real, private, dimension(NAQRC), save :: aqrc ! constant rates for ! so2 oxidn. real, private, dimension(2), save :: vw ! constant rates for - logical, public,save :: prclouds_present ! true if precipitating - ! clouds + logical, public,save :: prclouds_present ! true if precipitating clouds integer, public, parameter :: & - ICLOHSO2 = 1 & ! for [oh] + [so2] - ,ICLRC1 = 2 & ! for [h2o2] + [so2] - ,ICLRC2 = 3 & ! for [o3] + [so2] - ,ICLRC3 = 4 ! for [o3] + [o2] (Fe catalytic) - + ICLOHSO2 = 1, & ! for [oh] + [so2] + ICLRC1 = 2, & ! for [h2o2] + [so2] + ICLRC2 = 3, & ! for [o3] + [so2] + ICLRC3 = 4 ! for [o3] + [o2] (Fe catalytic) ! Incloud scavenging: (only dependant on precipitation (not cloud water) !----------------------------------------------------------------------- -! The parameterization of the scavenging of soluble chemical -! components is scaled to the precipitation in each layer. For -! incloud scavenging it is based on the parameterization described -! in Berge (1998). The incloud scavenging of a soluble component +! The parameterization of the scavenging of soluble chemical +! components is scaled to the precipitation in each layer. For +! incloud scavenging it is based on the parameterization described +! in Berge (1998). The incloud scavenging of a soluble component ! X is given by the expression: ! ! X * f * pr_acc * W_sca ! Q = ------------------------ ! Z_sca * rho_water ! -! where pr_acc is the accumulated precipitation in the layer, +! where pr_acc is the accumulated precipitation in the layer, ! Z_sca is the scavenging depth (scale=1000m) and rho_water is the ! density of water. ! f is an efficiency parameter. The module My_WetDep_ml should @@ -199,296 +195,274 @@ module Aqueous_ml ! from all the layers above. (From setup_1d) ! For particles the scavenging is believed to be much less effective, ! as they follow the air-current around the droplets (Berge, 1993). -! Scavenging for particles is calculated as +! Scavenging for particles is calculated as ! Q = A.e.P/v ! where A is 5.2 m3 kg-1 s-1, v is the fall-speed of the droplets, ! 5 m s-1, and e is the scavenging efficiency, 0.1. - ! ------------ WetDep initialisation (old My_WetDep -------------- - +! ------------ WetDep initialisation (old My_WetDep -------------- type, public :: WScav - real :: W_sca ! Scavenging ratio/z_Sca/rho = W_sca/1.0e6 - real :: W_sub ! same for subcloud - end type WScav - - - integer, public, parameter :: NWETDEP_CALC = 13 ! No. of solublity classes - - ! Note - these are for "master" or model species - they do not - ! need to be present in the chemical scheme. However, the chemical - ! scheme needs to define wet scavenging after these. If you would - ! like other characteristics, add them here. - + real :: W_sca ! Scavenging ratio/z_Sca/rho = W_sca/1.0e6 + real :: W_sub ! same for subcloud + endtype WScav + + integer, public, parameter :: NWETDEP_CALC = 14 ! No. of solublity classes +! Note - these are for "master" or model species - they do not +! need to be present in the chemical scheme. However, the chemical +! scheme needs to define wet scavenging after these. If you would +! like other characteristics, add them here. integer, parameter, public :: & - CWDEP_SO2 = 1, & - CWDEP_SO4 = 2, & - CWDEP_NH3 = 3, & - CWDEP_HNO3 = 4, & - CWDEP_H2O2 = 5, & - CWDEP_HCHO = 6, & - CWDEP_PMf = 7, & - CWDEP_PMc = 8, & - CWDEP_ECfn = 9, & - CWDEP_SSf = 10, & - CWDEP_SSc = 11, & - CWDEP_SSg = 12, & - CWDEP_ROOH = 13 ! TEST!! - - - - !===========================================! - ! Chemistry-dependent mapping: - ! WdepMap = (/ - ! depmap( HNO3, CWDEP_HNO3, -1) & etc. - ! .... produced from GenChem, also with e.g. - !integer, public, parameter :: NWETDEP_ADV = 14 - !===========================================! - - include 'CM_WetDep.inc' - - !===========================================! - !===========================================! - !===========================================! - - - ! And create an array to map from the "calc" to the advected species - ! Use zeroth column to store number of species in that row - - integer, public, dimension(NWETDEP_CALC,0:NWETDEP_ADV) :: Calc2tot - - ! arrays for species and groups, e.g. SOX, OXN - integer, save, private :: nwgrp = 0, nwspec = 0 ! no. groups & specs - integer, save, allocatable, dimension(:), private :: wetgroup, wetspec - - type(typ_i3), save, private, & - dimension(size(WDEP_WANTED(:)%txt1 )) :: tmpgroup, tmpspec - - type(WScav), public, dimension(NWETDEP_CALC), save :: WetDep - - integer, public, save :: WDEP_PREC ! Used in Aqueous_ml - - + CWDEP_SO2 = 1, CWDEP_SO4 = 2, CWDEP_NH3 = 3, CWDEP_HNO3 = 4, & + CWDEP_H2O2 = 5, CWDEP_HCHO = 6, CWDEP_PMf = 7, CWDEP_PMc = 8, & + CWDEP_ECfn = 9, CWDEP_SSf = 10, CWDEP_SSc = 11, CWDEP_SSg = 12, & + CWDEP_POLLw= 13, & + CWDEP_ROOH = 14 ! TEST!! + integer, parameter, public :: & + CWDEP_ASH1=CWDEP_PMf,CWDEP_ASH2=CWDEP_PMf,CWDEP_ASH3=CWDEP_PMf,& + CWDEP_ASH4=CWDEP_PMf,CWDEP_ASH5=CWDEP_PMc,CWDEP_ASH6=CWDEP_PMc,& + CWDEP_ASH7=CWDEP_PMc + +!===========================================! +! Chemistry-dependent mapping: +! WdepMap = (/ +! depmap( HNO3, CWDEP_HNO3, -1) & etc. +! .... produced from GenChem, also with e.g. +!integer, public, parameter :: NWETDEP_ADV = 14 +!===========================================! + include 'CM_WetDep.inc' +!===========================================! +!===========================================! +!===========================================! + +! And create an array to map from the "calc" to the advected species +! Use zeroth column to store number of species in that row + integer, public, dimension(NWETDEP_CALC,0:NWETDEP_ADV) :: Calc2adv + +! arrays for species and groups, e.g. SOX, OXN + integer, private, save :: nwgrp = 0, nwspec = 0 ! no. groups & specs + integer, private, allocatable, dimension(:), save :: wetGroup, wetSpec + type(group_umap), private, allocatable, dimension(:), target, save :: wetGroupUnits + + type(WScav), public, dimension(NWETDEP_CALC), save :: WetDep + + integer, public, save :: WDEP_PREC ! Used in Aqueous_ml contains - subroutine Init_WetDep() - - integer :: itot, icalc, n, nc, if2, igr, isp, alloc_err, atw - - !/ SUBCLFAC is A/FALLSPEED where A is 5.2 m3 kg-1 s-1, - ! and the fallspeed of the raindroplets is assumed to be 5 m/s. - real, parameter :: FALLSPEED = 5.0 ! m/s - real, parameter :: SUBCLFAC = 5.2 / FALLSPEED - - !/ e is the scavenging efficiency (0.02 for fine particles, 0.4 for course) - - real, parameter :: EFF25 = 0.02*SUBCLFAC & - , EFFCO = 0.4*SUBCLFAC & - , EFFGI = 0.7*SUBCLFAC - - !/.. setup the scavenging ratios for in-cloud and sub-cloud. For - ! gases, sub-cloud = 0.5 * incloud. For particles, sub-cloud= - ! efficiency * SUBCLFAC - !/.. W_Sca W_sub - WetDep(CWDEP_SO2) = WScav( 0.3, 0.15) ! Berge+Jakobsen - WetDep(CWDEP_SO4) = WScav( 1.0, EFF25) ! Berge+Jakobsen - WetDep(CWDEP_NH3) = WScav( 1.4, 0.5 ) ! subcloud = 1/3 of cloud for gases - WetDep(CWDEP_HNO3) = WScav( 1.4, 0.5) ! - WetDep(CWDEP_H2O2) = WScav( 1.4, 0.5) ! - WetDep(CWDEP_HCHO) = WScav( 0.1, 0.03) ! - WetDep(CWDEP_ECfn) = WScav( 0.0, EFF25) - WetDep(CWDEP_SSf) = WScav( 1.6, EFF25) - WetDep(CWDEP_SSc) = WScav( 1.6, EFFCO) - WetDep(CWDEP_SSg) = WScav( 1.6, EFFGI) - WetDep(CWDEP_PMf) = WScav( 1.0, EFF25) !! - WetDep(CWDEP_PMc) = WScav( 1.0, EFFCO) !! - WetDep(CWDEP_ROOH) = WScav( 0.05, 0.015) ! assumed half of HCHO - - ! Other PM compounds treated with SO4-LIKE array defined above - - !####################### gather indices from My_Derived - ! WDEP_WANTED array, and determine needed indices in d_2d - - do n = 1, size( WDEP_WANTED(:)%txt1 ) - - if2 = find_index("WDEP_"//WDEP_WANTED(n)%txt1,f_2d(:)%name) - atw = -999 - if( WDEP_WANTED(n)%txt3 == "mgS" ) atw = atwS - if( WDEP_WANTED(n)%txt3 == "mgN" ) atw = atwN - if( WDEP_WANTED(n)%txt3 == "mgSS") atw = 58 - if( WDEP_WANTED(n)%txt3 == "mm") atw = 999 ! Dummy for precip - call CheckStop( atw <1 , "AQUEOUS ATW PROBLEM:" // trim(WDEP_WANTED(n)%txt3) ) - - if ( WDEP_WANTED(n)%txt2 == "GROUP" ) then - - igr = find_index("WDEP_"//WDEP_WANTED(n)%txt1,chemgroups(:)%name) - - if(igr>0) then - nwgrp = nwgrp + 1 - tmpgroup(nwgrp) = typ_i3( igr, if2, atw ) ! link to array of - ! species integers - end if - - else if ( WDEP_WANTED(n)%txt2 == "PREC" ) then - - WDEP_PREC= find_index("WDEP_PREC",f_2d(:)%name) - igr = -999 ! just for printout - isp = -999 ! just for printout - atw = -999 - - else ! SPEC - - isp = find_index(WDEP_WANTED(n)%txt1,species(:)%name) - if(isp>0) then - nwspec = nwspec + 1 - tmpspec(nwspec) = typ_i3( isp, if2, atw ) - end if - end if - - if( DEBUG .and. MasterProc ) then - write(6,"(2a,4i5)") "WETPPP ", trim(f_2d(if2)%name), if2, igr , atw - if(igr>0) write(*,*) "WETFGROUP ", nwgrp, chemgroups(igr)%ptr, atw - if(isp>0) write(*,*) "WETFSPEC ", nwspec, isp, atw - end if - end do - allocate(wetspec(nwspec),stat=alloc_err) - call CheckStop( alloc_err /= 0, "alloc error wetspec") - allocate(wetgroup(nwgrp),stat=alloc_err) - call CheckStop( alloc_err /= 0, "alloc error wetgroup") - - ! And now we fill these arrays with the right indices: - ! Simplifies the code a little, but we still use the tmp arrays - ! to store the f2d and atw info. - - wetspec(:) = tmpspec(1:nwspec)%int1 - wetgroup(:) = tmpgroup(1:nwgrp)%int1 - - !####################### END indices here ########## - - ! Now create table to map calc species to actual advected ones: - Calc2tot = 0 - do n = 1, NWETDEP_ADV - icalc = WDepMap(n)%calc - itot = WDepMap(n)%ind - Calc2tot(icalc,0) = Calc2tot(icalc,0) + 1 - nc = Calc2tot(icalc,0) - if( MasterProc .and.DEBUG) write(6,"(a,4i5)") "CHECKING WetDep Calc2tot ", & - n,icalc,itot,nc - Calc2tot(icalc,nc) = itot - end do - - if( MasterProc.and.DEBUG ) then - write(*,*) "FINAL WetDep Calc2tot " - do icalc = 1, NWETDEP_CALC - write(*,"(i3,i4,15(1x,a))") icalc, Calc2tot(icalc,0 ), & - ( trim( species(Calc2tot(icalc,nc))%name ), & - nc= 1, Calc2tot(icalc,0 )) - end do - end if - - end subroutine Init_WetDep +subroutine Init_WetDep() + integer :: iadv, igrp, icalc, n, nc, f2d, alloc_err + character(len=30) :: dname +!/ SUBCLFAC is A/FALLSPEED where A is 5.2 m3 kg-1 s-1, +! and the fallspeed of the raindroplets is assumed to be 5 m/s. + real, parameter :: FALLSPEED = 5.0 ! m/s + real, parameter :: SUBCLFAC = 5.2 / FALLSPEED + +!/ e is the scavenging efficiency (0.02 for fine particles, 0.4 for course) + real, parameter :: EFF25 = 0.02*SUBCLFAC, & + EFFCO = 0.4 *SUBCLFAC, & + EFFGI = 0.7 *SUBCLFAC + +!/.. setup the scavenging ratios for in-cloud and sub-cloud. For +! gases, sub-cloud = 0.5 * incloud. For particles, sub-cloud= +! efficiency * SUBCLFAC +!/.. W_Sca W_sub + WetDep(CWDEP_SO2) = WScav( 0.3, 0.15) ! Berge+Jakobsen + WetDep(CWDEP_SO4) = WScav( 1.0, EFF25) ! Berge+Jakobsen + WetDep(CWDEP_NH3) = WScav( 1.4, 0.5 ) ! subcloud = 1/3 of cloud for gases + WetDep(CWDEP_HNO3) = WScav( 1.4, 0.5) ! + WetDep(CWDEP_H2O2) = WScav( 1.4, 0.5) ! + WetDep(CWDEP_HCHO) = WScav( 0.1, 0.03) ! + WetDep(CWDEP_ECfn) = WScav( 0.05, EFF25) + WetDep(CWDEP_SSf) = WScav( 1.6, EFF25) + WetDep(CWDEP_SSc) = WScav( 1.6, EFFCO) + WetDep(CWDEP_SSg) = WScav( 1.6, EFFGI) + WetDep(CWDEP_PMf) = WScav( 1.0, EFF25) !! + WetDep(CWDEP_PMc) = WScav( 1.0, EFFCO) !! + WetDep(CWDEP_POLLw) = WScav( 1.0, SUBCLFAC) ! pollen + WetDep(CWDEP_ROOH) = WScav( 0.05, 0.015) ! assumed half of HCHO + +! Other PM compounds treated with SO4-LIKE array defined above + +!####################### gather indices from My_Derived +! WDEP_WANTED array, and determine needed indices in d_2d + + nwspec=count(WDEP_WANTED(:)%txt2=="SPEC") + nwgrp =count(WDEP_WANTED(:)%txt2=="GROUP") + allocate(wetSpec(nwspec),wetGroup(nwgrp),wetGroupUnits(nwgrp),stat=alloc_err) + call CheckStop(alloc_err, "alloc error wetSpec/wetGroup") + + nwspec=0;nwgrp=0 + do n = 1, size(WDEP_WANTED(:)%txt1) + dname = "WDEP_"//trim(WDEP_WANTED(n)%txt1) + f2d = find_index(dname,f_2d(:)%name) + call CheckStop(f2d<1, "AQUEOUS f_2d PROBLEM: "//trim(dname)) + + iadv=0;igrp=0 + select case(WDEP_WANTED(n)%txt2) + case("PREC") + WDEP_PREC=f2d + if(WDEP_PREC>0) then + iadv=-999;igrp=-999 ! just for printout + elseif(DEBUG.and.MasterProc)then + call CheckStop(WDEP_PREC,find_index(dname,f_2d(:)%name),& + "Inconsistent WDEP_WANTED/f_2d definition for "//trim(dname)) + endif + case("SPEC") + iadv=f_2d(f2d)%index + if(iadv>0) then + nwspec = nwspec + 1 + wetSpec(nwspec) = f2d + elseif(DEBUG.and.MasterProc)then + call CheckStop(iadv,find_index(dname,species_adv(:)%name),& + "Inconsistent WDEP_WANTED/f_2d definition for "//trim(dname)) + endif + case("GROUP") + igrp=f_2d(f2d)%index + if(igrp>0) then + nwgrp = nwgrp + 1 + wetGroup(nwgrp) = f2d + wetGroupUnits(nwgrp) = Group_Scale(igrp,f_2d(f2d)%unit,& + debug=DEBUG.and.MasterProc) + elseif(DEBUG.and.MasterProc)then + call CheckStop(igrp,find_index(dname,chemgroups(:)%name),& + "Inconsistent WDEP_WANTED/f_2d definition for "//trim(dname)) + endif + endselect + + if(DEBUG.and.MasterProc) then + write(*,"(2a,3i5)") "WETPPP ", trim(f_2d(f2d)%name), f2d, iadv, igrp + if(igrp>0) write(*,*) "WETFGROUP ", nwgrp, wetGroupUnits(nwgrp)%iadv + if(iadv>0) write(*,*) "WETFSPEC ", nwspec, iadv + endif + enddo + +!####################### END indices here ########## + +! Now create table to map calc species to actual advected ones: + Calc2adv = 0 + do n = 1, NWETDEP_ADV + icalc = WDepMap(n)%calc + iadv = WDepMap(n)%ind + nc = Calc2adv(icalc,0) + 1 + if(MasterProc.and.DEBUG) write(*,"(a,4i5)") & + "CHECKING WetDep Calc2adv ", n,icalc,iadv,nc + Calc2adv(icalc,0 ) = nc + Calc2adv(icalc,nc) = iadv + enddo + if(MasterProc.and.DEBUG) then + write(*,*) "FINAL WetDep Calc2adv " + write(*,"(i3,i4,15(1x,a))") (icalc, Calc2adv(icalc,0), & + (trim(species_adv(Calc2adv(icalc,nc))%name),nc=1,Calc2adv(icalc,0)),& + icalc=1,NWETDEP_CALC) + endif +end subroutine Init_WetDep !----------------------------------------------------------------------- subroutine Setup_Clouds(i,j,debug_flag) - !----------------------------------------------------------------------- ! DESCRIPTION ! Define incloud and precipitating clouds. -! The layer must contain at least 1.e-7 kgwater/kg air to -! be considered a cloud. +! The layer must contain at least 1.e-7 kgwater/kg air to +! be considered a cloud. ! -! Also calculates +! Also calculates ! pr_acc - the accumulated precipitation for each k ! b - fractional cloud cover for each k !----------------------------------------------------------------------- - integer, intent(in) :: i,j - logical, intent(in) :: debug_flag + logical, intent(in) :: debug_flag real, dimension(KUPPER:KMAX_MID) :: & - b & ! Cloud-area (fraction) - ,cloudwater ! Cloud-water (volume mixing ratio) - ! cloudwater = 1.e-6 same as 1.g m^-3 - + b, & ! Cloud-area (fraction) + cloudwater, & ! Cloud-water (volume mixing ratio) + ! cloudwater = 1.e-6 same as 1.g m^-3 + pres ! Pressure (Pa) integer :: k ! Add up the precipitation in the column: - pr_acc(KUPPER) = sum ( pr(i,j,1:KUPPER) ) ! prec. from above + pr_acc(KUPPER) = sum ( pr(i,j,1:KUPPER) ) ! prec. from above do k= KUPPER+1, KMAX_MID - pr_acc(k) = pr_acc(k-1) + pr(i,j,k) - pr_acc(k) = max( pr_acc(k), 0.0 ) - end do + pr_acc(k) = pr_acc(k-1) + pr(i,j,k) + pr_acc(k) = max( pr_acc(k), 0.0 ) + enddo - prclouds_present = .false. - if ( pr_acc(KMAX_MID) > PR_LIMIT ) prclouds_present = .true. - ! --> precipitation at the surface + prclouds_present=(pr_acc(KMAX_MID)>PR_LIMIT) ! --> precipitation at the surface ! initialise with .false. and 0: incloud(:) = .false. cloudwater(:) = 0. - + pres(:)=0.0 ! Loop starting at surface finding the cloud base: - ksubcloud = KMAX_MID+1 ! k-coordinate of sub-cloud limit - - do k = KMAX_MID, KUPPER, -1 - if ( lwc(i,j,k) > CW_LIMIT ) exit - ksubcloud = k + do k = KMAX_MID, KUPPER, -1 + if(lwc(i,j,k)>CW_LIMIT) exit + ksubcloud = k end do - if ( ksubcloud == 0 ) return ! No cloud water found below level 6 - ! Cloud above level 6 are likely thin - ! cirrus clouds, and if included may - ! need special treatment... - ! ==> assume no cloud + if(ksubcloud == 0) return ! No cloud water found below level 6 + ! Cloud above level 6 are likely thin + ! cirrus clouds, and if included may + ! need special treatment... + ! ==> assume no cloud ! Define incloud part of the column requiring that both cloud water -! and cloud fractions are above limit values - +! and cloud fractions are above limit values kcloudtop = -1 ! k-level of cloud top do k = KUPPER, ksubcloud-1 - - b(k) = cc3d(i,j,k) - + b(k) = cc3d(i,j,k) ! Units: kg(w)/kg(air) * kg(air(m^3) / density of water 10^3 kg/m^3 -! ==> cloudwater (volume mixing ratio of water to air in cloud +! ==> cloudwater (volume mixing ratio of water to air in cloud ! (when devided by cloud fraction b ) -! cloudwater(k) = 1.0e-3 * cw(i,j,k,1) * roa(i,j,k,1) / b(k) - - if ( lwc(i,j,k) > CW_LIMIT ) then - cloudwater(k) = lwc(i,j,k) / b(k) ! value of cloudwater in the - ! cloud fraction of the grid - incloud(k) = .true. - if ( kcloudtop < 0 ) kcloudtop = k - end if - - end do - - if ( prclouds_present .and. kcloudtop == -1 ) then - if ( DEBUG ) write(6,"(a20,2i5,3es12.4)") & - "ERROR prclouds sum_cw", & - i,j, maxval(lwc(i,j,KUPPER:KMAX_MID),1) , & - maxval(pr(i,j,:)), pr_acc(KMAX_MID) - kcloudtop = KUPPER ! for safety - end if - -! sets up the aqueous phase reaction rates (SO2 oxidation) and the -! fractional solubility - - call setup_aqurates(b ,cloudwater,incloud) +! cloudwater(k) = 1.0e-3 * cw(i,j,k,1) * roa(i,j,k,1) / b(k) + if(lwc(i,j,k)>CW_LIMIT) then + cloudwater(k) = lwc(i,j,k) / b(k) ! value of cloudwater in the + ! cloud fraction of the grid + +!hf : alternative if cloudwater exists (and can be used) from met model +! cloudwater(k) = 1.0e-3 * cw(i,j,k,1) * roa(i,j,k,1) / b(k) +! cloudwater min 0.03 g/m3 (0.03e-6 mix ratio) +! cloudwater(k) = max(0.3e-7, (1.0e-3 * cw(i,j,k,1) * roa(i,j,k,1) )) +! cloudwater(k) = cloudwater(k)/ b(k) + incloud(k) = .true. +!hf + pres(k)=ps(i,j,1) + if(kcloudtop<0) kcloudtop = k + endif + enddo - if ( DEBUG .and. debug_flag ) then - write(6,"(a,l1,2i4,es14.4)") "DEBUG_AQ ",prclouds_present, & - kcloudtop, ksubcloud, pr_acc(KMAX_MID) - end if + if(kcloudtop == -1) then + if(prclouds_present.and.DEBUG) & + write(*,"(a20,2i5,3es12.4)") "ERROR prclouds sum_cw", & + i,j, maxval(lwc(i,j,KUPPER:KMAX_MID),1), maxval(pr(i,j,:)), pr_acc(KMAX_MID) + kcloudtop = KUPPER ! for safety + endif + +! sets up the aqueous phase reaction rates (SO2 oxidation) and the +! fractional solubility + +!hf add pres + call setup_aqurates(b ,cloudwater,incloud,pres) + + if(DEBUG_pH .and. debug_flag .and. incloud(kcloudtop)) then +! write(*,"(a,l1,2i4,es14.4)") "DEBUG_AQ ",prclouds_present, & +! kcloudtop, ksubcloud, pr_acc(KMAX_MID) + + write(*,*) "DEBUG_pH ",prclouds_present, & + kcloudtop, ksubcloud, (pH(k),k=kcloudtop,ksubcloud-1) + write(*,*) "CONC (mol/l)",& + so4_aq(ksubcloud-1),no3_aq(ksubcloud-1),nh4_aq(ksubcloud-1),& + nh3_aq(ksubcloud-1),hco3_aq(ksubcloud-1),co2_aq(ksubcloud-1) + write(*,*)"H+(ph_factor) ",& + hco3_aq(ksubcloud-1)+2.*so4_aq(ksubcloud-1)+hso3_aq(ksubcloud-1)& + +2.*so32_aq(ksubcloud-1)+no3_aq(ksubcloud-1)-nh4_aq(ksubcloud-1)-nh3_aq(ksubcloud-1) + write(*,*) "CLW(l_vann/l_luft) ",cloudwater(ksubcloud-1) + write(*,*) "xn_2d(SO4) ugS/m3 ",(xn_2d(SO4,k)*10.e12*32./AVOG,k=kcloudtop,KMAX_MID) + endif end subroutine Setup_Clouds - - !----------------------------------------------------------------------- -subroutine init_aqueous() - +subroutine init_aqueous() !----------------------------------------------------------------------- ! DESCRIPTION ! Calls initial tabulations, sets frac_aq to zero above cloud level, and @@ -498,14 +472,12 @@ subroutine init_aqueous() ! depleted within the clouds, and must be replenished from the ! surrounding cloudfree volume. !----------------------------------------------------------------------- - - - real, parameter :: & - Hplus = 5.0e-5 ! H+ (Hydrogen ion concentration) +!hf real, parameter :: & +!hf Hplus = 5.0e-5 ! H+ (Hydrogen ion concentration) +! h_plus = 5.0e-5 ! H+ (Hydrogen ion concentration) real, parameter :: MASSTRLIM = 1.0 ! Mass transport limitation - - INV_Hplus = 1.0/Hplus ! 1/H+ - INV_Hplus0p4 = INV_Hplus**0.4 ! (1/H+)**0.4 +!hf INV_Hplus = 1.0/Hplus ! 1/H+ +!hf INV_Hplus0p4 = INV_Hplus**0.4 ! (1/H+)**0.4 ! tabulations !======================== @@ -523,7 +495,7 @@ subroutine init_aqueous() aqrc(2) = 1.8e4 * 1.0e3/AVOG * MASSTRLIM ! (so2aq + hso3-) + o2 ( + Fe ) --> so4, see documentation below - aqrc(3) = 3.3e-10 * MASSTRLIM + aqrc(3) = 3.3e-10 * MASSTRLIM ! Regarding aqrc(3): ! catalytic oxidation with Fe. The assumption is that 2% of SIV @@ -536,157 +508,229 @@ subroutine init_aqueous() ! multiply with the assumed liquid water fraction from Seland and ! Iversen (0.5e-6) and with an assumed fso2 since the reaction is ! scaled by the calculated value for these parameters later. - end subroutine init_aqueous - - !----------------------------------------------------------------------- subroutine tabulate_aqueous() - !----------------------------------------------------------------------- ! DESCRIPTION ! Tabulates Henry's law coefficients over the temperature range ! defined in Tabulations_ml. ! For SO2, the effective Henry's law is given by -! Heff = H * ( 1 + K1/H+ ) +! Heff = H * ( 1 + K1/H+ ) ! where k2 is omitted as it is significant only at high pH. ! We tabulate also the factor 1+K1/H+ as K1fac. !----------------------------------------------------------------------- - real, dimension(CHEMTMIN:CHEMTMAX) :: t, tfac ! Temperature, K, factor integer :: i - t(:) = (/ ( real(i), i=CHEMTMIN, CHEMTMAX ) /) - tfac(:) = 1.0/t(:) - 1.0/298.0 + t(:) = (/ ( real(i), i=CHEMTMIN, CHEMTMAX ) /) + tfac(:) = 1.0/t(:) - 1.0/298.0 - H (IH_SO2 ,:) = 1.23 * exp(3020.0*tfac(:) ) - H (IH_H2O2,:) = 7.1e4 * exp(6800.0*tfac(:) ) - H (IH_O3 ,:) = 1.13e-2 * exp(2300.0*tfac(:) ) + H(IH_SO2 ,:) = 1.23 * exp(3020.0*tfac(:)) + H(IH_H2O2,:) = 7.1e4 * exp(6800.0*tfac(:)) + H(IH_O3 ,:) = 1.13e-2 * exp(2300.0*tfac(:)) + H(IH_NH3 ,:) = 60.0 * exp(4400.0*tfac(:)) !http://www.ceset.unicamp.br/~mariaacm/ST405/Lei%20de%20Henry.pdf + H(IH_CO2,:) = 3.5e-2 * exp(2400.0*tfac(:)) !http://www.ceset.unicamp.br/~mariaacm/ST405/Lei%20de%20Henry.pdf -! Need effective Henry's coefficient for SO2: - K1fac(IH_SO2 ,:) = & - ( 1.0 + 1.23e-2 * exp(2010.0*tfac(:) ) * INV_Hplus) - - H (IH_SO2 ,:) = H(IH_SO2,:) * K1fac(IH_SO2,:) + K1(:) = 1.23e-2 * exp( 2010.0*tfac(:)) + K2(:) = 6.6e-8 * exp( 1122.0*tfac(:))!Seinfeldt&Pandis 1998 + Knh3(:) = 1.7e-5 * exp(-4353.0*tfac(:))!Seinfeldt&Pandis 1998 + Kw(:) = 1.0e-14 * exp(-6718.0*tfac(:))!Seinfeldt&Pandis 1998 + Kco2(:) = 4.3e-7 * exp( -921.0*tfac(:))!Seinfeldt&Pandis 1998 end subroutine tabulate_aqueous - !----------------------------------------------------------------------- - -subroutine setup_aqurates(b ,cloudwater,incloud) - +subroutine setup_aqurates(b ,cloudwater,incloud,pres) !----------------------------------------------------------------------- ! DESCRIPTION ! sets the rate-coefficients for thr aqueous-phase reactions !----------------------------------------------------------------------- - - real, dimension(KUPPER:KMAX_MID) :: & - b & ! cloud-aread (fraction) - ,cloudwater ! cloud-water + b, & ! cloud-aread (fraction) + cloudwater, & ! cloud-water + pres ! Pressure(Pa) !hf + logical, dimension(KUPPER:KMAX_MID) :: & - incloud ! True for in-cloud k values + incloud ! True for in-cloud k values ! Outputs -> aqurates ! local real, dimension(KUPPER:KMAX_MID) :: & - fso2grid & ! f_aq * b = {f_aq} - ,fso2aq & ! only so2.h2o part (not hso4-) - ,caqh2o2 & ! rate of oxidation of so2 with H2O2 - ,caqo3 & ! rate of oxidation of so2 with H2O2 - ,caqsx ! rate of oxidation of so2 with o2 ( Fe ) + fso2grid, & ! f_aq * b = {f_aq} + fso2aq, & ! only so2.h2o part (not hso3- and so32-) + caqh2o2, & ! rate of oxidation of so2 with H2O2 + caqo3, & ! rate of oxidation of so2 with H2O2 + caqsx ! rate of oxidation of so2 with o2 ( Fe ) - integer k +! PH + real, dimension(KUPPER:KMAX_MID) :: & + phfactor, & + h_plus + + real, parameter :: CO2conc_ppm = 392 !mix ratio for CO2 in ppm + real :: CO2conc !Co2 in mol/l + !real :: invhplus04, K1_fac,K1K2_fac, Heff,Heff_NH3 + real :: invhplus04, K1K2_fac, Heff,Heff_NH3,pH_old + integer, parameter :: pH_ITER = 2 ! num iter to calc pH. + !Do not change without knowing what you are doing + real, dimension (KUPPER:KMAX_MID) :: VfRT ! Vf * Rgas * Temp + real, parameter :: Hplus43=5.011872336272724E-005! 10.0**-4.3 + real, parameter :: Hplus55=3.162277660168379e-06! 10.0**-5.5 + real ::pHin(0:pH_ITER),pHout(0:pH_ITER)!start at zero to avoid debugger warnings for iter-1 + integer k, iter call get_frac(cloudwater,incloud) ! => frac_aq - + ! initialize: aqrck(:,:)=0. +! for PH + + pH(:)=4.3!dspw 13082012 + h_plus(:)=Hplus43!dspw 13082012 + pH(:)=5.5!stpw 23082012 + h_plus(:)=Hplus55!stpw 23082012 + ph_old=0.0 ! Gas phase ox. of SO2 is "default" ! in cloudy air, only the part remaining in gas phase (not -! dissolved) is oxidized - - aqrck(ICLOHSO2,:) = 1.0 +! dissolved) is oxidized + aqrck(ICLOHSO2,:) = 1.0 do k = KUPPER,KMAX_MID - if ( incloud(k) ) then ! Vf > 1.0e-10) ! lwc > CW_limit - fso2grid(k) = b(k) * frac_aq(IH_SO2,k) - fso2aq (k) = fso2grid(k) / K1fac(IH_SO2,itemp(k)) - caqh2o2 (k) = aqrc(1) * frac_aq(IH_H2O2,k) / cloudwater(k) - caqo3 (k) = aqrc(2) * frac_aq(IH_O3,k) / cloudwater(k) - caqsx (k) = aqrc(3) / cloudwater(k) - -! oh + so2 gas-phase - aqrck(ICLOHSO2,k) = ( 1.0-fso2grid(k) ) ! now correction factor! - aqrck(ICLRC1,k) = caqh2o2(k) * fso2aq(k) - aqrck(ICLRC2,k) = caqo3(k) * INV_Hplus0p4 * fso2grid(k) - aqrck(ICLRC3,k) = caqsx(k) * fso2grid(k) - - end if + if(.not.incloud(k)) cycle ! Vf > 1.0e-10) ! lwc > CW_limit +!For pH calculations: +!Assume total uptake of so4,no3,hno3,nh4+ +!For pH below 5, all NH3 will be dissolved, at pH=6 around 50% +!Effectively all dissolved NH3 will ionize to NH4+ (Seinfeldt) + so4_aq(k)= (xn_2d(SO4,k)*1000./AVOG)/cloudwater(k) !xn_2d=molec cm-3 + !cloudwater volume mix. ratio + !so4_aq= mol/l + no3_aq(k)= ( (xn_2d(NO3_F,k)+xn_2d(HNO3,k))*1000./AVOG)/cloudwater(k) + nh4_aq(k)= ( xn_2d(NH4_F,k) *1000./AVOG )/cloudwater(k)!only nh4+ now + ! hso3_aq(k)= 0.0 !initial, before dissolved + ! so32_aq(k)= 0.0 + ! nh3_aq(k) = 0.0 !nh3 dissolved and ionized to nh4+(aq) + ! hco3_aq(k) = 0.0 !co2 dissolved and ionized to hco3 + + VfRT(k) = cloudwater(k) * RGAS_ATML * temp(k) + + !dissolve CO2 and SO2 (pH independent) + !CO2conc=392 ppm + CO2conc=CO2conc_ppm * 1e-9 * pres(k)/(RGAS_J *temp(k)) !mol/l + + frac_aq(IH_CO2,k) = 1.0 / ( 1.0+1.0/( H(IH_CO2,itemp(k))*VfRT(k) ) ) + co2_aq(k)=frac_aq(IH_CO2,k)*CO2CONC /cloudwater(k) + + frac_aq(IH_SO2,k) = 1.0 / ( 1.0+1.0/( H(IH_SO2,itemp(k))*VfRT(k) ) ) + so2_aq(k)= frac_aq(IH_SO2,k)*(xn_2d(SO2,k)*1000./AVOG)/cloudwater(k) + + + do iter = 1,pH_ITER !iteratively calc pH + pHin(iter)=pH(k)!save input pH + +! moved pH calculation after X_aq determination + !nh4+, hco3, hso3 and so32 dissolve and ionize + Heff_NH3= H(IH_NH3,itemp(k))*Knh3(itemp(k))*h_plus(k)/Kw(itemp(k)) + frac_aq(IH_NH3,k) = 1.0 / ( 1.0+1.0/( Heff_NH3*VfRT(k) ) ) + nh3_aq(k)= frac_aq(IH_NH3,k)*(xn_2d(NH3,k)*1000./AVOG)/cloudwater(k) + + hco3_aq(k)= co2_aq(k) * Kco2(itemp(k))/h_plus(k) + hso3_aq(k)= so2_aq(k) * K1(itemp(k))/h_plus(k) + so32_aq(k)= hso3_aq(k) * K2(itemp(k))/h_plus(k) + + pH_old=pH(k) + phfactor(k)=hco3_aq(k)+2.*so4_aq(k)+hso3_aq(k)+2.*so32_aq(k)+no3_aq(k)-nh4_aq(k)-nh3_aq(k) + h_plus(k)=0.5*(phfactor(k) + sqrt(phfactor(k)*phfactor(k)+4.*1.e-14) ) + h_plus(k)=min(1.e-1,max(h_plus(k),1.e-7))! between 1 and 7 + pH(k)=-log(h_plus(k))/log(10.) + + pHout(iter)=pH(k)!save output pH + + if(iter>1.and.(abs(pHin(iter-1)-pHin(iter)-pHout(iter-1)+pHout(iter))>1.E-10))then + !linear interpolation for pH . (Solution of f(pH)=pH) + !assume a linear relation between pHin and pHout. + !make a straight line between vaues at iter and iter-a, + !and find where the line cross the diagonal, i.e. pHin = pHout + pH(k)=(pHin(iter-1)*pHout(iter)-pHin(iter)*pHout(iter-1))& + /(pHin(iter-1)-pHin(iter)-pHout(iter-1)+pHout(iter)) + pH(k)=max(1.0,min(pH(k),7.0))! between 1 and 7 + h_plus(k)=exp(-pH(k)*log(10.)) + endif + + enddo + + +!after pH determined, final numbers of frac_aq(IH_SO2) +!= effective fraction of S(IV): +!include now also ionization to SO32- +! K1_fac = & +! 1.0 + K1(k)/h_plus(k) !not used +! H (IH_SO2 ,itemp(k)) = H(IH_SO2,itemp(k)) * K1_fac + invhplus04= (1.0/h_plus(k))**0.4 + K1K2_fac=& + 1.0 + K1(itemp(k))/h_plus(k) + K1(itemp(k))*K2(itemp(k))/(h_plus(k)**2) + Heff = H(IH_SO2,itemp(k)) * K1K2_fac + frac_aq(IH_SO2,k) = 1.0 / ( 1.0+1.0/( Heff*VfRT(k) ) ) + fso2grid(k) = b(k) * frac_aq(IH_SO2,k)!frac of S(IV) in grid in aqueous phase +! fso2aq (k) = fso2grid(k) / K1_fac + fso2aq (k) = fso2grid(k) / K1K2_fac !frac of SO2 in total grid in aqueous phase + caqh2o2 (k) = aqrc(1) * frac_aq(IH_H2O2,k) / cloudwater(k) + caqo3 (k) = aqrc(2) * frac_aq(IH_O3,k) / cloudwater(k) + caqsx (k) = aqrc(3) / cloudwater(k) + ! oh + so2 gas-phase + aqrck(ICLOHSO2,k) = ( 1.0-fso2grid(k) ) ! now correction factor! + aqrck(ICLRC1,k) = caqh2o2(k) * fso2aq(k) !only SO2 + ! aqrck(ICLRC2,k) = caqo3(k) * INV_Hplus0p4 * fso2grid(k) + aqrck(ICLRC2,k) = caqo3(k) * invhplus04 * fso2grid(k) + aqrck(ICLRC3,k) = caqsx(k) * fso2grid(k) enddo - end subroutine setup_aqurates - - !----------------------------------------------------------------------- subroutine get_frac(cloudwater,incloud) - !----------------------------------------------------------------------- ! DESCRIPTION ! Calculating pH dependant solubility fractions: Calculates the fraction ! of each soluble gas in the aqueous phase, frac_aq !----------------------------------------------------------------------- - ! intent in from used modules : cloudwater and logical incloud ! intent out to rest of module : frac_aq - ! local - real, dimension (KUPPER:KMAX_MID) :: & - cloudwater ! Volume fraction - see notes above. - logical, dimension(KUPPER:KMAX_MID) :: & - incloud ! True for in-cloud k values - real, dimension (KUPPER:KMAX_MID) :: VfRT ! Vf * Rgas * Temp - - integer :: ih, k ! index over species with Henry's law, vertical level k + real, dimension (KUPPER:KMAX_MID), intent(in) :: & + cloudwater ! Volume fraction - see notes above. + logical, dimension(KUPPER:KMAX_MID), intent(in) :: & + incloud ! True for in-cloud k values + real :: VfRT ! Vf * Rgas * Temp + integer :: ih, k ! index over species with Henry's law, vertical level k ! Make sure frac_aq is zero outside clouds: - frac_aq(:,:) = 0. + frac_aq(:,:) = 0.0 do k = KUPPER, KMAX_MID - if ( incloud(k) ) then - - VfRT(k) = cloudwater(k) * RGAS_ATML * temp(k) + if(.not.incloud(k)) cycle + VfRT = cloudwater(k) * RGAS_ATML * temp(k) ! Get aqueous fractions: - do ih = 1, NHENRY - frac_aq(ih,k) = 1.0 / ( 1.0+1.0/( H(ih,itemp(k))*VfRT(k) ) ) - end do - - end if - end do - + do ih = 1, NHENRY + frac_aq(ih,k) = 1.0 / ( 1.0+1.0/( H(ih,itemp(k))*VfRT ) ) + enddo + enddo end subroutine get_frac - - !----------------------------------------------------------------------- subroutine WetDeposition(i,j,debug_flag) - !----------------------------------------------------------------------- ! DESCRIPTION ! Calculates wet deposition and changes in xn concentrations ! WetDeposition called from RunChem if precipitation reach the surface !----------------------------------------------------------------------- - ! input integer, intent(in) :: i,j - logical, intent(in) :: debug_flag + logical, intent(in) :: debug_flag ! local - integer :: itot,is ! index in xn_2d arrays + integer :: itot,iadv,is ! index in xn_2d arrays integer :: k, icalc real :: invgridarea ! xm2/(h*h) @@ -700,117 +744,101 @@ subroutine WetDeposition(i,j,debug_flag) f_rho = 1.0/(invgridarea*GRAV*ATWAIR) ! Loop starting from above: do k=kcloudtop, KMAX_MID ! No need to go above cloudtop - rho(k) = f_rho*(dA(k) + dB(k)*ps(i,j,1))/ amk(k) - end do + rho(k) = f_rho*(dA(k) + dB(k)*ps(i,j,1))/ amk(k) + enddo wdeploss(:) = 0.0 - ! calculate concentration after wet deposition and sum up the vertical ! column of the depositions for the fully soluble species. - if ( DEBUG .and. debug_flag ) then - Write(6,*) "(a15,2i4,es14.4)", "DEBUG_WDEP2", & - kcloudtop, ksubcloud, pr_acc(KMAX_MID) - end if ! DEBUG + if(DEBUG.and.debug_flag) write(*,*) "(a15,2i4,es14.4)", & + "DEBUG_WDEP2", kcloudtop, ksubcloud, pr_acc(KMAX_MID) do icalc = 1, NWETDEP_CALC ! Here we loop over "model" species ! Put both in- and sub-cloud scavenging ratios in the array vw: -!TMP xnloss = 0.0 - vw(kcloudtop:ksubcloud-1) = WetDep(icalc)%W_sca ! Scav. for incloud - vw(ksubcloud:KMAX_MID ) = WetDep(icalc)%W_sub ! Scav. for subcloud - - do k = kcloudtop, KMAX_MID + vw(kcloudtop:ksubcloud-1) = WetDep(icalc)%W_sca ! Scav. for incloud + vw(ksubcloud:KMAX_MID ) = WetDep(icalc)%W_sub ! Scav. for subcloud - lossfac(k) = exp( -vw(k)*pr_acc(k)*dt ) + do k = kcloudtop, KMAX_MID + lossfac(k) = exp( -vw(k)*pr_acc(k)*dt ) - ! For each "calc" species we have often a number of model - ! species - do is = 1, Calc2tot(icalc,0) ! number of species - itot = Calc2tot(icalc,is) + ! For each "calc" species we have often a number of model + ! species + do is = 1, Calc2adv(icalc,0) ! number of species + iadv = Calc2adv(icalc,is) + itot = iadv+NSPEC_SHL ! For semivolatile species only the particle fraction is deposited - - if ( itot >= FIRST_SEMIVOL .and. itot <= LAST_SEMIVOL) then - loss = xn_2d(itot,k) * Fpart(itot,k)*( 1.0 - lossfac(k) ) - else - loss = xn_2d(itot,k) * ( 1.0 - lossfac(k) ) - endif - xn_2d(itot,k) = xn_2d(itot,k) - loss - wdeploss(itot) = wdeploss(itot) + loss * rho(k) - end do ! is - - - end do ! k loop - if ( DEBUG .and. debug_flag .and. pr_acc(20)>1.0e-5 ) then - do k = kcloudtop, KMAX_MID - Write(6,"(a,2i4,a,9es12.2)") "DEBUG_WDEP, k, icalc, spec", k, & - icalc, trim(species(itot)%name), vw(k), pr_acc(k), lossfac(k) - end do ! k loop - end if ! DEBUG - - end do ! icalc loop - - d_2d(WDEP_PREC,i,j,IOU_INST) = sum ( pr(i,j,:) ) * dt - ! Same for all models + if(itot>=FIRST_SEMIVOL .and. itot<=LAST_SEMIVOL) then + loss = xn_2d(itot,k) * Fpart(itot,k)*( 1.0 - lossfac(k) ) + else + loss = xn_2d(itot,k) * ( 1.0 - lossfac(k) ) + endif + xn_2d(itot,k) = xn_2d(itot,k) - loss + wdeploss(iadv) = wdeploss(iadv) + loss * rho(k) + enddo ! is + enddo ! k loop + + if(DEBUG.and.debug_flag.and.pr_acc(20)>1.0e-5) then + do k = kcloudtop, KMAX_MID + write(*,"(a,2i4,a,9es12.2)") "DEBUG_WDEP, k, icalc, spec", k, & + icalc, trim(species_adv(iadv)%name), vw(k), pr_acc(k), lossfac(k) + enddo ! k loop + endif ! DEBUG + + enddo ! icalc loop + + d_2d(WDEP_PREC,i,j,IOU_INST) = sum (pr(i,j,:)) * dt ! Same for all models ! add other losses into twetdep and wdep arrays: - call WetDep_Budget(i,j,invgridarea, debug_flag) - + call WetDep_Budget(i,j,invgridarea,debug_flag) end subroutine WetDeposition - !----------------------------------------------------------------------- - subroutine WetDep_Budget(i,j,invgridarea, debug_flag) - integer, intent(in) :: i,j - real, intent(in) :: invgridarea - logical, intent(in) :: debug_flag - - real :: wdep - real :: fwt - integer :: itot, n, n2, igr, f2d - - ! Process groups of species, SOX, OXN, DUST ..... as needed - do n = 1, nwgrp - wdep = 0.0 - igr = wetgroup(n) - f2d = tmpgroup(n)%int2 - fwt = tmpgroup(n)%int3 * invgridarea ! int3=atw - - do n2 = 1, size( chemgroups(igr)%ptr ) - itot = chemgroups(igr)%ptr(n2) - wdep = wdep + wdeploss(itot) - if( DEBUG_MY_WETDEP .and. debug_flag ) & - call datewrite("WET-PPPGROUP: "//species(itot)%name ,& - itot, (/ wdeploss(itot) /) ) - end do ! n2 - -!Hardcoded TEMPORARY! - if(igr==INDEX_WDEP_SOX_GROUP)totwdep(IXADV_SO4) = totwdep(IXADV_SO4)+wdep - if(igr==INDEX_WDEP_OXN_GROUP)totwdep(IXADV_HNO3) = totwdep(IXADV_HNO3)+wdep - if(igr==INDEX_WDEP_RDN_GROUP)totwdep(IXADV_NH3) = totwdep(IXADV_NH3)+wdep - - d_2d(f2d,i,j,IOU_INST) = wdep * fwt - end do ! n - - ! Process individual species, SOX, OXN, DUST ..... as needed - - do n = 1, nwspec - - itot = wetspec(n) - f2d = tmpspec(n)%int2 - fwt = tmpspec(n)%int3 * invgridarea ! int3=atw - d_2d(f2d,i,j,IOU_INST) = wdeploss(itot) * fwt - - if( DEBUG_MY_WETDEP .and. debug_flag ) & - call datewrite("WET-PPPSPEC: "//species(itot)%name ,& - itot, (/ wdeploss(itot) /) ) - - end do ! n - - end subroutine WetDep_Budget - +subroutine WetDep_Budget(i,j,invgridarea, debug_flag) + integer, intent(in) :: i,j + real, intent(in) :: invgridarea + logical, intent(in) :: debug_flag + + logical :: inside + integer :: f2d, igrp ,iadv, n, g + real :: wdep + type(group_umap), pointer :: gmap=>null() ! group unit mapping + + ! Mass Budget: Do not include values on outer frame + if(.not.(ili1.or.jlj1)) & + totwdep(:) = totwdep(:) + wdeploss(:) + + ! Deriv.Output: individual species (SO4, HNO3, etc.) as needed + do n = 1, nwspec + f2d = wetSpec(n) + iadv = f_2d(f2d)%index + d_2d(f2d,i,j,IOU_INST) = wdeploss(iadv) * invgridarea + + if(DEBUG_MY_WETDEP.and.debug_flag) & + call datewrite("WET-PPPSPEC: "//species_adv(iadv)%name,& + iadv,(/wdeploss(iadv)/)) + enddo + ! Deriv.Output: groups of species (SOX, OXN, etc.) as needed + do n = 1, nwgrp + f2d = wetGroup(n) + gmap => wetGroupUnits(n) + igrp = f_2d(f2d)%index + + wdep = dot_product(wdeploss(gmap%iadv),gmap%uconv(:)) + d_2d(f2d,i,j,IOU_INST) = wdep * invgridarea + + if(DEBUG_MY_WETDEP.and.debug_flag)then + do g=1,size(gmap%iadv) + iadv=gmap%iadv(g) + call datewrite("WET-PPPGROUP: "//species_adv(iadv)%name ,& + iadv,(/wdeploss(iadv)/)) + enddo + endif + enddo +end subroutine WetDep_Budget !----------------------------------------------------------------------- end module Aqueous_ml diff --git a/BLPhysics_ml.f90 b/BLPhysics_ml.f90 index 70e7e8d..6b7e7bf 100644 --- a/BLPhysics_ml.f90 +++ b/BLPhysics_ml.f90 @@ -4,6 +4,8 @@ module BLPhysics_ml ! here in future. Try to keep 1-D or elemental to allow use in offline codes ! (*No* routines in use, except for testing) + use Landuse_ml, only : Landcover, water_fraction + use MetFields_ml, only : nwp_sea use ModelConstants_ml, only : KMAX_MID, KMAX_BND, KWINDTOP, PT use PhysicalConstants_ml, only : KARMAN, GRAV implicit none @@ -34,6 +36,11 @@ module BLPhysics_ml !"BW" ! Brost Wynngard !"Sb" ! Seibert +!Movbed +! character(len=4), parameter, public :: FluxPROFILE = & +! "Iter" ! +! ! "Ln95" ! ! will use Launiainen1995 + logical, parameter, public :: PIELKE = .true. real, public, parameter :: KZ_MINIMUM = 0.001 ! m2/s real, public, parameter :: KZ_MAXIMUM = 1.0e3 ! m2/s - as old kzmax @@ -48,7 +55,9 @@ module BLPhysics_ml public :: SeibertRiB_Hmix public :: SeibertRiB_Hmix_3d public :: JericevicRiB_Hmix +public :: JericevicRiB_Hmix0 ! Now allow mixing heights based upon surface T public :: Venkatram_Hmix +public :: VogelezangHoltslag_Hmix public :: Zilitinkevich_Hmix public :: TI_Hmix @@ -84,25 +93,26 @@ module BLPhysics_ml !---------------------------------------------------------------------------- -function BrostWyngaardKz(z,h,ustar,invL) result(Kz) +function BrostWyngaardKz(z,h,ustar,invL,Kdef) result(Kz) real, intent(in) :: z ! height real, intent(in) :: h ! Boundary layer depth real, intent(in) :: ustar! u* real, intent(in) :: invL ! 1/L + real, intent(in) :: Kdef ! 1/L real :: Kz if ( z < h ) then Kz = KARMAN * ustar * z * (1-z/h)**1.5 / (1+5*z*invL) else - Kz= 0.0 + Kz = Kdef end if end function BrostWyngaardKz -function JericevicKz(z,h,ustar) result(Kz) +function JericevicKz(z,h,ustar,Kdef) result(Kz) real, intent(in) :: z ! height real, intent(in) :: h ! Boundary layer depth - real, intent(in) :: ustar! u* + real, intent(in) :: ustar, Kdef ! u*, default Kz real :: Kz real :: Kmax, zmax @@ -111,8 +121,12 @@ function JericevicKz(z,h,ustar) result(Kz) Kmax = 0.05 * h * ustar zmax = 0.21 * h Kz = 0.39 * ustar * z * exp( -0.5*(z/zmax)**2 ) - else - Kz= 0.0 + !OS_TEST_Hmix1 + + else ! open-source had this Kz=0.0 line. Not sure why + !OS_TEST_Hmix1 + !Kz= 0.0 + Kz = Kdef end if end function JericevicKz @@ -157,7 +171,7 @@ end subroutine SeibertRiB_Hmix_3d !---------------------------------------------------------------------------- subroutine SeibertRiB_Hmix (u,v, zm, theta, pzpbl) - real, dimension(KWINDTOP:KMAX_MID), intent(in) :: u,v ! winds + real, dimension(KMAX_MID), intent(in) :: u,v ! winds real, dimension(KMAX_MID), intent(in) :: zm ! mid-cell height real, dimension(KMAX_MID), intent(in) :: theta !pot. temp real, intent(out) :: pzpbl @@ -186,7 +200,7 @@ end subroutine SeibertRiB_Hmix !---------------------------------------------------------------------------- subroutine JericevicRiB_Hmix (u,v, zm, theta, zi) - real, dimension(KWINDTOP:KMAX_MID), intent(in) :: u,v ! winds + real, dimension(KMAX_MID), intent(in) :: u,v ! winds real, dimension(KMAX_MID), intent(in) :: zm ! mid-cell height real, dimension(KMAX_MID), intent(in) :: theta !pot. temp real, intent(out) :: zi @@ -214,6 +228,78 @@ subroutine JericevicRiB_Hmix (u,v, zm, theta, zi) end subroutine JericevicRiB_Hmix + !---------------------------------------------------------------------------- +subroutine JericevicRiB_Hmix0 (u,v, zm, theta, zi, theta0, coastal) + !- as above, but allow test for surface SBL + real, dimension(KMAX_MID), intent(in) :: u,v ! winds + real, dimension(KMAX_MID), intent(in) :: zm ! mid-cell height + real, dimension(KMAX_MID), intent(in) :: theta !pot. temp + real, intent(out) :: zi + real, intent(in) :: theta0 ! pot temp at ground (2m) + logical, intent(in) :: coastal ! or likely coastal, be careful + integer :: k + real, parameter :: Ric = 0.25 ! critical Ric + real :: Rib ! bulk Richardson number + real :: Theta1, z1 ! pot temp and height of lowest cell + +! Jericevic et al., ACP, 2009, pp1001-, eqn (17): + + Theta1 = theta(KMAX_MID) + z1 = zm(KMAX_MID) + zi = z1 ! start val + + do k=KMAX_MID-1, KWINDTOP, -1 + + Rib = GRAV * ( zm(k) - z1 ) & + * (theta(k)-Theta1 ) / & + ( 0.5*(theta(k)+Theta1) * ( u(k)**2 + v(k)**2 )+EPS ) + if(Rib >= Ric) then + zi = zm(k) + exit + endif + enddo + +end subroutine JericevicRiB_Hmix0 + +subroutine VogelezangHoltslag_Hmix (u,v, zm, theta, q, ustar, pzpbl) + real, dimension(KMAX_MID), intent(in) :: u,v ! winds + real, dimension(KMAX_MID), intent(in) :: zm ! mid-cell height + real, dimension(KMAX_MID), intent(in) :: theta !pot. temp + real, dimension(KMAX_MID), intent(in) :: q ! spec humid + real, intent(in) :: ustar + real, intent(out) :: pzpbl + real, dimension(KMAX_MID):: tv !virtual pot. temp + integer :: k + real, parameter :: Ric = 0.25 ! critical Ric + real :: Rig ! bulk Richardson number + real :: Theta1, u1, v1, z1, bu2 ! values for lowest grid cell + +! Vogelezang, D. & Holtslag, A., BLM, 1996, 81, 245-269, Eqn. (3) +! Although we should use virtual pot temp, not just theta + + + ! Calculate virtual temperature + + tv(:) = theta(:) * (1.0+0.622*q(:)) + + Theta1 = tv(KMAX_MID) + z1 = zm(KMAX_MID) + bu2 = 100.0 * ustar * ustar + u1 = u(KMAX_MID) + v1 = v(KMAX_MID) + + do k=KMAX_MID-1, KWINDTOP, -1 + Rig = GRAV * ( zm(k) - z1 ) & + *(tv(k)-Theta1 ) / & + ( Theta1 * ( ( u(k) - u1) **2 + ( v(k) - v1) **2 )+ bu2 + EPS ) + !print *, k, zm(k), theta(k), sqrt(( u(k)**2 + v(k)**2 )), RiB + if(Rig >= Ric) then + pzpbl = zm(k) + exit + endif + enddo + +end subroutine VogelezangHoltslag_Hmix !---------------------------------------------------------------------------- function Venkatram_Hmix (ustar) result(zi) real, intent(in) :: ustar @@ -292,9 +378,10 @@ subroutine PielkeBlackadarKz (u,v, zm, zb, th, Kz, Pielke_flag, debug_flag) !if( debug_flag ) write(6,*) "BLPielke Ris ",k, Ris(k), Ric if (Ris(k) > Ric ) then Kz(k) = KZ_MINIMUM + if( debug_flag ) write(6,"(a,i3,9es10.2)") "BLPielke Kmin ",k, Ris(k), Ric, Kz(k) else Kz(k) = 1.1 * (Ric-Ris(k)) * xl2 * dvdz /Ric - if( debug_flag ) write(6,"(a,es10.2,f6.3,9es10.2)") "BLPielke Ks ", & + if( debug_flag ) write(6,"(a,i3,es10.2,f6.3,9es10.2)") "BLPielke Ks ",k, & Ris(k), Ric, xl2, dvdz, Kz(k) end if else @@ -319,7 +406,7 @@ end subroutine PielkeBlackadarKz !---------------------------------------------------------------------------- subroutine Test_BLM (mm,dd,hh,fH,u,v, zm, zb, pb, exnm, & - th, Kz, Kz_nwp, invL, ustar, zi ) + th, q, Kz, Kz_nwp, invL, ustar, zi ) integer, intent(in) :: mm, dd, hh ! date real, intent(in) :: fh ! heart flux, -ve = Unstable real, dimension(:), intent(in) :: u,v ! winds @@ -328,6 +415,7 @@ subroutine Test_BLM (mm,dd,hh,fH,u,v, zm, zb, pb, exnm, & real, dimension(:), intent(in) :: zb ! cell boundary height real, dimension(:), intent(in) :: pb ! pressure at boundaries real, dimension(:), intent(in) :: th ! pot. temp + real, dimension(:), intent(in) :: q ! specific humid ! TEST Vogel real, dimension(:), intent(in) :: Kz ! Kz (m2/s) real, dimension(:), intent(in) :: Kz_nwp ! Kz from NWP if available/used real, intent(in) :: ustar ! m/s @@ -341,7 +429,7 @@ subroutine Test_BLM (mm,dd,hh,fH,u,v, zm, zb, pb, exnm, & ,Kz_BW &! Kz Brost-Wynaargd, unstable ,Kz_PBT &! Kz Pielke+Blackader, Pielke flag=T ,Kz_PBF ! Kz " " flag=F - real :: ziSeibert, ziJericevic, ziVenki, ziTI + real :: ziSeibert, ziJericevic, ziVenki, ziTI, ziVH write(*,*)"HmixMETHOD "//HmixMethod write(*,*)"KzMETHOD "//KzMethod//"-U:"//UnstableKzMethod// & @@ -359,17 +447,19 @@ subroutine Test_BLM (mm,dd,hh,fH,u,v, zm, zb, pb, exnm, & call JericevicRiB_Hmix (u,v, zm, th, ziJericevic) + call VogelezangHoltslag_Hmix (u,v, zm, th, q, ustar, ziVH) + ziVenki = Venkatram_Hmix(ustar) call TI_Hmix(Kz_PBT, zm, zb, fh, th, exnm, pb, ziTI, debug_flag=.true.) - write(*,"(a,3i3,f9.3,10(a,f7.1))") "TEST_BLM fh:", mm, dd, hh, fh, & + write(*,"(a,3i3,f8.2,10(a,f5.0))") "TEST_BLM fh:", mm, dd, hh, fh, & " zi ", zi, " ziS: ", ziSeibert, " ziJ: ", ziJericevic, & - " ziV: ", ziVenki, " ziTI: ", ziTI + " ziV: ", ziVenki, " ziTI: ", ziTI, " ziVH: ", ziVH !/ Kz ************************************************* - write(*,"(a,4a3,a7,a9,9a8)") "DEBUG_Kz: ", "mm", "dd", "hh", "k", & - "fh", "zb", "pzpbl", & + write(*,"(a,4a3,2a7,a9,9a10)") "DEBUG_Kz: ", "mm", "dd", "hh", "k", & + "fh", "u*", "zb", "pzpbl", & "Kz_m2s", "Kz_nwp", "Kz_PBT", "Kz_PBF", "Kz_OB", "KBW", "KAJ" Kz_OB(:) = Kz_PBT(:) ! sim to orig emep @@ -382,18 +472,23 @@ subroutine Test_BLM (mm,dd,hh,fH,u,v, zm, zb, pb, exnm, & do k = 2, size(th) - Kz_AJ(k) = JericevicKz ( zb(k), ziJericevic, ustar ) + if ( zb(k) < zi ) then + Kz_AJ(k) = JericevicKz( zb(k), ziJericevic, ustar, -8.888 ) + else + Kz_AJ(k) = -9.999 + end if + if( fh > 0 ) then ! Query choices above zi? if( zb(k) < ziSeibert ) then ! Query - Kz_BW(k) = BrostWyngaardKz( zb(k), ziSeibert, ustar, invL ) + Kz_BW(k) = BrostWyngaardKz( zb(k), ziSeibert, ustar, invL, -8.888 ) else Kz_BW(k) = KZ_MINIMUM end if end if - write(*,"(a,4i3,f7.1,2f8.0,9f8.2)") "DEBUG_Kz: ", & - mm, dd, hh, k, fh, zb(k), zi, Kz(k), Kz_nwp(k), Kz_PBT(k), & + write(*,"(a,4i3,f7.1,f7.3,2f8.0,9es10.2)") "DEBUG_Kz: ", & + mm, dd, hh, k, fh, ustar, zb(k), zi, Kz(k), Kz_nwp(k), Kz_PBT(k), & Kz_PBF(k), Kz_OB(k), Kz_BW(k), Kz_AJ(k) end do @@ -749,7 +844,7 @@ subroutine fake_zbnd(z) z(20) = 91.302 z(21) = 91.302 end subroutine fake_zbnd -function SigmaKz_2_m2s_scalar (roa,ps) result(Kz_fac) ! hb +subroutine SigmaKz_2_m2s_scalar (roa,ps,Kz_fac) ! hb real, intent(in) :: roa real, intent(in) :: ps real :: fac @@ -758,7 +853,7 @@ function SigmaKz_2_m2s_scalar (roa,ps) result(Kz_fac) ! hb fac= (ps - PT)/(GRAV*roa) Kz_fac= fac*fac -end function SigmaKz_2_m2s_scalar +end subroutine SigmaKz_2_m2s_scalar subroutine SigmaKz_2_m2s_arrays (SigmaKz,roa,ps,Kz) real, intent(in), dimension(:,:,:) :: SigmaKz, roa diff --git a/Biogenics_ml.f90 b/Biogenics_ml.f90 index f116b57..c92117b 100644 --- a/Biogenics_ml.f90 +++ b/Biogenics_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -52,10 +52,11 @@ module Biogenics_ml ! by the ReadField_CDF interpolation routines. No need to worry about ! conserving these very imperfect numbers accurately ;-) ! - ! Dave Simpson, 2010-2011 + ! Dave Simpson, 2010-2012 !--------------------------------------------------------------------------- use CheckStop_ml, only: CheckStop + use ChemChemicals_ml, only : species use GridValues_ml , only : i_fdom,j_fdom, debug_proc,debug_li,debug_lj use Io_ml , only : IO_FORES, open_file, ios, PrintLog, datewrite use KeyValue_ml, only : KeyVal,KeyValue @@ -63,6 +64,8 @@ module Biogenics_ml use LandPFT_ml, only: MapPFT_LAI, pft_lai use Landuse_ml, only : LandCover use LocalVariables_ml, only : Grid ! -> izen, DeltaZ + use MetFields_ml, only : t2_nwp + use ModelConstants_ml, only : USE_SOILNOX, DEBUG_SOILNOX, USE_SOILNH3 use ModelConstants_ml, only : NPROC, MasterProc, TINY, & USE_PFT_MAPS, NLANDUSEMAX, IOU_INST, & KT => KCHEMTOP, KG => KMAX_MID, & @@ -70,15 +73,16 @@ module Biogenics_ml use NetCDF_ml, only : ReadField_CDF, printCDF use OwnDataTypes_ml, only : Deriv, TXTLEN_SHORT use Par_ml , only : MAXLIMAX,MAXLJMAX,MSG_READ1,me, limax, ljmax + use Par_ml, only : limax, ljmax, MAXLIMAX, MAXLJMAX, me use PhysicalConstants_ml, only : AVOG, GRAV use Radiation_ml, only : PARfrac, Wm2_uE - use Setup_1dfields_ml, only : rcbio + use Setup_1dfields_ml, only : rcemis use SmallUtils_ml, only : find_index - use TimeDate_ml, only : current_date + use TimeDate_ml, only : current_date, daynumber implicit none private - !/-- subroutines + !/-- subroutines for BVOC public :: Init_BVOC private :: Get_LCinfo public :: GetEuroBVOC @@ -87,19 +91,40 @@ module Biogenics_ml public :: SetDailyBVOC private :: TabulateECF + !/-- subroutines for soil NO + public :: Set_SoilNOx + INCLUDE 'mpif.h' + include 'CM_EmisBioNat.inc' + !e.g. + ! integer, parameter, public :: NEMIS_BioNat = 3 + ! character(len=7), save, dimension(NEMIS_BioNat), public:: & + ! EMIS_BioNat = (/ "C5H8 " , "APINENE" , "NO " /) + INTEGER STATUS(MPI_STATUS_SIZE),INFO integer, public, parameter :: N_ECF=2, ECF_ISOP=1, ECF_TERP=2 - integer, public, parameter :: NBIO_DEF=3, BIO_ISOP=1, BIO_MTP=2, BIO_MTL=3 + integer, public, parameter :: BIO_ISOP=1, BIO_MTP=2, & + BIO_MTL=3 ! , BIO_SOILNO=4, BIO_SOILNH3=5 integer, public, parameter :: BIO_TERP=2 ! Used for final emis, sum of MTP+MTL integer, public, save :: last_bvoc_LC !max index land-cover with BVOC (min 4) + + ! Soil NOx + real,public, save, allocatable, dimension(:,:) :: & + AnnualNdep, & ! N-dep in mgN/m2/ + SoilNOx, SoilNH3 ! Set true if LCC read from e.g. EMEP_EuroBVOC.nc: ! (Currently for 1st four LCC, CF, DF, BF, NF) logical, private, dimension(NLANDUSEMAX), save :: HaveLocalEF - real, public, save, dimension(MAXLIMAX,MAXLJMAX,size(BVOC_USED)) :: & - EmisNat =0.0 ! will be transferred to d_2d emis sums +! real, public, save, dimension(MAXLIMAX,MAXLJMAX,size(BVOC_USED)+NSOIL_EMIS) :: & + + ! EmisNat is used for BVOC; soil-NO, also in futur for sea-salt etc. + ! Main criteria is not provided in gridded data-bases, often land-use + ! dependent. + + real, public, save, allocatable, dimension(:,:,:) :: & + EmisNat ! will be transferred to d_2d emis sums !standard emission factors (EFs) per LC @@ -108,10 +133,10 @@ module Biogenics_ml bvocEF ! Gridded std. emissions per PFT !standard emission factors per LC for daily LAI - real, private, save, dimension(MAXLIMAX,MAXLJMAX,size(BVOC_USED)) :: & - day_embvoc = 0.0 ! emissions scaled by daily LAI + real, private, save, allocatable, dimension(:,:,:) :: & + day_embvoc ! emissions scaled by daily LAI - logical, private, dimension(MAXLIMAX,MAXLJMAX) :: EuroMask + logical, private, save, allocatable, dimension(:,:) :: EuroMask !/-- Canopy environmental correction factors----------------------------- ! @@ -119,7 +144,11 @@ module Biogenics_ml ! - from Guenther's papers. (Limit to 0-1.0) + where(bvocEF(:,:,ibvoc,iEmis)>-1.0) EuroMask = .true. end where else ! Just check that following maps are consistent - do i=1,MAXLIMAX - do j=1,MAXLJMAX - if ( EuroMask(i,j) .and. loc(i,j)<0.0 ) then + do i=1,limax + do j=1,ljmax + if ( EuroMask(i,j) .and. bvocEF(i,j,ibvoc,iEmis)<0.0 ) then write(*,*) "MASK ERROR", me, i_fdom(i), j_fdom(j) call CheckStop("EuroMask BVOC ERROR") end if @@ -409,14 +463,14 @@ subroutine SetDailyBVOC(daynumber) end do if ( DEBUG_BIO ) then - if ( my_first_call ) then ! print out 1st day - call printCDF("BIO-LAI", workarray, "m2/m2" ) - workarray(:,:) = day_embvoc(:,:,1) - call printCDF("BIO-Eiso", workarray, "ug/m2/h" ) - workarray(:,:) = day_embvoc(:,:,2) + day_embvoc(:,:,3) - call printCDF("BIO-Emt", workarray, "ug/m2/h" ) - deallocate( workarray ) - end if +! if ( my_first_call ) then ! print out 1st day +! call printCDF("BIO-LAI", workarray, "m2/m2" ) +! workarray(:,:) = day_embvoc(:,:,1) +! call printCDF("BIO-Eiso", workarray, "ug/m2/h" ) +! workarray(:,:) = day_embvoc(:,:,2) + day_embvoc(:,:,3) +! call printCDF("BIO-Emt", workarray, "ug/m2/h" ) +! deallocate( workarray ) +! end if end if my_first_call = .false. @@ -471,12 +525,16 @@ subroutine setup_bio(i,j) integer, intent(in) :: i,j integer :: it2m - real :: E_ISOP , E_MTP, E_MTL + real :: E_ISOP, E_MTP, E_MTL ! To get from ug/m2/h to molec/cm3/s ! ug -> g 1.0e-9; g -> mole / MW; x AVOG - real, save :: biofac_ISOP = 1.0e-12*AVOG/64.0/3600.0 ! needs /Grid%DeltaZ - real, save :: biofac_TERP = 1.0e-12*AVOG/136.0/3600.0 ! needs /Grid%DeltaZ +! will need /Grid%DeltaZ + real, parameter :: & + biofac_ISOP = 1.0e-12*AVOG/68.0 /3600.0 & + ,biofac_TERP = 1.0e-12*AVOG/136.0/3600.0 & + ,biofac_SOILNO = 1.0e-12*AVOG/14.0 /3600.0 & + ,biofac_SOILNH3= 1.0e-12*AVOG/14.0 /3600.0 ! Light effects added for isoprene emissions @@ -493,9 +551,8 @@ subroutine setup_bio(i,j) it2m = max(it2m,1) it2m = min(it2m,40) - rcbio(:,KG) = 0.0 - - if ( Grid%izen <= 90) then ! Isoprene in daytime only: + !ASSUME C5H8 FOR NOW if ( ispec_C5H8 > 0 ) then + if ( Grid%izen <= 90) then ! Isoprene in daytime only: ! Light effects from Guenther G93 @@ -516,31 +573,47 @@ subroutine setup_bio(i,j) ! Emissions_ml (snapemis). ug/m2/h -> kg/m2/s needs 1.0-9/3600.0. E_ISOP = day_embvoc(i,j,BIO_ISOP)*canopy_ecf(BIO_ISOP,it2m) * cL - rcbio(BIO_ISOP,KG) = E_ISOP * biofac_ISOP/Grid%DeltaZ - EmisNat(i,j,BIO_ISOP)= E_ISOP * 1.0e-9/3600.0 + + rcemis(itot_C5H8,KG) = rcemis(itot_C5H8,KG) + E_ISOP * biofac_ISOP/Grid%DeltaZ + EmisNat(ispec_C5H8,i,j)= E_ISOP * 1.0e-9/3600.0 else ! night - EmisNat(i,j,BIO_ISOP) = 0.0 + EmisNat(ispec_C5H8,i,j) = 0.0 E_MTL = 0.0 E_ISOP = 0.0 endif ! daytime - if ( BIO_TERP > 0 ) then + if ( ispec_APIN > 0 ) then ! add pool-only terpenes rate; E_MTP = day_embvoc(i,j,BIO_MTP)*canopy_ecf(ECF_TERP,it2m) - rcbio(BIO_TERP,KG) = (E_MTL+E_MTP) * biofac_TERP/Grid%DeltaZ - EmisNat(i,j,BIO_TERP) = (E_MTL+E_MTP) * 1.0e-9/3600.0 + rcemis(itot_APIN,KG) = rcemis(itot_APIN,KG) + & + (E_MTL+E_MTP) * biofac_TERP/Grid%DeltaZ + EmisNat(ispec_APIN,i,j) = (E_MTL+E_MTP) * 1.0e-9/3600.0 end if + + if ( USE_SOILNOX ) then + rcemis(itot_NO,KG) = rcemis(itot_NO,KG) + & + SoilNOx(i,j) * biofac_SOILNO/Grid%DeltaZ + EmisNat(ispec_NO,i,j) = SoilNOx(i,j) * 1.0e-9/3600.0 + end if + + !EXPERIMENTAL + if ( USE_SOILNH3 ) then + rcemis(itot_NH3,KG) = rcemis(itot_NH3,KG) + & + SoilNH3(i,j) * biofac_SOILNH3/Grid%DeltaZ + EmisNat(ispec_NH3,i,j) = SoilNH3(i,j) * 1.0e-9/3600.0 + end if + if ( DEBUG_BIO .and. debug_proc .and. i==debug_li .and. j==debug_lj .and. & current_date%seconds == 0 ) then call datewrite("DBIO env ", it2m, (/ max(par,0.0), max(cL,0.0), & canopy_ecf(BIO_ISOP,it2m),canopy_ecf(BIO_TERP,it2m) /) ) - call datewrite("DBIO EISOP EMTP EMTL ", (/ E_ISOP, E_MTP, E_MTL /) ) - call datewrite("DBIO rc ", (/ rcbio(BIO_ISOP,KG), rcbio(BIO_TERP,KG) /) ) - call datewrite("DBIO EmisNat ", EmisNat(i,j,:) ) + call datewrite("DBIO EISOP EMTP EMTL ESOIL ", (/ E_ISOP, & + E_MTP, E_MTL, SoilNOx(i,j) /) ) + call datewrite("DBIO EmisNat ", EmisNat(:,i,j) ) end if @@ -548,4 +621,141 @@ subroutine setup_bio(i,j) end subroutine setup_bio !---------------------------------------------------------------------------- + + + subroutine Set_SoilNOx() + integer :: i, j, nLC, iLC, LC + logical :: my_first_call = .true. + real :: f, ft, fn, ftn + real :: enox, enh3 ! emissions, ugN/m2/h + real :: beta, bmin, bmax, bx, by ! for beta function + real :: hfac + + if( DEBUG_SOILNOX .and. debug_proc )write(*,*)"DEBUG_SOILNOX START: ",& + current_date%day, current_date%hour, current_date%seconds + + if ( .not. USE_SOILNOX ) return ! and fSW has been set to 1. at start + + + ! We reset once per hour + + if ( current_date%seconds /= 0 .and. .not. my_first_call ) return + hfac = 0.5 ! Lower at night + if ( current_date%hour > 7 .and. current_date%hour < 20 ) hfac = 1.5 + + + do j = 1, ljmax + do i = 1, limax + + nlc = LandCover(i,j)%ncodes + + ! Temperature function from Rolland et al., 2005, eqn. 6 + + ft = exp( (t2_nwp(i,j,1)-273.15-20)*log(2.1) / 10.0 ) + + ! Inspired by e.g. Pilegaard et al, Schaufler et al. (2010) + ! we scale emissions from seminat with N-depositions + ! We use a factor normalised to 1.0 at 5000 mgN/m2/a + + fn = AnnualNdep(i,j)/5000.0 ! scale for now + + ftn = ft * fn * hfac + + enox = 0.0 + enh3 = 0.0 + + LCLOOP: do ilc= 1, nLC + + LC = LandCover(i,j)%codes(ilc) + if ( LandType(LC)%is_water ) cycle + if ( LandType(LC)%is_ice ) cycle + if ( LandType(LC)%is_iam ) cycle + + ! Soil NO + ! for 1 ugN/m2/hr, the temp funct alone would give + ! ca. 6 mgN/m2/a in Germany, where dep is about 5000 mgN/m2 max ca. 9 + ! Conif Forests in Germany + + f = LandCover(i,j)%fraction(ilc) + beta = 0.0 + + if ( LandType(LC)%is_conif ) then + enox = enox + f*ftn*150.0 + enh3 = enh3 + f*ftn*1500.0 ! Huge?! W+E ca. 600 ngNH3/m2/s -> 1800 ugN/m2/h + else if ( LandType(LC)%is_decid ) then + enox = enox + f*ftn* 50.0 + enh3 = enh3 + f*ftn*500.0 ! Just guessing + else if ( LandType(LC)%is_seminat ) then + enox = enox + f*ftn* 50.0 + enh3 = enh3 + f * ftn *20.0 !mg/m2/h approx from US report 1 ng/m2/s + + else if ( LandType(LC)%is_crop ) then ! emissions in 1st 70 days + + bmin = Landcover(i,j)%SGS(iLC) -30 ! !st March LandCover(i,j)%SGS(iLC) - 30 + bmax = Landcover(i,j)%SGS(iLC) +30 ! End April LandCover(i,j)%SGS(iLC) + 40 + + ! US p.29, Suttn had ca. 20 ng/m2/s = 60ugN/m2/hfor crops + ! throughout growing season + if ( daynumber >= Landcover(i,j)%SGS(iLC) .and. & + daynumber <= Landcover(i,j)%EGS(iLC) ) then + enox = enox + f* 1.0 + enh3 = enh3 + f * 60.0 + end if + + ! CRUDE - just playing for NH3. + ! NH3 from fertilizer? Assume e.g. 120 kg/ha over 1 month + ! with 10% giving emission, i.e. 10 kg/ha + ! 10 kg/ha/month = ca. 1000 ugN/m2/h + + ! For NO, numbers based upon papers by e.g. Rolland, + ! Butterbach, etc. + if ( daynumber >= bmin .and. daynumber <= bmax ) then + + bx = (daynumber-bmin)/( bmax-bmin) + bx = max(bx,0.0) + by = 1.0 - bx + beta = ( bx*by *4.0) + enox = enox + f*80.0*ft* beta + enh3 = enh3 + f * 1000.0*ft * beta + end if + + + end if + if ( DEBUG_SOILNOX .and. debug_proc .and. & + i == debug_li .and. j == debug_lj ) then + write(*, "(a,4i4,f7.2,9g12.3)") "LOOPING SOIL", daynumber, & + iLC, LC, LandCover(i,j)%SGS(iLC), t2_nwp(i,j,1)-273.15, & + f, ft, fn, ftn, beta, enox, enh3 + if(iLC==1) & + call datewrite("HFAC SOIL", (/ 1.0*daynumber,hfac /) ) + end if + enox = max( 0.001, enox ) ! Just to stop negatives while testing + + ! Soil NH3 + end do LCLOOP + + + ! And we scale EmisNat to get units kg/m2 consistent with + ! Emissions_ml (snapemis). ug/m2/h -> kg/m2/s needs 1.0-9/3600.0. + + SoilNOx(i,j) = enox + SoilNH3(i,j) = enh3 + + end do + end do + ! if ( DEBUG_SOILNOX .and. debug_proc ) then + ! SoilNOx(:,:) = 1.0 ! Check scaling + ! end if + + if ( DEBUG_SOILNOX .and. debug_proc ) then + i = debug_li + j = debug_lj + write(*,"(a,4i4)") "RESET_SOILNOX: ", 1, limax, 1, ljmax + write(*,"(a,2i4,2f12.4,es12.4)") "RESET_SOILNOX: ", & + daynumber, current_date%hour, t2_nwp(i,j,1), SoilNOx(i,j), AnnualNdep(i,j) + end if + + my_first_call = .false. + + end subroutine Set_SoilNOx end module Biogenics_ml diff --git a/BiomassBurningMapping.inc b/BiomassBurningMapping.inc new file mode 100644 index 0000000..b55e437 --- /dev/null +++ b/BiomassBurningMapping.inc @@ -0,0 +1,50 @@ +!-------------------------------------------------------------------------! +! Mapping of emissions from FINNv1 to EMEP EmChem09 species +! Included by ForestFire_ml +!-------------------------------------------------------------------------! + + character(len=*), public, parameter :: & + BiomassBurningMapping = "FINNv1toEmChem09" + integer, private, parameter :: & + NBB_DEFS = 19 & ! No mapping lines below + ,NEMEPSPECS = 15 ! No EMEP chemical mech specs used + + !-----------------------------------------------------------------------! + ! Column-1 gives FINNv1 species , + ! Column-2 gives MW if needed to get to kg/day. + ! (Some FINN emissions are given with mass basis, kg/day, so just + ! set to 1.0, except for OC, which is given in units of C and + ! needs to be scaled from OC to OM. Others are given as mole/day, + ! so multiply by MW/1000 to get kg/day ) + ! IMPORTANT - use just one value for unitsfac per txt + ! Column-3 gives mass fraction of FINN emissions assign to EMEP species + ! Column-4 gives EMEP species + !-----------------------------------------------------------------------! + + ! BBname unitsfac frac emep: + type(bbtype), private, dimension(NBB_DEFS) :: FF_defs = (/ & + bbtype("CO ",0.028 , 1.000, CO ) & + ,bbtype("NO ",0.030 , 1.000, NO ) & + ,bbtype("NO2 ",0.046 , 1.000, NO2 ) & + ,bbtype("SO2 ",0.064 , 1.000, SO2 ) & + ,bbtype("NH3 ",0.017 , 1.000, NH3 ) & + ,bbtype("ACET",0.058 , 1.000, C2H6 ) & ! acetone + ,bbtype("ALD2",0.044 , 1.000, CH3CHO ) & + ,bbtype("ALK4",0.058 , 1.000, NC4H10 ) & + ,bbtype("C2H6",0.030 , 1.000, C2H6 ) & + ,bbtype("C3H8",0.044 , 0.700, NC4H10 ) & ! obs + ,bbtype("CH2O",0.030 , 1.000, HCHO ) & + ,bbtype("ISOP",0.068 , 1.000, C5H8 ) & + ,bbtype("MEK ",0.072 , 1.000, MEK ) & + ,bbtype("PRPE",0.042 , 1.000, C3H6 ) & !CHECK! +! We read in OC and PM25, but want OM and REMPPM25 + ,bbtype("PM25",1.0 , 1.000, FFIRE_REMPPM25 ) & ! Will need to subtract OM, BC + ,bbtype("OC ",1.7 , 1.000, FFIRE_OM ) & ! Put OM/OC=1.7 in fac + ,bbtype("BC ",1.0 , 1.000, FFIRE_BC ) & +! Subtract, assuming OM/OC=1.7. ForestFire_ml will pevent zeros + ,bbtype("OC ",-1.7 , 1.000, FFIRE_REMPPM25 ) & ! Will subtract OM + ,bbtype("BC ",-1.0 , 1.000, FFIRE_REMPPM25 ) & ! Will subtract BC + /) +! Not used in EmChem09 standard + !,bbtype("CH4 " , 1.000, CH4 ) & + ! ,bbtype("HCN " , 1.000, HCN ) & diff --git a/BoundaryConditions_ml.f90 b/BoundaryConditions_ml.f90 index 1594872..acfc023 100644 --- a/BoundaryConditions_ml.f90 +++ b/BoundaryConditions_ml.f90 @@ -78,7 +78,6 @@ module BoundaryConditions_ml use Chemfields_ml, only: xn_adv, xn_bgn, NSPEC_BGN ! emep model concs. use ChemSpecs_adv_ml ! provide NSPEC_ADV and IXADV_* use ChemSpecs_shl_ml ! provide NSPEC_SHL -use ChemGroups_ml, only: SS_GROUP ! Sea-salt special use GlobalBCs_ml, only: & NGLOB_BC & ! Number of species from global-model ,GetGlobalData & ! Sub., reads global data+vert interp. @@ -184,192 +183,528 @@ module BoundaryConditions_ml contains -subroutine BoundaryConditions(year,iyr_trend,month) -! --------------------------------------------------------------------------- -! Read in monthly-average global mixing ratios, and if found, collect the -! data in bc_adv, bc_bgn arrays for later interpolations -! NOTES -! 1.- If mixing ratio by mass the scale by molcular weight) -! 2.- So far no scaling is done, but this could be done -! in Set_bcmap with atomic weights -! 3.- On the first call, we also run the setup-subroutines -! 4.- Year is now obtained from the iyr_trend set in run.pl. -! This allows, e.g. runs with BCs for 2100 and met of 1990. -! --------------------------------------------------------------------------- - integer, intent(in) :: year ! "meteorology" year - integer, intent(in) :: iyr_trend ! "trend" year - integer, intent(in) :: month - integer :: ibc, iem, k, iem1, i, j ! loop variables - integer :: info ! used in rsend - integer :: io_num ! i/o number used for reading global data - integer :: alloc_err - - !/ data arrays for boundary data (BCs) - quite large, so NOT saved - real, allocatable,dimension(:,:,:) :: bc_data ! for one bc species - real, allocatable,dimension(:,:,:,:) :: bc_adv,bc_bgn -! Dimensions correspond to: -! bc_data(IGLOB,JGLOB,KMAX_MID) -! bc_adv(NSPEC_ADV,IGLOB,JGLOB,KMAX_MID) -! bc_bgn(NSPEC_BGN,IGLOB,JGLOB,KMAX_MID) - - integer :: iglobact, jglobact, errcode - integer, save :: idebug=0, itest=1, i_test=0, j_test=0 - - if (first_call) then - if (DEBUG_BCS) print "((A,I0,1X))", & - "FIRST CALL TO BOUNDARY CONDITIONS, me: ", me, & - "TREND YR ", iyr_trend - - call My_bcmap(iyr_trend) ! assigns bc2xn_adv and bc2xn_bgn mappings - call Set_bcmap() ! assigns xn2adv_changed, etc. - - num_changed = num_adv_changed + num_bgn_changed !u1 - if (DEBUG_BCS) print "((A,I0,1X))", & - "BCs: num_adv_changed: ", num_adv_changed, & - "BCs: num_bgn_changed: ", num_bgn_changed, & - "BCs: num changed: ", num_changed - - endif ! first call - if (DEBUG_BCS) print "((A,I0,1X))", & - "CALL TO BOUNDARY CONDITIONS, me:", me, & - "month ", month, "TREND2 YR ", iyr_trend, me - - if (num_changed==0) then - print *,"BCs: No species requested" - return - endif - -!MUST CONTAIN DECIDED DIMENSION FOR READ-IN DATA -! iglobac and jglobac are now the actual domains (the chosen domain) -! given in the same coord as the data we read - call setgl_actarray(iglobact,jglobact) - - allocate(bc_data(iglobact,jglobact,KMAX_MID),stat=alloc_err) - call CheckStop(alloc_err, "alloc1 failed in BoundaryConditions_ml") - - allocate(bc_adv(num_adv_changed,iglobact,jglobact,KMAX_MID),stat=alloc_err) - call CheckStop(alloc_err, "alloc2 failed in BoundaryConditions_ml") - bc_adv(:,:,:,:) = 0.0 - - allocate(bc_bgn(num_bgn_changed,iglobact,jglobact,KMAX_MID),stat=alloc_err) - call CheckStop(alloc_err, "alloc3 failed in BoundaryConditions_ml") - bc_bgn(:,:,:,:) = 0.0 - - errcode = 0 - if (DEBUG_BCS.and.debug_proc) then - do i = 1, limax - do j = 1, ljmax - if (i_fdom(i)==DEBUG_i.and.j_fdom(j)==DEBUG_j) then - i_test = i - j_test = j - endif - enddo - enddo - endif - - !== BEGIN READ_IN OF GLOBAL DATA - do ibc = 1, NGLOB_BC - if (MasterProc) call GetGlobalData(year,iyr_trend,month,ibc,bc_used(ibc), & - iglobact,jglobact,bc_data,io_num,errcode) - - if (DEBUG_BCS.and.MasterProc) & - print *,'Calls GetGlobalData: year,iyr_trend,ibc,month,bc_used=', & - year,iyr_trend,ibc,month,bc_used(ibc) - - call CheckStop(ibc==1.and.errcode/= 0,& - "ERRORBCs: GetGlobalData, failed in BoundaryConditions_ml") - - !-- If the read-in bcs are required, we broadcast and use: - if ( bc_used(ibc) > 0 ) then - CALL MPI_BCAST(bc_data,8*iglobact*jglobact*KMAX_MID,MPI_BYTE,0,& - MPI_COMM_WORLD,INFO) - - ! - set bc_adv: advected species - do i = 1, bc_used_adv(ibc) - iem = spc_used_adv(ibc,i) - iem1 = spc_adv2changed(iem) - bc_adv (iem1,:,:,:) = bc_adv(iem1,:,:,:) & - + bc_data(:,:,:)*bc2xn_adv(ibc,iem) - enddo - - ! - set bc_bgn: background (prescribed) species - do i = 1, bc_used_bgn(ibc) - iem = spc_used_bgn(ibc,i) - iem1 = spc_bgn2changed(iem) - bc_bgn(iem1,:,:,:) = bc_bgn(iem1,:,:,:) & - + bc_data(:,:,:)*bc2xn_bgn(ibc,iem) - enddo - endif ! bc_used - enddo ! ibc - - if (MasterProc) close(io_num) - - if (first_call) then - idebug = 1 - if (DEBUG_BCS) print *, "RESET 3D BOUNDARY CONDITIONS", me - - ! Set 3-D arrays of new BCs - call MiscBoundaryConditions(iglobact,jglobact,bc_adv,bc_bgn) - call Set_BoundaryConditions("3d",iglobact,jglobact,bc_adv,bc_bgn) - else - idebug = idebug + 1 - - ! Set lateral (edge and top) arrays of new BCs - call MiscBoundaryConditions(iglobact,jglobact,bc_adv,bc_bgn) - call Set_BoundaryConditions("lateral",iglobact,jglobact,bc_adv,bc_bgn) - endif - + subroutine BoundaryConditions(year,iyr_trend,month) + ! --------------------------------------------------------------------------- + ! Read in monthly-average global mixing ratios, and if found, collect the + ! data in bc_adv, bc_bgn arrays for later interpolations + ! NOTES + ! 1.- If mixing ratio by mass the scale by molcular weight) + ! 2.- So far no scaling is done, but this could be done + ! in Set_bcmap with atomic weights + ! 3.- On the first call, we also run the setup-subroutines + ! 4.- Year is now obtained from the iyr_trend set in run.pl. + ! This allows, e.g. runs with BCs for 2100 and met of 1990. + ! --------------------------------------------------------------------------- + integer, intent(in) :: year ! "meteorology" year + integer, intent(in) :: iyr_trend ! "trend" year + integer, intent(in) :: month + integer :: ibc, iem, k, iem1, i, j ,n, nadv,ntot ! loop variables + integer :: info ! used in rsend + integer :: io_num ! i/o number used for reading global data + integer :: alloc_err + real :: bc_fac ! Set to 1.0, except sea-salt over land = 0.01 + logical :: bc_seaspec ! if sea-salt species + + !/ data arrays for boundary data (BCs) - quite large, so NOT saved + real, allocatable,dimension(:,:,:) :: bc_data ! for one bc species +! real, allocatable,dimension(:,:,:,:) :: bc_adv,bc_bgn + ! Dimensions correspond to: + ! bc_data(IGLOB,JGLOB,KMAX_MID) + ! bc_adv(NSPEC_ADV,IGLOB,JGLOB,KMAX_MID) + ! bc_bgn(NSPEC_BGN,IGLOB,JGLOB,KMAX_MID) + + integer :: iglobact, jglobact, errcode + integer, save :: idebug=0, itest=1, i_test=0, j_test=0 + + if (first_call) then + if (DEBUG_BCS) write(*,"(a,I3,1X,a,i5)") & + "FIRST CALL TO BOUNDARY CONDITIONS, me: ", me, "TREND YR ", iyr_trend + + call My_bcmap(iyr_trend) ! assigns bc2xn_adv and bc2xn_bgn mappings + call Set_bcmap() ! assigns xn2adv_changed, etc. + + num_changed = num_adv_changed + num_bgn_changed !u1 + if (DEBUG_BCS) write(*, "((A,I0,1X))") & + "BCs: num_adv_changed: ", num_adv_changed, & + "BCs: num_bgn_changed: ", num_bgn_changed, & + "BCs: num changed: ", num_changed + + endif ! first call + if (DEBUG_BCS) write(*, "((A,I0,1X))") & + "CALL TO BOUNDARY CONDITIONS, me:", me, & + "month ", month, "TREND2 YR ", iyr_trend, "me ", me + + if (num_changed==0) then + write(*,*) "BCs: No species requested" + return + endif - if (DEBUG_BCS.and.debug_proc.and.i_test>0) then - i = i_test - j = j_test - print "(a20,3i4,2f8.2)","DEBUG BCS Rorvik", me, i,j,glon(i,j),glat(i,j) - print "(a20,3i4)","DEBUG BCS Rorvik DIMS",num_adv_changed,iglobact,jglobact - do k = 1, KMAX_MID - print "(a20,i4,f8.2)","DEBUG O3 Debug-site ", k, & - xn_adv(IXADV_O3,i_test,j_test,k)/PPB - enddo - endif ! DEBUG + !MUST CONTAIN DECIDED DIMENSION FOR READ-IN DATA + ! iglobac and jglobac are now the actual domains (the chosen domain) + ! given in the same coord as the data we read + call setgl_actarray(iglobact,jglobact) + + allocate(bc_data(iglobact,jglobact,KMAX_MID),stat=alloc_err) + call CheckStop(alloc_err, "alloc1 failed in BoundaryConditions_ml") + +! allocate(bc_adv(num_adv_changed,iglobact,jglobact,KMAX_MID),stat=alloc_err) +! call CheckStop(alloc_err, "alloc2 failed in BoundaryConditions_ml") +! bc_adv(:,:,:,:) = 0.0 + +! allocate(bc_bgn(num_bgn_changed,iglobact,jglobact,KMAX_MID),stat=alloc_err) +! call CheckStop(alloc_err, "alloc3 failed in BoundaryConditions_ml") +! bc_bgn(:,:,:,:) = 0.0 + + errcode = 0 + if (DEBUG_BCS.and.debug_proc) then + do i = 1, limax + do j = 1, ljmax + if (i_fdom(i)==DEBUG_i.and.j_fdom(j)==DEBUG_j) then + i_test = i + j_test = j + endif + enddo + enddo + endif - if (DEBUG_BCS.and.debug_proc) then - itest = 1 - print *,"BoundaryConditions: No CALLS TO BOUND Cs", first_call,idebug - !/** the following uses hard-coded IXADV_ values for testing. - ! Remove later **/ - info = 1 ! index for ozone in bcs - print *,"BCs: bc2xn(info,itest) : ", bc2xn_adv(info,itest) - do k = KMAX_MID, 1, -1 - print "(a,2i3,f12.4)","BCs: After Set_3d BOUND: me, itest: " , & - me, itest, bc_adv(spc_adv2changed(itest),i_test,i_test,k)/PPB - end do - - info = 43 ! index for NO in bcs - print *,"BCs: NSPECS: BC, ADV, BG, ", NTOT_BC, NSPEC_ADV, NSPEC_BGN - print *,"BCs: Number of bc_used: ", sum(bc_used) - print *,"BCs: limax, ljmax", limax, ljmax - - if (NSPEC_BGN>0) then - do k = KMAX_MID, 1, -1 - print "(a23,i3,e14.4)","BCs NO :",k,xn_bgn(itest,i_test,j_test,k)/PPB - enddo + if (first_call) then + idebug = 1 + if (DEBUG_BCS) write(*,*) "RESET 3D BOUNDARY CONDITIONS", me + do k = 1, KMAX_MID + do j = 1, ljmax + do i = 1, limax + xn_adv(:,i,j,k)=0.0 + xn_bgn(:,i,j,k)=0.0 + enddo + enddo + enddo + else + if (DEBUG_BCS.and.MasterProc) write(*,*) "RESET LATERAL BOUNDARIES" + do k = 2, KMAX_MID + do j = lj0, lj1 + !left + do i = 1, li0-1 + xn_adv(:,i,j,k)=0.0 + xn_bgn(:,i,j,k)=0.0 + enddo + !right + do i = li1+1, limax + xn_adv(:,i,j,k)=0.0 + xn_bgn(:,i,j,k)=0.0 + enddo + enddo + !lower + do j = 1, lj0-1 + do i = 1, limax + xn_adv(:,i,j,k)=0.0 + xn_bgn(:,i,j,k)=0.0 + enddo + enddo + !upper + do j = lj1+1, ljmax + do i = 1, limax + xn_adv(:,i,j,k)=0.0 + xn_bgn(:,i,j,k)=0.0 + enddo + enddo + enddo + !top + do k = 1, 1 + do j = 1, ljmax + do i = 1, limax + xn_adv(:,i,j,k)=0.0 + xn_bgn(:,i,j,k)=0.0 + enddo + enddo + enddo + endif + !== BEGIN READ_IN OF GLOBAL DATA + + do ibc = 1, NGLOB_BC + if (MasterProc) call GetGlobalData(year,iyr_trend,month,ibc,bc_used(ibc), & + iglobact,jglobact,bc_data,io_num,errcode) + + if (DEBUG_BCS.and.MasterProc) & + write(*, *)'Calls GetGlobalData: year,iyr_trend,ibc,month,bc_used=', & + year,iyr_trend,ibc,month,bc_used(ibc) + + call CheckStop(ibc==1.and.errcode/= 0,& + "ERRORBCs: GetGlobalData, failed in BoundaryConditions_ml") + + !-- If the read-in bcs are required, we broadcast and use: + if ( bc_used(ibc) > 0 ) then + CALL MPI_BCAST(bc_data,8*iglobact*jglobact*KMAX_MID,MPI_BYTE,0,& + MPI_COMM_WORLD,INFO) + + ! - set bc_adv: advected species +! do i = 1, bc_used_adv(ibc) +! iem = spc_used_adv(ibc,i) +! iem1 = spc_adv2changed(iem) +! bc_adv (iem1,:,:,:) = bc_adv(iem1,:,:,:) & +! + bc_data(:,:,:)*bc2xn_adv(ibc,iem) +! enddo + + ! - set bc_bgn: background (prescribed) species +! do i = 1, bc_used_bgn(ibc) +! iem = spc_used_bgn(ibc,i) +! iem1 = spc_bgn2changed(iem) + ! bc_bgn(iem1,:,:,:) = bc_bgn(iem1,:,:,:) & + ! + bc_data(:,:,:)*bc2xn_bgn(ibc,iem) +! enddo + endif ! bc_used + + ! if (MasterProc) close(io_num) + + if (first_call) then + + ! Set 3-D arrays of new BCs + do n = 1, bc_used_adv(ibc) + iem = spc_used_adv(ibc,n) + ntot = iem + NSPEC_SHL + + ! Sea-salt. + ! If SeaSalt isn't called from mk.GenChem, we don't have the + ! SS_GROUP, so we search for the simple SEASALT name. + bc_seaspec = .false. + if ( USE_SEASALT .and. & + ( index( species(ntot)%name, "SEASALT_" ) > 0 ) ) then + bc_seaspec = .true. + end if + + if ( debug_proc ) write (*,*) "SEAINDEX", & + trim(species(ntot)%name), n, ntot, bc_seaspec,& + index( species(ntot)%name, "SEASALT_") + + do k = 1, KMAX_MID + do j = 1, ljmax + do i = 1, limax + bc_fac = 1.0 + + if ( bc_seaspec ) then + if ( .not. nwp_sea(i,j)) bc_fac = 0.001 ! low over land + if ( .not. USE_SEASALT ) bc_fac = 0.0 ! not wanted! + end if + + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) +& + bc_fac * & ! used for sea-salt species + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_adv(ibc,iem) + end do ! i + end do ! j + end do ! k + end do !n + + do n = 1,bc_used_bgn(ibc) + iem = spc_used_bgn(ibc,n) + + !/- Non-advected background species + do k = 1, KMAX_MID + do j = 1, ljmax + do i = 1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) & + + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_bgn(ibc,iem) + ! ! bc_bgn(n,(i_fdom(i)-IRUNBEG+1),(j_fdom(j)-JRUNBEG+1),k) + end do ! i + end do ! j + end do ! k + enddo + else + + ! Set LATERAL (edge and top) arrays of new BCs + + ! call MiscBoundaryConditions(iglobact,jglobact,bc_adv,bc_bgn) + ! call Set_BoundaryConditions("lateral",iglobact,jglobact,bc_adv,bc_bgn) + idebug = idebug + 1 + do n = 1, bc_used_adv(ibc) + iem = spc_used_adv(ibc,n) + ntot = iem + NSPEC_SHL + bc_seaspec = .false. + if ( USE_SEASALT .and. ( index( species(ntot)%name, "SEASALT_" ) > 0 ) ) then + bc_seaspec = .true. + end if + + do k = 2, KMAX_MID + do j = lj0, lj1 + !left + do i = 1, li0-1 + bc_fac = 1.0 + + if ( bc_seaspec ) then + if ( .not. nwp_sea(i,j)) bc_fac = 0.001 ! low over land + if ( .not. USE_SEASALT ) bc_fac = 0.0 ! not wanted! + end if + + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) +& + bc_fac * & ! used for sea-salt species + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_adv(ibc,iem) + + enddo + !right + do i = li1+1, limax + bc_fac = 1.0 + + if ( bc_seaspec ) then + if ( .not. nwp_sea(i,j)) bc_fac = 0.001 ! low over land + if ( .not. USE_SEASALT ) bc_fac = 0.0 ! not wanted! + end if + + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) +& + bc_fac * & ! used for sea-salt species + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_adv(ibc,iem) + + enddo + enddo + !lower + do j = 1, lj0-1 + do i = 1, limax + bc_fac = 1.0 + + if ( bc_seaspec ) then + if ( .not. nwp_sea(i,j)) bc_fac = 0.001 ! low over land + if ( .not. USE_SEASALT ) bc_fac = 0.0 ! not wanted! + end if + + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) +& + bc_fac * & ! used for sea-salt species + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_adv(ibc,iem) + + enddo + enddo + !upper + do j = lj1+1, ljmax + do i = 1, limax + bc_fac = 1.0 + + if ( bc_seaspec ) then + if ( .not. nwp_sea(i,j)) bc_fac = 0.001 ! low over land + if ( .not. USE_SEASALT ) bc_fac = 0.0 ! not wanted! + end if + + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) +& + bc_fac * & ! used for sea-salt species + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_adv(ibc,iem) + + enddo + enddo + enddo + !top + do k = 1, 1 + do j = 1, ljmax + do i = 1, limax + bc_fac = 1.0 + + if ( bc_seaspec ) then + if ( .not. nwp_sea(i,j)) bc_fac = 0.001 ! low over land + if ( .not. USE_SEASALT ) bc_fac = 0.0 ! not wanted! + end if + + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) +& + bc_fac * & ! used for sea-salt species + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_adv(ibc,iem) + + enddo + enddo + enddo + + end do !n + + !/- Non-advected background species + do n = 1,bc_used_bgn(ibc) + iem = spc_used_bgn(ibc,n) + + do k = 2, KMAX_MID + do j = lj0, lj1 + !left + do i = 1, li0-1 + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) & + + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_bgn(ibc,iem) + enddo + !right + do i = li1+1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) & + + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_bgn(ibc,iem) + enddo + enddo + !lower + do j = 1, lj0-1 + do i = 1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) & + + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_bgn(ibc,iem) + enddo + enddo + !upper + do j = lj1+1, ljmax + do i = 1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) & + + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_bgn(ibc,iem) + enddo + enddo + enddo + !top + do k = 1, 1 + do j = 1, ljmax + do i = 1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) & + + bc_data(i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,k)*bc2xn_bgn(ibc,iem) + enddo + enddo + enddo + enddo + endif + enddo ! ibc + if (first_call) then + !3D misc + do ibc = NGLOB_BC+1, NTOT_BC + do n = 1,bc_used_bgn(ibc) + iem = spc_used_bgn(ibc,n) + !/- Non-advected background misc species + do k = 1, KMAX_MID + do j = 1, ljmax + do i = 1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) +misc_bc(ibc,k) + end do ! i + end do ! j + end do ! k + enddo + do n = 1,bc_used_adv(ibc) + iem = spc_used_adv(ibc,n) + + !/- Advected misc species + do k = 1, KMAX_MID + do j = 1, ljmax + do i = 1, limax + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) + misc_bc(ibc,k)! + ! ! bc_bgn(n,(i_fdom(i)-IRUNBEG+1),(j_fdom(j)-JRUNBEG+1),k) + end do ! i + end do ! j + end do ! k + enddo!n + enddo!ibc else - print "(a)","No SET BACKGROUND BCs" + !LATERAL misc + do ibc = NGLOB_BC+1, NTOT_BC + do n = 1,bc_used_bgn(ibc) + iem = spc_used_bgn(ibc,n) + !/- Non-advected background misc species + do k = 2, KMAX_MID + do j = lj0, lj1 + !left + do i = 1, li0-1 + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) +misc_bc(ibc,k) + enddo + !right + do i = li1+1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) +misc_bc(ibc,k) + enddo + enddo + !lower + do j = 1, lj0-1 + do i = 1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) +misc_bc(ibc,k) + enddo + enddo + !upper + do j = lj1+1, ljmax + do i = 1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) +misc_bc(ibc,k) + enddo + enddo + enddo + !top + do k = 1, 1 + do j = 1, ljmax + do i = 1, limax + xn_bgn(iem,i,j,k) = xn_bgn(iem,i,j,k) +misc_bc(ibc,k) + enddo + enddo + enddo + enddo + !/- Advected misc species + do n = 1,bc_used_adv(ibc) + iem = spc_used_adv(ibc,n) + do k = 2, KMAX_MID + do j = lj0, lj1 + !left + do i = 1, li0-1 + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) + misc_bc(ibc,k)! + enddo + !right + do i = li1+1, limax + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) + misc_bc(ibc,k)! + enddo + enddo + !lower + do j = 1, lj0-1 + do i = 1, limax + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) + misc_bc(ibc,k)! + enddo + enddo + !upper + do j = lj1+1, ljmax + do i = 1, limax + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) + misc_bc(ibc,k)! + enddo + enddo + enddo + !top + do k = 1, 1 + do j = 1, ljmax + do i = 1, limax + xn_adv(iem,i,j,k) = xn_adv(iem,i,j,k) + misc_bc(ibc,k)! + enddo + enddo + enddo + enddo!n + enddo!ibc endif - endif ! DEBUG - deallocate(bc_data,stat=alloc_err) - call CheckStop(alloc_err,"de-alloc1 failed in BoundaryConditions_ml") - if (num_adv_changed>0) then - deallocate(bc_adv,stat=alloc_err) - call CheckStop(alloc_err,"de-alloc2 failed in BoundaryConditions_ml") - endif - if (num_bgn_changed>0) then - deallocate(bc_bgn,stat=alloc_err) - call CheckStop(alloc_err,"de-alloc3 failed in BoundaryConditions_ml") - endif - if (first_call) first_call = .false. -end subroutine BoundaryConditions + if (DEBUG_BCS.and.debug_proc.and.i_test>0) then + i = i_test + j = j_test + print "(a20,3i4,2f8.2)","DEBUG BCS Rorvik", me, i,j,glon(i,j),glat(i,j) + print "(a20,3i4)","DEBUG BCS Rorvik DIMS",num_adv_changed,iglobact,jglobact + do k = 1, KMAX_MID + print "(a20,i4,f8.2)","DEBUG O3 Debug-site ", k, & + xn_adv(IXADV_O3,i_test,j_test,k)/PPB + enddo + endif ! DEBUG + + if (DEBUG_BCS.and.debug_proc) then + itest = 1 + print *,"BoundaryConditions: No CALLS TO BOUND Cs", first_call,idebug + !/** the following uses hard-coded IXADV_ values for testing. + ! Remove later **/ + info = 1 ! index for ozone in bcs + print *,"BCs: bc2xn(info,itest) : ", bc2xn_adv(info,itest) + + + info = 43 ! index for NO in bcs + print *,"BCs: NSPECS: BC, ADV, BG, ", NTOT_BC, NSPEC_ADV, NSPEC_BGN + print *,"BCs: Number of bc_used: ", sum(bc_used) + print *,"BCs: limax, ljmax", limax, ljmax + + if (NSPEC_BGN>0) then + do k = KMAX_MID, 1, -1 + print "(a23,i3,e14.4)","BCs NO :",k,xn_bgn(itest,i_test,j_test,k)/PPB + enddo + else + print "(a)","No SET BACKGROUND BCs" + endif + endif ! DEBUG + + deallocate(bc_data,stat=alloc_err) + call CheckStop(alloc_err,"de-alloc1 failed in BoundaryConditions_ml") +! if (num_adv_changed>0) then +! deallocate(bc_adv,stat=alloc_err) +! call CheckStop(alloc_err,"de-alloc2 failed in BoundaryConditions_ml") +! endif +! if (num_bgn_changed>0) then +! deallocate(bc_bgn,stat=alloc_err) +! call CheckStop(alloc_err,"de-alloc3 failed in BoundaryConditions_ml") +! endif + + if (first_call) first_call = .false. + end subroutine BoundaryConditions subroutine My_bcmap(iyr_trend) ! --------------------------------------------------------------------------- @@ -398,11 +733,17 @@ subroutine My_bcmap(iyr_trend) ! concentrations specified in misc_bc are transferred correctly into the ! boundary conditions. - ! set values of 1625 in 1980, 1780 in 1990, and 1820 in 2000. Interpolate + ! set values of 1625 in 1980, 1780 in 1990, 1820 in 2000, and 1970 in + ! 2010. Interpolate ! between these for other years. Values from EMEP Rep 3/97, Table 6.2 for ! 1980, 1990, and from CDIAC (Mace Head) data for 2000. + ! 2010 also from Mace Head - if ( iyr_trend >= 1990 ) then + if( iyr_trend >= 2010) then + top_misc_bc(IBC_CH4) = 1870.0 + else if ( iyr_trend >= 2000) then + top_misc_bc(IBC_CH4) = 1820 + (iyr_trend-2000)*0.1*(1870-1820) + else if ( iyr_trend >= 1990 ) then top_misc_bc(IBC_CH4) = 1780.0 + (iyr_trend-1990)*0.1*(1820-1780.0) else top_misc_bc(IBC_CH4) = 1780.0 * exp(-0.01*0.91*(1990-iyr_trend)) ! Zander,1975-1990 @@ -507,9 +848,9 @@ subroutine Set_bcmap() endif enddo ! iem - if (DEBUG_BCS) print "(A,/10i5)","TEST SET_BCMAP bc_used: ",& + if (DEBUG_BCS) write(*,*) "TEST SET_BCMAP bc_used: ",& (bc_used(ibc),ibc=1, NTOT_BC) - if (MasterProc.and.DEBUG_BCS) print *,"Finished Set_bcmap: Nbcused is ", sum(bc_used) + if (MasterProc.and.DEBUG_BCS) write(*,*)"Finished Set_bcmap: Nbcused is ", sum(bc_used) allocate(spc_changed2adv(num_adv_changed)) allocate(spc_changed2bgn(num_bgn_changed)) @@ -573,25 +914,32 @@ subroutine MiscBoundaryConditions(iglobact,jglobact,bc_adv,bc_bgn) integer :: ibc, iem, i, iem1, k ! local loop variables integer :: itest ! Used to specify species index - if (NTOT_BC>NGLOB_BC) then + do ibc = NGLOB_BC+1, NTOT_BC + do i = 1,bc_used_adv(ibc) + iem = spc_used_adv(ibc,i) + iem1 = spc_adv2changed(iem) + if(me==0)write(*,*)'bc_adv misc ',ibc,i,iem1 + enddo + enddo + if (NTOT_BC>NGLOB_BC) then do k=1,KMAX_MID do ibc = NGLOB_BC+1, NTOT_BC do i = 1,bc_used_adv(ibc) iem = spc_used_adv(ibc,i) iem1 = spc_adv2changed(iem) - bc_adv(iem1,:,:,k) = misc_bc(ibc,k) +! bc_adv(iem1,:,:,k) = misc_bc(ibc,k) enddo do i = 1,bc_used_bgn(ibc) iem = spc_used_bgn(ibc,i) iem1 = spc_bgn2changed(iem) - bc_bgn(iem1,:,:,k) = misc_bc(ibc,k) +! bc_bgn(iem1,:,:,k) = misc_bc(ibc,k) enddo enddo enddo endif itest = 1 - if (DEBUG_BCS.and.debug_proc) print "(a50,i4,/,(5es12.4))", & + if (DEBUG_BCS.and.debug_proc) write(*,*) "(a50,i4,/,(5es12.4))", & "From MiscBoundaryConditions: ITEST (ppb): ",& itest, ((bc_adv(spc_adv2changed(itest),1,1,k)/1.0e-9),k=1,20) end subroutine MiscBoundaryConditions @@ -651,7 +999,7 @@ subroutine Set_BoundaryConditions(mode,iglobact,jglobact,bc_adv,bc_bgn) ntot = nadv + NSPEC_SHL bc_seaspec = .false. - if ( USE_SEASALT .and. ( find_index( ntot, SS_GROUP(:) ) > 0 ) ) then + if ( USE_SEASALT .and. ( index( species(ntot)%name, "SEASALT_" ) > 0 ) ) then bc_seaspec = .true. end if if ( debug_proc ) write (*,*) "SEAINDEX", & @@ -663,10 +1011,11 @@ subroutine Set_BoundaryConditions(mode,iglobact,jglobact,bc_adv,bc_bgn) if ( mask(i,j,k) ) then bc_fac = 1.0 - ! Parentheses needed to get correct precedence (dangerous!): - if ( bc_seaspec .and. ( nwp_sea(i,j) .eqv. .false. ) ) bc_fac = 0.01 + if ( bc_seaspec ) then + if ( .not. nwp_sea(i,j)) bc_fac = 0.001 ! low over land + if ( .not. USE_SEASALT ) bc_fac = 0.0 ! not wanted! + end if - !xn_adv(spc_changed2adv(n),i,j,k) = & xn_adv(nadv,i,j,k) = & bc_fac * & ! used for sea-salt species bc_adv(n,(i_fdom(i)-IRUNBEG+1),(j_fdom(j)-JRUNBEG+1),k) @@ -687,10 +1036,10 @@ subroutine Set_BoundaryConditions(mode,iglobact,jglobact,bc_adv,bc_bgn) !/- Non-advected background species - forall(i=1:limax, j=1:ljmax, k=1:KMAX_MID, n=1:num_bgn_changed) - xn_bgn(spc_changed2bgn(n),i,j,k) = & - bc_bgn(n,(i_fdom(i)-IRUNBEG+1),(j_fdom(j)-JRUNBEG+1),k) - endforall +! forall(i=1:limax, j=1:ljmax, k=1:KMAX_MID, n=1:num_bgn_changed) +! xn_bgn(spc_changed2bgn(n),i,j,k) = & +! bc_bgn(n,(i_fdom(i)-IRUNBEG+1),(j_fdom(j)-JRUNBEG+1),k) +! endforall end subroutine Set_BoundaryConditions ! call every 3-hours end module BoundaryConditions_ml diff --git a/CM_BoundaryConditions.inc b/CM_BoundaryConditions.inc index a0206f3..126598a 100644 --- a/CM_BoundaryConditions.inc +++ b/CM_BoundaryConditions.inc @@ -1,3 +1,5 @@ +!---- Boundary conditions ------- +!---- SECTION BICs /home/birthems/Unimod/ZCM_EmChem09/EmChem09base !Available BCs are indexed: !use GlobalBCs_ml, only: NGLOB_BC &! indices from UiO model ! ,IBC_SO2, IBC_SO4, IBC_HCHO, IBC_CH3CHO & @@ -27,9 +29,9 @@ bc2xn_adv(IBC_NO2 ,IXADV_NO2 ) = 1.0 bc2xn_adv(IBC_HCHO ,IXADV_HCHO ) = 1.0 !EMEP: - bc2xn_adv(IBC_SEASALT_F ,IXADV_SEASALT_F ) = 1.0 - bc2xn_adv(IBC_SEASALT_C ,IXADV_SEASALT_C ) = 1.0 - bc2xn_adv(IBC_SEASALT_G ,IXADV_SEASALT_G ) = 1.0 +!FEB2012 bc2xn_adv(IBC_SEASALT_F ,IXADV_SEASALT_F ) = 1.0 +!FEB2012 bc2xn_adv(IBC_SEASALT_C ,IXADV_SEASALT_C ) = 1.0 +! bc2xn_adv(IBC_SEASALT_G ,IXADV_SEASALT_G ) = 1.0 !CB: bc2xn_adv(IBC_CH3CHO ,IXADV_ALD2 ) = 1.0 !CB05 ???? bc2xn_adv(IBC_CH3CHO ,IXADV_CH3CHO ) = 1.0 bc2xn_adv(IBC_NO3_f ,IXADV_NO3_f ) = 1.0 @@ -38,8 +40,8 @@ bc2xn_adv(IBC_H2O2 ,IXADV_H2O2 ) = 1.0 !EMEP: !SS bc2xn_adv(IBC_CH3COO2 ,IXADV_CH3COO2 ) = 1.0 - bc2xn_adv(IBC_DUST_f ,IXADV_DUST_NAT_F ) = 1.0 !Dust - bc2xn_adv(IBC_DUST_c ,IXADV_DUST_NAT_C ) = 1.0 !Dust +!FEB2012 bc2xn_adv(IBC_DUST_f ,IXADV_DUST_SAH_F ) = 1.0 !Dust +!FEB2012 bc2xn_adv(IBC_DUST_c ,IXADV_DUST_SAH_C ) = 1.0 !Dust !SKIP bc2xn_adv(IBC_CH3COO2 ,IXADV_C2O3 ) = 1.0 !CB05 !QUERY?? @@ -89,3 +91,34 @@ !!bc2xn_adv(IBC_OH ,IXADV_OH ) = -1.0 ! Short-lived !!bc2xn_adv(IBC_O3NO ,IXADV_O3NO ) = -1.0 ! Excluded !!bc2xn_adv(IBC_DMS ,IXADV_DMS ) = -1.0 ! Query ???? +!---- SECTION BICs /home/birthems/Unimod/ZCM_EmChem09/SeaSalt + !Available BCs are indexed: + !use GlobalBCs_ml, only: NGLOB_BC &! indices from UiO model + ! ,IBC_SO2, IBC_SO4, IBC_HCHO, IBC_CH3CHO & + ! ,IBC_O3,IBC_HNO3,IBC_PAN,IBC_CO,IBC_C2H6 & + ! ,IBC_C4H10, IBC_NO ,IBC_NO2,IBC_NH4_f,IBC_NO3_f,IBC_NO3_c& + ! ,IBC_H2O2,IBC_CH3COO2 + + ! mappings for species from Logan + obs model given with IBC index. + ! EMEP model species have IXADV indices. + + bc2xn_adv(IBC_SEASALT_F ,IXADV_SEASALT_F ) = 1.0 + bc2xn_adv(IBC_SEASALT_C ,IXADV_SEASALT_C ) = 1.0 + +! Skipped: +! bc2xn_adv(IBC_SEASALT_G ,IXADV_SEASALT_G ) = 1.0 +!---- SECTION BICs /home/birthems/Unimod/ZCM_EmChem09/Dust + !Available BCs are indexed: + !use GlobalBCs_ml, only: NGLOB_BC &! indices from UiO model + ! ,IBC_SO2, IBC_SO4, IBC_HCHO, IBC_CH3CHO & + ! ,IBC_O3,IBC_HNO3,IBC_PAN,IBC_CO,IBC_C2H6 & + ! ,IBC_C4H10, IBC_NO ,IBC_NO2,IBC_NH4_f,IBC_NO3_f,IBC_NO3_c& + ! ,IBC_H2O2,IBC_CH3COO2 + + ! mappings for species from Logan + obs model given with IBC index. + ! EMEP model species have IXADV indices. + + bc2xn_adv(IBC_DUST_f ,IXADV_DUST_SAH_F ) = 1.0 !Dust + bc2xn_adv(IBC_DUST_c ,IXADV_DUST_SAH_C ) = 1.0 !Dust + +!---- SECTION BICs /home/birthems/Unimod/ZCM_EmChem09/Isotopes diff --git a/CM_ChemGroups_ml.f90 b/CM_ChemGroups_ml.f90 index e16edc9..ff7dbe5 100644 --- a/CM_ChemGroups_ml.f90 +++ b/CM_ChemGroups_ml.f90 @@ -13,226 +13,726 @@ module ChemGroups_ml ! ------- Gas/particle species ------------------ integer, public, parameter :: INDEX_DDEP_SS_GROUP = 1 + integer, public, target, save, dimension(2) :: & + DDEP_SS_GROUP = (/ SEASALT_F,SEASALT_C /) + + integer, public, parameter :: INDEX_WDEP_OXN_GROUP = 2 + integer, public, target, save, dimension(4) :: & + WDEP_OXN_GROUP = (/ HNO3,HONO,NO3_F,NO3_C /) + + integer, public, parameter :: INDEX_WDEP_PPM10_GROUP = 3 + integer, public, target, save, dimension(11) :: & + WDEP_PPM10_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C /) + + integer, public, parameter :: INDEX_ASH_C_GROUP = 4 + integer, public, target, save, dimension(1) :: & + ASH_C_GROUP = (/ V1702A02B_C /) + + integer, public, parameter :: INDEX_DUST_GROUP = 5 + integer, public, target, save, dimension(6) :: & + DUST_GROUP = (/ DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C /) + + integer, public, parameter :: INDEX_WDEP_AOD_GROUP = 6 + integer, public, target, save, dimension(13) :: & + WDEP_AOD_GROUP = (/ SO4,NO3_F,NH4_F,V1702A02B_F,V1702A02B_C,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C /) + + integer, public, parameter :: INDEX_WDEP_BSOA_GROUP = 7 + integer, public, target, save, dimension(10) :: & + WDEP_BSOA_GROUP = (/ BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3 /) + + integer, public, parameter :: INDEX_DDEP_NOX_GROUP = 8 + integer, public, target, save, dimension(1) :: & + DDEP_NOX_GROUP = (/ NO2 /) + + integer, public, parameter :: INDEX_PPM_C_GROUP = 9 + integer, public, target, save, dimension(4) :: & + PPM_C_GROUP = (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C /) + + integer, public, parameter :: INDEX_DDEP_DUST_NAT_C_GROUP = 10 + integer, public, target, save, dimension(2) :: & + DDEP_DUST_NAT_C_GROUP = (/ DUST_WB_C,DUST_SAH_C /) + + integer, public, parameter :: INDEX_PPM25_FIRE_GROUP = 11 integer, public, target, save, dimension(3) :: & - DDEP_SS_GROUP = (/ SEASALT_F,SEASALT_C,SEASALT_G /) + PPM25_FIRE_GROUP = (/ FFIRE_OM,FFIRE_BC,FFIRE_REMPPM25 /) + + integer, public, parameter :: INDEX_WDEP_SVWOODOA25_GROUP = 12 + integer, public, target, save, dimension(1) :: & + WDEP_SVWOODOA25_GROUP = (/ WOODOA_NG10 /) + + integer, public, parameter :: INDEX_DDEP_PMFINE_GROUP = 13 + integer, public, target, save, dimension(15) :: & + DDEP_PMFINE_GROUP = (/ SO4,NO3_F,NH4_F,V1702A02B_F,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,DUST_ROAD_F,DUST_WB_F,DUST_SAH_F /) + + integer, public, parameter :: INDEX_WDEP_PPM25_GROUP = 14 + integer, public, target, save, dimension(7) :: & + WDEP_PPM25_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25 /) + + integer, public, parameter :: INDEX_WDEP_PM10_GROUP = 15 + integer, public, target, save, dimension(25) :: & + WDEP_PM10_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F,V1702A02B_F,V1702A02B_C,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C /) - integer, public, parameter :: INDEX_SOX_GROUP = 2 + integer, public, parameter :: INDEX_DDEP_OX_GROUP = 16 integer, public, target, save, dimension(2) :: & - SOX_GROUP = (/ SO2,SO4 /) + DDEP_OX_GROUP = (/ O3,NO2 /) - integer, public, parameter :: INDEX_PMFINE_GROUP = 3 + integer, public, parameter :: INDEX_DDEP_ECCOARSE_GROUP = 17 + integer, public, target, save, dimension(2) :: & + DDEP_ECCOARSE_GROUP = (/ EC_C_WOOD,EC_C_FFUEL /) + + integer, public, parameter :: INDEX_NVWOODOC25_GROUP = 18 + integer, public, target, save, dimension(1) :: & + NVWOODOC25_GROUP = (/ POM_F_WOOD /) + + integer, public, parameter :: INDEX_ASH_GROUP = 19 + integer, public, target, save, dimension(2) :: & + ASH_GROUP = (/ V1702A02B_F,V1702A02B_C /) + + integer, public, parameter :: INDEX_WDEP_NVFFUELOC_COARSE_GROUP = 20 + integer, public, target, save, dimension(1) :: & + WDEP_NVFFUELOC_COARSE_GROUP = (/ POM_C_FFUEL /) + + integer, public, parameter :: INDEX_PM10_GROUP = 21 + integer, public, target, save, dimension(26) :: & + PM10_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F,V1702A02B_F,V1702A02B_C,PART_OM_F,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C /) + + integer, public, parameter :: INDEX_WDEP_PWOODOA25_GROUP = 22 + integer, public, target, save, dimension(1) :: & + WDEP_PWOODOA25_GROUP = (/ WOODOA_NG10 /) + + integer, public, parameter :: INDEX_DDEP_ASOA_GROUP = 23 + integer, public, target, save, dimension(10) :: & + DDEP_ASOA_GROUP = (/ ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3 /) + + integer, public, parameter :: INDEX_OX_GROUP = 24 + integer, public, target, save, dimension(2) :: & + OX_GROUP = (/ O3,NO2 /) + + integer, public, parameter :: INDEX_DDEP_OXN_GROUP = 25 integer, public, target, save, dimension(7) :: & - PMFINE_GROUP = (/ SO4,NO3_F,NH4_F,PPM25,PPM25_FIRE,SEASALT_F,DUST_NAT_F /) + DDEP_OXN_GROUP = (/ NO2,PAN,MPAN,HNO3,HONO,NO3_F,NO3_C /) + + integer, public, parameter :: INDEX_WDEP_PFFUELOA25_GROUP = 26 + integer, public, target, save, dimension(1) :: & + WDEP_PFFUELOA25_GROUP = (/ FFFUEL_NG10 /) + + integer, public, parameter :: INDEX_DDEP_PPM10_GROUP = 27 + integer, public, target, save, dimension(11) :: & + DDEP_PPM10_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C /) - integer, public, parameter :: INDEX_WDEP_OXN_GROUP = 4 + integer, public, parameter :: INDEX_WDEP_PPM_C_GROUP = 28 integer, public, target, save, dimension(4) :: & - WDEP_OXN_GROUP = (/ HNO3,HONO,NO3_F,NO3_C /) + WDEP_PPM_C_GROUP = (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C /) - integer, public, parameter :: INDEX_WDEP_PMCO_GROUP = 5 + integer, public, parameter :: INDEX_DDEP_PPM25_FIRE_GROUP = 29 + integer, public, target, save, dimension(3) :: & + DDEP_PPM25_FIRE_GROUP = (/ FFIRE_OM,FFIRE_BC,FFIRE_REMPPM25 /) + + integer, public, parameter :: INDEX_WDEP_EC_F_GROUP = 30 integer, public, target, save, dimension(5) :: & - WDEP_PMCO_GROUP = (/ NO3_C,PPM_C,SEASALT_C,SEASALT_G,DUST_NAT_C /) + WDEP_EC_F_GROUP = (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_BC /) + + integer, public, parameter :: INDEX_DDEP_PM10_GROUP = 31 + integer, public, target, save, dimension(25) :: & + DDEP_PM10_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F,V1702A02B_F,V1702A02B_C,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C /) - integer, public, parameter :: INDEX_DUST_GROUP = 6 + integer, public, parameter :: INDEX_WDEP_SIA_GROUP = 32 + integer, public, target, save, dimension(4) :: & + WDEP_SIA_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F /) + + integer, public, parameter :: INDEX_BVOC_GROUP = 33 integer, public, target, save, dimension(2) :: & - DUST_GROUP = (/ DUST_NAT_F,DUST_NAT_C /) + BVOC_GROUP = (/ C5H8,APINENE /) - integer, public, parameter :: INDEX_DDEP_AOD_GROUP = 7 - integer, public, target, save, dimension(8) :: & - DDEP_AOD_GROUP = (/ SO4,NO3_F,NH4_F,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C /) + integer, public, parameter :: INDEX_PWOODOA25_GROUP = 34 + integer, public, target, save, dimension(1) :: & + PWOODOA25_GROUP = (/ WOODOA_NG10 /) - integer, public, parameter :: INDEX_WDEP_AOD_GROUP = 8 - integer, public, target, save, dimension(8) :: & - WDEP_AOD_GROUP = (/ SO4,NO3_F,NH4_F,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C /) + integer, public, parameter :: INDEX_EC_F_GROUP = 35 + integer, public, target, save, dimension(5) :: & + EC_F_GROUP = (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_BC /) + + integer, public, parameter :: INDEX_DDEP_NONVOLPCM_GROUP = 36 + integer, public, target, save, dimension(10) :: & + DDEP_NONVOLPCM_GROUP = (/ POM_F_WOOD,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,FFIRE_OM,FFIRE_BC /) - integer, public, parameter :: INDEX_DDEP_NOX_GROUP = 9 + integer, public, parameter :: INDEX_WDEP_NVFFIREOC25_GROUP = 37 integer, public, target, save, dimension(1) :: & - DDEP_NOX_GROUP = (/ NO2 /) + WDEP_NVFFIREOC25_GROUP = (/ FFIRE_OM /) - integer, public, parameter :: INDEX_WDEP_DUST_GROUP = 10 + integer, public, parameter :: INDEX_SOX_GROUP = 38 integer, public, target, save, dimension(2) :: & - WDEP_DUST_GROUP = (/ DUST_NAT_F,DUST_NAT_C /) + SOX_GROUP = (/ SO2,SO4 /) + + integer, public, parameter :: INDEX_DUST_ANT_F_GROUP = 39 + integer, public, target, save, dimension(1) :: & + DUST_ANT_F_GROUP = (/ DUST_ROAD_F /) + + integer, public, parameter :: INDEX_PMFINE_GROUP = 40 + integer, public, target, save, dimension(16) :: & + PMFINE_GROUP = (/ SO4,NO3_F,NH4_F,V1702A02B_F,PART_OM_F,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,DUST_ROAD_F,DUST_WB_F,DUST_SAH_F /) + + integer, public, parameter :: INDEX_DDEP_NVABSOM_GROUP = 41 + integer, public, target, save, dimension(3) :: & + DDEP_NVABSOM_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,FFIRE_OM /) + + integer, public, parameter :: INDEX_WDEP_SVFFIREOA25_GROUP = 42 + integer, public, target, save, dimension(1) :: & + WDEP_SVFFIREOA25_GROUP = (/ FFIREOA_NG10 /) + + integer, public, parameter :: INDEX_DDEP_AOD_GROUP = 43 + integer, public, target, save, dimension(13) :: & + DDEP_AOD_GROUP = (/ SO4,NO3_F,NH4_F,V1702A02B_F,V1702A02B_C,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C /) - integer, public, parameter :: INDEX_NOX_GROUP = 11 + integer, public, parameter :: INDEX_NONVOLPCM_GROUP = 44 + integer, public, target, save, dimension(10) :: & + NONVOLPCM_GROUP = (/ POM_F_WOOD,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,FFIRE_OM,FFIRE_BC /) + + integer, public, parameter :: INDEX_WDEP_V1702A02B_GROUP = 45 + integer, public, target, save, dimension(2) :: & + WDEP_V1702A02B_GROUP = (/ V1702A02B_F,V1702A02B_C /) + + integer, public, parameter :: INDEX_WDEP_ASH_F_GROUP = 46 + integer, public, target, save, dimension(1) :: & + WDEP_ASH_F_GROUP = (/ V1702A02B_F /) + + integer, public, parameter :: INDEX_WDEP_DUST_NAT_C_GROUP = 47 integer, public, target, save, dimension(2) :: & - NOX_GROUP = (/ NO,NO2 /) + WDEP_DUST_NAT_C_GROUP = (/ DUST_WB_C,DUST_SAH_C /) + + integer, public, parameter :: INDEX_PMCO_GROUP = 48 + integer, public, target, save, dimension(10) :: & + PMCO_GROUP = (/ NO3_C,V1702A02B_C,POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C,SEASALT_C,DUST_ROAD_C,DUST_WB_C,DUST_SAH_C /) + + integer, public, parameter :: INDEX_DDEP_DUST_ANT_F_GROUP = 49 + integer, public, target, save, dimension(1) :: & + DDEP_DUST_ANT_F_GROUP = (/ DUST_ROAD_F /) + + integer, public, parameter :: INDEX_DDEP_OMCOARSE_GROUP = 50 + integer, public, target, save, dimension(1) :: & + DDEP_OMCOARSE_GROUP = (/ POM_C_FFUEL /) + + integer, public, parameter :: INDEX_NVFFIREOC25_GROUP = 51 + integer, public, target, save, dimension(1) :: & + NVFFIREOC25_GROUP = (/ FFIRE_OM /) + + integer, public, parameter :: INDEX_WDEP_RDN_GROUP = 52 + integer, public, target, save, dimension(2) :: & + WDEP_RDN_GROUP = (/ NH3,NH4_F /) + + integer, public, parameter :: INDEX_WDEP_ASOA_GROUP = 53 + integer, public, target, save, dimension(10) :: & + WDEP_ASOA_GROUP = (/ ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3 /) + + integer, public, parameter :: INDEX_WDEP_NVWOODOC25_GROUP = 54 + integer, public, target, save, dimension(1) :: & + WDEP_NVWOODOC25_GROUP = (/ POM_F_WOOD /) + + integer, public, parameter :: INDEX_WDEP_ASH_C_GROUP = 55 + integer, public, target, save, dimension(1) :: & + WDEP_ASH_C_GROUP = (/ V1702A02B_C /) + + integer, public, parameter :: INDEX_DDEP_NVWOODOC25_GROUP = 56 + integer, public, target, save, dimension(1) :: & + DDEP_NVWOODOC25_GROUP = (/ POM_F_WOOD /) + + integer, public, parameter :: INDEX_WDEP_ECFINE_GROUP = 57 + integer, public, target, save, dimension(4) :: & + WDEP_ECFINE_GROUP = (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE /) + + integer, public, parameter :: INDEX_WDEP_ECCOARSE_GROUP = 58 + integer, public, target, save, dimension(2) :: & + WDEP_ECCOARSE_GROUP = (/ EC_C_WOOD,EC_C_FFUEL /) + + integer, public, parameter :: INDEX_OXN_GROUP = 59 + integer, public, target, save, dimension(13) :: & + OXN_GROUP = (/ NO,NO2,PAN,MPAN,NO3,N2O5,ISONO3,HNO3,HONO,ISNI,ISNIR,NO3_F,NO3_C /) + + integer, public, parameter :: INDEX_WDEP_DUST_ANT_F_GROUP = 60 + integer, public, target, save, dimension(1) :: & + WDEP_DUST_ANT_F_GROUP = (/ DUST_ROAD_F /) + + integer, public, parameter :: INDEX_DDEP_NVFFUELOC25_GROUP = 61 + integer, public, target, save, dimension(1) :: & + DDEP_NVFFUELOC25_GROUP = (/ POM_F_FFUEL /) + + integer, public, parameter :: INDEX_SIA_GROUP = 62 + integer, public, target, save, dimension(4) :: & + SIA_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F /) - integer, public, parameter :: INDEX_SS_GROUP = 12 + integer, public, parameter :: INDEX_DDEP_ASH_GROUP = 63 + integer, public, target, save, dimension(2) :: & + DDEP_ASH_GROUP = (/ V1702A02B_F,V1702A02B_C /) + + integer, public, parameter :: INDEX_DDEP_NVFFIREOC25_GROUP = 64 + integer, public, target, save, dimension(1) :: & + DDEP_NVFFIREOC25_GROUP = (/ FFIRE_OM /) + + integer, public, parameter :: INDEX_DDEP_TNO3_GROUP = 65 + integer, public, target, save, dimension(2) :: & + DDEP_TNO3_GROUP = (/ NO3_F,NO3_C /) + + integer, public, parameter :: INDEX_DDEP_ASH_F_GROUP = 66 + integer, public, target, save, dimension(1) :: & + DDEP_ASH_F_GROUP = (/ V1702A02B_F /) + + integer, public, parameter :: INDEX_DDEP_PMCO_GROUP = 67 + integer, public, target, save, dimension(10) :: & + DDEP_PMCO_GROUP = (/ NO3_C,V1702A02B_C,POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C,SEASALT_C,DUST_ROAD_C,DUST_WB_C,DUST_SAH_C /) + + integer, public, parameter :: INDEX_DDEP_BSOA_GROUP = 68 + integer, public, target, save, dimension(10) :: & + DDEP_BSOA_GROUP = (/ BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3 /) + + integer, public, parameter :: INDEX_DDEP_PCM_GROUP = 69 + integer, public, target, save, dimension(28) :: & + DDEP_PCM_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_OM,FFIRE_BC,ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3,BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3 /) + + integer, public, parameter :: INDEX_DDEP_NVFFUELOC_COARSE_GROUP = 70 + integer, public, target, save, dimension(1) :: & + DDEP_NVFFUELOC_COARSE_GROUP = (/ POM_C_FFUEL /) + + integer, public, parameter :: INDEX_ECCOARSE_GROUP = 71 + integer, public, target, save, dimension(2) :: & + ECCOARSE_GROUP = (/ EC_C_WOOD,EC_C_FFUEL /) + + integer, public, parameter :: INDEX_WOODEC_GROUP = 72 integer, public, target, save, dimension(3) :: & - SS_GROUP = (/ SEASALT_F,SEASALT_C,SEASALT_G /) + WOODEC_GROUP = (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD /) - integer, public, parameter :: INDEX_DDEP_DUST_GROUP = 13 + integer, public, parameter :: INDEX_WDEP_TNO3_GROUP = 73 integer, public, target, save, dimension(2) :: & - DDEP_DUST_GROUP = (/ DUST_NAT_F,DUST_NAT_C /) + WDEP_TNO3_GROUP = (/ NO3_F,NO3_C /) - integer, public, parameter :: INDEX_PMCO_GROUP = 14 - integer, public, target, save, dimension(5) :: & - PMCO_GROUP = (/ NO3_C,PPM_C,SEASALT_C,SEASALT_G,DUST_NAT_C /) + integer, public, parameter :: INDEX_DDEP_DUST_ANT_C_GROUP = 74 + integer, public, target, save, dimension(1) :: & + DDEP_DUST_ANT_C_GROUP = (/ DUST_ROAD_C /) + + integer, public, parameter :: INDEX_WDEP_PMCO_GROUP = 75 + integer, public, target, save, dimension(10) :: & + WDEP_PMCO_GROUP = (/ NO3_C,V1702A02B_C,POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C,SEASALT_C,DUST_ROAD_C,DUST_WB_C,DUST_SAH_C /) - integer, public, parameter :: INDEX_DDEP_PMFINE_GROUP = 15 + integer, public, parameter :: INDEX_DDEP_FFUELEC_GROUP = 76 + integer, public, target, save, dimension(3) :: & + DDEP_FFUELEC_GROUP = (/ EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL /) + + integer, public, parameter :: INDEX_DDEP_ASH_C_GROUP = 77 + integer, public, target, save, dimension(1) :: & + DDEP_ASH_C_GROUP = (/ V1702A02B_C /) + + integer, public, parameter :: INDEX_WDEP_NVFFUELOC25_GROUP = 78 + integer, public, target, save, dimension(1) :: & + WDEP_NVFFUELOC25_GROUP = (/ POM_F_FFUEL /) + + integer, public, parameter :: INDEX_WDEP_PM10ANTHR_GROUP = 79 + integer, public, target, save, dimension(3) :: & + WDEP_PM10ANTHR_GROUP = (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL /) + + integer, public, parameter :: INDEX_WDEP_SVFFUELOA25_GROUP = 80 + integer, public, target, save, dimension(1) :: & + WDEP_SVFFUELOA25_GROUP = (/ FFFUEL_NG10 /) + + integer, public, parameter :: INDEX_DDEP_PPM25_GROUP = 81 integer, public, target, save, dimension(7) :: & - DDEP_PMFINE_GROUP = (/ SO4,NO3_F,NH4_F,PPM25,PPM25_FIRE,SEASALT_F,DUST_NAT_F /) + DDEP_PPM25_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25 /) - integer, public, parameter :: INDEX_RO2_GROUP = 16 - integer, public, target, save, dimension(13) :: & - RO2_GROUP = (/ HO2,CH3O2,C2H5O2,SECC4H9O2,ISRO2,ETRO2,PRRO2,OXYO2,MEKO2,MALO2,MVKO2,MACRO2,MACO3 /) + integer, public, parameter :: INDEX_WDEP_PPM25_FIRE_GROUP = 82 + integer, public, target, save, dimension(3) :: & + WDEP_PPM25_FIRE_GROUP = (/ FFIRE_OM,FFIRE_BC,FFIRE_REMPPM25 /) - integer, public, parameter :: INDEX_ROOH_GROUP = 17 - integer, public, target, save, dimension(16) :: & - ROOH_GROUP = (/ CH3O2H,C2H5OOH,BURO2H,ETRO2H,PRRO2H,OXYO2H,MEKO2H,MALO2H,MVKO2H,MACROOH,MACO3H,ISRO2H,H2O2,CH3COO2H,ISONO3H,ISNIRH /) + integer, public, parameter :: INDEX_FFIREBC_GROUP = 83 + integer, public, target, save, dimension(1) :: & + FFIREBC_GROUP = (/ FFIRE_BC /) - integer, public, parameter :: INDEX_WDEP_ROOH_GROUP = 18 + integer, public, parameter :: INDEX_WDEP_FFIREBC_GROUP = 84 integer, public, target, save, dimension(1) :: & - WDEP_ROOH_GROUP = (/ H2O2 /) + WDEP_FFIREBC_GROUP = (/ FFIRE_BC /) + + integer, public, parameter :: INDEX_NOX_GROUP = 85 + integer, public, target, save, dimension(2) :: & + NOX_GROUP = (/ NO,NO2 /) - integer, public, parameter :: INDEX_WDEP_RDN_GROUP = 19 + integer, public, parameter :: INDEX_DUST_NAT_F_GROUP = 86 integer, public, target, save, dimension(2) :: & - WDEP_RDN_GROUP = (/ NH3,NH4_F /) + DUST_NAT_F_GROUP = (/ DUST_WB_F,DUST_SAH_F /) - integer, public, parameter :: INDEX_AOD_GROUP = 20 - integer, public, target, save, dimension(8) :: & - AOD_GROUP = (/ SO4,NO3_F,NH4_F,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C /) + integer, public, parameter :: INDEX_SS_GROUP = 87 + integer, public, target, save, dimension(2) :: & + SS_GROUP = (/ SEASALT_F,SEASALT_C /) + + integer, public, parameter :: INDEX_DDEP_DUST_GROUP = 88 + integer, public, target, save, dimension(6) :: & + DDEP_DUST_GROUP = (/ DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C /) + + integer, public, parameter :: INDEX_RO2_GROUP = 89 + integer, public, target, save, dimension(14) :: & + RO2_GROUP = (/ HO2,CH3O2,C2H5O2,SECC4H9O2,ISRO2,ETRO2,PRRO2,OXYO2,MEKO2,MALO2,MVKO2,MACRO2,MACO3,TERPPEROXY /) + + integer, public, parameter :: INDEX_DDEP_EC_F_GROUP = 90 + integer, public, target, save, dimension(5) :: & + DDEP_EC_F_GROUP = (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_BC /) + + integer, public, parameter :: INDEX_ROOH_GROUP = 91 + integer, public, target, save, dimension(16) :: & + ROOH_GROUP = (/ CH3O2H,C2H5OOH,BURO2H,ETRO2H,PRRO2H,OXYO2H,MEKO2H,MALO2H,MVKO2H,MACROOH,MACO3H,ISRO2H,H2O2,CH3COO2H,ISONO3H,ISNIRH /) + + integer, public, parameter :: INDEX_DUST_ANT_C_GROUP = 92 + integer, public, target, save, dimension(1) :: & + DUST_ANT_C_GROUP = (/ DUST_ROAD_C /) + + integer, public, parameter :: INDEX_AOD_GROUP = 93 + integer, public, target, save, dimension(13) :: & + AOD_GROUP = (/ SO4,NO3_F,NH4_F,V1702A02B_F,V1702A02B_C,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C /) - integer, public, parameter :: INDEX_DDEP_SIA_GROUP = 21 + integer, public, parameter :: INDEX_DDEP_PPM_C_GROUP = 94 integer, public, target, save, dimension(4) :: & - DDEP_SIA_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F /) + DDEP_PPM_C_GROUP = (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C /) - integer, public, parameter :: INDEX_WDEP_PM10_GROUP = 22 - integer, public, target, save, dimension(12) :: & - WDEP_PM10_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F,PPM25,PPM25_FIRE,PPM_C,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C /) + integer, public, parameter :: INDEX_WDEP_NVABSOM_GROUP = 95 + integer, public, target, save, dimension(3) :: & + WDEP_NVABSOM_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,FFIRE_OM /) + + integer, public, parameter :: INDEX_SVFFUELOA25_GROUP = 96 + integer, public, target, save, dimension(1) :: & + SVFFUELOA25_GROUP = (/ FFFUEL_NG10 /) - integer, public, parameter :: INDEX_DDEP_OX_GROUP = 23 + integer, public, parameter :: INDEX_DDEP_SOX_GROUP = 97 integer, public, target, save, dimension(2) :: & - DDEP_OX_GROUP = (/ O3,NO2 /) + DDEP_SOX_GROUP = (/ SO2,SO4 /) - integer, public, parameter :: INDEX_DDEP_SOX_GROUP = 24 + integer, public, parameter :: INDEX_WDEP_DUST_NAT_F_GROUP = 98 integer, public, target, save, dimension(2) :: & - DDEP_SOX_GROUP = (/ SO2,SO4 /) + WDEP_DUST_NAT_F_GROUP = (/ DUST_WB_F,DUST_SAH_F /) - integer, public, parameter :: INDEX_OXN_GROUP = 25 - integer, public, target, save, dimension(13) :: & - OXN_GROUP = (/ NO,NO2,PAN,MPAN,NO3,N2O5,ISONO3,HNO3,HONO,ISNI,ISNIR,NO3_F,NO3_C /) + integer, public, parameter :: INDEX_ASH_F_GROUP = 99 + integer, public, target, save, dimension(1) :: & + ASH_F_GROUP = (/ V1702A02B_F /) - integer, public, parameter :: INDEX_TNO3_GROUP = 26 + integer, public, parameter :: INDEX_WDEP_SOX_GROUP = 100 integer, public, target, save, dimension(2) :: & - TNO3_GROUP = (/ NO3_F,NO3_C /) + WDEP_SOX_GROUP = (/ SO2,SO4 /) + + integer, public, parameter :: INDEX_PFFUELOA25_GROUP = 101 + integer, public, target, save, dimension(1) :: & + PFFUELOA25_GROUP = (/ FFFUEL_NG10 /) + + integer, public, parameter :: INDEX_FFUELEC_GROUP = 102 + integer, public, target, save, dimension(3) :: & + FFUELEC_GROUP = (/ EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL /) - integer, public, parameter :: INDEX_WDEP_SOX_GROUP = 27 + integer, public, parameter :: INDEX_PM10ANTHR_GROUP = 103 + integer, public, target, save, dimension(3) :: & + PM10ANTHR_GROUP = (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL /) + + integer, public, parameter :: INDEX_WDEP_DUST_ANT_C_GROUP = 104 + integer, public, target, save, dimension(1) :: & + WDEP_DUST_ANT_C_GROUP = (/ DUST_ROAD_C /) + + integer, public, parameter :: INDEX_DDEP_DUST_NAT_F_GROUP = 105 integer, public, target, save, dimension(2) :: & - WDEP_SOX_GROUP = (/ SO2,SO4 /) + DDEP_DUST_NAT_F_GROUP = (/ DUST_WB_F,DUST_SAH_F /) + + integer, public, parameter :: INDEX_DDEP_PM10ANTHR_GROUP = 106 + integer, public, target, save, dimension(3) :: & + DDEP_PM10ANTHR_GROUP = (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL /) - integer, public, parameter :: INDEX_PM10_GROUP = 28 - integer, public, target, save, dimension(12) :: & - PM10_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F,PPM25,PPM25_FIRE,PPM_C,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C /) + integer, public, parameter :: INDEX_DDEP_WOODEC_GROUP = 107 + integer, public, target, save, dimension(3) :: & + DDEP_WOODEC_GROUP = (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD /) - integer, public, parameter :: INDEX_OX_GROUP = 29 + integer, public, parameter :: INDEX_V1702A02B_GROUP = 108 integer, public, target, save, dimension(2) :: & - OX_GROUP = (/ O3,NO2 /) + V1702A02B_GROUP = (/ V1702A02B_F,V1702A02B_C /) - integer, public, parameter :: INDEX_SIA_GROUP = 30 - integer, public, target, save, dimension(4) :: & - SIA_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F /) + integer, public, parameter :: INDEX_WDEP_WOODEC_GROUP = 109 + integer, public, target, save, dimension(3) :: & + WDEP_WOODEC_GROUP = (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD /) + + integer, public, parameter :: INDEX_WDEP_PCM_GROUP = 110 + integer, public, target, save, dimension(31) :: & + WDEP_PCM_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_OM,FFIRE_BC,ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3,BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3,FFFUEL_NG10,WOODOA_NG10,FFIREOA_NG10 /) + + integer, public, parameter :: INDEX_WDEP_SS_GROUP = 111 + integer, public, target, save, dimension(2) :: & + WDEP_SS_GROUP = (/ SEASALT_F,SEASALT_C /) + + integer, public, parameter :: INDEX_DUST_NAT_C_GROUP = 112 + integer, public, target, save, dimension(2) :: & + DUST_NAT_C_GROUP = (/ DUST_WB_C,DUST_SAH_C /) - integer, public, parameter :: INDEX_DDEP_OXN_GROUP = 31 + integer, public, parameter :: INDEX_WDEP_NONVOLPCM_GROUP = 113 + integer, public, target, save, dimension(10) :: & + WDEP_NONVOLPCM_GROUP = (/ POM_F_WOOD,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,FFIRE_OM,FFIRE_BC /) + + integer, public, parameter :: INDEX_PPM25_GROUP = 114 integer, public, target, save, dimension(7) :: & - DDEP_OXN_GROUP = (/ NO2,PAN,MPAN,HNO3,HONO,NO3_F,NO3_C /) + PPM25_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25 /) + + integer, public, parameter :: INDEX_ASOA_GROUP = 115 + integer, public, target, save, dimension(10) :: & + ASOA_GROUP = (/ ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3 /) + + integer, public, parameter :: INDEX_PPM10_GROUP = 116 + integer, public, target, save, dimension(11) :: & + PPM10_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C /) - integer, public, parameter :: INDEX_DDEP_ROOH_GROUP = 32 + integer, public, parameter :: INDEX_NVABSOM_GROUP = 117 integer, public, target, save, dimension(3) :: & - DDEP_ROOH_GROUP = (/ CH3O2H,C2H5OOH,H2O2 /) + NVABSOM_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,FFIRE_OM /) - integer, public, parameter :: INDEX_DDEP_PM10_GROUP = 33 - integer, public, target, save, dimension(12) :: & - DDEP_PM10_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F,PPM25,PPM25_FIRE,PPM_C,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C /) + integer, public, parameter :: INDEX_BSOA_GROUP = 118 + integer, public, target, save, dimension(10) :: & + BSOA_GROUP = (/ BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3 /) - integer, public, parameter :: INDEX_WDEP_PMFINE_GROUP = 34 - integer, public, target, save, dimension(7) :: & - WDEP_PMFINE_GROUP = (/ SO4,NO3_F,NH4_F,PPM25,PPM25_FIRE,SEASALT_F,DUST_NAT_F /) + integer, public, parameter :: INDEX_ECFINE_GROUP = 119 + integer, public, target, save, dimension(4) :: & + ECFINE_GROUP = (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE /) - integer, public, parameter :: INDEX_DDEP_TNO3_GROUP = 35 - integer, public, target, save, dimension(2) :: & - DDEP_TNO3_GROUP = (/ NO3_F,NO3_C /) + integer, public, parameter :: INDEX_DDEP_FFIREBC_GROUP = 120 + integer, public, target, save, dimension(1) :: & + DDEP_FFIREBC_GROUP = (/ FFIRE_BC /) + + integer, public, parameter :: INDEX_WDEP_DUST_GROUP = 121 + integer, public, target, save, dimension(6) :: & + WDEP_DUST_GROUP = (/ DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C /) - integer, public, parameter :: INDEX_WDEP_SIA_GROUP = 36 + integer, public, parameter :: INDEX_NVFFUELOC_COARSE_GROUP = 122 + integer, public, target, save, dimension(1) :: & + NVFFUELOC_COARSE_GROUP = (/ POM_C_FFUEL /) + + integer, public, parameter :: INDEX_DDEP_ECFINE_GROUP = 123 integer, public, target, save, dimension(4) :: & - WDEP_SIA_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F /) + DDEP_ECFINE_GROUP = (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE /) - integer, public, parameter :: INDEX_DDEP_RDN_GROUP = 37 - integer, public, target, save, dimension(2) :: & - DDEP_RDN_GROUP = (/ NH3,NH4_F /) + integer, public, parameter :: INDEX_WDEP_ROOH_GROUP = 124 + integer, public, target, save, dimension(1) :: & + WDEP_ROOH_GROUP = (/ H2O2 /) - integer, public, parameter :: INDEX_DDEP_PMCO_GROUP = 38 - integer, public, target, save, dimension(5) :: & - DDEP_PMCO_GROUP = (/ NO3_C,PPM_C,SEASALT_C,SEASALT_G,DUST_NAT_C /) + integer, public, parameter :: INDEX_PCM_GROUP = 125 + integer, public, target, save, dimension(31) :: & + PCM_GROUP = (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_OM,FFIRE_BC,ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3,BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3,FFFUEL_NG10,WOODOA_NG10,FFIREOA_NG10 /) + + integer, public, parameter :: INDEX_SVWOODOA25_GROUP = 126 + integer, public, target, save, dimension(1) :: & + SVWOODOA25_GROUP = (/ WOODOA_NG10 /) + + integer, public, parameter :: INDEX_DDEP_SIA_GROUP = 127 + integer, public, target, save, dimension(4) :: & + DDEP_SIA_GROUP = (/ SO4,NO3_F,NO3_C,NH4_F /) + + integer, public, parameter :: INDEX_WDEP_PFFIREOA25_GROUP = 128 + integer, public, target, save, dimension(1) :: & + WDEP_PFFIREOA25_GROUP = (/ FFIREOA_NG10 /) + + integer, public, parameter :: INDEX_PCM_HELP_GROUP = 129 + integer, public, target, save, dimension(20) :: & + PCM_HELP_GROUP = (/ GAS_ASOA_OC,PART_ASOA_OC,PART_ASOA_OM,GAS_BSOA_OC,PART_BSOA_OC,PART_BSOA_OM,PART_FFUELOA25_OC,PART_FFUELOA25_OM,PART_WOODOA25_OC,PART_WOODOA25_OM,PART_FFIREOA25_OC,PART_FFIREOA25_OM,PART_OC10,PART_OC25,NONVOL_FFUELOC25,NONV_FFUELOC_COARSE,NONVOL_WOODOC25,NONVOL_BGNDOC,NONVOL_FFIREOC25,PART_OM_F /) + + integer, public, parameter :: INDEX_WDEP_OMCOARSE_GROUP = 130 + integer, public, target, save, dimension(1) :: & + WDEP_OMCOARSE_GROUP = (/ POM_C_FFUEL /) - integer, public, parameter :: INDEX_BVOC_GROUP = 39 + integer, public, parameter :: INDEX_TNO3_GROUP = 131 integer, public, target, save, dimension(2) :: & - BVOC_GROUP = (/ C5H8,APINENE /) + TNO3_GROUP = (/ NO3_F,NO3_C /) - integer, public, parameter :: INDEX_RDN_GROUP = 40 + integer, public, parameter :: INDEX_SVFFIREOA25_GROUP = 132 + integer, public, target, save, dimension(1) :: & + SVFFIREOA25_GROUP = (/ FFIREOA_NG10 /) + + integer, public, parameter :: INDEX_NVFFUELOC25_GROUP = 133 + integer, public, target, save, dimension(1) :: & + NVFFUELOC25_GROUP = (/ POM_F_FFUEL /) + + integer, public, parameter :: INDEX_DDEP_V1702A02B_GROUP = 134 integer, public, target, save, dimension(2) :: & - RDN_GROUP = (/ NH3,NH4_F /) + DDEP_V1702A02B_GROUP = (/ V1702A02B_F,V1702A02B_C /) + + integer, public, parameter :: INDEX_OMCOARSE_GROUP = 135 + integer, public, target, save, dimension(1) :: & + OMCOARSE_GROUP = (/ POM_C_FFUEL /) - integer, public, parameter :: INDEX_WDEP_SS_GROUP = 41 + integer, public, parameter :: INDEX_DDEP_ROOH_GROUP = 136 integer, public, target, save, dimension(3) :: & - WDEP_SS_GROUP = (/ SEASALT_F,SEASALT_C,SEASALT_G /) + DDEP_ROOH_GROUP = (/ CH3O2H,C2H5OOH,H2O2 /) - integer, public, parameter :: INDEX_WDEP_TNO3_GROUP = 42 + integer, public, parameter :: INDEX_WDEP_PMFINE_GROUP = 137 + integer, public, target, save, dimension(15) :: & + WDEP_PMFINE_GROUP = (/ SO4,NO3_F,NH4_F,V1702A02B_F,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,DUST_ROAD_F,DUST_WB_F,DUST_SAH_F /) + + integer, public, parameter :: INDEX_DDEP_RDN_GROUP = 138 integer, public, target, save, dimension(2) :: & - WDEP_TNO3_GROUP = (/ NO3_F,NO3_C /) + DDEP_RDN_GROUP = (/ NH3,NH4_F /) + + integer, public, parameter :: INDEX_PFFIREOA25_GROUP = 139 + integer, public, target, save, dimension(1) :: & + PFFIREOA25_GROUP = (/ FFIREOA_NG10 /) + integer, public, parameter :: INDEX_RDN_GROUP = 140 + integer, public, target, save, dimension(2) :: & + RDN_GROUP = (/ NH3,NH4_F /) -!GROUP ARRAY SIZE 42 MAXN 16 + integer, public, parameter :: INDEX_WDEP_ASH_GROUP = 141 + integer, public, target, save, dimension(2) :: & + WDEP_ASH_GROUP = (/ V1702A02B_F,V1702A02B_C /) - type, public :: gtype + integer, public, parameter :: INDEX_WDEP_FFUELEC_GROUP = 142 + integer, public, target, save, dimension(3) :: & + WDEP_FFUELEC_GROUP = (/ EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL /) + + +!GROUP ARRAY SIZE 142 MAXN 31 + + type, public :: gtype character(len=20) :: name integer :: Ngroup - integer, dimension(16) :: itot ! indices from xn_tot arrays + integer, dimension(31) :: itot ! indices from xn_tot arrays end type gtype - type(gtype), public, parameter, dimension(42) :: & + type(gtype), public, parameter, dimension(142) :: & GROUP_ARRAY = (/ & - gtype( "DDEP_SS", 3, (/ SEASALT_F,SEASALT_C,SEASALT_G,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "SOX", 2, (/ SO2,SO4,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "PMFINE", 7, (/ SO4,NO3_F,NH4_F,PPM25,PPM25_FIRE,SEASALT_F,DUST_NAT_F,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_OXN", 4, (/ HNO3,HONO,NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_PMCO", 5, (/ NO3_C,PPM_C,SEASALT_C,SEASALT_G,DUST_NAT_C,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DUST", 2, (/ DUST_NAT_F,DUST_NAT_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_AOD", 8, (/ SO4,NO3_F,NH4_F,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_AOD", 8, (/ SO4,NO3_F,NH4_F,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_NOX", 1, (/ NO2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_DUST", 2, (/ DUST_NAT_F,DUST_NAT_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "NOX", 2, (/ NO,NO2,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "SS", 3, (/ SEASALT_F,SEASALT_C,SEASALT_G,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_DUST", 2, (/ DUST_NAT_F,DUST_NAT_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "PMCO", 5, (/ NO3_C,PPM_C,SEASALT_C,SEASALT_G,DUST_NAT_C,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_PMFINE", 7, (/ SO4,NO3_F,NH4_F,PPM25,PPM25_FIRE,SEASALT_F,DUST_NAT_F,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "RO2", 13, (/ HO2,CH3O2,C2H5O2,SECC4H9O2,ISRO2,ETRO2,PRRO2,OXYO2,MEKO2,MALO2,MVKO2,MACRO2,MACO3,0,0,0 /) ) & -, gtype( "ROOH", 16, (/ CH3O2H,C2H5OOH,BURO2H,ETRO2H,PRRO2H,OXYO2H,MEKO2H,MALO2H,MVKO2H,MACROOH,MACO3H,ISRO2H,H2O2,CH3COO2H,ISONO3H,ISNIRH /) ) & -, gtype( "WDEP_ROOH", 1, (/ H2O2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_RDN", 2, (/ NH3,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "AOD", 8, (/ SO4,NO3_F,NH4_F,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_SIA", 4, (/ SO4,NO3_F,NO3_C,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_PM10", 12, (/ SO4,NO3_F,NO3_C,NH4_F,PPM25,PPM25_FIRE,PPM_C,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C,0,0,0,0 /) ) & -, gtype( "DDEP_OX", 2, (/ O3,NO2,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_SOX", 2, (/ SO2,SO4,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "OXN", 13, (/ NO,NO2,PAN,MPAN,NO3,N2O5,ISONO3,HNO3,HONO,ISNI,ISNIR,NO3_F,NO3_C,0,0,0 /) ) & -, gtype( "TNO3", 2, (/ NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_SOX", 2, (/ SO2,SO4,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "PM10", 12, (/ SO4,NO3_F,NO3_C,NH4_F,PPM25,PPM25_FIRE,PPM_C,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C,0,0,0,0 /) ) & -, gtype( "OX", 2, (/ O3,NO2,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "SIA", 4, (/ SO4,NO3_F,NO3_C,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_OXN", 7, (/ NO2,PAN,MPAN,HNO3,HONO,NO3_F,NO3_C,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_ROOH", 3, (/ CH3O2H,C2H5OOH,H2O2,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_PM10", 12, (/ SO4,NO3_F,NO3_C,NH4_F,PPM25,PPM25_FIRE,PPM_C,SEASALT_F,SEASALT_C,SEASALT_G,DUST_NAT_F,DUST_NAT_C,0,0,0,0 /) ) & -, gtype( "WDEP_PMFINE", 7, (/ SO4,NO3_F,NH4_F,PPM25,PPM25_FIRE,SEASALT_F,DUST_NAT_F,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_TNO3", 2, (/ NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_SIA", 4, (/ SO4,NO3_F,NO3_C,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_RDN", 2, (/ NH3,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "DDEP_PMCO", 5, (/ NO3_C,PPM_C,SEASALT_C,SEASALT_G,DUST_NAT_C,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "BVOC", 2, (/ C5H8,APINENE,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "RDN", 2, (/ NH3,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_SS", 3, (/ SEASALT_F,SEASALT_C,SEASALT_G,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & -, gtype( "WDEP_TNO3", 2, (/ NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & + gtype( "DDEP_SS", 2, (/ SEASALT_F,SEASALT_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_OXN", 4, (/ HNO3,HONO,NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PPM10", 11, (/ POM_F_WOOD,POM_F_FFUEL,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "ASH_C", 1, (/ V1702A02B_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DUST", 6, (/ DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_AOD", 13, (/ SO4,NO3_F,NH4_F,V1702A02B_F,V1702A02B_C,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_BSOA", 10, (/ BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_NOX", 1, (/ NO2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PPM_C", 4, (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_DUST_NAT_C", 2, (/ DUST_WB_C,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PPM25_FIRE", 3, (/ FFIRE_OM,FFIRE_BC,FFIRE_REMPPM25,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_SVWOODOA25", 1, (/ WOODOA_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_PMFINE", 15, (/ SO4,NO3_F,NH4_F,V1702A02B_F,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,DUST_ROAD_F,DUST_WB_F,DUST_SAH_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PPM25", 7, (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PM10", 25, (/ SO4,NO3_F,NO3_C,NH4_F,V1702A02B_F,V1702A02B_C,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_OX", 2, (/ O3,NO2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_ECCOARSE", 2, (/ EC_C_WOOD,EC_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "NVWOODOC25", 1, (/ POM_F_WOOD,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "ASH", 2, (/ V1702A02B_F,V1702A02B_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_NVFFUELOC_COARSE", 1, (/ POM_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PM10", 26, (/ SO4,NO3_F,NO3_C,NH4_F,V1702A02B_F,V1702A02B_C,PART_OM_F,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C,0,0,0,0,0 /) ) & +, gtype( "WDEP_PWOODOA25", 1, (/ WOODOA_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_ASOA", 10, (/ ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "OX", 2, (/ O3,NO2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_OXN", 7, (/ NO2,PAN,MPAN,HNO3,HONO,NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PFFUELOA25", 1, (/ FFFUEL_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_PPM10", 11, (/ POM_F_WOOD,POM_F_FFUEL,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PPM_C", 4, (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_PPM25_FIRE", 3, (/ FFIRE_OM,FFIRE_BC,FFIRE_REMPPM25,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_EC_F", 5, (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_BC,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_PM10", 25, (/ SO4,NO3_F,NO3_C,NH4_F,V1702A02B_F,V1702A02B_C,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_SIA", 4, (/ SO4,NO3_F,NO3_C,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "BVOC", 2, (/ C5H8,APINENE,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PWOODOA25", 1, (/ WOODOA_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "EC_F", 5, (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_BC,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_NONVOLPCM", 10, (/ POM_F_WOOD,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,FFIRE_OM,FFIRE_BC,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_NVFFIREOC25", 1, (/ FFIRE_OM,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "SOX", 2, (/ SO2,SO4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DUST_ANT_F", 1, (/ DUST_ROAD_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PMFINE", 16, (/ SO4,NO3_F,NH4_F,V1702A02B_F,PART_OM_F,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,DUST_ROAD_F,DUST_WB_F,DUST_SAH_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_NVABSOM", 3, (/ POM_F_WOOD,POM_F_FFUEL,FFIRE_OM,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_SVFFIREOA25", 1, (/ FFIREOA_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_AOD", 13, (/ SO4,NO3_F,NH4_F,V1702A02B_F,V1702A02B_C,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "NONVOLPCM", 10, (/ POM_F_WOOD,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,FFIRE_OM,FFIRE_BC,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_V1702A02B", 2, (/ V1702A02B_F,V1702A02B_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_ASH_F", 1, (/ V1702A02B_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_DUST_NAT_C", 2, (/ DUST_WB_C,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PMCO", 10, (/ NO3_C,V1702A02B_C,POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C,SEASALT_C,DUST_ROAD_C,DUST_WB_C,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_DUST_ANT_F", 1, (/ DUST_ROAD_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_OMCOARSE", 1, (/ POM_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "NVFFIREOC25", 1, (/ FFIRE_OM,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_RDN", 2, (/ NH3,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_ASOA", 10, (/ ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_NVWOODOC25", 1, (/ POM_F_WOOD,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_ASH_C", 1, (/ V1702A02B_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_NVWOODOC25", 1, (/ POM_F_WOOD,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_ECFINE", 4, (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_ECCOARSE", 2, (/ EC_C_WOOD,EC_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "OXN", 13, (/ NO,NO2,PAN,MPAN,NO3,N2O5,ISONO3,HNO3,HONO,ISNI,ISNIR,NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_DUST_ANT_F", 1, (/ DUST_ROAD_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_NVFFUELOC25", 1, (/ POM_F_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "SIA", 4, (/ SO4,NO3_F,NO3_C,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_ASH", 2, (/ V1702A02B_F,V1702A02B_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_NVFFIREOC25", 1, (/ FFIRE_OM,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_TNO3", 2, (/ NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_ASH_F", 1, (/ V1702A02B_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_PMCO", 10, (/ NO3_C,V1702A02B_C,POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C,SEASALT_C,DUST_ROAD_C,DUST_WB_C,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_BSOA", 10, (/ BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_PCM", 28, (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_OM,FFIRE_BC,ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3,BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3,0,0,0 /) ) & +, gtype( "DDEP_NVFFUELOC_COARSE", 1, (/ POM_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "ECCOARSE", 2, (/ EC_C_WOOD,EC_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WOODEC", 3, (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_TNO3", 2, (/ NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_DUST_ANT_C", 1, (/ DUST_ROAD_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PMCO", 10, (/ NO3_C,V1702A02B_C,POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C,SEASALT_C,DUST_ROAD_C,DUST_WB_C,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_FFUELEC", 3, (/ EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_ASH_C", 1, (/ V1702A02B_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_NVFFUELOC25", 1, (/ POM_F_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PM10ANTHR", 3, (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_SVFFUELOA25", 1, (/ FFFUEL_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_PPM25", 7, (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PPM25_FIRE", 3, (/ FFIRE_OM,FFIRE_BC,FFIRE_REMPPM25,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "FFIREBC", 1, (/ FFIRE_BC,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_FFIREBC", 1, (/ FFIRE_BC,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "NOX", 2, (/ NO,NO2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DUST_NAT_F", 2, (/ DUST_WB_F,DUST_SAH_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "SS", 2, (/ SEASALT_F,SEASALT_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_DUST", 6, (/ DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "RO2", 14, (/ HO2,CH3O2,C2H5O2,SECC4H9O2,ISRO2,ETRO2,PRRO2,OXYO2,MEKO2,MALO2,MVKO2,MACRO2,MACO3,TERPPEROXY,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_EC_F", 5, (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_BC,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "ROOH", 16, (/ CH3O2H,C2H5OOH,BURO2H,ETRO2H,PRRO2H,OXYO2H,MEKO2H,MALO2H,MVKO2H,MACROOH,MACO3H,ISRO2H,H2O2,CH3COO2H,ISONO3H,ISNIRH,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DUST_ANT_C", 1, (/ DUST_ROAD_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "AOD", 13, (/ SO4,NO3_F,NH4_F,V1702A02B_F,V1702A02B_C,SEASALT_F,SEASALT_C,DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_PPM_C", 4, (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,REMPPM_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_NVABSOM", 3, (/ POM_F_WOOD,POM_F_FFUEL,FFIRE_OM,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "SVFFUELOA25", 1, (/ FFFUEL_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_SOX", 2, (/ SO2,SO4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_DUST_NAT_F", 2, (/ DUST_WB_F,DUST_SAH_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "ASH_F", 1, (/ V1702A02B_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_SOX", 2, (/ SO2,SO4,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PFFUELOA25", 1, (/ FFFUEL_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "FFUELEC", 3, (/ EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PM10ANTHR", 3, (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_DUST_ANT_C", 1, (/ DUST_ROAD_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_DUST_NAT_F", 2, (/ DUST_WB_F,DUST_SAH_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_PM10ANTHR", 3, (/ POM_C_FFUEL,EC_C_WOOD,EC_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_WOODEC", 3, (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "V1702A02B", 2, (/ V1702A02B_F,V1702A02B_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_WOODEC", 3, (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PCM", 31, (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_OM,FFIRE_BC,ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3,BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3,FFFUEL_NG10,WOODOA_NG10,FFIREOA_NG10 /) ) & +, gtype( "WDEP_SS", 2, (/ SEASALT_F,SEASALT_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DUST_NAT_C", 2, (/ DUST_WB_C,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_NONVOLPCM", 10, (/ POM_F_WOOD,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,FFIRE_OM,FFIRE_BC,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PPM25", 7, (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "ASOA", 10, (/ ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PPM10", 11, (/ POM_F_WOOD,POM_F_FFUEL,POM_C_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_C_WOOD,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,REMPPM25,REMPPM_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "NVABSOM", 3, (/ POM_F_WOOD,POM_F_FFUEL,FFIRE_OM,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "BSOA", 10, (/ BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "ECFINE", 4, (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_FFIREBC", 1, (/ FFIRE_BC,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_DUST", 6, (/ DUST_ROAD_F,DUST_ROAD_C,DUST_WB_F,DUST_WB_C,DUST_SAH_F,DUST_SAH_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "NVFFUELOC_COARSE", 1, (/ POM_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_ECFINE", 4, (/ EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_ROOH", 1, (/ H2O2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PCM", 31, (/ POM_F_WOOD,POM_F_FFUEL,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,FFIRE_OM,FFIRE_BC,ASOC_NG100,ASOC_UG1,ASOC_UG10,ASOC_UG1E2,ASOC_UG1E3,NON_C_ASOA_NG100,NON_C_ASOA_UG1,NON_C_ASOA_UG10,NON_C_ASOA_UG1E2,NON_C_ASOA_UG1E3,BSOC_NG100,BSOC_UG1,BSOC_UG10,BSOC_UG1E2,BSOC_UG1E3,NON_C_BSOA_NG100,NON_C_BSOA_UG1,NON_C_BSOA_UG10,NON_C_BSOA_UG1E2,NON_C_BSOA_UG1E3,FFFUEL_NG10,WOODOA_NG10,FFIREOA_NG10 /) ) & +, gtype( "SVWOODOA25", 1, (/ WOODOA_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_SIA", 4, (/ SO4,NO3_F,NO3_C,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PFFIREOA25", 1, (/ FFIREOA_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PCM_HELP", 20, (/ GAS_ASOA_OC,PART_ASOA_OC,PART_ASOA_OM,GAS_BSOA_OC,PART_BSOA_OC,PART_BSOA_OM,PART_FFUELOA25_OC,PART_FFUELOA25_OM,PART_WOODOA25_OC,PART_WOODOA25_OM,PART_FFIREOA25_OC,PART_FFIREOA25_OM,PART_OC10,PART_OC25,NONVOL_FFUELOC25,NONV_FFUELOC_COARSE,NONVOL_WOODOC25,NONVOL_BGNDOC,NONVOL_FFIREOC25,PART_OM_F,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_OMCOARSE", 1, (/ POM_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "TNO3", 2, (/ NO3_F,NO3_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "SVFFIREOA25", 1, (/ FFIREOA_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "NVFFUELOC25", 1, (/ POM_F_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_V1702A02B", 2, (/ V1702A02B_F,V1702A02B_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "OMCOARSE", 1, (/ POM_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_ROOH", 3, (/ CH3O2H,C2H5OOH,H2O2,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_PMFINE", 15, (/ SO4,NO3_F,NH4_F,V1702A02B_F,EC_F_WOOD_NEW,EC_F_WOOD_AGE,EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,REMPPM25,FFIRE_BC,FFIRE_REMPPM25,SEASALT_F,DUST_ROAD_F,DUST_WB_F,DUST_SAH_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "DDEP_RDN", 2, (/ NH3,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "PFFIREOA25", 1, (/ FFIREOA_NG10,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "RDN", 2, (/ NH3,NH4_F,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_ASH", 2, (/ V1702A02B_F,V1702A02B_C,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & +, gtype( "WDEP_FFUELEC", 3, (/ EC_F_FFUEL_NEW,EC_F_FFUEL_AGE,EC_C_FFUEL,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0 /) ) & /) ! ------- Dry dep species ------------------ @@ -251,8 +751,8 @@ module ChemGroups_ml WDEP_OXNGROUP = (/ HNO3,HONO,NO3_f,NO3_c /) integer, public, parameter, dimension(2) :: & WDEP_SOXGROUP = (/ SO2,SO4 /) - integer, public, parameter, dimension(3) :: & - WDEP_SSALTGROUP = (/ SeaSalt_f,SeaSalt_c,SeaSalt_g /) + integer, public, parameter, dimension(2) :: & + WDEP_SSALTGROUP = (/ SeaSalt_f,SeaSalt_c /) integer, public, parameter, dimension(2) :: & WDEP_RDNGROUP = (/ NH3,NH4_f /) @@ -263,7 +763,7 @@ module ChemGroups_ml integer, public, parameter :: SIZE_RO2_POOL = 1 integer, public, parameter, dimension(1) :: & RO2_POOL = (/ -99 /) - type(typ_sp), dimension(42), public, save :: chemgroups + type(typ_sp), dimension(142), public, save :: chemgroups !----------------------------------------------------------- @@ -275,128 +775,428 @@ subroutine Init_ChemGroups() p => DDEP_SS_GROUP chemgroups(1) = typ_sp("DDEP_SS", p ) + p => WDEP_OXN_GROUP + chemgroups(2) = typ_sp("WDEP_OXN", p ) + + p => WDEP_PPM10_GROUP + chemgroups(3) = typ_sp("WDEP_PPM10", p ) + + p => ASH_C_GROUP + chemgroups(4) = typ_sp("ASH_C", p ) + + p => DUST_GROUP + chemgroups(5) = typ_sp("DUST", p ) + + p => WDEP_AOD_GROUP + chemgroups(6) = typ_sp("WDEP_AOD", p ) + + p => WDEP_BSOA_GROUP + chemgroups(7) = typ_sp("WDEP_BSOA", p ) + + p => DDEP_NOX_GROUP + chemgroups(8) = typ_sp("DDEP_NOX", p ) + + p => PPM_C_GROUP + chemgroups(9) = typ_sp("PPM_C", p ) + + p => DDEP_DUST_NAT_C_GROUP + chemgroups(10) = typ_sp("DDEP_DUST_NAT_C", p ) + + p => PPM25_FIRE_GROUP + chemgroups(11) = typ_sp("PPM25_FIRE", p ) + + p => WDEP_SVWOODOA25_GROUP + chemgroups(12) = typ_sp("WDEP_SVWOODOA25", p ) + + p => DDEP_PMFINE_GROUP + chemgroups(13) = typ_sp("DDEP_PMFINE", p ) + + p => WDEP_PPM25_GROUP + chemgroups(14) = typ_sp("WDEP_PPM25", p ) + + p => WDEP_PM10_GROUP + chemgroups(15) = typ_sp("WDEP_PM10", p ) + + p => DDEP_OX_GROUP + chemgroups(16) = typ_sp("DDEP_OX", p ) + + p => DDEP_ECCOARSE_GROUP + chemgroups(17) = typ_sp("DDEP_ECCOARSE", p ) + + p => NVWOODOC25_GROUP + chemgroups(18) = typ_sp("NVWOODOC25", p ) + + p => ASH_GROUP + chemgroups(19) = typ_sp("ASH", p ) + + p => WDEP_NVFFUELOC_COARSE_GROUP + chemgroups(20) = typ_sp("WDEP_NVFFUELOC_COARSE", p ) + + p => PM10_GROUP + chemgroups(21) = typ_sp("PM10", p ) + + p => WDEP_PWOODOA25_GROUP + chemgroups(22) = typ_sp("WDEP_PWOODOA25", p ) + + p => DDEP_ASOA_GROUP + chemgroups(23) = typ_sp("DDEP_ASOA", p ) + + p => OX_GROUP + chemgroups(24) = typ_sp("OX", p ) + + p => DDEP_OXN_GROUP + chemgroups(25) = typ_sp("DDEP_OXN", p ) + + p => WDEP_PFFUELOA25_GROUP + chemgroups(26) = typ_sp("WDEP_PFFUELOA25", p ) + + p => DDEP_PPM10_GROUP + chemgroups(27) = typ_sp("DDEP_PPM10", p ) + + p => WDEP_PPM_C_GROUP + chemgroups(28) = typ_sp("WDEP_PPM_C", p ) + + p => DDEP_PPM25_FIRE_GROUP + chemgroups(29) = typ_sp("DDEP_PPM25_FIRE", p ) + + p => WDEP_EC_F_GROUP + chemgroups(30) = typ_sp("WDEP_EC_F", p ) + + p => DDEP_PM10_GROUP + chemgroups(31) = typ_sp("DDEP_PM10", p ) + + p => WDEP_SIA_GROUP + chemgroups(32) = typ_sp("WDEP_SIA", p ) + + p => BVOC_GROUP + chemgroups(33) = typ_sp("BVOC", p ) + + p => PWOODOA25_GROUP + chemgroups(34) = typ_sp("PWOODOA25", p ) + + p => EC_F_GROUP + chemgroups(35) = typ_sp("EC_F", p ) + + p => DDEP_NONVOLPCM_GROUP + chemgroups(36) = typ_sp("DDEP_NONVOLPCM", p ) + + p => WDEP_NVFFIREOC25_GROUP + chemgroups(37) = typ_sp("WDEP_NVFFIREOC25", p ) + p => SOX_GROUP - chemgroups(2) = typ_sp("SOX", p ) + chemgroups(38) = typ_sp("SOX", p ) + + p => DUST_ANT_F_GROUP + chemgroups(39) = typ_sp("DUST_ANT_F", p ) p => PMFINE_GROUP - chemgroups(3) = typ_sp("PMFINE", p ) + chemgroups(40) = typ_sp("PMFINE", p ) - p => WDEP_OXN_GROUP - chemgroups(4) = typ_sp("WDEP_OXN", p ) + p => DDEP_NVABSOM_GROUP + chemgroups(41) = typ_sp("DDEP_NVABSOM", p ) + + p => WDEP_SVFFIREOA25_GROUP + chemgroups(42) = typ_sp("WDEP_SVFFIREOA25", p ) + + p => DDEP_AOD_GROUP + chemgroups(43) = typ_sp("DDEP_AOD", p ) + + p => NONVOLPCM_GROUP + chemgroups(44) = typ_sp("NONVOLPCM", p ) + + p => WDEP_V1702A02B_GROUP + chemgroups(45) = typ_sp("WDEP_V1702A02B", p ) + + p => WDEP_ASH_F_GROUP + chemgroups(46) = typ_sp("WDEP_ASH_F", p ) + + p => WDEP_DUST_NAT_C_GROUP + chemgroups(47) = typ_sp("WDEP_DUST_NAT_C", p ) + + p => PMCO_GROUP + chemgroups(48) = typ_sp("PMCO", p ) + + p => DDEP_DUST_ANT_F_GROUP + chemgroups(49) = typ_sp("DDEP_DUST_ANT_F", p ) + + p => DDEP_OMCOARSE_GROUP + chemgroups(50) = typ_sp("DDEP_OMCOARSE", p ) + + p => NVFFIREOC25_GROUP + chemgroups(51) = typ_sp("NVFFIREOC25", p ) + + p => WDEP_RDN_GROUP + chemgroups(52) = typ_sp("WDEP_RDN", p ) + + p => WDEP_ASOA_GROUP + chemgroups(53) = typ_sp("WDEP_ASOA", p ) + + p => WDEP_NVWOODOC25_GROUP + chemgroups(54) = typ_sp("WDEP_NVWOODOC25", p ) + + p => WDEP_ASH_C_GROUP + chemgroups(55) = typ_sp("WDEP_ASH_C", p ) + + p => DDEP_NVWOODOC25_GROUP + chemgroups(56) = typ_sp("DDEP_NVWOODOC25", p ) + + p => WDEP_ECFINE_GROUP + chemgroups(57) = typ_sp("WDEP_ECFINE", p ) + + p => WDEP_ECCOARSE_GROUP + chemgroups(58) = typ_sp("WDEP_ECCOARSE", p ) + + p => OXN_GROUP + chemgroups(59) = typ_sp("OXN", p ) + + p => WDEP_DUST_ANT_F_GROUP + chemgroups(60) = typ_sp("WDEP_DUST_ANT_F", p ) + + p => DDEP_NVFFUELOC25_GROUP + chemgroups(61) = typ_sp("DDEP_NVFFUELOC25", p ) + + p => SIA_GROUP + chemgroups(62) = typ_sp("SIA", p ) + + p => DDEP_ASH_GROUP + chemgroups(63) = typ_sp("DDEP_ASH", p ) + + p => DDEP_NVFFIREOC25_GROUP + chemgroups(64) = typ_sp("DDEP_NVFFIREOC25", p ) + + p => DDEP_TNO3_GROUP + chemgroups(65) = typ_sp("DDEP_TNO3", p ) + + p => DDEP_ASH_F_GROUP + chemgroups(66) = typ_sp("DDEP_ASH_F", p ) + + p => DDEP_PMCO_GROUP + chemgroups(67) = typ_sp("DDEP_PMCO", p ) + + p => DDEP_BSOA_GROUP + chemgroups(68) = typ_sp("DDEP_BSOA", p ) + + p => DDEP_PCM_GROUP + chemgroups(69) = typ_sp("DDEP_PCM", p ) + + p => DDEP_NVFFUELOC_COARSE_GROUP + chemgroups(70) = typ_sp("DDEP_NVFFUELOC_COARSE", p ) + + p => ECCOARSE_GROUP + chemgroups(71) = typ_sp("ECCOARSE", p ) + + p => WOODEC_GROUP + chemgroups(72) = typ_sp("WOODEC", p ) + + p => WDEP_TNO3_GROUP + chemgroups(73) = typ_sp("WDEP_TNO3", p ) + + p => DDEP_DUST_ANT_C_GROUP + chemgroups(74) = typ_sp("DDEP_DUST_ANT_C", p ) p => WDEP_PMCO_GROUP - chemgroups(5) = typ_sp("WDEP_PMCO", p ) + chemgroups(75) = typ_sp("WDEP_PMCO", p ) - p => DUST_GROUP - chemgroups(6) = typ_sp("DUST", p ) + p => DDEP_FFUELEC_GROUP + chemgroups(76) = typ_sp("DDEP_FFUELEC", p ) - p => DDEP_AOD_GROUP - chemgroups(7) = typ_sp("DDEP_AOD", p ) + p => DDEP_ASH_C_GROUP + chemgroups(77) = typ_sp("DDEP_ASH_C", p ) - p => WDEP_AOD_GROUP - chemgroups(8) = typ_sp("WDEP_AOD", p ) + p => WDEP_NVFFUELOC25_GROUP + chemgroups(78) = typ_sp("WDEP_NVFFUELOC25", p ) - p => DDEP_NOX_GROUP - chemgroups(9) = typ_sp("DDEP_NOX", p ) + p => WDEP_PM10ANTHR_GROUP + chemgroups(79) = typ_sp("WDEP_PM10ANTHR", p ) - p => WDEP_DUST_GROUP - chemgroups(10) = typ_sp("WDEP_DUST", p ) + p => WDEP_SVFFUELOA25_GROUP + chemgroups(80) = typ_sp("WDEP_SVFFUELOA25", p ) + + p => DDEP_PPM25_GROUP + chemgroups(81) = typ_sp("DDEP_PPM25", p ) + + p => WDEP_PPM25_FIRE_GROUP + chemgroups(82) = typ_sp("WDEP_PPM25_FIRE", p ) + + p => FFIREBC_GROUP + chemgroups(83) = typ_sp("FFIREBC", p ) + + p => WDEP_FFIREBC_GROUP + chemgroups(84) = typ_sp("WDEP_FFIREBC", p ) p => NOX_GROUP - chemgroups(11) = typ_sp("NOX", p ) + chemgroups(85) = typ_sp("NOX", p ) + + p => DUST_NAT_F_GROUP + chemgroups(86) = typ_sp("DUST_NAT_F", p ) p => SS_GROUP - chemgroups(12) = typ_sp("SS", p ) + chemgroups(87) = typ_sp("SS", p ) p => DDEP_DUST_GROUP - chemgroups(13) = typ_sp("DDEP_DUST", p ) - - p => PMCO_GROUP - chemgroups(14) = typ_sp("PMCO", p ) - - p => DDEP_PMFINE_GROUP - chemgroups(15) = typ_sp("DDEP_PMFINE", p ) + chemgroups(88) = typ_sp("DDEP_DUST", p ) p => RO2_GROUP - chemgroups(16) = typ_sp("RO2", p ) + chemgroups(89) = typ_sp("RO2", p ) - p => ROOH_GROUP - chemgroups(17) = typ_sp("ROOH", p ) + p => DDEP_EC_F_GROUP + chemgroups(90) = typ_sp("DDEP_EC_F", p ) - p => WDEP_ROOH_GROUP - chemgroups(18) = typ_sp("WDEP_ROOH", p ) + p => ROOH_GROUP + chemgroups(91) = typ_sp("ROOH", p ) - p => WDEP_RDN_GROUP - chemgroups(19) = typ_sp("WDEP_RDN", p ) + p => DUST_ANT_C_GROUP + chemgroups(92) = typ_sp("DUST_ANT_C", p ) p => AOD_GROUP - chemgroups(20) = typ_sp("AOD", p ) + chemgroups(93) = typ_sp("AOD", p ) - p => DDEP_SIA_GROUP - chemgroups(21) = typ_sp("DDEP_SIA", p ) + p => DDEP_PPM_C_GROUP + chemgroups(94) = typ_sp("DDEP_PPM_C", p ) - p => WDEP_PM10_GROUP - chemgroups(22) = typ_sp("WDEP_PM10", p ) + p => WDEP_NVABSOM_GROUP + chemgroups(95) = typ_sp("WDEP_NVABSOM", p ) - p => DDEP_OX_GROUP - chemgroups(23) = typ_sp("DDEP_OX", p ) + p => SVFFUELOA25_GROUP + chemgroups(96) = typ_sp("SVFFUELOA25", p ) p => DDEP_SOX_GROUP - chemgroups(24) = typ_sp("DDEP_SOX", p ) + chemgroups(97) = typ_sp("DDEP_SOX", p ) - p => OXN_GROUP - chemgroups(25) = typ_sp("OXN", p ) + p => WDEP_DUST_NAT_F_GROUP + chemgroups(98) = typ_sp("WDEP_DUST_NAT_F", p ) - p => TNO3_GROUP - chemgroups(26) = typ_sp("TNO3", p ) + p => ASH_F_GROUP + chemgroups(99) = typ_sp("ASH_F", p ) p => WDEP_SOX_GROUP - chemgroups(27) = typ_sp("WDEP_SOX", p ) + chemgroups(100) = typ_sp("WDEP_SOX", p ) - p => PM10_GROUP - chemgroups(28) = typ_sp("PM10", p ) + p => PFFUELOA25_GROUP + chemgroups(101) = typ_sp("PFFUELOA25", p ) - p => OX_GROUP - chemgroups(29) = typ_sp("OX", p ) + p => FFUELEC_GROUP + chemgroups(102) = typ_sp("FFUELEC", p ) - p => SIA_GROUP - chemgroups(30) = typ_sp("SIA", p ) + p => PM10ANTHR_GROUP + chemgroups(103) = typ_sp("PM10ANTHR", p ) - p => DDEP_OXN_GROUP - chemgroups(31) = typ_sp("DDEP_OXN", p ) + p => WDEP_DUST_ANT_C_GROUP + chemgroups(104) = typ_sp("WDEP_DUST_ANT_C", p ) - p => DDEP_ROOH_GROUP - chemgroups(32) = typ_sp("DDEP_ROOH", p ) + p => DDEP_DUST_NAT_F_GROUP + chemgroups(105) = typ_sp("DDEP_DUST_NAT_F", p ) - p => DDEP_PM10_GROUP - chemgroups(33) = typ_sp("DDEP_PM10", p ) + p => DDEP_PM10ANTHR_GROUP + chemgroups(106) = typ_sp("DDEP_PM10ANTHR", p ) - p => WDEP_PMFINE_GROUP - chemgroups(34) = typ_sp("WDEP_PMFINE", p ) + p => DDEP_WOODEC_GROUP + chemgroups(107) = typ_sp("DDEP_WOODEC", p ) - p => DDEP_TNO3_GROUP - chemgroups(35) = typ_sp("DDEP_TNO3", p ) + p => V1702A02B_GROUP + chemgroups(108) = typ_sp("V1702A02B", p ) - p => WDEP_SIA_GROUP - chemgroups(36) = typ_sp("WDEP_SIA", p ) + p => WDEP_WOODEC_GROUP + chemgroups(109) = typ_sp("WDEP_WOODEC", p ) - p => DDEP_RDN_GROUP - chemgroups(37) = typ_sp("DDEP_RDN", p ) + p => WDEP_PCM_GROUP + chemgroups(110) = typ_sp("WDEP_PCM", p ) - p => DDEP_PMCO_GROUP - chemgroups(38) = typ_sp("DDEP_PMCO", p ) + p => WDEP_SS_GROUP + chemgroups(111) = typ_sp("WDEP_SS", p ) - p => BVOC_GROUP - chemgroups(39) = typ_sp("BVOC", p ) + p => DUST_NAT_C_GROUP + chemgroups(112) = typ_sp("DUST_NAT_C", p ) + + p => WDEP_NONVOLPCM_GROUP + chemgroups(113) = typ_sp("WDEP_NONVOLPCM", p ) + + p => PPM25_GROUP + chemgroups(114) = typ_sp("PPM25", p ) + + p => ASOA_GROUP + chemgroups(115) = typ_sp("ASOA", p ) + + p => PPM10_GROUP + chemgroups(116) = typ_sp("PPM10", p ) + + p => NVABSOM_GROUP + chemgroups(117) = typ_sp("NVABSOM", p ) + + p => BSOA_GROUP + chemgroups(118) = typ_sp("BSOA", p ) + + p => ECFINE_GROUP + chemgroups(119) = typ_sp("ECFINE", p ) + + p => DDEP_FFIREBC_GROUP + chemgroups(120) = typ_sp("DDEP_FFIREBC", p ) + + p => WDEP_DUST_GROUP + chemgroups(121) = typ_sp("WDEP_DUST", p ) + + p => NVFFUELOC_COARSE_GROUP + chemgroups(122) = typ_sp("NVFFUELOC_COARSE", p ) + + p => DDEP_ECFINE_GROUP + chemgroups(123) = typ_sp("DDEP_ECFINE", p ) + + p => WDEP_ROOH_GROUP + chemgroups(124) = typ_sp("WDEP_ROOH", p ) + + p => PCM_GROUP + chemgroups(125) = typ_sp("PCM", p ) + + p => SVWOODOA25_GROUP + chemgroups(126) = typ_sp("SVWOODOA25", p ) + + p => DDEP_SIA_GROUP + chemgroups(127) = typ_sp("DDEP_SIA", p ) + + p => WDEP_PFFIREOA25_GROUP + chemgroups(128) = typ_sp("WDEP_PFFIREOA25", p ) + + p => PCM_HELP_GROUP + chemgroups(129) = typ_sp("PCM_HELP", p ) + + p => WDEP_OMCOARSE_GROUP + chemgroups(130) = typ_sp("WDEP_OMCOARSE", p ) + + p => TNO3_GROUP + chemgroups(131) = typ_sp("TNO3", p ) + + p => SVFFIREOA25_GROUP + chemgroups(132) = typ_sp("SVFFIREOA25", p ) + + p => NVFFUELOC25_GROUP + chemgroups(133) = typ_sp("NVFFUELOC25", p ) + + p => DDEP_V1702A02B_GROUP + chemgroups(134) = typ_sp("DDEP_V1702A02B", p ) + + p => OMCOARSE_GROUP + chemgroups(135) = typ_sp("OMCOARSE", p ) + + p => DDEP_ROOH_GROUP + chemgroups(136) = typ_sp("DDEP_ROOH", p ) + + p => WDEP_PMFINE_GROUP + chemgroups(137) = typ_sp("WDEP_PMFINE", p ) + + p => DDEP_RDN_GROUP + chemgroups(138) = typ_sp("DDEP_RDN", p ) + + p => PFFIREOA25_GROUP + chemgroups(139) = typ_sp("PFFIREOA25", p ) p => RDN_GROUP - chemgroups(40) = typ_sp("RDN", p ) + chemgroups(140) = typ_sp("RDN", p ) - p => WDEP_SS_GROUP - chemgroups(41) = typ_sp("WDEP_SS", p ) + p => WDEP_ASH_GROUP + chemgroups(141) = typ_sp("WDEP_ASH", p ) - p => WDEP_TNO3_GROUP - chemgroups(42) = typ_sp("WDEP_TNO3", p ) + p => WDEP_FFUELEC_GROUP + chemgroups(142) = typ_sp("WDEP_FFUELEC", p ) nullify(p) diff --git a/CM_ChemRates_ml.f90 b/CM_ChemRates_ml.f90 index c1ec97e..f18ad32 100644 --- a/CM_ChemRates_ml.f90 +++ b/CM_ChemRates_ml.f90 @@ -1,10 +1,11 @@ !>_________________________________________________________< - module ChemRates_rcmisc_ml + module ChemRates_rct_ml !----------------------------------------------------------- - + use ChemFunctions_ml ! => kaero, RiemerN2O5 + use Setup_1dfields_ml ! => tinv, h2o, m, Fgas use Setup_1dfields_ml, m=> amk use ChemSpecs_tot_ml ! => PINALD, .... for FgasJ08 @@ -12,171 +13,155 @@ module ChemRates_rcmisc_ml implicit none private - !+ Tabulates Rate-coefficients - complex dependancies + !+ Tabulates Rate-coefficients - temperature dependant - public :: set_rcmisc_rates + public :: set_rct_rates - integer, parameter, public :: NRCMISC = 30 !! No. coefficients + integer, parameter, public :: NRCT = 93 !! No. coefficients - real, save, public, dimension(NRCMISC,KCHEMTOP:KMAX_MID) :: rcmisc + real, save, public, dimension(NRCT,KCHEMTOP:KMAX_MID) :: rct contains !------------------------------------ - subroutine set_rcmisc_rates() -!OLD real, dimension(KCHEMTOP:KMAX_MID) :: lt300 + subroutine set_rct_rates() real, dimension(KCHEMTOP:KMAX_MID) :: log300divt, logtdiv300 ! real, dimension(KCHEMTOP:KMAX_MID) :: BranchingNO ! real, dimension(KCHEMTOP:KMAX_MID) :: BranchingHO2 -!OLD lt300(:) = log(300.0*tinv(:)) log300divt(:) = log(300.0*tinv(:)) logtdiv300(:) = log(temp(:)/300.0) ! BranchingNO(:) = 1.0e-11*xn_2d(NO,:)/ & !( 1.0e-11*xn_2d(NO,:) + 4.2e-12*exp(180*TINV(:))*xn_2d(HO2,:) ) ! BranchingHO2(:) = 1.0 - BranchingNO(:) - rcmisc(1,:) = (6.0e-34*o2+5.6e-34*n2)*o2*exp(-2.6*logtdiv300) - rcmisc(2,:) = 1.8e-11*n2*exp(107.0*tinv) - rcmisc(3,:) = 3.2e-11*o2*exp(67.0*tinv) - rcmisc(4,:) = 2.2e-10*h2o - rcmisc(5,:) = 2.03e-16*exp(-4.57*log300divt)*exp(693.0*tinv) - rcmisc(6,:) = kmt3(2.4e-14,460.0,6.5e-34,1335.0,2.7e-17,2199.0,m) - rcmisc(7,:) = (1.0+1.4e-21*h2o*exp(2200.0*tinv))*2.2e-13*exp(600.0*tinv) - rcmisc(8,:) = (1.0+1.4e-21*h2o*exp(2200.0*tinv))*1.9e-33*exp(980.0*tinv)*m - rcmisc(9,:) = 1.85e-20*exp(2.82*log(temp))*exp(-987.0*tinv) - rcmisc(10,:) = 1.44e-13+m*3.43e-33 - rcmisc(11,:) = 6.38e-18*(temp**2)*exp(144.0*tinv) - rcmisc(12,:) = 1.25e-17*(temp**2)*exp(615.0*tinv) - rcmisc(13,:) = 6.7e-18*(temp**2)*exp(511.0*tinv) - rcmisc(14,:) = 2.03e-17*(temp**2)*exp(78.0*tinv) - rcmisc(15,:) = 2.53e-18*(temp**2)*exp(503.0*tinv) - rcmisc(16,:) = 6.6e-18*(temp**2)*exp(820.0*tinv) - rcmisc(17,:) = riemern2o5() - rcmisc(18,:) = 1e-12*h2o - rcmisc(19,:) = kaero() - rcmisc(20,:) = iupac_troe(1.0e-31*exp(1.6*log300divt) & - ,3.0e-11*exp(-0.3*log300divt) & + rct(1,:) = (6.0e-34*O2+5.6E-34*N2)*O2*exp(-2.6*LOGTDIV300) + rct(2,:) = 1.8e-11*N2*exp(107.0*TINV) + rct(3,:) = 3.2e-11*O2*exp(67.0*TINV) + rct(4,:) = 2.2e-10*H2O + rct(5,:) = 1.4e-12*exp(-1310.0*TINV) + rct(6,:) = 1.4e-13*exp(-2470.0*TINV) + rct(7,:) = 1.7e-12*exp(-940.0*TINV) + rct(8,:) = 2.03e-16*exp(-4.57*LOG300DIVT)*exp(693.0*TINV) + rct(9,:) = 1.8e-11*exp(110.0*TINV) + rct(10,:) = 3.6e-12*exp(270.0*TINV) + rct(11,:) = 4.5e-14*exp(-1260.0*TINV) + rct(12,:) = 4.8e-11*exp(250.0*TINV) + rct(13,:) = 2.9e-12*exp(-160.0*TINV) + rct(14,:) = 7.7e-12*exp(-2100.0*TINV) + rct(15,:) = KMT3(2.4e-14,460.0,6.5E-34,1335.0,2.7E-17,2199.0,M) + rct(16,:) = (1.0+1.4e-21*H2O*exp(2200.0*TINV))*2.2E-13*exp(600.0*TINV) + rct(17,:) = (1.0+1.4e-21*H2O*exp(2200.0*TINV))*1.9E-33*exp(980.0*TINV)*M + rct(18,:) = 2.5e-12*exp(-260.0*TINV) + rct(19,:) = 1.85e-20*exp(2.82*LOG(TEMP))*exp(-987.0*TINV) + rct(20,:) = 1.44e-13+M*3.43E-33 + rct(21,:) = 2.3e-12*exp(360.0*TINV) + rct(22,:) = 7.4e-13*exp(-520.0*TINV) + rct(23,:) = 1.03e-13*exp(365.0*TINV)-7.4E-13*exp(-520.0*TINV) + rct(24,:) = 6.38e-18*(TEMP**2)*exp(144.0*TINV) + rct(25,:) = 3.8e-13*exp(780.0*TINV) + rct(26,:) = 5.3e-12*exp(190.0*TINV) + rct(27,:) = 1.25e-17*(TEMP**2)*exp(615.0*TINV) + rct(28,:) = 2e-12*exp(-2440.0*TINV) + rct(29,:) = 6.9e-12*exp(-1000.0*TINV) + rct(30,:) = 2.55e-12*exp(380.0*TINV) + rct(31,:) = 3.8e-13*exp(900.0*TINV) + rct(32,:) = 1.9e-12*exp(190.0*TINV) + rct(33,:) = 4.4e-12*exp(365.0*TINV) + rct(34,:) = 7.5e-12*exp(290.0*TINV) + rct(35,:) = 2e-12*exp(500.0*TINV) + rct(36,:) = 2.9e-12*exp(500.0*TINV) + rct(37,:) = 5.2e-13*exp(980.0*TINV) + rct(38,:) = 6.7e-18*(TEMP**2)*exp(511.0*TINV) + rct(39,:) = 2.03e-17*(TEMP**2)*exp(78.0*TINV) + rct(40,:) = 2.54e-12*exp(360.0*TINV) + rct(41,:) = 1.81875e-13*exp(1300.0*TINV) + rct(42,:) = 2.53e-18*(TEMP**2)*exp(503.0*TINV) + rct(43,:) = 9.1e-15*exp(-2580.0*TINV) + rct(44,:) = 5.5e-15*exp(-1880.0*TINV) + rct(45,:) = 1.5132e-13*exp(1300.0*TINV) + rct(46,:) = 2.49969e-13*exp(1300.0*TINV) + rct(47,:) = 2.05446e-13*exp(1300.0*TINV) + rct(48,:) = 6.6e-18*(TEMP**2)*exp(820.0*TINV) + rct(49,:) = 1.9e-12*exp(575.0*TINV) + rct(50,:) = 1.03e-14*exp(-1995.0*TINV) + rct(51,:) = 2.7e-11*exp(390.0*TINV) + rct(52,:) = 2.6e-12*exp(610.0*TINV) + rct(53,:) = 1.36e-15*exp(-2112.0*TINV) + rct(54,:) = 8e-12*exp(380.0*TINV) + rct(55,:) = 7.6e-12*exp(180.0*TINV) + rct(56,:) = 1.6e-12*exp(305.0*TINV) + rct(57,:) = 8.7e-12*exp(290.0*TINV) + rct(58,:) = 8.5e-16*exp(-1520.0*TINV) + rct(59,:) = 3.15e-12*exp(-450.0*TINV) + rct(60,:) = 4.3e-13*exp(1040.0*TINV) + rct(61,:) = RIEMERN2O5() + rct(62,:) = KAERO() + rct(63,:) = IUPAC_TROE(1.0e-31*exp(1.6*LOG300DIVT) & + ,3.0E-11*exp(-0.3*LOG300DIVT) & ,0.85 & - ,m & - ,0.75-1.27*log10(0.85)) - rcmisc(21,:) = iupac_troe(3.6e-30*exp(4.1*log300divt) & - ,1.9e-12*exp(-0.2*log300divt) & + ,M & + ,0.75-1.27*LOG10(0.85)) + rct(64,:) = IUPAC_TROE(3.6e-30*exp(4.1*LOG300DIVT) & + ,1.9E-12*exp(-0.2*LOG300DIVT) & ,0.35 & - ,m & - ,0.75-1.27*log10(0.35)) - rcmisc(22,:) = iupac_troe(1.3e-3*exp(3.5*log300divt)*exp(-11000.0*tinv) & - ,9.70e14*exp(-0.1*log300divt)*exp(-11080.0*tinv) & + ,M & + ,0.75-1.27*LOG10(0.35)) + rct(65,:) = IUPAC_TROE(1.3e-3*exp(3.5*LOG300DIVT)*exp(-11000.0*TINV) & + ,9.70E14*exp(-0.1*LOG300DIVT)*exp(-11080.0*TINV) & ,0.35 & - ,m & - ,0.75-1.27*log10(0.35)) - rcmisc(23,:) = iupac_troe(3.3e-30*exp(3.0*log300divt) & - ,4.1e-11 & + ,M & + ,0.75-1.27*LOG10(0.35)) + rct(66,:) = IUPAC_TROE(3.3e-30*exp(3.0*LOG300DIVT) & + ,4.1E-11 & ,0.40 & - ,m & - ,0.75-1.27*log10(0.4)) - rcmisc(24,:) = iupac_troe(2.7e-28*exp(7.1*log300divt) & - ,1.2e-11*exp(0.9*log300divt) & + ,M & + ,0.75-1.27*LOG10(0.4)) + rct(67,:) = IUPAC_TROE(2.7e-28*exp(7.1*LOG300DIVT) & + ,1.2E-11*exp(0.9*LOG300DIVT) & ,0.3 & - ,m & - ,0.75-1.27*log10(0.3)) - rcmisc(25,:) = iupac_troe(4.9e-3*exp(-12100.0*tinv) & - ,5.4e16*exp(-13830.0*tinv) & + ,M & + ,0.75-1.27*LOG10(0.3)) + rct(68,:) = IUPAC_TROE(4.9e-3*exp(-12100.0*TINV) & + ,5.4E16*exp(-13830.0*TINV) & ,0.3 & - ,m & - ,0.75-1.27*log10(0.3)) - rcmisc(26,:) = iupac_troe(8.6e-29*exp(3.1*log300divt) & - ,9.0e-12*exp(0.85*log300divt) & + ,M & + ,0.75-1.27*LOG10(0.3)) + rct(69,:) = IUPAC_TROE(8.6e-29*exp(3.1*LOG300DIVT) & + ,9.0E-12*exp(0.85*LOG300DIVT) & ,0.48 & - ,m & - ,0.75-1.27*log10(0.48)) - rcmisc(27,:) = iupac_troe(8.0e-27*exp(3.5*log300divt) & - ,3.0e-11*300.0*tinv & + ,M & + ,0.75-1.27*LOG10(0.48)) + rct(70,:) = IUPAC_TROE(8.0e-27*exp(3.5*LOG300DIVT) & + ,3.0E-11*300.0*TINV & ,0.5 & - ,m & - ,0.75-1.27*log10(0.5)) - rcmisc(28,:) = iupac_troe(2.7e-28*exp(7.1*log300divt) & - ,1.2e-11*exp(0.9*log300divt) & - ,0.3 & - ,m & - ,0.75-1.27*log10(0.3)) - rcmisc(29,:) = iupac_troe(4.9e-3*exp(-12100.0*tinv) & - ,5.4e16*exp(-13830.0*tinv) & - ,0.3 & - ,m & - ,0.75-1.27*log10(0.3)) - rcmisc(30,:) = iupac_troe(7.4e-31*exp(2.4*log300divt) & - ,3.3e-11*exp(0.3*log300divt) & + ,M & + ,0.75-1.27*LOG10(0.5)) + rct(71,:) = IUPAC_TROE(7.4e-31*exp(2.4*LOG300DIVT) & + ,3.3E-11*exp(0.3*LOG300DIVT) & ,exp(-temp/1420.0) & - ,m & - ,0.75+3.884e-4*temp) - - end subroutine set_rcmisc_rates -end module ChemRates_rcmisc_ml -!>_________________________________________________________< - - module ChemRates_rct_ml -!----------------------------------------------------------- - - - use Setup_1dfields_ml ! => tinv, h2o, m, Fgas - use ModelConstants_ml, only : KMAX_MID,KCHEMTOP - implicit none - private - - !+ Tabulates Rate-coefficients - temperature dependant - - public :: set_rct_rates - - integer, parameter, public :: NRCT = 44 !! No. coefficients - - real, save, public, dimension(NRCT,KCHEMTOP:KMAX_MID) :: rct - - contains - !------------------------------------ - subroutine set_rct_rates() - rct(1,:) = 1.4e-12*exp(-1310.0*TINV) - rct(2,:) = 1.4e-13*exp(-2470.0*TINV) - rct(3,:) = 1.7e-12*exp(-940.0*TINV) - rct(4,:) = 1.8e-11*exp(110.0*TINV) - rct(5,:) = 3.6e-12*exp(270.0*TINV) - rct(6,:) = 4.5e-14*exp(-1260.0*TINV) - rct(7,:) = 4.8e-11*exp(250.0*TINV) - rct(8,:) = 2.9e-12*exp(-160.0*TINV) - rct(9,:) = 7.7e-12*exp(-2100.0*TINV) - rct(10,:) = 2.5e-12*exp(-260.0*TINV) - rct(11,:) = 2.3e-12*exp(360.0*TINV) - rct(12,:) = 7.4e-13*exp(-520.0*TINV) - rct(13,:) = 1.03e-13*exp(365.0*TINV)-7.4E-13*exp(-520.0*TINV) - rct(14,:) = 3.8e-13*exp(780.0*TINV) - rct(15,:) = 5.3e-12*exp(190.0*TINV) - rct(16,:) = 2e-12*exp(-2440.0*TINV) - rct(17,:) = 6.9e-12*exp(-1000.0*TINV) - rct(18,:) = 2.55e-12*exp(380.0*TINV) - rct(19,:) = 3.8e-13*exp(900.0*TINV) - rct(20,:) = 1.9e-12*exp(190.0*TINV) - rct(21,:) = 4.4e-12*exp(365.0*TINV) - rct(22,:) = 7.5e-12*exp(290.0*TINV) - rct(23,:) = 2e-12*exp(500.0*TINV) - rct(24,:) = 2.9e-12*exp(500.0*TINV) - rct(25,:) = 5.2e-13*exp(980.0*TINV) - rct(26,:) = 2.54e-12*exp(360.0*TINV) - rct(27,:) = 1.81875e-13*exp(1300.0*TINV) - rct(28,:) = 9.1e-15*exp(-2580.0*TINV) - rct(29,:) = 5.5e-15*exp(-1880.0*TINV) - rct(30,:) = 1.5132e-13*exp(1300.0*TINV) - rct(31,:) = 2.49969e-13*exp(1300.0*TINV) - rct(32,:) = 2.05446e-13*exp(1300.0*TINV) - rct(33,:) = 1.9e-12*exp(575.0*TINV) - rct(34,:) = 1.03e-14*exp(-1995.0*TINV) - rct(35,:) = 2.7e-11*exp(390.0*TINV) - rct(36,:) = 2.6e-12*exp(610.0*TINV) - rct(37,:) = 1.36e-15*exp(-2112.0*TINV) - rct(38,:) = 8e-12*exp(380.0*TINV) - rct(39,:) = 7.6e-12*exp(180.0*TINV) - rct(40,:) = 1.6e-12*exp(305.0*TINV) - rct(41,:) = 8.7e-12*exp(290.0*TINV) - rct(42,:) = 8.5e-16*exp(-1520.0*TINV) - rct(43,:) = 3.15e-12*exp(-450.0*TINV) - rct(44,:) = 4.3e-13*exp(1040.0*TINV) + ,M & + ,0.75+3.884E-4*temp) + rct(72,:) = 6.3e-16*exp(-580.0*TINV) + rct(73,:) = 1.2e-11*exp(444.0*TINV) + rct(74,:) = 1.2e-12*exp(490.0*TINV) + rct(75,:) = 2.65974e-13*exp(1300.0*TINV) + rct(76,:) = 4e-12*FGAS(ASOC_UG1,:) + rct(77,:) = 4e-12*FGAS(ASOC_UG10,:) + rct(78,:) = 4e-12*FGAS(ASOC_UG1E2,:) + rct(79,:) = 4e-12*FGAS(ASOC_UG1E3,:) + rct(80,:) = 4e-12*FGAS(NON_C_ASOA_UG1,:) + rct(81,:) = 4e-12*FGAS(NON_C_ASOA_UG10,:) + rct(82,:) = 4e-12*FGAS(NON_C_ASOA_UG1E2,:) + rct(83,:) = 4e-12*FGAS(NON_C_ASOA_UG1E3,:) + rct(84,:) = 4e-12*FGAS(BSOC_UG1,:) + rct(85,:) = 4e-12*FGAS(BSOC_UG10,:) + rct(86,:) = 4e-12*FGAS(BSOC_UG1E2,:) + rct(87,:) = 4e-12*FGAS(BSOC_UG1E3,:) + rct(88,:) = 4e-12*FGAS(NON_C_BSOA_UG1,:) + rct(89,:) = 4e-12*FGAS(NON_C_BSOA_UG10,:) + rct(90,:) = 4e-12*FGAS(NON_C_BSOA_UG1E2,:) + rct(91,:) = 4e-12*FGAS(NON_C_BSOA_UG1E3,:) + rct(92,:) = EC_AGEING_RATE() + rct(93,:) = EC_AGEING_RATE() end subroutine set_rct_rates end module ChemRates_rct_ml diff --git a/CM_ChemSpecs_ml.f90 b/CM_ChemSpecs_ml.f90 index 4d1fa9b..0df8e62 100644 --- a/CM_ChemSpecs_ml.f90 +++ b/CM_ChemSpecs_ml.f90 @@ -9,7 +9,7 @@ module ChemSpecs_adv_ml ! ( Output from GenChem, sub print_species ) - integer, public, parameter :: NSPEC_ADV = 67 + integer, public, parameter :: NSPEC_ADV = 128 @@ -81,18 +81,91 @@ module ChemSpecs_adv_ml , IXADV_NO3_F = 55 & , IXADV_NO3_C = 56 & , IXADV_NH4_F = 57 & - , IXADV_PPM25 = 58 & - , IXADV_PPM25_FIRE = 59 + , IXADV_V1702A02B_F = 58 & + , IXADV_V1702A02B_C = 59 integer, public, parameter :: & - IXADV_PPM_C = 60 & - , IXADV_SEASALT_F = 61 & - , IXADV_SEASALT_C = 62 & - , IXADV_SEASALT_G = 63 & - , IXADV_DUST_NAT_F = 64 & - , IXADV_DUST_NAT_C = 65 & - , IXADV_RN222 = 66 & - , IXADV_PB210 = 67 + IXADV_GAS_ASOA_OC = 60 & + , IXADV_PART_ASOA_OC= 61 & + , IXADV_PART_ASOA_OM= 62 & + , IXADV_GAS_BSOA_OC = 63 & + , IXADV_PART_BSOA_OC= 64 & + , IXADV_PART_BSOA_OM= 65 & + , IXADV_PART_FFUELOA25_OC= 66 & + , IXADV_PART_FFUELOA25_OM= 67 & + , IXADV_PART_WOODOA25_OC= 68 & + , IXADV_PART_WOODOA25_OM= 69 + + integer, public, parameter :: & + IXADV_PART_FFIREOA25_OC= 70 & + , IXADV_PART_FFIREOA25_OM= 71 & + , IXADV_PART_OC10 = 72 & + , IXADV_PART_OC25 = 73 & + , IXADV_NONVOL_FFUELOC25= 74 & + , IXADV_NONV_FFUELOC_COARSE= 75 & + , IXADV_NONVOL_WOODOC25= 76 & + , IXADV_NONVOL_BGNDOC= 77 & + , IXADV_NONVOL_FFIREOC25= 78 & + , IXADV_PART_OM_F = 79 + + integer, public, parameter :: & + IXADV_POM_F_WOOD = 80 & + , IXADV_POM_F_FFUEL = 81 & + , IXADV_POM_C_FFUEL = 82 & + , IXADV_EC_F_WOOD_NEW= 83 & + , IXADV_EC_F_WOOD_AGE= 84 & + , IXADV_EC_C_WOOD = 85 & + , IXADV_EC_F_FFUEL_NEW= 86 & + , IXADV_EC_F_FFUEL_AGE= 87 & + , IXADV_EC_C_FFUEL = 88 & + , IXADV_REMPPM25 = 89 + + integer, public, parameter :: & + IXADV_REMPPM_C = 90 & + , IXADV_FFIRE_OM = 91 & + , IXADV_FFIRE_BC = 92 & + , IXADV_FFIRE_REMPPM25= 93 & + , IXADV_TERPPEROXY = 94 & + , IXADV_ASOC_NG100 = 95 & + , IXADV_ASOC_UG1 = 96 & + , IXADV_ASOC_UG10 = 97 & + , IXADV_ASOC_UG1E2 = 98 & + , IXADV_ASOC_UG1E3 = 99 + + integer, public, parameter :: & + IXADV_NON_C_ASOA_NG100= 100 & + , IXADV_NON_C_ASOA_UG1= 101 & + , IXADV_NON_C_ASOA_UG10= 102 & + , IXADV_NON_C_ASOA_UG1E2= 103 & + , IXADV_NON_C_ASOA_UG1E3= 104 & + , IXADV_BSOC_NG100 = 105 & + , IXADV_BSOC_UG1 = 106 & + , IXADV_BSOC_UG10 = 107 & + , IXADV_BSOC_UG1E2 = 108 & + , IXADV_BSOC_UG1E3 = 109 + + integer, public, parameter :: & + IXADV_NON_C_BSOA_NG100= 110 & + , IXADV_NON_C_BSOA_UG1= 111 & + , IXADV_NON_C_BSOA_UG10= 112 & + , IXADV_NON_C_BSOA_UG1E2= 113 & + , IXADV_NON_C_BSOA_UG1E3= 114 & + , IXADV_FFFUEL_NG10 = 115 & + , IXADV_WOODOA_NG10 = 116 & + , IXADV_FFIREOA_NG10= 117 & + , IXADV_SEASALT_F = 118 & + , IXADV_SEASALT_C = 119 + + integer, public, parameter :: & + IXADV_DUST_ROAD_F = 120 & + , IXADV_DUST_ROAD_C = 121 & + , IXADV_DUST_WB_F = 122 & + , IXADV_DUST_WB_C = 123 & + , IXADV_DUST_SAH_F = 124 & + , IXADV_DUST_SAH_C = 125 & + , IXADV_RN222 = 126 & + , IXADV_RNWATER = 127 & + , IXADV_PB210 = 128 !----------------------------------------------------------- end module ChemSpecs_adv_ml @@ -144,13 +217,13 @@ module ChemSpecs_tot_ml ! ( Output from GenChem, sub print_species ) - integer, public, parameter :: NSPEC_TOT = 83 + integer, public, parameter :: NSPEC_TOT = 144 ! Aerosols: integer, public, parameter :: & - NAEROSOL=0, &! Number of aerosol species - FIRST_SEMIVOL=-999, &! First aerosol species - LAST_SEMIVOL=-999 ! Last aerosol species + NAEROSOL=23, &! Number of aerosol species + FIRST_SEMIVOL=111, &! First aerosol species + LAST_SEMIVOL=133 ! Last aerosol species @@ -242,18 +315,91 @@ module ChemSpecs_tot_ml , NO3_F = 71 & , NO3_C = 72 & , NH4_F = 73 & - , PPM25 = 74 & - , PPM25_FIRE = 75 & - , PPM_C = 76 & - , SEASALT_F = 77 & - , SEASALT_C = 78 & - , SEASALT_G = 79 + , V1702A02B_F = 74 & + , V1702A02B_C = 75 & + , GAS_ASOA_OC = 76 & + , PART_ASOA_OC= 77 & + , PART_ASOA_OM= 78 & + , GAS_BSOA_OC = 79 + + integer, public, parameter :: & + PART_BSOA_OC= 80 & + , PART_BSOA_OM= 81 & + , PART_FFUELOA25_OC= 82 & + , PART_FFUELOA25_OM= 83 & + , PART_WOODOA25_OC= 84 & + , PART_WOODOA25_OM= 85 & + , PART_FFIREOA25_OC= 86 & + , PART_FFIREOA25_OM= 87 & + , PART_OC10 = 88 & + , PART_OC25 = 89 integer, public, parameter :: & - DUST_NAT_F = 80 & - , DUST_NAT_C = 81 & - , RN222 = 82 & - , PB210 = 83 + NONVOL_FFUELOC25= 90 & + , NONV_FFUELOC_COARSE= 91 & + , NONVOL_WOODOC25= 92 & + , NONVOL_BGNDOC= 93 & + , NONVOL_FFIREOC25= 94 & + , PART_OM_F = 95 & + , POM_F_WOOD = 96 & + , POM_F_FFUEL = 97 & + , POM_C_FFUEL = 98 & + , EC_F_WOOD_NEW= 99 + + integer, public, parameter :: & + EC_F_WOOD_AGE= 100 & + , EC_C_WOOD = 101 & + , EC_F_FFUEL_NEW= 102 & + , EC_F_FFUEL_AGE= 103 & + , EC_C_FFUEL = 104 & + , REMPPM25 = 105 & + , REMPPM_C = 106 & + , FFIRE_OM = 107 & + , FFIRE_BC = 108 & + , FFIRE_REMPPM25= 109 + + integer, public, parameter :: & + TERPPEROXY = 110 & + , ASOC_NG100 = 111 & + , ASOC_UG1 = 112 & + , ASOC_UG10 = 113 & + , ASOC_UG1E2 = 114 & + , ASOC_UG1E3 = 115 & + , NON_C_ASOA_NG100= 116 & + , NON_C_ASOA_UG1= 117 & + , NON_C_ASOA_UG10= 118 & + , NON_C_ASOA_UG1E2= 119 + + integer, public, parameter :: & + NON_C_ASOA_UG1E3= 120 & + , BSOC_NG100 = 121 & + , BSOC_UG1 = 122 & + , BSOC_UG10 = 123 & + , BSOC_UG1E2 = 124 & + , BSOC_UG1E3 = 125 & + , NON_C_BSOA_NG100= 126 & + , NON_C_BSOA_UG1= 127 & + , NON_C_BSOA_UG10= 128 & + , NON_C_BSOA_UG1E2= 129 + + integer, public, parameter :: & + NON_C_BSOA_UG1E3= 130 & + , FFFUEL_NG10 = 131 & + , WOODOA_NG10 = 132 & + , FFIREOA_NG10= 133 & + , SEASALT_F = 134 & + , SEASALT_C = 135 & + , DUST_ROAD_F = 136 & + , DUST_ROAD_C = 137 & + , DUST_WB_F = 138 & + , DUST_WB_C = 139 + + integer, public, parameter :: & + DUST_SAH_F = 140 & + , DUST_SAH_C = 141 & + , RN222 = 142 & + , RNWATER = 143 & + , PB210 = 144 !----------------------------------------------------------- end module ChemSpecs_tot_ml @@ -262,18 +408,21 @@ end module ChemSpecs_tot_ml module ChemChemicals_ml !----------------------------------------------------------- - use ChemSpecs_tot_ml ! => NSPEC_TOT, species indices + + use ChemSpecs_tot_ml ! => NSPEC_TOT, species indices + use ChemSpecs_shl_ml, only: NSPEC_SHL + use ChemSpecs_adv_ml, only: NSPEC_ADV implicit none private - !/-- Characteristics of species: + !/-- Characteristics of species: !/-- Number, name, molwt, carbon num, nmhc (1) or not(0) - + public :: define_chemicals ! Sets names, molwts, carbon num, advec, nmhc - type, public :: Chemical + type, public :: Chemical character(len=20) :: name - integer :: molwt + real :: molwt integer :: nmhc ! nmhc (1) or not(0) integer :: carbons ! Carbon-number real :: nitrogens ! Nitrogen-number @@ -282,97 +431,166 @@ module ChemChemicals_ml real :: CiStar ! VBS param real :: DeltaH ! VBS param end type Chemical - type(Chemical), public, dimension(NSPEC_TOT) :: species + type(Chemical), public, dimension(NSPEC_TOT), target :: species + type(Chemical), public, dimension(:), pointer :: & + species_shl=>null(),& ! => species(..short lived..) + species_adv=>null() ! => species(..advected..) contains - subroutine define_chemicals() - !+ - ! Assigns names, mol wts, carbon numbers, advec, nmhc to user-defined Chemical - ! array, using indices from total list of species (advected + short-lived). - ! MW NM C N S ExtC C* dH - species(OD) = Chemical("OD ", 16, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(OP) = Chemical("OP ", 16, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(OH) = Chemical("OH ", 17, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(HO2) = Chemical("HO2 ", 33, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(CH3O2) = Chemical("CH3O2 ", 47, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) - species(C2H5O2) = Chemical("C2H5O2 ", 61, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(SECC4H9O2) = Chemical("SECC4H9O2 ", 89, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(ISRO2) = Chemical("ISRO2 ", 101, 0, 5, 0, 0, 0.0, 0.0000, 0.0 ) - species(ETRO2) = Chemical("ETRO2 ", 77, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(PRRO2) = Chemical("PRRO2 ", 91, 0, 3, 0, 0, 0.0, 0.0000, 0.0 ) - species(OXYO2) = Chemical("OXYO2 ", 1, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(MEKO2) = Chemical("MEKO2 ", 103, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(MALO2) = Chemical("MALO2 ", 147, 0, 5, 0, 0, 0.0, 0.0000, 0.0 ) - species(MVKO2) = Chemical("MVKO2 ", 119, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(MACRO2) = Chemical("MACRO2 ", 119, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(MACO3) = Chemical("MACO3 ", 101, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(O3) = Chemical("O3 ", 48, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(NO) = Chemical("NO ", 30, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) - species(NO2) = Chemical("NO2 ", 46, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) - species(PAN) = Chemical("PAN ", 121, 0, 2, 1, 0, 0.0, 0.0000, 0.0 ) - species(MPAN) = Chemical("MPAN ", 132, 0, 4, 1, 0, 0.0, 0.0000, 0.0 ) - species(NO3) = Chemical("NO3 ", 62, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) - species(N2O5) = Chemical("N2O5 ", 108, 0, 0, 2, 0, 0.0, 0.0000, 0.0 ) - species(ISONO3) = Chemical("ISONO3 ", 1, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(HNO3) = Chemical("HNO3 ", 63, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) - species(HONO) = Chemical("HONO ", 47, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) - species(CH3COO2) = Chemical("CH3COO2 ", 75, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(MACR) = Chemical("MACR ", 70, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(ISNI) = Chemical("ISNI ", 1, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(ISNIR) = Chemical("ISNIR ", 1, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(GLYOX) = Chemical("GLYOX ", 58, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(MGLYOX) = Chemical("MGLYOX ", 72, 0, 3, 0, 0, 0.0, 0.0000, 0.0 ) - species(MAL) = Chemical("MAL ", 98, 0, 5, 0, 0, 0.0, 0.0000, 0.0 ) - species(MEK) = Chemical("MEK ", 72, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(MVK) = Chemical("MVK ", 70, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(HCHO) = Chemical("HCHO ", 30, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) - species(CH3CHO) = Chemical("CH3CHO ", 44, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(C2H6) = Chemical("C2H6 ", 30, 1, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(NC4H10) = Chemical("NC4H10 ", 58, 1, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(C2H4) = Chemical("C2H4 ", 28, 1, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(C3H6) = Chemical("C3H6 ", 42, 1, 3, 0, 0, 0.0, 0.0000, 0.0 ) - species(OXYL) = Chemical("OXYL ", 106, 1, 8, 0, 0, 0.0, 0.0000, 0.0 ) - species(C5H8) = Chemical("C5H8 ", 68, 1, 5, 0, 0, 0.0, 0.0000, 0.0 ) - species(APINENE) = Chemical("APINENE ", 136, 1, 10, 0, 0, 0.0, 0.0000, 0.0 ) - species(CH3O2H) = Chemical("CH3O2H ", 48, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) - species(C2H5OOH) = Chemical("C2H5OOH ", 62, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(BURO2H) = Chemical("BURO2H ", 90, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(ETRO2H) = Chemical("ETRO2H ", 78, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(PRRO2H) = Chemical("PRRO2H ", 92, 0, 3, 0, 0, 0.0, 0.0000, 0.0 ) - species(OXYO2H) = Chemical("OXYO2H ", 1, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(MEKO2H) = Chemical("MEKO2H ", 104, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(MALO2H) = Chemical("MALO2H ", 147, 0, 5, 0, 0, 0.0, 0.0000, 0.0 ) - species(MVKO2H) = Chemical("MVKO2H ", 1, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(MACROOH) = Chemical("MACROOH ", 120, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(MACO3H) = Chemical("MACO3H ", 102, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(MACO2H) = Chemical("MACO2H ", 86, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) - species(ISRO2H) = Chemical("ISRO2H ", 1, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(H2O2) = Chemical("H2O2 ", 34, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(CH3COO2H) = Chemical("CH3COO2H ", 76, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(ISONO3H) = Chemical("ISONO3H ", 1, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(ISNIRH) = Chemical("ISNIRH ", 1, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(CH3OH) = Chemical("CH3OH ", 32, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) - species(C2H5OH) = Chemical("C2H5OH ", 46, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) - species(ACETOL) = Chemical("ACETOL ", 74, 0, 3, 0, 0, 0.0, 0.0000, 0.0 ) - species(H2) = Chemical("H2 ", 2, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(CO) = Chemical("CO ", 28, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) - species(CH4) = Chemical("CH4 ", 16, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) - species(SO2) = Chemical("SO2 ", 64, 0, 0, 0, 1, 0.0, 0.0000, 0.0 ) - species(SO4) = Chemical("SO4 ", 96, 0, 0, 0, 1, 8.5, 0.0000, 0.0 ) - species(NH3) = Chemical("NH3 ", 17, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) - species(NO3_F) = Chemical("NO3_F ", 62, 0, 0, 1, 0, 8.5, 0.0000, 0.0 ) - species(NO3_C) = Chemical("NO3_C ", 62, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) - species(NH4_F) = Chemical("NH4_F ", 18, 0, 0, 1, 0, 8.5, 0.0000, 0.0 ) - species(PPM25) = Chemical("PPM25 ", 12, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(PPM25_FIRE) = Chemical("PPM25_FIRE ", 12, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(PPM_C) = Chemical("PPM_C ", 12, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(SEASALT_F) = Chemical("SEASALT_F ", 58, 0, 0, 0, 0, 3.0, 0.0000, 0.0 ) - species(SEASALT_C) = Chemical("SEASALT_C ", 58, 0, 0, 0, 0, 0.4, 0.0000, 0.0 ) - species(SEASALT_G) = Chemical("SEASALT_G ", 58, 0, 0, 0, 0, 0.4, 0.0000, 0.0 ) - species(DUST_NAT_F) = Chemical("DUST_NAT_F ", 200, 0, 0, 0, 0, 1.0, 0.0000, 0.0 ) - species(DUST_NAT_C) = Chemical("DUST_NAT_C ", 200, 0, 0, 0, 0, 0.3, 0.0000, 0.0 ) - species(RN222) = Chemical("RN222 ", 222, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - species(PB210) = Chemical("PB210 ", 210, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) - end subroutine define_chemicals - end module ChemChemicals_ml + subroutine define_chemicals() + !+ + ! Pointers to short lived and advected portions of species + ! + species_shl=>species(1:NSPEC_SHL) + species_adv=>species(NSPEC_SHL+1:NSPEC_SHL+NSPEC_ADV) + !+ + ! Assigns names, mol wts, carbon numbers, advec, nmhc to user-defined Chemical + ! array, using indices from total list of species (advected + short-lived). + ! MW NM C N S ExtC C* dH + species(OD ) = Chemical("OD ", 16.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(OP ) = Chemical("OP ", 16.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(OH ) = Chemical("OH ", 17.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(HO2 ) = Chemical("HO2 ", 33.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(CH3O2 ) = Chemical("CH3O2 ", 47.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(C2H5O2 ) = Chemical("C2H5O2 ", 61.0000, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(SECC4H9O2 ) = Chemical("SECC4H9O2 ", 89.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(ISRO2 ) = Chemical("ISRO2 ", 101.0000, 0, 5, 0, 0, 0.0, 0.0000, 0.0 ) + species(ETRO2 ) = Chemical("ETRO2 ", 77.0000, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(PRRO2 ) = Chemical("PRRO2 ", 91.0000, 0, 3, 0, 0, 0.0, 0.0000, 0.0 ) + species(OXYO2 ) = Chemical("OXYO2 ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(MEKO2 ) = Chemical("MEKO2 ", 103.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(MALO2 ) = Chemical("MALO2 ", 147.0000, 0, 5, 0, 0, 0.0, 0.0000, 0.0 ) + species(MVKO2 ) = Chemical("MVKO2 ", 119.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(MACRO2 ) = Chemical("MACRO2 ", 119.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(MACO3 ) = Chemical("MACO3 ", 101.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(O3 ) = Chemical("O3 ", 48.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(NO ) = Chemical("NO ", 30.0000, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) + species(NO2 ) = Chemical("NO2 ", 46.0000, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) + species(PAN ) = Chemical("PAN ", 121.0000, 0, 2, 1, 0, 0.0, 0.0000, 0.0 ) + species(MPAN ) = Chemical("MPAN ", 132.0000, 0, 4, 1, 0, 0.0, 0.0000, 0.0 ) + species(NO3 ) = Chemical("NO3 ", 62.0000, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) + species(N2O5 ) = Chemical("N2O5 ", 108.0000, 0, 0, 2, 0, 0.0, 0.0000, 0.0 ) + species(ISONO3 ) = Chemical("ISONO3 ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(HNO3 ) = Chemical("HNO3 ", 63.0000, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) + species(HONO ) = Chemical("HONO ", 47.0000, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) + species(CH3COO2 ) = Chemical("CH3COO2 ", 75.0000, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(MACR ) = Chemical("MACR ", 70.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(ISNI ) = Chemical("ISNI ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(ISNIR ) = Chemical("ISNIR ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(GLYOX ) = Chemical("GLYOX ", 58.0000, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(MGLYOX ) = Chemical("MGLYOX ", 72.0000, 0, 3, 0, 0, 0.0, 0.0000, 0.0 ) + species(MAL ) = Chemical("MAL ", 98.0000, 0, 5, 0, 0, 0.0, 0.0000, 0.0 ) + species(MEK ) = Chemical("MEK ", 72.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(MVK ) = Chemical("MVK ", 70.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(HCHO ) = Chemical("HCHO ", 30.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(CH3CHO ) = Chemical("CH3CHO ", 44.0000, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(C2H6 ) = Chemical("C2H6 ", 30.0000, 1, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(NC4H10 ) = Chemical("NC4H10 ", 58.0000, 1, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(C2H4 ) = Chemical("C2H4 ", 28.0000, 1, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(C3H6 ) = Chemical("C3H6 ", 42.0000, 1, 3, 0, 0, 0.0, 0.0000, 0.0 ) + species(OXYL ) = Chemical("OXYL ", 106.0000, 1, 8, 0, 0, 0.0, 0.0000, 0.0 ) + species(C5H8 ) = Chemical("C5H8 ", 68.0000, 1, 5, 0, 0, 0.0, 0.0000, 0.0 ) + species(APINENE ) = Chemical("APINENE ", 136.0000, 1, 10, 0, 0, 0.0, 0.0000, 0.0 ) + species(CH3O2H ) = Chemical("CH3O2H ", 48.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(C2H5OOH ) = Chemical("C2H5OOH ", 62.0000, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(BURO2H ) = Chemical("BURO2H ", 90.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(ETRO2H ) = Chemical("ETRO2H ", 78.0000, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(PRRO2H ) = Chemical("PRRO2H ", 92.0000, 0, 3, 0, 0, 0.0, 0.0000, 0.0 ) + species(OXYO2H ) = Chemical("OXYO2H ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(MEKO2H ) = Chemical("MEKO2H ", 104.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(MALO2H ) = Chemical("MALO2H ", 147.0000, 0, 5, 0, 0, 0.0, 0.0000, 0.0 ) + species(MVKO2H ) = Chemical("MVKO2H ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(MACROOH ) = Chemical("MACROOH ", 120.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(MACO3H ) = Chemical("MACO3H ", 102.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(MACO2H ) = Chemical("MACO2H ", 86.0000, 0, 4, 0, 0, 0.0, 0.0000, 0.0 ) + species(ISRO2H ) = Chemical("ISRO2H ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(H2O2 ) = Chemical("H2O2 ", 34.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(CH3COO2H ) = Chemical("CH3COO2H ", 76.0000, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(ISONO3H ) = Chemical("ISONO3H ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(ISNIRH ) = Chemical("ISNIRH ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(CH3OH ) = Chemical("CH3OH ", 32.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(C2H5OH ) = Chemical("C2H5OH ", 46.0000, 0, 2, 0, 0, 0.0, 0.0000, 0.0 ) + species(ACETOL ) = Chemical("ACETOL ", 74.0000, 0, 3, 0, 0, 0.0, 0.0000, 0.0 ) + species(H2 ) = Chemical("H2 ", 2.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(CO ) = Chemical("CO ", 28.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(CH4 ) = Chemical("CH4 ", 16.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(SO2 ) = Chemical("SO2 ", 64.0000, 0, 0, 0, 1, 0.0, 0.0000, 0.0 ) + species(SO4 ) = Chemical("SO4 ", 96.0000, 0, 0, 0, 1, 8.5, 0.0000, 0.0 ) + species(NH3 ) = Chemical("NH3 ", 17.0000, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) + species(NO3_F ) = Chemical("NO3_F ", 62.0000, 0, 0, 1, 0, 8.5, 0.0000, 0.0 ) + species(NO3_C ) = Chemical("NO3_C ", 62.0000, 0, 0, 1, 0, 0.0, 0.0000, 0.0 ) + species(NH4_F ) = Chemical("NH4_F ", 18.0000, 0, 0, 1, 0, 8.5, 0.0000, 0.0 ) + species(V1702A02B_F ) = Chemical("V1702A02B_F ", 12.0000, 0, 0, 0, 0, 1.0, 0.0000, 0.0 ) + species(V1702A02B_C ) = Chemical("V1702A02B_C ", 12.0000, 0, 0, 0, 0, 0.3, 0.0000, 0.0 ) + species(GAS_ASOA_OC ) = Chemical("GAS_ASOA_OC ", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_ASOA_OC) = Chemical("PART_ASOA_OC", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_ASOA_OM) = Chemical("PART_ASOA_OM", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(GAS_BSOA_OC ) = Chemical("GAS_BSOA_OC ", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_BSOA_OC) = Chemical("PART_BSOA_OC", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_BSOA_OM) = Chemical("PART_BSOA_OM", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_FFUELOA25_OC) = Chemical("PART_FFUELOA25_OC", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_FFUELOA25_OM) = Chemical("PART_FFUELOA25_OM", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_WOODOA25_OC) = Chemical("PART_WOODOA25_OC", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_WOODOA25_OM) = Chemical("PART_WOODOA25_OM", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_FFIREOA25_OC) = Chemical("PART_FFIREOA25_OC", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_FFIREOA25_OM) = Chemical("PART_FFIREOA25_OM", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_OC10 ) = Chemical("PART_OC10 ", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_OC25 ) = Chemical("PART_OC25 ", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(NONVOL_FFUELOC25) = Chemical("NONVOL_FFUELOC25", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(NONV_FFUELOC_COARSE) = Chemical("NONV_FFUELOC_COARSE", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(NONVOL_WOODOC25) = Chemical("NONVOL_WOODOC25", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(NONVOL_BGNDOC) = Chemical("NONVOL_BGNDOC", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(NONVOL_FFIREOC25) = Chemical("NONVOL_FFIREOC25", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(PART_OM_F ) = Chemical("PART_OM_F ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(POM_F_WOOD ) = Chemical("POM_F_WOOD ", 20.4000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(POM_F_FFUEL ) = Chemical("POM_F_FFUEL ", 15.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(POM_C_FFUEL ) = Chemical("POM_C_FFUEL ", 15.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(EC_F_WOOD_NEW) = Chemical("EC_F_WOOD_NEW", 12.0000, 0, 1, 0, 0, 7.5, 0.0000, 0.0 ) + species(EC_F_WOOD_AGE) = Chemical("EC_F_WOOD_AGE", 12.0000, 0, 1, 0, 0, 11.0, 0.0000, 0.0 ) + species(EC_C_WOOD ) = Chemical("EC_C_WOOD ", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(EC_F_FFUEL_NEW) = Chemical("EC_F_FFUEL_NEW", 12.0000, 0, 1, 0, 0, 7.5, 0.0000, 0.0 ) + species(EC_F_FFUEL_AGE) = Chemical("EC_F_FFUEL_AGE", 12.0000, 0, 1, 0, 0, 11.0, 0.0000, 0.0 ) + species(EC_C_FFUEL ) = Chemical("EC_C_FFUEL ", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(REMPPM25 ) = Chemical("REMPPM25 ", 12.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(REMPPM_C ) = Chemical("REMPPM_C ", 12.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(FFIRE_OM ) = Chemical("FFIRE_OM ", 20.4000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(FFIRE_BC ) = Chemical("FFIRE_BC ", 12.0000, 0, 1, 0, 0, 0.0, 0.0000, 0.0 ) + species(FFIRE_REMPPM25) = Chemical("FFIRE_REMPPM25", 12.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(TERPPEROXY ) = Chemical("TERPPEROXY ", 1.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(ASOC_NG100 ) = Chemical("ASOC_NG100 ", 12.0000, 0, 1, 0, 0, 0.0, 0.1000, 30.0 ) + species(ASOC_UG1 ) = Chemical("ASOC_UG1 ", 12.0000, 0, 1, 0, 0, 0.0, 1.0000, 30.0 ) + species(ASOC_UG10 ) = Chemical("ASOC_UG10 ", 12.0000, 0, 1, 0, 0, 0.0, 10.0000, 30.0 ) + species(ASOC_UG1E2 ) = Chemical("ASOC_UG1E2 ", 12.0000, 0, 1, 0, 0, 0.0,100.0000, 30.0 ) + species(ASOC_UG1E3 ) = Chemical("ASOC_UG1E3 ", 12.0000, 0, 1, 0, 0, 0.0,1000.0000, 30.0 ) + species(NON_C_ASOA_NG100) = Chemical("NON_C_ASOA_NG100", 1.0000, 0, 0, 0, 0, 0.0, 0.1000, 30.0 ) + species(NON_C_ASOA_UG1) = Chemical("NON_C_ASOA_UG1", 1.0000, 0, 0, 0, 0, 0.0, 1.0000, 30.0 ) + species(NON_C_ASOA_UG10) = Chemical("NON_C_ASOA_UG10", 1.0000, 0, 0, 0, 0, 0.0, 10.0000, 30.0 ) + species(NON_C_ASOA_UG1E2) = Chemical("NON_C_ASOA_UG1E2", 1.0000, 0, 0, 0, 0, 0.0,100.0000, 30.0 ) + species(NON_C_ASOA_UG1E3) = Chemical("NON_C_ASOA_UG1E3", 1.0000, 0, 0, 0, 0, 0.0,1000.0000, 30.0 ) + species(BSOC_NG100 ) = Chemical("BSOC_NG100 ", 12.0000, 0, 1, 0, 0, 0.0, 0.1000, 30.0 ) + species(BSOC_UG1 ) = Chemical("BSOC_UG1 ", 12.0000, 0, 1, 0, 0, 0.0, 1.0000, 30.0 ) + species(BSOC_UG10 ) = Chemical("BSOC_UG10 ", 12.0000, 0, 1, 0, 0, 0.0, 10.0000, 30.0 ) + species(BSOC_UG1E2 ) = Chemical("BSOC_UG1E2 ", 12.0000, 0, 1, 0, 0, 0.0,100.0000, 30.0 ) + species(BSOC_UG1E3 ) = Chemical("BSOC_UG1E3 ", 12.0000, 0, 1, 0, 0, 0.0,1000.0000, 30.0 ) + species(NON_C_BSOA_NG100) = Chemical("NON_C_BSOA_NG100", 1.0000, 0, 0, 0, 0, 0.0, 0.1000, 30.0 ) + species(NON_C_BSOA_UG1) = Chemical("NON_C_BSOA_UG1", 1.0000, 0, 0, 0, 0, 0.0, 1.0000, 30.0 ) + species(NON_C_BSOA_UG10) = Chemical("NON_C_BSOA_UG10", 1.0000, 0, 0, 0, 0, 0.0, 10.0000, 30.0 ) + species(NON_C_BSOA_UG1E2) = Chemical("NON_C_BSOA_UG1E2", 1.0000, 0, 0, 0, 0, 0.0,100.0000, 30.0 ) + species(NON_C_BSOA_UG1E3) = Chemical("NON_C_BSOA_UG1E3", 1.0000, 0, 0, 0, 0, 0.0,1000.0000, 30.0 ) + species(FFFUEL_NG10 ) = Chemical("FFFUEL_NG10 ", 15.0000, 0, 1, 0, 0, 0.0, 0.0100, 112.0 ) + species(WOODOA_NG10 ) = Chemical("WOODOA_NG10 ", 20.4000, 0, 1, 0, 0, 0.0, 0.0100, 112.0 ) + species(FFIREOA_NG10) = Chemical("FFIREOA_NG10", 20.4000, 0, 1, 0, 0, 0.0, 0.0100, 112.0 ) + species(SEASALT_F ) = Chemical("SEASALT_F ", 58.0000, 0, 0, 0, 0, 3.0, 0.0000, 0.0 ) + species(SEASALT_C ) = Chemical("SEASALT_C ", 58.0000, 0, 0, 0, 0, 0.4, 0.0000, 0.0 ) + species(DUST_ROAD_F ) = Chemical("DUST_ROAD_F ", 200.0000, 0, 0, 0, 0, 1.0, 0.0000, 0.0 ) + species(DUST_ROAD_C ) = Chemical("DUST_ROAD_C ", 200.0000, 0, 0, 0, 0, 0.3, 0.0000, 0.0 ) + species(DUST_WB_F ) = Chemical("DUST_WB_F ", 200.0000, 0, 0, 0, 0, 1.0, 0.0000, 0.0 ) + species(DUST_WB_C ) = Chemical("DUST_WB_C ", 200.0000, 0, 0, 0, 0, 0.3, 0.0000, 0.0 ) + species(DUST_SAH_F ) = Chemical("DUST_SAH_F ", 200.0000, 0, 0, 0, 0, 1.0, 0.0000, 0.0 ) + species(DUST_SAH_C ) = Chemical("DUST_SAH_C ", 200.0000, 0, 0, 0, 0, 0.3, 0.0000, 0.0 ) + species(RN222 ) = Chemical("RN222 ", 222.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(RNWATER ) = Chemical("RNWATER ", 222.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + species(PB210 ) = Chemical("PB210 ", 210.0000, 0, 0, 0, 0, 0.0, 0.0000, 0.0 ) + end subroutine define_chemicals +end module ChemChemicals_ml !----------------------------------------------------------- diff --git a/CM_DryDep.inc b/CM_DryDep.inc index 69d7e50..d1fb281 100644 --- a/CM_DryDep.inc +++ b/CM_DryDep.inc @@ -1,6 +1,6 @@ - integer, public, parameter :: NDRYDEP_ADV = 28 + integer, public, parameter :: NDRYDEP_ADV = 64 type(depmap), public, dimension(NDRYDEP_ADV), parameter:: DDepMap= (/ & - depmap( IXADV_O3, CDDEP_O3, -1) & + depmap( IXADV_O3, CDDEP_O3, -1) & , depmap( IXADV_NO2, CDDEP_NO2, -1) & , depmap( IXADV_PAN, CDDEP_PAN, -1) & , depmap( IXADV_MPAN, CDDEP_PAN, -1) & @@ -19,13 +19,49 @@ , depmap( IXADV_NO3_f, CDDEP_PMfN, -1) & , depmap( IXADV_NO3_c, CDDEP_PMc, -1) & , depmap( IXADV_NH4_f, CDDEP_PMfN, -1) & - , depmap( IXADV_PPM25, CDDEP_PMfS, -1) & - , depmap( IXADV_PPM25_FIRE, CDDEP_PMfS, -1) & - , depmap( IXADV_PPM_c, CDDEP_PMc, -1) & + , depmap( IXADV_V1702A02B_f, CDDEP_PMfS, -1) & + , depmap( IXADV_V1702A02B_c, CDDEP_PMc, -1) & + , depmap( IXADV_POM_f_WOOD, CDDEP_PMfS, -1) & + , depmap( IXADV_POM_f_FFUEL, CDDEP_PMfS, -1) & + , depmap( IXADV_POM_c_FFUEL, CDDEP_PMc, -1) & + , depmap( IXADV_EC_f_WOOD_new, CDDEP_PMfS, -1) & + , depmap( IXADV_EC_f_WOOD_age, CDDEP_PMfS, -1) & + , depmap( IXADV_EC_c_WOOD, CDDEP_PMc, -1) & + , depmap( IXADV_EC_f_FFUEL_new, CDDEP_PMfS, -1) & + , depmap( IXADV_EC_f_FFUEL_age, CDDEP_PMfS, -1) & + , depmap( IXADV_EC_c_FFUEL, CDDEP_PMc, -1) & + , depmap( IXADV_REMPPM25, CDDEP_PMfS, -1) & + , depmap( IXADV_REMPPM_c, CDDEP_PMc, -1) & + , depmap( IXADV_FFIRE_OM, CDDEP_PMfS, -1) & + , depmap( IXADV_FFIRE_BC, CDDEP_PMfS, -1) & + , depmap( IXADV_FFIRE_REMPPM25, CDDEP_PMfS, -1) & + , depmap( IXADV_ASOC_ng100, CDDEP_ALD, -1) & + , depmap( IXADV_ASOC_ug1, CDDEP_ALD, -1) & + , depmap( IXADV_ASOC_ug10, CDDEP_ALD, -1) & + , depmap( IXADV_ASOC_ug1e2, CDDEP_ALD, -1) & + , depmap( IXADV_ASOC_ug1e3, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_ASOA_ng100, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_ASOA_ug1, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_ASOA_ug10, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_ASOA_ug1e2, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_ASOA_ug1e3, CDDEP_ALD, -1) & + , depmap( IXADV_BSOC_ng100, CDDEP_ALD, -1) & + , depmap( IXADV_BSOC_ug1, CDDEP_ALD, -1) & + , depmap( IXADV_BSOC_ug10, CDDEP_ALD, -1) & + , depmap( IXADV_BSOC_ug1e2, CDDEP_ALD, -1) & + , depmap( IXADV_BSOC_ug1e3, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_BSOA_ng100, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_BSOA_ug1, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_BSOA_ug10, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_BSOA_ug1e2, CDDEP_ALD, -1) & + , depmap( IXADV_NON_C_BSOA_ug1e3, CDDEP_ALD, -1) & , depmap( IXADV_SeaSalt_f, CDDEP_PMfS, -1) & - , depmap( IXADV_SeaSalt_c, CDDEP_PMc, -1) & - , depmap( IXADV_SeaSalt_g, CDDEP_PMg, -1) & - , depmap( IXADV_Dust_nat_f, CDDEP_PMfS, -1) & - , depmap( IXADV_Dust_nat_c, CDDEP_PMc, -1) & + , depmap( IXADV_SeaSalt_c, CDDEP_SSc, -1) & + , depmap( IXADV_DUST_ROAD_F, CDDEP_PMfS, -1) & + , depmap( IXADV_DUST_ROAD_C, CDDEP_DUc, -1) & + , depmap( IXADV_Dust_wb_f, CDDEP_PMfS, -1) & + , depmap( IXADV_Dust_wb_c, CDDEP_DUc, -1) & + , depmap( IXADV_Dust_sah_f, CDDEP_PMfS, -1) & + , depmap( IXADV_Dust_sah_c, CDDEP_DUc, -1) & , depmap( IXADV_Pb210, CDDEP_PMfS, -1) & /) diff --git a/CM_EmisBioNat.inc b/CM_EmisBioNat.inc new file mode 100644 index 0000000..02b71f4 --- /dev/null +++ b/CM_EmisBioNat.inc @@ -0,0 +1,17 @@ + integer, parameter, public :: NEMIS_BioNat = 12 + character(len=11), save, dimension(NEMIS_BioNat), public:: & + EMIS_BioNat = (/ & + "C5H8 " & + , "APINENE " & + , "NO " & + , "V1702A02B_F" & + , "V1702A02B_C" & + , "SEASALT_F " & + , "SEASALT_C " & + , "DUST_WB_F " & + , "DUST_WB_C " & + , "DUST_ROAD_F" & + , "DUST_ROAD_C" & + , "RN222 " & + /) + \ No newline at end of file diff --git a/CM_EmisFiles.inc b/CM_EmisFiles.inc new file mode 100644 index 0000000..c09e979 --- /dev/null +++ b/CM_EmisFiles.inc @@ -0,0 +1,12 @@ + integer, parameter, public :: NEMIS_File = 7 + character(len=4), save, dimension(NEMIS_File), public:: & + EMIS_File = (/ & + "sox " & + , "nox " & + , "co " & + , "voc " & + , "nh3 " & + , "pm25" & + , "pmco" & + /) + \ No newline at end of file diff --git a/CM_EmisSpecs.inc b/CM_EmisSpecs.inc index 294c2ef..d10a210 100644 --- a/CM_EmisSpecs.inc +++ b/CM_EmisSpecs.inc @@ -1,27 +1,47 @@ - integer, parameter :: NEMIS_SPECS = 22 - character(len=12), save, dimension(NEMIS_SPECS):: & - EMIS_SPECS = (/ & - "NO " & - , "NO2 " & - , "SO2 " & - , "SO4 " & - , "NH3 " & - , "CO " & - , "C2H6 " & - , "NC4H10 " & - , "C2H4 " & - , "C3H6 " & - , "OXYL " & - , "HCHO " & - , "CH3CHO " & - , "MEK " & - , "C2H5OH " & - , "CH3OH " & - , "GLYOX " & - , "MGLYOX " & - , "C5H8 " & - , "PPM25 " & - , "PPM_C " & - , "PPM25_FIRE " & + integer, parameter, public :: NEMIS_Specs = 42 + character(len=14), save, dimension(NEMIS_Specs), public:: & + EMIS_Specs = (/ & + "NO " & + , "NO2 " & + , "SO2 " & + , "SO4 " & + , "CO " & + , "NH3 " & + , "C2H6 " & + , "NC4H10 " & + , "C2H4 " & + , "C3H6 " & + , "OXYL " & + , "HCHO " & + , "CH3CHO " & + , "MEK " & + , "C2H5OH " & + , "CH3OH " & + , "GLYOX " & + , "MGLYOX " & + , "C5H8 " & + , "APINENE " & + , "V1702A02B_F " & + , "V1702A02B_C " & + , "POM_F_FFUEL " & + , "POM_C_FFUEL " & + , "EC_F_FFUEL_NEW" & + , "EC_F_FFUEL_AGE" & + , "EC_C_FFUEL " & + , "POM_F_WOOD " & + , "EC_F_WOOD_NEW " & + , "EC_F_WOOD_AGE " & + , "REMPPM25 " & + , "REMPPM_C " & + , "FFIRE_OM " & + , "FFIRE_BC " & + , "FFIRE_REMPPM25" & + , "SEASALT_F " & + , "SEASALT_C " & + , "DUST_WB_F " & + , "DUST_WB_C " & + , "DUST_ROAD_F " & + , "DUST_ROAD_C " & + , "RN222 " & /) \ No newline at end of file diff --git a/CM_Reactions1.inc b/CM_Reactions1.inc index 6bea060..30045d8 100644 --- a/CM_Reactions1.inc +++ b/CM_Reactions1.inc @@ -5,47 +5,47 @@ rcphot(IDBO3,K) * xnew(O3 ) L = & - rcmisc(2,k) & - + rcmisc(3,k) & - + rcmisc(4,k) + rct(2,k) & + + rct(3,k) & + + rct(4,k) - xnew(OD)= max(0.0, ( xold(OD) + dt2 * P)) /(1.0 + dt2*L ) + xnew(OD)= ( xold(OD) + dt2 * P) /(1.0 + dt2*L ) !-> OP P = & - rcmisc(2,k) * xnew(OD ) & - + rcmisc(3,k) * xnew(OD ) & - + 0.3*rct(34,k) * xnew(C5H8 ) * xnew(O3 ) & - + 0.2*rct(42,k) * xnew(MVK ) * xnew(O3 ) & + rct(2,k) * xnew(OD ) & + + rct(3,k) * xnew(OD ) & + + 0.3*rct(50,k) * xnew(C5H8 ) * xnew(O3 ) & + + 0.2*rct(58,k) * xnew(MVK ) * xnew(O3 ) & + rcphot(IDAO3,K) * xnew(O3 ) & + rcphot(IDNO2,K) * xnew(NO2 ) & + rcphot(IDNO3,K) * xnew(NO3 ) L = & - rcmisc(1,k) & - + rcmisc(20,k)* xnew(NO ) + rct(1,k) & + + rct(63,k)* xnew(NO ) - xnew(OP)= max(0.0, ( xold(OP) + dt2 * P)) /(1.0 + dt2*L ) + xnew(OP)= ( xold(OP) + dt2 * P) /(1.0 + dt2*L ) !-> OH P = & - 2.*rcmisc(4,k) * xnew(OD ) & - + rcmisc(5,k) * xnew(O3 ) * xnew(HO2 ) & - + rct(5,k) * xnew(NO ) * xnew(HO2 ) & - + 0.4*rct(15,k) * xnew(CH3O2H ) * xnew(OH ) & + 2.*rct(4,k) * xnew(OD ) & + + rct(8,k) * xnew(O3 ) * xnew(HO2 ) & + + rct(10,k) * xnew(NO ) * xnew(HO2 ) & + + 0.4*rct(26,k) * xnew(CH3O2H ) * xnew(OH ) & + 8.01e-12 * xnew(C2H5OOH ) * xnew(OH ) & - + 0.44*rct(25,k) * xnew(CH3COO2 ) * xnew(HO2 ) & + + 0.44*rct(37,k) * xnew(CH3COO2 ) * xnew(HO2 ) & + 2.15e-11 * xnew(BURO2H ) * xnew(OH ) & + 1.38e-11 * xnew(ETRO2H ) * xnew(OH ) & - + 0.13*rct(28,k) * xnew(C2H4 ) * xnew(O3 ) & - + 0.36*rct(29,k) * xnew(O3 ) * xnew(C3H6 ) & + + 0.13*rct(43,k) * xnew(C2H4 ) * xnew(O3 ) & + + 0.36*rct(44,k) * xnew(O3 ) * xnew(C3H6 ) & + 2.44e-11 * xnew(PRRO2H ) * xnew(OH ) & - + 0.55*rct(34,k) * xnew(C5H8 ) * xnew(O3 ) & + + 0.55*rct(50,k) * xnew(C5H8 ) * xnew(O3 ) & + 7.5e-11 * xnew(ISRO2H ) * xnew(OH ) & - + 0.82*rct(37,k) * xnew(MACR ) * xnew(O3 ) & - + 0.08*rct(42,k) * xnew(MVK ) * xnew(O3 ) & + + 0.82*rct(53,k) * xnew(MACR ) * xnew(O3 ) & + + 0.08*rct(58,k) * xnew(MVK ) * xnew(O3 ) & + 2*rcphot(IDH2O2,K) * xnew(H2O2 ) & + rcphot(IDHNO3,K) * xnew(HNO3 ) & + rcphot(IDCH3O2H,K) * xnew(CH3O2H ) & @@ -59,45 +59,45 @@ + 0.222*rcphot(IDNO2,K) * xnew(HONO ) L = & - rct(3,k)* xnew(O3 ) & - + rct(7,k)* xnew(HO2 ) & - + rct(8,k)* xnew(H2O2 ) & - + rct(9,k)* xnew(H2 ) & - + rcmisc(6,k)* xnew(HNO3 ) & - + rct(10,k)* xnew(HONO ) & + rct(7,k)* xnew(O3 ) & + + rct(12,k)* xnew(HO2 ) & + + rct(13,k)* xnew(H2O2 ) & + + rct(14,k)* xnew(H2 ) & + + rct(15,k)* xnew(HNO3 ) & + + rct(18,k)* xnew(HONO ) & + 2e-12*AQRCK(ICLOHSO2,K)* xnew(SO2 ) & - + rcmisc(9,k)* xnew(CH4 ) & - + rcmisc(10,k)* xnew(CO ) & - + rcmisc(11,k)* xnew(CH3OH ) & - + rct(15,k)* xnew(CH3O2H ) & - + rcmisc(12,k)* xnew(HCHO ) & - + rct(17,k)* xnew(C2H6 ) & + + rct(19,k)* xnew(CH4 ) & + + rct(20,k)* xnew(CO ) & + + rct(24,k)* xnew(CH3OH ) & + + rct(26,k)* xnew(CH3O2H ) & + + rct(27,k)* xnew(HCHO ) & + + rct(29,k)* xnew(C2H6 ) & + 8.01e-12* xnew(C2H5OOH ) & - + rct(20,k)* xnew(C2H5OOH ) & - + rct(21,k)* xnew(CH3CHO ) & - + rct(20,k)* xnew(CH3COO2H ) & - + rcmisc(13,k)* xnew(C2H5OH ) & - + rcmisc(14,k)* xnew(NC4H10 ) & - + rcmisc(15,k)* xnew(MEK ) & - + rct(20,k)* xnew(MEKO2H ) & - + rct(20,k)* xnew(BURO2H ) & + + rct(32,k)* xnew(C2H5OOH ) & + + rct(33,k)* xnew(CH3CHO ) & + + rct(32,k)* xnew(CH3COO2H ) & + + rct(38,k)* xnew(C2H5OH ) & + + rct(39,k)* xnew(NC4H10 ) & + + rct(42,k)* xnew(MEK ) & + + rct(32,k)* xnew(MEKO2H ) & + + rct(32,k)* xnew(BURO2H ) & + 2.15e-11* xnew(BURO2H ) & + 1.38e-11* xnew(ETRO2H ) & - + rct(20,k)* xnew(ETRO2H ) & + + rct(32,k)* xnew(ETRO2H ) & + 2.44e-11* xnew(PRRO2H ) & - + rct(20,k)* xnew(PRRO2H ) & + + rct(32,k)* xnew(PRRO2H ) & + 1.36e-11* xnew(OXYL ) & + 4.2e-11* xnew(OXYO2H ) & + 5.58e-11* xnew(MAL ) & - + rct(20,k)* xnew(MALO2H ) & - + rcmisc(16,k)* xnew(GLYOX ) & - + rct(33,k)* xnew(MGLYOX ) & - + rct(35,k)* xnew(C5H8 ) & - + rct(36,k)* xnew(MVK ) & + + rct(32,k)* xnew(MALO2H ) & + + rct(48,k)* xnew(GLYOX ) & + + rct(49,k)* xnew(MGLYOX ) & + + rct(51,k)* xnew(C5H8 ) & + + rct(52,k)* xnew(MVK ) & + 7.5e-11* xnew(ISRO2H ) & - + rct(38,k)* xnew(MACR ) & + + rct(54,k)* xnew(MACR ) & + 2.82e-11* xnew(MACROOH ) & - + rct(40,k)* xnew(ACETOL ) & + + rct(56,k)* xnew(ACETOL ) & + 5.96e-11* xnew(ISNI ) & + 1.87e-11* xnew(MACO3H ) & + 1.51e-11* xnew(MACO2H ) & @@ -105,47 +105,47 @@ + 2.2e-11* xnew(MVKO2H ) & + 3.7e-11* xnew(ISNIRH ) & + 2.9e-11* xnew(MPAN ) & - + rcmisc(23,k)* xnew(NO2 ) & - + rcmisc(26,k)* xnew(C2H4 ) & - + rcmisc(27,k)* xnew(C3H6 ) & - + rcmisc(30,k)* xnew(NO ) + + rct(66,k)* xnew(NO2 ) & + + rct(69,k)* xnew(C2H4 ) & + + rct(70,k)* xnew(C3H6 ) & + + rct(71,k)* xnew(NO ) - xnew(OH)= max(0.0, ( xold(OH) + dt2 * P)) /(1.0 + dt2*L ) + xnew(OH)= ( xold(OH) + dt2 * P) /(1.0 + dt2*L ) !-> HO2 P = & - rct(3,k) * xnew(O3 ) * xnew(OH ) & - + rct(8,k) * xnew(OH ) * xnew(H2O2 ) & - + rct(9,k) * xnew(OH ) * xnew(H2 ) & + rct(7,k) * xnew(O3 ) * xnew(OH ) & + + rct(13,k) * xnew(OH ) * xnew(H2O2 ) & + + rct(14,k) * xnew(OH ) * xnew(H2 ) & + 2e-12*AQRCK(ICLOHSO2,K) * xnew(OH ) * xnew(SO2 ) & - + rcmisc(10,k) * xnew(OH ) * xnew(CO ) & - + rct(11,k) * xnew(CH3O2 ) * xnew(NO ) & - + 2.*rct(12,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & - + rcmisc(11,k) * xnew(OH ) * xnew(CH3OH ) & - + rcmisc(12,k) * xnew(OH ) * xnew(HCHO ) & - + rct(16,k) * xnew(NO3 ) * xnew(HCHO ) & - + rct(18,k) * xnew(C2H5O2 ) * xnew(NO ) & - + 0.9*rct(23,k) * xnew(CH3O2 ) * xnew(CH3COO2 ) & - + rcmisc(13,k) * xnew(OH ) * xnew(C2H5OH ) & - + 0.65*rct(26,k) * xnew(NO ) * xnew(SECC4H9O2 ) & - + rct(26,k) * xnew(ETRO2 ) * xnew(NO ) & - + 0.13*rct(28,k) * xnew(C2H4 ) * xnew(O3 ) & - + 0.28*rct(29,k) * xnew(O3 ) * xnew(C3H6 ) & - + rct(26,k) * xnew(NO ) * xnew(PRRO2 ) & - + rct(26,k) * xnew(OXYO2 ) * xnew(NO ) & - + rct(26,k) * xnew(MALO2 ) * xnew(NO ) & - + rcmisc(16,k) * xnew(OH ) * xnew(GLYOX ) & - + 0.06*rct(34,k) * xnew(C5H8 ) * xnew(O3 ) & - + 0.78*rct(26,k) * xnew(ISRO2 ) * xnew(NO ) & - + 0.95*rct(26,k) * xnew(MVKO2 ) * xnew(NO ) & - + 0.41*rct(37,k) * xnew(MACR ) * xnew(O3 ) & - + 0.95*rct(39,k) * xnew(MACRO2 ) * xnew(NO ) & + + rct(20,k) * xnew(OH ) * xnew(CO ) & + + rct(21,k) * xnew(CH3O2 ) * xnew(NO ) & + + 2.*rct(22,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & + + rct(24,k) * xnew(OH ) * xnew(CH3OH ) & + + rct(27,k) * xnew(OH ) * xnew(HCHO ) & + + rct(28,k) * xnew(NO3 ) * xnew(HCHO ) & + + rct(30,k) * xnew(C2H5O2 ) * xnew(NO ) & + + 0.9*rct(35,k) * xnew(CH3O2 ) * xnew(CH3COO2 ) & + + rct(38,k) * xnew(OH ) * xnew(C2H5OH ) & + + 0.65*rct(40,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + + rct(40,k) * xnew(ETRO2 ) * xnew(NO ) & + + 0.13*rct(43,k) * xnew(C2H4 ) * xnew(O3 ) & + + 0.28*rct(44,k) * xnew(O3 ) * xnew(C3H6 ) & + + rct(40,k) * xnew(NO ) * xnew(PRRO2 ) & + + rct(40,k) * xnew(OXYO2 ) * xnew(NO ) & + + rct(40,k) * xnew(MALO2 ) * xnew(NO ) & + + rct(48,k) * xnew(OH ) * xnew(GLYOX ) & + + 0.06*rct(50,k) * xnew(C5H8 ) * xnew(O3 ) & + + 0.78*rct(40,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.95*rct(40,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.41*rct(53,k) * xnew(MACR ) * xnew(O3 ) & + + 0.95*rct(55,k) * xnew(MACRO2 ) * xnew(NO ) & + 2.5e-12 * xnew(MACRO2 ) * xnew(NO3 ) & - + rct(40,k) * xnew(ACETOL ) * xnew(OH ) & - + 0.06*rct(42,k) * xnew(MVK ) * xnew(O3 ) & - + 0.05*rct(26,k) * xnew(ISNIR ) * xnew(NO ) & - + 0.8*rct(26,k) * xnew(ISONO3 ) * xnew(NO ) & + + rct(56,k) * xnew(ACETOL ) * xnew(OH ) & + + 0.06*rct(58,k) * xnew(MVK ) * xnew(O3 ) & + + 0.05*rct(40,k) * xnew(ISNIR ) * xnew(NO ) & + + 0.8*rct(40,k) * xnew(ISONO3 ) * xnew(NO ) & + 2*rcphot(IDACH2O,K) * xnew(HCHO ) & + rcphot(IDCH3CHO,K) * xnew(CH3CHO ) & + rcphot(IDCH3O2H,K) * xnew(CH3O2H ) & @@ -159,120 +159,121 @@ + rcphot(IDCH3O2H,K) * xnew(MALO2H ) L = & - rcmisc(5,k)* xnew(O3 ) & - + rct(5,k)* xnew(NO ) & - + rct(7,k)* xnew(OH ) & - + rcmisc(7,k)* xnew(HO2 ) & - + rcmisc(7,k)* xnew(HO2 ) & - + rcmisc(8,k)* xnew(HO2 ) & - + rcmisc(8,k)* xnew(HO2 ) & - + rct(14,k)* xnew(CH3O2 ) & - + rct(19,k)* xnew(C2H5O2 ) & - + rct(25,k)* xnew(CH3COO2 ) & - + rct(27,k)* xnew(SECC4H9O2 ) & - + rct(27,k)* xnew(MEKO2 ) & + rct(8,k)* xnew(O3 ) & + + rct(10,k)* xnew(NO ) & + + rct(12,k)* xnew(OH ) & + + rct(16,k)* xnew(HO2 ) & + + rct(16,k)* xnew(HO2 ) & + + rct(17,k)* xnew(HO2 ) & + + rct(17,k)* xnew(HO2 ) & + + rct(25,k)* xnew(CH3O2 ) & + + rct(31,k)* xnew(C2H5O2 ) & + + rct(37,k)* xnew(CH3COO2 ) & + + rct(41,k)* xnew(SECC4H9O2 ) & + + rct(41,k)* xnew(MEKO2 ) & + 1.2e-11* xnew(ETRO2 ) & - + rct(30,k)* xnew(PRRO2 ) & - + rct(31,k)* xnew(OXYO2 ) & - + rct(32,k)* xnew(MALO2 ) & - + rct(32,k)* xnew(ISRO2 ) & - + rct(27,k)* xnew(MACRO2 ) & - + rct(32,k)* xnew(ISONO3 ) & - + rct(27,k)* xnew(MVKO2 ) & - + rct(44,k)* xnew(MACO3 ) & - + rct(32,k)* xnew(ISNIR ) - - xnew(HO2)= max(0.0, ( xold(HO2) + dt2 * P)) /(1.0 + dt2*L ) + + rct(45,k)* xnew(PRRO2 ) & + + rct(46,k)* xnew(OXYO2 ) & + + rct(47,k)* xnew(MALO2 ) & + + rct(47,k)* xnew(ISRO2 ) & + + rct(41,k)* xnew(MACRO2 ) & + + rct(47,k)* xnew(ISONO3 ) & + + rct(41,k)* xnew(MVKO2 ) & + + rct(60,k)* xnew(MACO3 ) & + + rct(47,k)* xnew(ISNIR ) & + + rct(75,k)* xnew(TERPPEROXY ) + + xnew(HO2)= ( xold(HO2) + dt2 * P) /(1.0 + dt2*L ) !-> CH3O2 P = & - rcmisc(9,k) * xnew(OH ) * xnew(CH4 ) & - + 0.6*rct(15,k) * xnew(CH3O2H ) * xnew(OH ) & - + 0.05*rct(21,k) * xnew(OH ) * xnew(CH3CHO ) & - + rct(22,k) * xnew(CH3COO2 ) * xnew(NO ) & - + 0.9*rct(23,k) * xnew(CH3O2 ) * xnew(CH3COO2 ) & - + rct(24,k) * xnew(CH3COO2 ) * xnew(CH3COO2 ) & - + rct(24,k) * xnew(CH3COO2 ) * xnew(CH3COO2 ) & - + 0.44*rct(25,k) * xnew(CH3COO2 ) * xnew(HO2 ) & - + 0.28*rct(29,k) * xnew(O3 ) * xnew(C3H6 ) & + rct(19,k) * xnew(OH ) * xnew(CH4 ) & + + 0.6*rct(26,k) * xnew(CH3O2H ) * xnew(OH ) & + + 0.05*rct(33,k) * xnew(OH ) * xnew(CH3CHO ) & + + rct(34,k) * xnew(CH3COO2 ) * xnew(NO ) & + + 0.9*rct(35,k) * xnew(CH3O2 ) * xnew(CH3COO2 ) & + + rct(36,k) * xnew(CH3COO2 ) * xnew(CH3COO2 ) & + + rct(36,k) * xnew(CH3COO2 ) * xnew(CH3COO2 ) & + + 0.44*rct(37,k) * xnew(CH3COO2 ) * xnew(HO2 ) & + + 0.28*rct(44,k) * xnew(O3 ) * xnew(C3H6 ) & + rcphot(IDCH3CHO,K) * xnew(CH3CHO ) & + rcphot(IDCH3O2H,K) * xnew(CH3COO2H ) L = & - rct(11,k)* xnew(NO ) & - + rct(12,k)* xnew(CH3O2 ) & - + rct(12,k)* xnew(CH3O2 ) & - + rct(13,k)* xnew(CH3O2 ) & - + rct(13,k)* xnew(CH3O2 ) & - + rct(14,k)* xnew(HO2 ) & - + rct(23,k)* xnew(CH3COO2 ) + rct(21,k)* xnew(NO ) & + + rct(22,k)* xnew(CH3O2 ) & + + rct(22,k)* xnew(CH3O2 ) & + + rct(23,k)* xnew(CH3O2 ) & + + rct(23,k)* xnew(CH3O2 ) & + + rct(25,k)* xnew(HO2 ) & + + rct(35,k)* xnew(CH3COO2 ) - xnew(CH3O2)= max(0.0, ( xold(CH3O2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(CH3O2)= ( xold(CH3O2) + dt2 * P) /(1.0 + dt2*L ) !-> C2H5O2 P = & - rct(17,k) * xnew(OH ) * xnew(C2H6 ) & - + rct(20,k) * xnew(C2H5OOH ) * xnew(OH ) & - + 0.35*rct(26,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + rct(29,k) * xnew(OH ) * xnew(C2H6 ) & + + rct(32,k) * xnew(C2H5OOH ) * xnew(OH ) & + + 0.35*rct(40,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + 0.35*rcphot(IDCH3O2H,K) * xnew(BURO2H ) & + rcphot(IDCH3COX,K) * xnew(MEK ) L = & - rct(18,k)* xnew(NO ) & - + rct(19,k)* xnew(HO2 ) + rct(30,k)* xnew(NO ) & + + rct(31,k)* xnew(HO2 ) - xnew(C2H5O2)= max(0.0, ( xold(C2H5O2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(C2H5O2)= ( xold(C2H5O2) + dt2 * P) /(1.0 + dt2*L ) !-> SECC4H9O2 P = & - rcmisc(14,k) * xnew(OH ) * xnew(NC4H10 ) & - + rct(20,k) * xnew(BURO2H ) * xnew(OH ) + rct(39,k) * xnew(OH ) * xnew(NC4H10 ) & + + rct(32,k) * xnew(BURO2H ) * xnew(OH ) L = & - rct(26,k)* xnew(NO ) & - + rct(27,k)* xnew(HO2 ) + rct(40,k)* xnew(NO ) & + + rct(41,k)* xnew(HO2 ) - xnew(SECC4H9O2)= max(0.0, ( xold(SECC4H9O2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(SECC4H9O2)= ( xold(SECC4H9O2) + dt2 * P) /(1.0 + dt2*L ) !-> ISRO2 P = & - rct(35,k) * xnew(C5H8 ) * xnew(OH ) & - + 0.12*rct(26,k) * xnew(ISRO2 ) * xnew(NO ) & + rct(51,k) * xnew(C5H8 ) * xnew(OH ) & + + 0.12*rct(40,k) * xnew(ISRO2 ) * xnew(NO ) & + 7.5e-11 * xnew(ISRO2H ) * xnew(OH ) L = & - rct(26,k)* xnew(NO ) & - + rct(32,k)* xnew(HO2 ) + rct(40,k)* xnew(NO ) & + + rct(47,k)* xnew(HO2 ) - xnew(ISRO2)= max(0.0, ( xold(ISRO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ISRO2)= ( xold(ISRO2) + dt2 * P) /(1.0 + dt2*L ) !-> ETRO2 P = & - rct(20,k) * xnew(ETRO2H ) * xnew(OH ) & - + rcmisc(26,k) * xnew(C2H4 ) * xnew(OH ) + rct(32,k) * xnew(ETRO2H ) * xnew(OH ) & + + rct(69,k) * xnew(C2H4 ) * xnew(OH ) L = & - rct(26,k)* xnew(NO ) & + rct(40,k)* xnew(NO ) & + 1.2e-11* xnew(HO2 ) - xnew(ETRO2)= max(0.0, ( xold(ETRO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ETRO2)= ( xold(ETRO2) + dt2 * P) /(1.0 + dt2*L ) !-> PRRO2 P = & - rct(20,k) * xnew(PRRO2H ) * xnew(OH ) & - + rcmisc(27,k) * xnew(OH ) * xnew(C3H6 ) + rct(32,k) * xnew(PRRO2H ) * xnew(OH ) & + + rct(70,k) * xnew(OH ) * xnew(C3H6 ) L = & - rct(26,k)* xnew(NO ) & - + rct(30,k)* xnew(HO2 ) + rct(40,k)* xnew(NO ) & + + rct(45,k)* xnew(HO2 ) - xnew(PRRO2)= max(0.0, ( xold(PRRO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(PRRO2)= ( xold(PRRO2) + dt2 * P) /(1.0 + dt2*L ) !-> OXYO2 @@ -281,313 +282,316 @@ + 4.2e-11 * xnew(OXYO2H ) * xnew(OH ) L = & - rct(26,k)* xnew(NO ) & - + rct(31,k)* xnew(HO2 ) + rct(40,k)* xnew(NO ) & + + rct(46,k)* xnew(HO2 ) - xnew(OXYO2)= max(0.0, ( xold(OXYO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(OXYO2)= ( xold(OXYO2) + dt2 * P) /(1.0 + dt2*L ) !-> MEKO2 P = & - rcmisc(15,k) * xnew(OH ) * xnew(MEK ) & - + rct(20,k) * xnew(MEKO2H ) * xnew(OH ) + rct(42,k) * xnew(OH ) * xnew(MEK ) & + + rct(32,k) * xnew(MEKO2H ) * xnew(OH ) L = & - rct(26,k)* xnew(NO ) & - + rct(27,k)* xnew(HO2 ) + rct(40,k)* xnew(NO ) & + + rct(41,k)* xnew(HO2 ) - xnew(MEKO2)= max(0.0, ( xold(MEKO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MEKO2)= ( xold(MEKO2) + dt2 * P) /(1.0 + dt2*L ) !-> MALO2 P = & 5.58e-11 * xnew(MAL ) * xnew(OH ) & - + rct(20,k) * xnew(MALO2H ) * xnew(OH ) + + rct(32,k) * xnew(MALO2H ) * xnew(OH ) L = & - rct(26,k)* xnew(NO ) & - + rct(32,k)* xnew(HO2 ) + rct(40,k)* xnew(NO ) & + + rct(47,k)* xnew(HO2 ) - xnew(MALO2)= max(0.0, ( xold(MALO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MALO2)= ( xold(MALO2) + dt2 * P) /(1.0 + dt2*L ) !-> MVKO2 P = & - rct(36,k) * xnew(MVK ) * xnew(OH ) & + rct(52,k) * xnew(MVK ) * xnew(OH ) & + 2.2e-11 * xnew(MVKO2H ) * xnew(OH ) L = & - rct(26,k)* xnew(NO ) & - + rct(27,k)* xnew(HO2 ) + rct(40,k)* xnew(NO ) & + + rct(41,k)* xnew(HO2 ) - xnew(MVKO2)= max(0.0, ( xold(MVKO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MVKO2)= ( xold(MVKO2) + dt2 * P) /(1.0 + dt2*L ) !-> MACRO2 P = & - 0.5*rct(38,k) * xnew(MACR ) * xnew(OH ) & + 0.5*rct(54,k) * xnew(MACR ) * xnew(OH ) & + 2.82e-11 * xnew(MACROOH ) * xnew(OH ) L = & - rct(39,k)* xnew(NO ) & + rct(55,k)* xnew(NO ) & + 2.5e-12* xnew(NO3 ) & - + rct(27,k)* xnew(HO2 ) + + rct(41,k)* xnew(HO2 ) - xnew(MACRO2)= max(0.0, ( xold(MACRO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MACRO2)= ( xold(MACRO2) + dt2 * P) /(1.0 + dt2*L ) !-> MACO3 P = & - 0.5*rct(38,k) * xnew(MACR ) * xnew(OH ) & + 0.5*rct(54,k) * xnew(MACR ) * xnew(OH ) & + 1.87e-11 * xnew(MACO3H ) * xnew(OH ) & - + rcmisc(29,k) * xnew(MPAN ) + + rct(68,k) * xnew(MPAN ) L = & - rct(41,k)* xnew(NO ) & - + rct(44,k)* xnew(HO2 ) & - + rcmisc(28,k)* xnew(NO2 ) + rct(57,k)* xnew(NO ) & + + rct(60,k)* xnew(HO2 ) & + + rct(67,k)* xnew(NO2 ) - xnew(MACO3)= max(0.0, ( xold(MACO3) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MACO3)= ( xold(MACO3) + dt2 * P) /(1.0 + dt2*L ) !-> O3 P = & - rcmisc(1,k) * xnew(OP ) & - + 0.15*rct(25,k) * xnew(CH3COO2 ) * xnew(HO2 ) & - + 0.29*rct(44,k) * xnew(MACO3 ) * xnew(HO2 ) + rct(1,k) * xnew(OP ) & + + 0.15*rct(37,k) * xnew(CH3COO2 ) * xnew(HO2 ) & + + 0.29*rct(60,k) * xnew(MACO3 ) * xnew(HO2 ) L = & - rct(1,k)* xnew(NO ) & - + rct(2,k)* xnew(NO2 ) & - + rct(3,k)* xnew(OH ) & - + rcmisc(5,k)* xnew(HO2 ) & + rct(5,k)* xnew(NO ) & + + rct(6,k)* xnew(NO2 ) & + + rct(7,k)* xnew(OH ) & + + rct(8,k)* xnew(HO2 ) & + AQRCK(ICLRC2,K)* xnew(SO2 ) & - + rct(28,k)* xnew(C2H4 ) & - + rct(29,k)* xnew(C3H6 ) & - + rct(34,k)* xnew(C5H8 ) & - + rct(37,k)* xnew(MACR ) & - + rct(42,k)* xnew(MVK ) & + + rct(43,k)* xnew(C2H4 ) & + + rct(44,k)* xnew(C3H6 ) & + + rct(50,k)* xnew(C5H8 ) & + + rct(53,k)* xnew(MACR ) & + + rct(58,k)* xnew(MVK ) & + rcphot(IDAO3,K) & + rcphot(IDBO3,K) - xnew(O3)= max(0.0, ( xold(O3) + dt2 * P)) /(1.0 + dt2*L ) + xnew(O3)= ( xold(O3) + dt2 * P) /(1.0 + dt2*L ) !-> NO P = & - rct(6,k) * xnew(NO2 ) * xnew(NO3 ) & + rct(11,k) * xnew(NO2 ) * xnew(NO3 ) & + rcphot(IDNO2,K) * xnew(NO2 ) & + 0.222*rcphot(IDNO2,K) * xnew(HONO ) & - + rcemis(NO,k) - - L = & - rct(1,k)* xnew(O3 ) & - + rct(4,k)* xnew(NO3 ) & - + rct(5,k)* xnew(HO2 ) & - + rct(11,k)* xnew(CH3O2 ) & - + rct(18,k)* xnew(C2H5O2 ) & - + rct(22,k)* xnew(CH3COO2 ) & - + rct(26,k)* xnew(SECC4H9O2 ) & - + rct(26,k)* xnew(MEKO2 ) & - + rct(26,k)* xnew(ETRO2 ) & - + rct(26,k)* xnew(PRRO2 ) & - + rct(26,k)* xnew(OXYO2 ) & - + rct(26,k)* xnew(MALO2 ) & - + rct(26,k)* xnew(ISRO2 ) & - + rct(26,k)* xnew(MVKO2 ) & - + rct(39,k)* xnew(MACRO2 ) & - + rct(41,k)* xnew(MACO3 ) & - + rct(26,k)* xnew(ISNIR ) & - + rct(26,k)* xnew(ISONO3 ) & - + rcmisc(20,k)* xnew(OP ) & - + rcmisc(30,k)* xnew(OH ) - - xnew(NO)= max(0.0, ( xold(NO) + dt2 * P)) /(1.0 + dt2*L ) + + rcemis(NO,k) & + + 0 !Skip bio rate since rcemis exists + + L = & + rct(5,k)* xnew(O3 ) & + + rct(9,k)* xnew(NO3 ) & + + rct(10,k)* xnew(HO2 ) & + + rct(21,k)* xnew(CH3O2 ) & + + rct(30,k)* xnew(C2H5O2 ) & + + rct(34,k)* xnew(CH3COO2 ) & + + rct(40,k)* xnew(SECC4H9O2 ) & + + rct(40,k)* xnew(MEKO2 ) & + + rct(40,k)* xnew(ETRO2 ) & + + rct(40,k)* xnew(PRRO2 ) & + + rct(40,k)* xnew(OXYO2 ) & + + rct(40,k)* xnew(MALO2 ) & + + rct(40,k)* xnew(ISRO2 ) & + + rct(40,k)* xnew(MVKO2 ) & + + rct(55,k)* xnew(MACRO2 ) & + + rct(57,k)* xnew(MACO3 ) & + + rct(40,k)* xnew(ISNIR ) & + + rct(40,k)* xnew(ISONO3 ) & + + rct(63,k)* xnew(OP ) & + + rct(71,k)* xnew(OH ) & + + rct(40,k)* xnew(TERPPEROXY ) + + xnew(NO)= ( xold(NO) + dt2 * P) /(1.0 + dt2*L ) !-> NO2 P = & - rct(1,k) * xnew(O3 ) * xnew(NO ) & - + rct(4,k) * xnew(NO ) * xnew(NO3 ) & - + rct(4,k) * xnew(NO ) * xnew(NO3 ) & - + rct(5,k) * xnew(NO ) * xnew(HO2 ) & - + rct(6,k) * xnew(NO2 ) * xnew(NO3 ) & - + rct(10,k) * xnew(OH ) * xnew(HONO ) & - + rct(11,k) * xnew(CH3O2 ) * xnew(NO ) & - + rct(18,k) * xnew(C2H5O2 ) * xnew(NO ) & - + rct(22,k) * xnew(CH3COO2 ) * xnew(NO ) & - + rct(26,k) * xnew(NO ) * xnew(SECC4H9O2 ) & - + rct(26,k) * xnew(MEKO2 ) * xnew(NO ) & - + rct(26,k) * xnew(ETRO2 ) * xnew(NO ) & - + rct(26,k) * xnew(NO ) * xnew(PRRO2 ) & - + rct(26,k) * xnew(OXYO2 ) * xnew(NO ) & - + rct(26,k) * xnew(MALO2 ) * xnew(NO ) & - + 0.86*rct(26,k) * xnew(ISRO2 ) * xnew(NO ) & - + 0.95*rct(26,k) * xnew(MVKO2 ) * xnew(NO ) & - + 0.95*rct(39,k) * xnew(MACRO2 ) * xnew(NO ) & + rct(5,k) * xnew(O3 ) * xnew(NO ) & + + rct(9,k) * xnew(NO ) * xnew(NO3 ) & + + rct(9,k) * xnew(NO ) * xnew(NO3 ) & + + rct(10,k) * xnew(NO ) * xnew(HO2 ) & + + rct(11,k) * xnew(NO2 ) * xnew(NO3 ) & + + rct(18,k) * xnew(OH ) * xnew(HONO ) & + + rct(21,k) * xnew(CH3O2 ) * xnew(NO ) & + + rct(30,k) * xnew(C2H5O2 ) * xnew(NO ) & + + rct(34,k) * xnew(CH3COO2 ) * xnew(NO ) & + + rct(40,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + + rct(40,k) * xnew(MEKO2 ) * xnew(NO ) & + + rct(40,k) * xnew(ETRO2 ) * xnew(NO ) & + + rct(40,k) * xnew(NO ) * xnew(PRRO2 ) & + + rct(40,k) * xnew(OXYO2 ) * xnew(NO ) & + + rct(40,k) * xnew(MALO2 ) * xnew(NO ) & + + 0.86*rct(40,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.95*rct(40,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.95*rct(55,k) * xnew(MACRO2 ) * xnew(NO ) & + 2.5e-12 * xnew(MACRO2 ) * xnew(NO3 ) & - + rct(41,k) * xnew(MACO3 ) * xnew(NO ) & - + 1.9*rct(26,k) * xnew(ISNIR ) * xnew(NO ) & - + 1.1*rct(26,k) * xnew(ISONO3 ) * xnew(NO ) & + + rct(57,k) * xnew(MACO3 ) * xnew(NO ) & + + 1.9*rct(40,k) * xnew(ISNIR ) * xnew(NO ) & + + 1.1*rct(40,k) * xnew(ISONO3 ) * xnew(NO ) & + 2.9e-11 * xnew(MPAN ) * xnew(OH ) & - + rcmisc(20,k) * xnew(OP ) * xnew(NO ) & - + rcmisc(22,k) * xnew(N2O5 ) & - + rcmisc(25,k) * xnew(PAN ) & - + rcmisc(29,k) * xnew(MPAN ) & + + rct(63,k) * xnew(OP ) * xnew(NO ) & + + rct(65,k) * xnew(N2O5 ) & + + rct(68,k) * xnew(PAN ) & + + rct(68,k) * xnew(MPAN ) & + rcphot(IDHNO3,K) * xnew(HNO3 ) & + rcphot(IDNO3,K) * xnew(NO3 ) & - + rcemis(NO2,k) + + rcemis(NO2,k) & + + rct(40,k) * xnew(TERPPEROXY ) * xnew(NO ) L = & - rct(2,k)* xnew(O3 ) & - + rct(6,k)* xnew(NO3 ) & - + rcmisc(21,k)* xnew(NO3 ) & - + rcmisc(23,k)* xnew(OH ) & - + rcmisc(24,k)* xnew(CH3COO2 ) & - + rcmisc(28,k)* xnew(MACO3 ) & + rct(6,k)* xnew(O3 ) & + + rct(11,k)* xnew(NO3 ) & + + rct(64,k)* xnew(NO3 ) & + + rct(66,k)* xnew(OH ) & + + rct(67,k)* xnew(CH3COO2 ) & + + rct(67,k)* xnew(MACO3 ) & + rcphot(IDNO2,K) - xnew(NO2)= max(0.0, ( xold(NO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(NO2)= ( xold(NO2) + dt2 * P) /(1.0 + dt2*L ) !-> PAN P = & - rcmisc(24,k) * xnew(CH3COO2 ) * xnew(NO2 ) + rct(67,k) * xnew(CH3COO2 ) * xnew(NO2 ) L = & - rcmisc(25,k) + rct(68,k) - xnew(PAN)= max(0.0, ( xold(PAN) + dt2 * P)) /(1.0 + dt2*L ) + xnew(PAN)= ( xold(PAN) + dt2 * P) /(1.0 + dt2*L ) !-> MPAN P = & - rcmisc(28,k) * xnew(MACO3 ) * xnew(NO2 ) + rct(67,k) * xnew(MACO3 ) * xnew(NO2 ) L = & 2.9e-11* xnew(OH ) & - + rcmisc(29,k) + + rct(68,k) - xnew(MPAN)= max(0.0, ( xold(MPAN) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MPAN)= ( xold(MPAN) + dt2 * P) /(1.0 + dt2*L ) !-> NO3 P = & - rct(2,k) * xnew(O3 ) * xnew(NO2 ) & - + rcmisc(6,k) * xnew(OH ) * xnew(HNO3 ) & - + rcmisc(22,k) * xnew(N2O5 ) + rct(6,k) * xnew(O3 ) * xnew(NO2 ) & + + rct(15,k) * xnew(OH ) * xnew(HNO3 ) & + + rct(65,k) * xnew(N2O5 ) L = & - rct(4,k)* xnew(NO ) & - + rct(6,k)* xnew(NO2 ) & - + rct(16,k)* xnew(HCHO ) & + rct(9,k)* xnew(NO ) & + + rct(11,k)* xnew(NO2 ) & + + rct(28,k)* xnew(HCHO ) & + 2.5e-12* xnew(MACRO2 ) & - + rct(43,k)* xnew(C5H8 ) & - + rcmisc(21,k)* xnew(NO2 ) & + + rct(59,k)* xnew(C5H8 ) & + + rct(64,k)* xnew(NO2 ) & + rcphot(IDNO3,K) - xnew(NO3)= max(0.0, ( xold(NO3) + dt2 * P)) /(1.0 + dt2*L ) + xnew(NO3)= ( xold(NO3) + dt2 * P) /(1.0 + dt2*L ) !-> N2O5 P = & - rcmisc(21,k) * xnew(NO2 ) * xnew(NO3 ) + rct(64,k) * xnew(NO2 ) * xnew(NO3 ) L = & - rcmisc(17,k) & - + rcmisc(22,k) + rct(61,k) & + + rct(65,k) - xnew(N2O5)= max(0.0, ( xold(N2O5) + dt2 * P)) /(1.0 + dt2*L ) + xnew(N2O5)= ( xold(N2O5) + dt2 * P) /(1.0 + dt2*L ) !-> ISONO3 P = & - rct(43,k) * xnew(C5H8 ) * xnew(NO3 ) & + rct(59,k) * xnew(C5H8 ) * xnew(NO3 ) & + 2.0e-11 * xnew(ISONO3H ) * xnew(OH ) L = & - rct(26,k)* xnew(NO ) & - + rct(32,k)* xnew(HO2 ) + rct(40,k)* xnew(NO ) & + + rct(47,k)* xnew(HO2 ) - xnew(ISONO3)= max(0.0, ( xold(ISONO3) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ISONO3)= ( xold(ISONO3) + dt2 * P) /(1.0 + dt2*L ) !-> HNO3 P = & - rct(16,k) * xnew(NO3 ) * xnew(HCHO ) & - + 2.*rcmisc(17,k) * xnew(N2O5 ) & - + rcmisc(23,k) * xnew(NO2 ) * xnew(OH ) + rct(28,k) * xnew(NO3 ) * xnew(HCHO ) & + + 2.*rct(61,k) * xnew(N2O5 ) & + + rct(66,k) * xnew(NO2 ) * xnew(OH ) L = & - rcmisc(6,k)* xnew(OH ) & - + rcmisc(19,k) & + rct(15,k)* xnew(OH ) & + + rct(62,k) & + rcphot(IDHNO3,K) - xnew(HNO3)= max(0.0, ( xold(HNO3) + dt2 * P)) /(1.0 + dt2*L ) + xnew(HNO3)= ( xold(HNO3) + dt2 * P) /(1.0 + dt2*L ) !-> HONO P = & - rcmisc(30,k) * xnew(OH ) * xnew(NO ) + rct(71,k) * xnew(OH ) * xnew(NO ) L = & - rct(10,k)* xnew(OH ) & + rct(18,k)* xnew(OH ) & + 0.222*rcphot(IDNO2,K) - xnew(HONO)= max(0.0, ( xold(HONO) + dt2 * P)) /(1.0 + dt2*L ) + xnew(HONO)= ( xold(HONO) + dt2 * P) /(1.0 + dt2*L ) !-> CH3COO2 P = & - 0.95*rct(21,k) * xnew(OH ) * xnew(CH3CHO ) & - + rct(20,k) * xnew(CH3COO2H ) * xnew(OH ) & - + rct(26,k) * xnew(MEKO2 ) * xnew(NO ) & - + rct(33,k) * xnew(OH ) * xnew(MGLYOX ) & - + 0.684*rct(26,k) * xnew(MVKO2 ) * xnew(NO ) & - + 0.41*rct(37,k) * xnew(MACR ) * xnew(O3 ) & - + rct(41,k) * xnew(MACO3 ) * xnew(NO ) & + 0.95*rct(33,k) * xnew(OH ) * xnew(CH3CHO ) & + + rct(32,k) * xnew(CH3COO2H ) * xnew(OH ) & + + rct(40,k) * xnew(MEKO2 ) * xnew(NO ) & + + rct(49,k) * xnew(OH ) * xnew(MGLYOX ) & + + 0.684*rct(40,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.41*rct(53,k) * xnew(MACR ) * xnew(O3 ) & + + rct(57,k) * xnew(MACO3 ) * xnew(NO ) & + 1.51e-11 * xnew(MACO2H ) * xnew(OH ) & - + rcmisc(25,k) * xnew(PAN ) & + + rct(68,k) * xnew(PAN ) & + rcphot(IDRCOHCO,K) * xnew(MGLYOX ) & + rcphot(IDCH3O2H,K) * xnew(MEKO2H ) & + rcphot(IDCH3COX,K) * xnew(MEK ) L = & - rct(22,k)* xnew(NO ) & - + rct(23,k)* xnew(CH3O2 ) & - + rct(24,k)* xnew(CH3COO2 ) & - + rct(24,k)* xnew(CH3COO2 ) & - + rct(25,k)* xnew(HO2 ) & - + rcmisc(24,k)* xnew(NO2 ) + rct(34,k)* xnew(NO ) & + + rct(35,k)* xnew(CH3O2 ) & + + rct(36,k)* xnew(CH3COO2 ) & + + rct(36,k)* xnew(CH3COO2 ) & + + rct(37,k)* xnew(HO2 ) & + + rct(67,k)* xnew(NO2 ) - xnew(CH3COO2)= max(0.0, ( xold(CH3COO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(CH3COO2)= ( xold(CH3COO2) + dt2 * P) /(1.0 + dt2*L ) !-> MACR P = & - 0.67*rct(34,k) * xnew(C5H8 ) * xnew(O3 ) & - + 0.32*rct(26,k) * xnew(ISRO2 ) * xnew(NO ) & - + 0.1*rct(26,k) * xnew(ISONO3 ) * xnew(NO ) + 0.67*rct(50,k) * xnew(C5H8 ) * xnew(O3 ) & + + 0.32*rct(40,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.1*rct(40,k) * xnew(ISONO3 ) * xnew(NO ) L = & - rct(37,k)* xnew(O3 ) & - + rct(38,k)* xnew(OH ) + rct(53,k)* xnew(O3 ) & + + rct(54,k)* xnew(OH ) - xnew(MACR)= max(0.0, ( xold(MACR) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MACR)= ( xold(MACR) + dt2 * P) /(1.0 + dt2*L ) !-> ISNI P = & - 0.14*rct(26,k) * xnew(ISRO2 ) * xnew(NO ) & - + 0.05*rct(26,k) * xnew(MVKO2 ) * xnew(NO ) & - + 0.05*rct(39,k) * xnew(MACRO2 ) * xnew(NO ) & - + 0.05*rct(26,k) * xnew(ISNIR ) * xnew(NO ) & - + 0.85*rct(26,k) * xnew(ISONO3 ) * xnew(NO ) + 0.14*rct(40,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.05*rct(40,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.05*rct(55,k) * xnew(MACRO2 ) * xnew(NO ) & + + 0.05*rct(40,k) * xnew(ISNIR ) * xnew(NO ) & + + 0.85*rct(40,k) * xnew(ISONO3 ) * xnew(NO ) L = & 5.96e-11* xnew(OH ) - xnew(ISNI)= max(0.0, ( xold(ISNI) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ISNI)= ( xold(ISNI) + dt2 * P) /(1.0 + dt2*L ) !-> ISNIR @@ -596,103 +600,103 @@ + 3.7e-11 * xnew(ISNIRH ) * xnew(OH ) L = & - rct(26,k)* xnew(NO ) & - + rct(32,k)* xnew(HO2 ) + rct(40,k)* xnew(NO ) & + + rct(47,k)* xnew(HO2 ) - xnew(ISNIR)= max(0.0, ( xold(ISNIR) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ISNIR)= ( xold(ISNIR) + dt2 * P) /(1.0 + dt2*L ) !-> GLYOX P = & - rct(26,k) * xnew(MALO2 ) * xnew(NO ) & + rct(40,k) * xnew(MALO2 ) * xnew(NO ) & + rcphot(IDCH3O2H,K) * xnew(MALO2H ) & + rcemis(GLYOX,k) L = & - rcmisc(16,k)* xnew(OH ) & + rct(48,k)* xnew(OH ) & + rcphot(IDHCOHCO,K) - xnew(GLYOX)= max(0.0, ( xold(GLYOX) + dt2 * P)) /(1.0 + dt2*L ) + xnew(GLYOX)= ( xold(GLYOX) + dt2 * P) /(1.0 + dt2*L ) !-> MGLYOX P = & - rct(26,k) * xnew(OXYO2 ) * xnew(NO ) & - + rct(26,k) * xnew(MALO2 ) * xnew(NO ) & - + 0.266*rct(26,k) * xnew(MVKO2 ) * xnew(NO ) & - + 0.59*rct(37,k) * xnew(MACR ) * xnew(O3 ) & - + rct(40,k) * xnew(ACETOL ) * xnew(OH ) & - + 0.82*rct(42,k) * xnew(MVK ) * xnew(O3 ) & + rct(40,k) * xnew(OXYO2 ) * xnew(NO ) & + + rct(40,k) * xnew(MALO2 ) * xnew(NO ) & + + 0.266*rct(40,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.59*rct(53,k) * xnew(MACR ) * xnew(O3 ) & + + rct(56,k) * xnew(ACETOL ) * xnew(OH ) & + + 0.82*rct(58,k) * xnew(MVK ) * xnew(O3 ) & + rcphot(IDCH3O2H,K) * xnew(OXYO2H ) & + rcphot(IDCH3O2H,K) * xnew(MALO2H ) & + rcemis(MGLYOX,k) L = & - rct(33,k)* xnew(OH ) & + rct(49,k)* xnew(OH ) & + rcphot(IDRCOHCO,K) - xnew(MGLYOX)= max(0.0, ( xold(MGLYOX) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MGLYOX)= ( xold(MGLYOX) + dt2 * P) /(1.0 + dt2*L ) !-> MAL P = & - rct(26,k) * xnew(OXYO2 ) * xnew(NO ) & + rct(40,k) * xnew(OXYO2 ) * xnew(NO ) & + rcphot(IDCH3O2H,K) * xnew(OXYO2H ) L = & 5.58e-11* xnew(OH ) - xnew(MAL)= max(0.0, ( xold(MAL) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MAL)= ( xold(MAL) + dt2 * P) /(1.0 + dt2*L ) !-> MEK P = & - 0.65*rct(26,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + 0.65*rct(40,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + 2.15e-11 * xnew(BURO2H ) * xnew(OH ) & + 0.65*rcphot(IDCH3O2H,K) * xnew(BURO2H ) & + rcemis(MEK,k) L = & - rcmisc(15,k)* xnew(OH ) & + rct(42,k)* xnew(OH ) & + rcphot(IDCH3COX,K) - xnew(MEK)= max(0.0, ( xold(MEK) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MEK)= ( xold(MEK) + dt2 * P) /(1.0 + dt2*L ) !-> MVK P = & - 0.26*rct(34,k) * xnew(C5H8 ) * xnew(O3 ) & - + 0.42*rct(26,k) * xnew(ISRO2 ) * xnew(NO ) & - + 0.05*rct(26,k) * xnew(ISONO3 ) * xnew(NO ) + 0.26*rct(50,k) * xnew(C5H8 ) * xnew(O3 ) & + + 0.42*rct(40,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.05*rct(40,k) * xnew(ISONO3 ) * xnew(NO ) L = & - rct(36,k)* xnew(OH ) & - + rct(42,k)* xnew(O3 ) + rct(52,k)* xnew(OH ) & + + rct(58,k)* xnew(O3 ) - xnew(MVK)= max(0.0, ( xold(MVK) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MVK)= ( xold(MVK) + dt2 * P) /(1.0 + dt2*L ) !-> HCHO P = & - rct(11,k) * xnew(CH3O2 ) * xnew(NO ) & - + 2.*rct(12,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & - + rct(13,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & - + rcmisc(11,k) * xnew(OH ) * xnew(CH3OH ) & - + 0.1*rct(14,k) * xnew(HO2 ) * xnew(CH3O2 ) & - + 0.4*rct(15,k) * xnew(CH3O2H ) * xnew(OH ) & - + rct(23,k) * xnew(CH3O2 ) * xnew(CH3COO2 ) & - + 2.*rct(26,k) * xnew(ETRO2 ) * xnew(NO ) & - + 1.14*rct(28,k) * xnew(C2H4 ) * xnew(O3 ) & - + 0.545*rct(29,k) * xnew(O3 ) * xnew(C3H6 ) & - + rct(26,k) * xnew(NO ) * xnew(PRRO2 ) & - + 0.8*rct(34,k) * xnew(C5H8 ) * xnew(O3 ) & - + 0.74*rct(26,k) * xnew(ISRO2 ) * xnew(NO ) & - + 0.266*rct(26,k) * xnew(MVKO2 ) * xnew(NO ) & - + 0.534*rct(37,k) * xnew(MACR ) * xnew(O3 ) & + rct(21,k) * xnew(CH3O2 ) * xnew(NO ) & + + 2.*rct(22,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & + + rct(23,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & + + rct(24,k) * xnew(OH ) * xnew(CH3OH ) & + + 0.1*rct(25,k) * xnew(HO2 ) * xnew(CH3O2 ) & + + 0.4*rct(26,k) * xnew(CH3O2H ) * xnew(OH ) & + + rct(35,k) * xnew(CH3O2 ) * xnew(CH3COO2 ) & + + 2.*rct(40,k) * xnew(ETRO2 ) * xnew(NO ) & + + 1.14*rct(43,k) * xnew(C2H4 ) * xnew(O3 ) & + + 0.545*rct(44,k) * xnew(O3 ) * xnew(C3H6 ) & + + rct(40,k) * xnew(NO ) * xnew(PRRO2 ) & + + 0.8*rct(50,k) * xnew(C5H8 ) * xnew(O3 ) & + + 0.74*rct(40,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.266*rct(40,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.534*rct(53,k) * xnew(MACR ) * xnew(O3 ) & + 2.5e-12 * xnew(MACRO2 ) * xnew(NO3 ) & - + rct(41,k) * xnew(MACO3 ) * xnew(NO ) & - + 0.8*rct(42,k) * xnew(MVK ) * xnew(O3 ) & - + 0.15*rct(26,k) * xnew(ISONO3 ) * xnew(NO ) & + + rct(57,k) * xnew(MACO3 ) * xnew(NO ) & + + 0.8*rct(58,k) * xnew(MVK ) * xnew(O3 ) & + + 0.15*rct(40,k) * xnew(ISONO3 ) * xnew(NO ) & + 1.51e-11 * xnew(MACO2H ) * xnew(OH ) & + rcphot(IDCH3O2H,K) * xnew(CH3O2H ) & + 0.1*rcphot(IDHCOHCO,K) * xnew(GLYOX ) & @@ -701,27 +705,27 @@ + rcemis(HCHO,k) L = & - rcmisc(12,k)* xnew(OH ) & - + rct(16,k)* xnew(NO3 ) & + rct(27,k)* xnew(OH ) & + + rct(28,k)* xnew(NO3 ) & + rcphot(IDACH2O,K) & + rcphot(IDBCH2O,K) - xnew(HCHO)= max(0.0, ( xold(HCHO) + dt2 * P)) /(1.0 + dt2*L ) + xnew(HCHO)= ( xold(HCHO) + dt2 * P) /(1.0 + dt2*L ) !-> CH3CHO P = & - rct(18,k) * xnew(C2H5O2 ) * xnew(NO ) & + rct(30,k) * xnew(C2H5O2 ) * xnew(NO ) & + 8.01e-12 * xnew(C2H5OOH ) * xnew(OH ) & - + rcmisc(13,k) * xnew(OH ) * xnew(C2H5OH ) & - + 0.35*rct(26,k) * xnew(NO ) * xnew(SECC4H9O2 ) & - + rct(26,k) * xnew(MEKO2 ) * xnew(NO ) & + + rct(38,k) * xnew(OH ) * xnew(C2H5OH ) & + + 0.35*rct(40,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + + rct(40,k) * xnew(MEKO2 ) * xnew(NO ) & + 1.38e-11 * xnew(ETRO2H ) * xnew(OH ) & - + 0.545*rct(29,k) * xnew(O3 ) * xnew(C3H6 ) & - + rct(26,k) * xnew(NO ) * xnew(PRRO2 ) & - + 0.684*rct(26,k) * xnew(MVKO2 ) * xnew(NO ) & - + 0.04*rct(42,k) * xnew(MVK ) * xnew(O3 ) & - + 0.95*rct(26,k) * xnew(ISNIR ) * xnew(NO ) & + + 0.545*rct(44,k) * xnew(O3 ) * xnew(C3H6 ) & + + rct(40,k) * xnew(NO ) * xnew(PRRO2 ) & + + 0.684*rct(40,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.04*rct(58,k) * xnew(MVK ) * xnew(O3 ) & + + 0.95*rct(40,k) * xnew(ISNIR ) * xnew(NO ) & + rcphot(IDCH3O2H,K) * xnew(C2H5OOH ) & + 0.22*rcphot(IDCH3O2H,K) * xnew(ETRO2H ) & + 0.35*rcphot(IDCH3O2H,K) * xnew(BURO2H ) & @@ -730,10 +734,10 @@ + rcemis(CH3CHO,k) L = & - rct(21,k)* xnew(OH ) & + rct(33,k)* xnew(OH ) & + rcphot(IDCH3CHO,K) - xnew(CH3CHO)= max(0.0, ( xold(CH3CHO) + dt2 * P)) /(1.0 + dt2*L ) + xnew(CH3CHO)= ( xold(CH3CHO) + dt2 * P) /(1.0 + dt2*L ) !-> C2H6 @@ -741,9 +745,9 @@ rcemis(C2H6,k) L = & - rct(17,k)* xnew(OH ) + rct(29,k)* xnew(OH ) - xnew(C2H6)= max(0.0, ( xold(C2H6) + dt2 * P)) /(1.0 + dt2*L ) + xnew(C2H6)= ( xold(C2H6) + dt2 * P) /(1.0 + dt2*L ) !-> NC4H10 @@ -751,9 +755,9 @@ rcemis(NC4H10,k) L = & - rcmisc(14,k)* xnew(OH ) + rct(39,k)* xnew(OH ) - xnew(NC4H10)= max(0.0, ( xold(NC4H10) + dt2 * P)) /(1.0 + dt2*L ) + xnew(NC4H10)= ( xold(NC4H10) + dt2 * P) /(1.0 + dt2*L ) !-> C2H4 @@ -761,22 +765,22 @@ rcemis(C2H4,k) L = & - rct(28,k)* xnew(O3 ) & - + rcmisc(26,k)* xnew(OH ) + rct(43,k)* xnew(O3 ) & + + rct(69,k)* xnew(OH ) - xnew(C2H4)= max(0.0, ( xold(C2H4) + dt2 * P)) /(1.0 + dt2*L ) + xnew(C2H4)= ( xold(C2H4) + dt2 * P) /(1.0 + dt2*L ) !-> C3H6 P = & - 0.07*rct(34,k) * xnew(C5H8 ) * xnew(O3 ) & + 0.07*rct(50,k) * xnew(C5H8 ) * xnew(O3 ) & + rcemis(C3H6,k) L = & - rct(29,k)* xnew(O3 ) & - + rcmisc(27,k)* xnew(OH ) + rct(44,k)* xnew(O3 ) & + + rct(70,k)* xnew(OH ) - xnew(C3H6)= max(0.0, ( xold(C3H6) + dt2 * P)) /(1.0 + dt2*L ) + xnew(C3H6)= ( xold(C3H6) + dt2 * P) /(1.0 + dt2*L ) !-> OXYL @@ -786,65 +790,68 @@ L = & 1.36e-11* xnew(OH ) - xnew(OXYL)= max(0.0, ( xold(OXYL) + dt2 * P)) /(1.0 + dt2*L ) + xnew(OXYL)= ( xold(OXYL) + dt2 * P) /(1.0 + dt2*L ) !-> C5H8 P = & rcemis(C5H8,k) & - + RCBIO(BIO_ISOP,K) + + 0 !Skip bio rate since rcemis exists L = & - rct(34,k)* xnew(O3 ) & - + rct(35,k)* xnew(OH ) & - + rct(43,k)* xnew(NO3 ) + rct(50,k)* xnew(O3 ) & + + rct(51,k)* xnew(OH ) & + + rct(59,k)* xnew(NO3 ) - xnew(C5H8)= max(0.0, ( xold(C5H8) + dt2 * P)) /(1.0 + dt2*L ) + xnew(C5H8)= ( xold(C5H8) + dt2 * P) /(1.0 + dt2*L ) !-> APINENE P = & - RCBIO(BIO_TERP,K) - ! L = 0.0 - + rcemis(APINENE,k) + + L = & + rct(72,k)*xnew(O3) & + + rct(73,k)*xnew(OH) & + + rct(74,k)*xnew(NO3) - xnew(APINENE)= max(0.0, xold(APINENE) + dt2 * P) + xnew(APINENE)= ( xold(APINENE) + dt2 * P) /(1.0 + dt2*L ) !-> CH3O2H P = & - 0.9*rct(14,k) * xnew(HO2 ) * xnew(CH3O2 ) + 0.9*rct(25,k) * xnew(HO2 ) * xnew(CH3O2 ) L = & - rct(15,k)* xnew(OH ) & + rct(26,k)* xnew(OH ) & + 1.0e-5 & + rcphot(IDCH3O2H,K) - xnew(CH3O2H)= max(0.0, ( xold(CH3O2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(CH3O2H)= ( xold(CH3O2H) + dt2 * P) /(1.0 + dt2*L ) !-> C2H5OOH P = & - rct(19,k) * xnew(C2H5O2 ) * xnew(HO2 ) + rct(31,k) * xnew(C2H5O2 ) * xnew(HO2 ) L = & 8.01e-12* xnew(OH ) & - + rct(20,k)* xnew(OH ) & + + rct(32,k)* xnew(OH ) & + rcphot(IDCH3O2H,K) - xnew(C2H5OOH)= max(0.0, ( xold(C2H5OOH) + dt2 * P)) /(1.0 + dt2*L ) + xnew(C2H5OOH)= ( xold(C2H5OOH) + dt2 * P) /(1.0 + dt2*L ) !-> BURO2H P = & - rct(27,k) * xnew(SECC4H9O2 ) * xnew(HO2 ) + 0.95*rct(41,k) * xnew(SECC4H9O2 ) * xnew(HO2 ) L = & - rct(20,k)* xnew(OH ) & + rct(32,k)* xnew(OH ) & + 2.15e-11* xnew(OH ) & + rcphot(IDCH3O2H,K) - xnew(BURO2H)= max(0.0, ( xold(BURO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(BURO2H)= ( xold(BURO2H) + dt2 * P) /(1.0 + dt2*L ) !-> ETRO2H @@ -853,164 +860,164 @@ L = & 1.38e-11* xnew(OH ) & - + rct(20,k)* xnew(OH ) & + + rct(32,k)* xnew(OH ) & + rcphot(IDCH3O2H,K) - xnew(ETRO2H)= max(0.0, ( xold(ETRO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ETRO2H)= ( xold(ETRO2H) + dt2 * P) /(1.0 + dt2*L ) !-> PRRO2H P = & - rct(30,k) * xnew(PRRO2 ) * xnew(HO2 ) + 0.795*rct(45,k) * xnew(PRRO2 ) * xnew(HO2 ) L = & 2.44e-11* xnew(OH ) & - + rct(20,k)* xnew(OH ) & + + rct(32,k)* xnew(OH ) & + rcphot(IDCH3O2H,K) - xnew(PRRO2H)= max(0.0, ( xold(PRRO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(PRRO2H)= ( xold(PRRO2H) + dt2 * P) /(1.0 + dt2*L ) !-> OXYO2H P = & - rct(31,k) * xnew(OXYO2 ) * xnew(HO2 ) + 0.33*rct(46,k) * xnew(OXYO2 ) * xnew(HO2 ) L = & 4.2e-11* xnew(OH ) & + rcphot(IDCH3O2H,K) - xnew(OXYO2H)= max(0.0, ( xold(OXYO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(OXYO2H)= ( xold(OXYO2H) + dt2 * P) /(1.0 + dt2*L ) !-> MEKO2H P = & - rct(27,k) * xnew(MEKO2 ) * xnew(HO2 ) + rct(41,k) * xnew(MEKO2 ) * xnew(HO2 ) L = & - rct(20,k)* xnew(OH ) & + rct(32,k)* xnew(OH ) & + rcphot(IDCH3O2H,K) - xnew(MEKO2H)= max(0.0, ( xold(MEKO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MEKO2H)= ( xold(MEKO2H) + dt2 * P) /(1.0 + dt2*L ) !-> MALO2H P = & - rct(32,k) * xnew(MALO2 ) * xnew(HO2 ) + rct(47,k) * xnew(MALO2 ) * xnew(HO2 ) L = & - rct(20,k)* xnew(OH ) & + rct(32,k)* xnew(OH ) & + rcphot(IDCH3O2H,K) - xnew(MALO2H)= max(0.0, ( xold(MALO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MALO2H)= ( xold(MALO2H) + dt2 * P) /(1.0 + dt2*L ) !-> MVKO2H P = & - rct(27,k) * xnew(MVKO2 ) * xnew(HO2 ) + rct(41,k) * xnew(MVKO2 ) * xnew(HO2 ) L = & 2.2e-11* xnew(OH ) - xnew(MVKO2H)= max(0.0, ( xold(MVKO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MVKO2H)= ( xold(MVKO2H) + dt2 * P) /(1.0 + dt2*L ) !-> MACROOH P = & - rct(27,k) * xnew(MACRO2 ) * xnew(HO2 ) + rct(41,k) * xnew(MACRO2 ) * xnew(HO2 ) L = & 2.82e-11* xnew(OH ) - xnew(MACROOH)= max(0.0, ( xold(MACROOH) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MACROOH)= ( xold(MACROOH) + dt2 * P) /(1.0 + dt2*L ) !-> MACO3H P = & - 0.71*rct(44,k) * xnew(MACO3 ) * xnew(HO2 ) + 0.71*rct(60,k) * xnew(MACO3 ) * xnew(HO2 ) L = & 1.87e-11* xnew(OH ) - xnew(MACO3H)= max(0.0, ( xold(MACO3H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MACO3H)= ( xold(MACO3H) + dt2 * P) /(1.0 + dt2*L ) !-> MACO2H P = & - 0.29*rct(44,k) * xnew(MACO3 ) * xnew(HO2 ) + 0.29*rct(60,k) * xnew(MACO3 ) * xnew(HO2 ) L = & 1.51e-11* xnew(OH ) - xnew(MACO2H)= max(0.0, ( xold(MACO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(MACO2H)= ( xold(MACO2H) + dt2 * P) /(1.0 + dt2*L ) !-> ISRO2H P = & - rct(32,k) * xnew(ISRO2 ) * xnew(HO2 ) + 0.97*rct(47,k) * xnew(ISRO2 ) * xnew(HO2 ) L = & 7.5e-11* xnew(OH ) - xnew(ISRO2H)= max(0.0, ( xold(ISRO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ISRO2H)= ( xold(ISRO2H) + dt2 * P) /(1.0 + dt2*L ) !-> H2O2 P = & - rcmisc(7,k) * xnew(HO2 ) * xnew(HO2 ) & - + rcmisc(8,k) * xnew(HO2 ) * xnew(HO2 ) & - + 0.14*rct(28,k) * xnew(C2H4 ) * xnew(O3 ) & - + 0.09*rct(29,k) * xnew(O3 ) * xnew(C3H6 ) & - + 0.124*rct(37,k) * xnew(MACR ) * xnew(O3 ) + rct(16,k) * xnew(HO2 ) * xnew(HO2 ) & + + rct(17,k) * xnew(HO2 ) * xnew(HO2 ) & + + 0.14*rct(43,k) * xnew(C2H4 ) * xnew(O3 ) & + + 0.09*rct(44,k) * xnew(O3 ) * xnew(C3H6 ) & + + 0.124*rct(53,k) * xnew(MACR ) * xnew(O3 ) L = & - rct(8,k)* xnew(OH ) & + rct(13,k)* xnew(OH ) & + AQRCK(ICLRC1,K)* xnew(SO2 ) & + 1.0e-5 & + rcphot(IDH2O2,K) - xnew(H2O2)= max(0.0, ( xold(H2O2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(H2O2)= ( xold(H2O2) + dt2 * P) /(1.0 + dt2*L ) !-> CH3COO2H P = & - 0.41*rct(25,k) * xnew(CH3COO2 ) * xnew(HO2 ) + 0.41*rct(37,k) * xnew(CH3COO2 ) * xnew(HO2 ) L = & - rct(20,k)* xnew(OH ) & + rct(32,k)* xnew(OH ) & + rcphot(IDCH3O2H,K) - xnew(CH3COO2H)= max(0.0, ( xold(CH3COO2H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(CH3COO2H)= ( xold(CH3COO2H) + dt2 * P) /(1.0 + dt2*L ) !-> ISONO3H P = & - rct(32,k) * xnew(ISONO3 ) * xnew(HO2 ) + rct(47,k) * xnew(ISONO3 ) * xnew(HO2 ) L = & 2.0e-11* xnew(OH ) - xnew(ISONO3H)= max(0.0, ( xold(ISONO3H) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ISONO3H)= ( xold(ISONO3H) + dt2 * P) /(1.0 + dt2*L ) !-> ISNIRH P = & - rct(32,k) * xnew(ISNIR ) * xnew(HO2 ) + rct(47,k) * xnew(ISNIR ) * xnew(HO2 ) L = & 3.7e-11* xnew(OH ) - xnew(ISNIRH)= max(0.0, ( xold(ISNIRH) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ISNIRH)= ( xold(ISNIRH) + dt2 * P) /(1.0 + dt2*L ) !-> CH3OH P = & - rct(13,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & + rct(23,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & + rcemis(CH3OH,k) L = & - rcmisc(11,k)* xnew(OH ) + rct(24,k)* xnew(OH ) - xnew(CH3OH)= max(0.0, ( xold(CH3OH) + dt2 * P)) /(1.0 + dt2*L ) + xnew(CH3OH)= ( xold(CH3OH) + dt2 * P) /(1.0 + dt2*L ) !-> C2H5OH @@ -1018,23 +1025,23 @@ rcemis(C2H5OH,k) L = & - rcmisc(13,k)* xnew(OH ) + rct(38,k)* xnew(OH ) - xnew(C2H5OH)= max(0.0, ( xold(C2H5OH) + dt2 * P)) /(1.0 + dt2*L ) + xnew(C2H5OH)= ( xold(C2H5OH) + dt2 * P) /(1.0 + dt2*L ) !-> ACETOL P = & 2.44e-11 * xnew(PRRO2H ) * xnew(OH ) & - + 0.95*rct(39,k) * xnew(MACRO2 ) * xnew(NO ) & + + 0.95*rct(55,k) * xnew(MACRO2 ) * xnew(NO ) & + 2.5e-12 * xnew(MACRO2 ) * xnew(NO3 ) & - + 0.95*rct(26,k) * xnew(ISNIR ) * xnew(NO ) & + + 0.95*rct(40,k) * xnew(ISNIR ) * xnew(NO ) & + 2.9e-11 * xnew(MPAN ) * xnew(OH ) L = & - rct(40,k)* xnew(OH ) + rct(56,k)* xnew(OH ) - xnew(ACETOL)= max(0.0, ( xold(ACETOL) + dt2 * P)) /(1.0 + dt2*L ) + xnew(ACETOL)= ( xold(ACETOL) + dt2 * P) /(1.0 + dt2*L ) !-> H2 @@ -1042,25 +1049,25 @@ rcphot(IDBCH2O,K) * xnew(HCHO ) L = & - rct(9,k)* xnew(OH ) + rct(14,k)* xnew(OH ) - xnew(H2)= max(0.0, ( xold(H2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(H2)= ( xold(H2) + dt2 * P) /(1.0 + dt2*L ) !-> CO P = & - rcmisc(12,k) * xnew(OH ) * xnew(HCHO ) & - + rct(16,k) * xnew(NO3 ) * xnew(HCHO ) & - + 0.05*rct(21,k) * xnew(OH ) * xnew(CH3CHO ) & - + 0.63*rct(28,k) * xnew(C2H4 ) * xnew(O3 ) & - + 0.56*rct(29,k) * xnew(O3 ) * xnew(C3H6 ) & - + rcmisc(16,k) * xnew(OH ) * xnew(GLYOX ) & - + rcmisc(16,k) * xnew(OH ) * xnew(GLYOX ) & - + rct(33,k) * xnew(OH ) * xnew(MGLYOX ) & - + 0.05*rct(34,k) * xnew(C5H8 ) * xnew(O3 ) & - + 0.82*rct(37,k) * xnew(MACR ) * xnew(O3 ) & - + 0.95*rct(39,k) * xnew(MACRO2 ) * xnew(NO ) & - + 0.05*rct(42,k) * xnew(MVK ) * xnew(O3 ) & + rct(27,k) * xnew(OH ) * xnew(HCHO ) & + + rct(28,k) * xnew(NO3 ) * xnew(HCHO ) & + + 0.05*rct(33,k) * xnew(OH ) * xnew(CH3CHO ) & + + 0.63*rct(43,k) * xnew(C2H4 ) * xnew(O3 ) & + + 0.56*rct(44,k) * xnew(O3 ) * xnew(C3H6 ) & + + rct(48,k) * xnew(OH ) * xnew(GLYOX ) & + + rct(48,k) * xnew(OH ) * xnew(GLYOX ) & + + rct(49,k) * xnew(OH ) * xnew(MGLYOX ) & + + 0.05*rct(50,k) * xnew(C5H8 ) * xnew(O3 ) & + + 0.82*rct(53,k) * xnew(MACR ) * xnew(O3 ) & + + 0.95*rct(55,k) * xnew(MACRO2 ) * xnew(NO ) & + + 0.05*rct(58,k) * xnew(MVK ) * xnew(O3 ) & + 2.9e-11 * xnew(MPAN ) * xnew(OH ) & + rcphot(IDACH2O,K) * xnew(HCHO ) & + rcphot(IDBCH2O,K) * xnew(HCHO ) & @@ -1070,19 +1077,19 @@ + rcemis(CO,k) L = & - rcmisc(10,k)* xnew(OH ) + rct(20,k)* xnew(OH ) - xnew(CO)= max(0.0, ( xold(CO) + dt2 * P)) /(1.0 + dt2*L ) + xnew(CO)= ( xold(CO) + dt2 * P) /(1.0 + dt2*L ) !-> CH4 P = & - 0.1*rct(29,k) * xnew(O3 ) * xnew(C3H6 ) + 0.1*rct(44,k) * xnew(O3 ) * xnew(C3H6 ) L = & - rcmisc(9,k)* xnew(OH ) + rct(19,k)* xnew(OH ) - xnew(CH4)= max(0.0, ( xold(CH4) + dt2 * P)) /(1.0 + dt2*L ) + xnew(CH4)= ( xold(CH4) + dt2 * P) /(1.0 + dt2*L ) !-> SO2 @@ -1095,4 +1102,4 @@ + AQRCK(ICLRC2,K)* xnew(O3 ) & + AQRCK(ICLRC3,K) - xnew(SO2)= max(0.0, ( xold(SO2) + dt2 * P)) /(1.0 + dt2*L ) + xnew(SO2)= ( xold(SO2) + dt2 * P) /(1.0 + dt2*L ) diff --git a/CM_Reactions2.inc b/CM_Reactions2.inc index ddbb0d5..2979de2 100644 --- a/CM_Reactions2.inc +++ b/CM_Reactions2.inc @@ -10,7 +10,7 @@ ! L = 0.0 - xnew(SO4)= max(0.0, xold(SO4) + dt2 * P) + xnew(SO4)= xold(SO4) + dt2 * P !-> NH3 @@ -19,7 +19,7 @@ ! L = 0.0 - xnew(NH3)= max(0.0, xold(NH3) + dt2 * P) + xnew(NH3)= xold(NH3) + dt2 * P !-> NO3_F ! P = 0.0 @@ -31,11 +31,11 @@ !-> NO3_C P = & - rcmisc(19,k) * xnew(HNO3 ) + rct(62,k) * xnew(HNO3 ) ! L = 0.0 - xnew(NO3_C)= max(0.0, xold(NO3_C) + dt2 * P) + xnew(NO3_C)= xold(NO3_C) + dt2 * P !-> NH4_F ! P = 0.0 @@ -44,90 +44,682 @@ !Nothing to do for NH4_F! xnew(NH4_F)= max(0.0, xold(NH4_F)) -!-> PPM25 +!-> V1702A02B_F P = & - rcemis(PPM25,k) + rcemis(V1702A02B_F,k) ! L = 0.0 - xnew(PPM25)= max(0.0, xold(PPM25) + dt2 * P) + xnew(V1702A02B_F)= xold(V1702A02B_F) + dt2 * P -!-> PPM25_FIRE +!-> V1702A02B_C P = & - rcemis(PPM25_FIRE,k) + rcemis(V1702A02B_C,k) ! L = 0.0 - xnew(PPM25_FIRE)= max(0.0, xold(PPM25_FIRE) + dt2 * P) + xnew(V1702A02B_C)= xold(V1702A02B_C) + dt2 * P -!-> PPM_C +!-> GAS_ASOA_OC + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for GAS_ASOA_OC! xnew(GAS_ASOA_OC)= max(0.0, xold(GAS_ASOA_OC)) + +!-> PART_ASOA_OC + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_ASOA_OC! xnew(PART_ASOA_OC)= max(0.0, xold(PART_ASOA_OC)) + +!-> PART_ASOA_OM + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_ASOA_OM! xnew(PART_ASOA_OM)= max(0.0, xold(PART_ASOA_OM)) + +!-> GAS_BSOA_OC + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for GAS_BSOA_OC! xnew(GAS_BSOA_OC)= max(0.0, xold(GAS_BSOA_OC)) + +!-> PART_BSOA_OC + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_BSOA_OC! xnew(PART_BSOA_OC)= max(0.0, xold(PART_BSOA_OC)) + +!-> PART_BSOA_OM + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_BSOA_OM! xnew(PART_BSOA_OM)= max(0.0, xold(PART_BSOA_OM)) + +!-> PART_FFUELOA25_OC + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_FFUELOA25_OC! xnew(PART_FFUELOA25_OC)= max(0.0, xold(PART_FFUELOA25_OC)) + +!-> PART_FFUELOA25_OM + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_FFUELOA25_OM! xnew(PART_FFUELOA25_OM)= max(0.0, xold(PART_FFUELOA25_OM)) + +!-> PART_WOODOA25_OC + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_WOODOA25_OC! xnew(PART_WOODOA25_OC)= max(0.0, xold(PART_WOODOA25_OC)) + +!-> PART_WOODOA25_OM + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_WOODOA25_OM! xnew(PART_WOODOA25_OM)= max(0.0, xold(PART_WOODOA25_OM)) + +!-> PART_FFIREOA25_OC + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_FFIREOA25_OC! xnew(PART_FFIREOA25_OC)= max(0.0, xold(PART_FFIREOA25_OC)) + +!-> PART_FFIREOA25_OM + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_FFIREOA25_OM! xnew(PART_FFIREOA25_OM)= max(0.0, xold(PART_FFIREOA25_OM)) + +!-> PART_OC10 + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_OC10! xnew(PART_OC10)= max(0.0, xold(PART_OC10)) + +!-> PART_OC25 + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_OC25! xnew(PART_OC25)= max(0.0, xold(PART_OC25)) + +!-> NONVOL_FFUELOC25 + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for NONVOL_FFUELOC25! xnew(NONVOL_FFUELOC25)= max(0.0, xold(NONVOL_FFUELOC25)) + +!-> NONV_FFUELOC_COARSE + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for NONV_FFUELOC_COARSE! xnew(NONV_FFUELOC_COARSE)= max(0.0, xold(NONV_FFUELOC_COARSE)) + +!-> NONVOL_WOODOC25 + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for NONVOL_WOODOC25! xnew(NONVOL_WOODOC25)= max(0.0, xold(NONVOL_WOODOC25)) + +!-> NONVOL_BGNDOC + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for NONVOL_BGNDOC! xnew(NONVOL_BGNDOC)= max(0.0, xold(NONVOL_BGNDOC)) + +!-> NONVOL_FFIREOC25 + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for NONVOL_FFIREOC25! xnew(NONVOL_FFIREOC25)= max(0.0, xold(NONVOL_FFIREOC25)) + +!-> PART_OM_F + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for PART_OM_F! xnew(PART_OM_F)= max(0.0, xold(PART_OM_F)) + +!-> POM_F_WOOD + + P = & + rcemis(POM_F_WOOD,k) + ! L = 0.0 + + + xnew(POM_F_WOOD)= xold(POM_F_WOOD) + dt2 * P + +!-> POM_F_FFUEL + + P = & + rcemis(POM_F_FFUEL,k) + ! L = 0.0 + + + xnew(POM_F_FFUEL)= xold(POM_F_FFUEL) + dt2 * P + +!-> POM_C_FFUEL + + P = & + rcemis(POM_C_FFUEL,k) + ! L = 0.0 + + + xnew(POM_C_FFUEL)= xold(POM_C_FFUEL) + dt2 * P + +!-> EC_F_WOOD_NEW + + P = & + rcemis(EC_F_WOOD_NEW,k) + + L = & + rct(92,k) + + xnew(EC_F_WOOD_NEW)= ( xold(EC_F_WOOD_NEW) + dt2 * P) /(1.0 + dt2*L ) + +!-> EC_F_WOOD_AGE P = & - rcemis(PPM_C,k) + rcemis(EC_F_WOOD_AGE,k) & + + rct(92,k) * xnew(EC_F_WOOD_NEW ) ! L = 0.0 - xnew(PPM_C)= max(0.0, xold(PPM_C) + dt2 * P) + xnew(EC_F_WOOD_AGE)= xold(EC_F_WOOD_AGE) + dt2 * P + +!-> EC_C_WOOD + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for EC_C_WOOD! xnew(EC_C_WOOD)= max(0.0, xold(EC_C_WOOD)) + +!-> EC_F_FFUEL_NEW + + P = & + rcemis(EC_F_FFUEL_NEW,k) + + L = & + rct(93,k) + + xnew(EC_F_FFUEL_NEW)= ( xold(EC_F_FFUEL_NEW) + dt2 * P) /(1.0 + dt2*L ) + +!-> EC_F_FFUEL_AGE + + P = & + rcemis(EC_F_FFUEL_AGE,k) & + + rct(93,k) * xnew(EC_F_FFUEL_NEW ) + ! L = 0.0 + + + xnew(EC_F_FFUEL_AGE)= xold(EC_F_FFUEL_AGE) + dt2 * P + +!-> EC_C_FFUEL + + P = & + rcemis(EC_C_FFUEL,k) + ! L = 0.0 + + + xnew(EC_C_FFUEL)= xold(EC_C_FFUEL) + dt2 * P + +!-> REMPPM25 + + P = & + rcemis(REMPPM25,k) + ! L = 0.0 + + + xnew(REMPPM25)= xold(REMPPM25) + dt2 * P + +!-> REMPPM_C + + P = & + rcemis(REMPPM_C,k) + ! L = 0.0 + + + xnew(REMPPM_C)= xold(REMPPM_C) + dt2 * P + +!-> FFIRE_OM + + P = & + rcemis(FFIRE_OM,k) + ! L = 0.0 + + + xnew(FFIRE_OM)= xold(FFIRE_OM) + dt2 * P + +!-> FFIRE_BC + + P = & + rcemis(FFIRE_BC,k) + ! L = 0.0 + + + xnew(FFIRE_BC)= xold(FFIRE_BC) + dt2 * P + +!-> FFIRE_REMPPM25 + + P = & + rcemis(FFIRE_REMPPM25,k) + ! L = 0.0 + + + xnew(FFIRE_REMPPM25)= xold(FFIRE_REMPPM25) + dt2 * P + +!-> TERPPEROXY + + P = & + rct(72,k)*xnew(O3) * xnew(APINENE ) & + + rct(73,k)*xnew(OH) * xnew(APINENE ) & + + rct(74,k)*xnew(NO3) * xnew(APINENE ) + + L = & + rct(40,k)* xnew(NO ) & + + rct(75,k)* xnew(HO2 ) + + xnew(TERPPEROXY)= ( xold(TERPPEROXY) + dt2 * P) /(1.0 + dt2*L ) + +!-> ASOC_NG100 + + P = & + rct(76,k)*xnew(OH) * xnew(ASOC_UG1 ) + ! L = 0.0 + + + xnew(ASOC_NG100)= xold(ASOC_NG100) + dt2 * P + +!-> ASOC_UG1 + + P = & + 0.00206*rct(40,k)*xnew(NO)*xnew(PRRO2) & + + 0.010294*rct(45,k)*xnew(PRRO2)*xnew(HO2) & + + 0.008413*rct(40,k)*xnew(OXYO2)*xnew(NO) & + + 0.315476*rct(46,k)*xnew(OXYO2)*xnew(HO2) & + + rct(77,k)*xnew(OH) * xnew(ASOC_UG10 ) + + L = & + rct(76,k)*xnew(OH) + + xnew(ASOC_UG1)= ( xold(ASOC_UG1) + dt2 * P) /(1.0 + dt2*L ) + +!-> ASOC_UG10 + + P = & + 0.108*rct(40,k)*xnew(NO)*xnew(SECC4H9O2) & + + 0.2132*rct(41,k)*xnew(SECC4H9O2)*xnew(HO2) & + + 0.01029*rct(40,k)*xnew(NO)*xnew(PRRO2) & + + 0.018529*rct(45,k)*xnew(PRRO2)*xnew(HO2) & + + 0.820238*rct(40,k)*xnew(OXYO2)*xnew(NO) & + + 1.261905*rct(46,k)*xnew(OXYO2)*xnew(HO2) & + + rct(78,k)*xnew(OH) * xnew(ASOC_UG1E2 ) + + L = & + rct(77,k)*xnew(OH) + + xnew(ASOC_UG10)= ( xold(ASOC_UG10) + dt2 * P) /(1.0 + dt2*L ) + +!-> ASOC_UG1E2 + + P = & + 0.078235*rct(40,k)*xnew(NO)*xnew(PRRO2) & + + 0.123529*rct(45,k)*xnew(PRRO2)*xnew(HO2) & + + 1.261905*rct(40,k)*xnew(OXYO2)*xnew(NO) & + + 1.577381*rct(46,k)*xnew(OXYO2)*xnew(HO2) & + + rct(79,k)*xnew(OH) * xnew(ASOC_UG1E3 ) + + L = & + rct(78,k)*xnew(OH) + + xnew(ASOC_UG1E2)= ( xold(ASOC_UG1E2) + dt2 * P) /(1.0 + dt2*L ) + +!-> ASOC_UG1E3 + + P = & + 0.30882*rct(40,k)*xnew(NO)*xnew(PRRO2) & + + 0.463235*rct(45,k)*xnew(PRRO2)*xnew(HO2) & + + 1.829762*rct(40,k)*xnew(OXYO2)*xnew(NO) & + + 2.208333*rct(46,k)*xnew(OXYO2)*xnew(HO2) + + L = & + rct(79,k)*xnew(OH) + + xnew(ASOC_UG1E3)= ( xold(ASOC_UG1E3) + dt2 * P) /(1.0 + dt2*L ) + +!-> NON_C_ASOA_NG100 + + P = & + 0.9*rct(76,k)*xnew(OH) * xnew(ASOC_UG1 ) & + + 1.075*rct(80,k)*xnew(OH) * xnew(NON_C_ASOA_UG1 ) + ! L = 0.0 + + + xnew(NON_C_ASOA_NG100)= xold(NON_C_ASOA_NG100) + dt2 * P + +!-> NON_C_ASOA_UG1 + + P = & + 0.0173*rct(40,k)*xnew(NO)*xnew(PRRO2) & + + 0.08647*rct(45,k)*xnew(PRRO2)*xnew(HO2) & + + 0.11105*rct(40,k)*xnew(OXYO2)*xnew(NO) & + + 4.16429*rct(46,k)*xnew(OXYO2)*xnew(HO2) & + + 0.9*rct(77,k)*xnew(OH) * xnew(ASOC_UG10 ) & + + 1.075*rct(81,k)*xnew(OH) * xnew(NON_C_ASOA_UG10 ) + + L = & + rct(80,k)*xnew(OH) + + xnew(NON_C_ASOA_UG1)= ( xold(NON_C_ASOA_UG1) + dt2 * P) /(1.0 + dt2*L ) + +!-> NON_C_ASOA_UG10 + + P = & + 0.90753*rct(40,k)*xnew(NO)*xnew(SECC4H9O2) & + + 1.7912*rct(41,k)*xnew(SECC4H9O2)*xnew(HO2) & + + 0.08647*rct(40,k)*xnew(NO)*xnew(PRRO2) & + + 0.15565*rct(45,k)*xnew(PRRO2)*xnew(HO2) & + + 10.8271*rct(40,k)*xnew(OXYO2)*xnew(NO) & + + 16.6571*rct(46,k)*xnew(OXYO2)*xnew(HO2) & + + 0.9*rct(78,k)*xnew(OH) * xnew(ASOC_UG1E2 ) & + + 1.075*rct(82,k)*xnew(OH) * xnew(NON_C_ASOA_UG1E2 ) + + L = & + rct(81,k)*xnew(OH) + + xnew(NON_C_ASOA_UG10)= ( xold(NON_C_ASOA_UG10) + dt2 * P) /(1.0 + dt2*L ) + +!-> NON_C_ASOA_UG1E2 + + P = & + 0.65718*rct(40,k)*xnew(NO)*xnew(PRRO2) & + + 1.03765*rct(45,k)*xnew(PRRO2)*xnew(HO2) & + + 16.6571*rct(40,k)*xnew(OXYO2)*xnew(NO) & + + 20.82143*rct(46,k)*xnew(OXYO2)*xnew(HO2) & + + 0.9*rct(79,k)*xnew(OH) * xnew(ASOC_UG1E3 ) & + + 1.075*rct(83,k)*xnew(OH) * xnew(NON_C_ASOA_UG1E3 ) + + L = & + rct(82,k)*xnew(OH) + + xnew(NON_C_ASOA_UG1E2)= ( xold(NON_C_ASOA_UG1E2) + dt2 * P) /(1.0 + dt2*L ) + +!-> NON_C_ASOA_UG1E3 + + P = & + 2.59412*rct(40,k)*xnew(NO)*xnew(PRRO2) & + + 3.89118*rct(45,k)*xnew(PRRO2)*xnew(HO2) & + + 24.15286*rct(40,k)*xnew(OXYO2)*xnew(NO) & + + 29.15*rct(46,k)*xnew(OXYO2)*xnew(HO2) + + L = & + rct(83,k)*xnew(OH) + + xnew(NON_C_ASOA_UG1E3)= ( xold(NON_C_ASOA_UG1E3) + dt2 * P) /(1.0 + dt2*L ) + +!-> BSOC_NG100 + + P = & + rct(84,k)*xnew(OH) * xnew(BSOC_UG1 ) + ! L = 0.0 + + + xnew(BSOC_NG100)= xold(BSOC_NG100) + dt2 * P + +!-> BSOC_UG1 + + P = & + 0.002833*rct(40,k)*xnew(ISRO2)*xnew(NO) & + + 0.0255*rct(47,k)*xnew(ISRO2)*xnew(HO2) & + + 0.08*rct(40,k) * xnew(TERPPEROXY ) * xnew(NO ) & + + 0.715333*rct(75,k) * xnew(TERPPEROXY ) * xnew(HO2 ) & + + rct(85,k)*xnew(OH) * xnew(BSOC_UG10 ) + + L = & + rct(84,k)*xnew(OH) + + xnew(BSOC_UG1)= ( xold(BSOC_UG1) + dt2 * P) /(1.0 + dt2*L ) + +!-> BSOC_UG10 + + P = & + 0.065167*rct(40,k)*xnew(ISRO2)*xnew(NO) & + + 0.085*rct(47,k)*xnew(ISRO2)*xnew(HO2) & + + 0.813333*rct(40,k) * xnew(TERPPEROXY ) * xnew(NO ) & + + 0.612*rct(75,k) * xnew(TERPPEROXY ) * xnew(HO2 ) & + + rct(86,k)*xnew(OH) * xnew(BSOC_UG1E2 ) + + L = & + rct(85,k)*xnew(OH) + + xnew(BSOC_UG10)= ( xold(BSOC_UG10) + dt2 * P) /(1.0 + dt2*L ) + +!-> BSOC_UG1E2 + + P = & + 0.0425*rct(40,k)*xnew(ISRO2)*xnew(NO) & + + 0.0425*rct(47,k)*xnew(ISRO2)*xnew(HO2) & + + 1.34*rct(40,k) * xnew(TERPPEROXY ) * xnew(NO ) & + + 2.391333*rct(75,k) * xnew(TERPPEROXY ) * xnew(HO2 ) & + + rct(87,k)*xnew(OH) * xnew(BSOC_UG1E3 ) + + L = & + rct(86,k)*xnew(OH) + + xnew(BSOC_UG1E2)= ( xold(BSOC_UG1E2) + dt2 * P) /(1.0 + dt2*L ) + +!-> BSOC_UG1E3 + + P = & + 3.333333*rct(40,k) * xnew(TERPPEROXY ) * xnew(NO ) & + + 4.05*rct(75,k) * xnew(TERPPEROXY ) * xnew(HO2 ) + + L = & + rct(87,k)*xnew(OH) + + xnew(BSOC_UG1E3)= ( xold(BSOC_UG1E3) + dt2 * P) /(1.0 + dt2*L ) + +!-> NON_C_BSOA_NG100 + + P = & + 0.9*rct(84,k)*xnew(OH) * xnew(BSOC_UG1 ) & + + 1.075*rct(88,k)*xnew(OH) * xnew(NON_C_BSOA_UG1 ) + ! L = 0.0 + + + xnew(NON_C_BSOA_NG100)= xold(NON_C_BSOA_NG100) + dt2 * P + +!-> NON_C_BSOA_UG1 + + P = & + 0.034*rct(40,k)*xnew(ISRO2)*xnew(NO) & + + 0.306*rct(47,k)*xnew(ISRO2)*xnew(HO2) & + + 0.672*rct(40,k) * xnew(TERPPEROXY ) * xnew(NO ) & + + 6.009*rct(75,k) * xnew(TERPPEROXY ) * xnew(HO2 ) & + + 0.9*rct(85,k)*xnew(OH) * xnew(BSOC_UG10 ) & + + 1.075*rct(89,k)*xnew(OH) * xnew(NON_C_BSOA_UG10 ) + + L = & + rct(88,k)*xnew(OH) + + xnew(NON_C_BSOA_UG1)= ( xold(NON_C_BSOA_UG1) + dt2 * P) /(1.0 + dt2*L ) + +!-> NON_C_BSOA_UG10 + + P = & + 0.782*rct(40,k)*xnew(ISRO2)*xnew(NO) & + + 1.02*rct(47,k)*xnew(ISRO2)*xnew(HO2) & + + 6.832*rct(40,k) * xnew(TERPPEROXY ) * xnew(NO ) & + + 5.1408*rct(75,k) * xnew(TERPPEROXY ) * xnew(HO2 ) & + + 0.9*rct(86,k)*xnew(OH) * xnew(BSOC_UG1E2 ) & + + 1.075*rct(90,k)*xnew(OH) * xnew(NON_C_BSOA_UG1E2 ) + + L = & + rct(89,k)*xnew(OH) + + xnew(NON_C_BSOA_UG10)= ( xold(NON_C_BSOA_UG10) + dt2 * P) /(1.0 + dt2*L ) + +!-> NON_C_BSOA_UG1E2 + + P = & + 0.51*rct(40,k)*xnew(ISRO2)*xnew(NO) & + + 0.51*rct(47,k)*xnew(ISRO2)*xnew(HO2) & + + 11.256*rct(40,k) * xnew(TERPPEROXY ) * xnew(NO ) & + + 20.0872*rct(75,k) * xnew(TERPPEROXY ) * xnew(HO2 ) & + + 0.9*rct(87,k)*xnew(OH) * xnew(BSOC_UG1E3 ) & + + 1.075*rct(91,k)*xnew(OH) * xnew(NON_C_BSOA_UG1E3 ) + + L = & + rct(90,k)*xnew(OH) + + xnew(NON_C_BSOA_UG1E2)= ( xold(NON_C_BSOA_UG1E2) + dt2 * P) /(1.0 + dt2*L ) + +!-> NON_C_BSOA_UG1E3 + + P = & + 28.*rct(40,k) * xnew(TERPPEROXY ) * xnew(NO ) & + + 34.02*rct(75,k) * xnew(TERPPEROXY ) * xnew(HO2 ) + + L = & + rct(91,k)*xnew(OH) + + xnew(NON_C_BSOA_UG1E3)= ( xold(NON_C_BSOA_UG1E3) + dt2 * P) /(1.0 + dt2*L ) + +!-> FFFUEL_NG10 + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for FFFUEL_NG10! xnew(FFFUEL_NG10)= max(0.0, xold(FFFUEL_NG10)) + +!-> WOODOA_NG10 + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for WOODOA_NG10! xnew(WOODOA_NG10)= max(0.0, xold(WOODOA_NG10)) + +!-> FFIREOA_NG10 + ! P = 0.0 + + ! L = 0.0 + +!Nothing to do for FFIREOA_NG10! xnew(FFIREOA_NG10)= max(0.0, xold(FFIREOA_NG10)) !-> SEASALT_F P = & - RCSS(QSSFI,K) + rcemis(SEASALT_F,k) ! L = 0.0 - xnew(SEASALT_F)= max(0.0, xold(SEASALT_F) + dt2 * P) + xnew(SEASALT_F)= xold(SEASALT_F) + dt2 * P !-> SEASALT_C P = & - RCSS(QSSCO,K) + rcemis(SEASALT_C,k) ! L = 0.0 - xnew(SEASALT_C)= max(0.0, xold(SEASALT_C) + dt2 * P) + xnew(SEASALT_C)= xold(SEASALT_C) + dt2 * P -!-> SEASALT_G +!-> DUST_ROAD_F P = & - RCSS(QSSGI,K) + rcemis(DUST_ROAD_F,k) ! L = 0.0 - xnew(SEASALT_G)= max(0.0, xold(SEASALT_G) + dt2 * P) + xnew(DUST_ROAD_F)= xold(DUST_ROAD_F) + dt2 * P -!-> DUST_NAT_F +!-> DUST_ROAD_C + + P = & + rcemis(DUST_ROAD_C,k) + ! L = 0.0 + + + xnew(DUST_ROAD_C)= xold(DUST_ROAD_C) + dt2 * P + +!-> DUST_WB_F + + P = & + rcemis(DUST_WB_F,k) + ! L = 0.0 + + + xnew(DUST_WB_F)= xold(DUST_WB_F) + dt2 * P + +!-> DUST_WB_C + + P = & + rcemis(DUST_WB_C,k) + ! L = 0.0 + + + xnew(DUST_WB_C)= xold(DUST_WB_C) + dt2 * P + +!-> DUST_SAH_F ! P = 0.0 ! L = 0.0 -!Nothing to do for DUST_NAT_F! xnew(DUST_NAT_F)= max(0.0, xold(DUST_NAT_F)) +!Nothing to do for DUST_SAH_F! xnew(DUST_SAH_F)= max(0.0, xold(DUST_SAH_F)) -!-> DUST_NAT_C +!-> DUST_SAH_C ! P = 0.0 ! L = 0.0 -!Nothing to do for DUST_NAT_C! xnew(DUST_NAT_C)= max(0.0, xold(DUST_NAT_C)) +!Nothing to do for DUST_SAH_C! xnew(DUST_SAH_C)= max(0.0, xold(DUST_SAH_C)) !-> RN222 P = & - RC_RN222(K) + rcemis(RN222,k) L = & 2.1e-6 - xnew(RN222)= max(0.0, ( xold(RN222) + dt2 * P)) /(1.0 + dt2*L ) + xnew(RN222)= ( xold(RN222) + dt2 * P) /(1.0 + dt2*L ) + +!-> RNWATER + ! P = 0.0 + + + L = & + 2.1e-6 + + xnew(RNWATER)= xold(RNWATER) / ( 1.0 + dt2 * L ) !-> PB210 P = & 2.1e-6 * xnew(RN222 ) + ! L = 0.0 + - L = & - rcmisc(18,k) - - xnew(PB210)= max(0.0, ( xold(PB210) + dt2 * P)) /(1.0 + dt2*L ) + xnew(PB210)= xold(PB210) + dt2 * P diff --git a/CM_WetDep.inc b/CM_WetDep.inc index 45f744e..ef73989 100644 --- a/CM_WetDep.inc +++ b/CM_WetDep.inc @@ -1,22 +1,58 @@ - integer, public, parameter :: NWETDEP_ADV = 19 + integer, public, parameter :: NWETDEP_ADV = 55 type(depmap), public, dimension(NWETDEP_ADV), parameter:: WDepMap= (/ & - depmap( HNO3, CWDEP_HNO3, -1) & - , depmap( HONO, CWDEP_HNO3, -1) & - , depmap( HCHO, CWDEP_HCHO, -1) & - , depmap( H2O2, CWDEP_H2O2, -1) & - , depmap( SO2, CWDEP_SO2, -1) & - , depmap( SO4, CWDEP_SO4, -1) & - , depmap( NH3, CWDEP_NH3, -1) & - , depmap( NO3_f, CWDEP_PMf, -1) & - , depmap( NO3_c, CWDEP_PMc, -1) & - , depmap( NH4_f, CWDEP_PMf, -1) & - , depmap( PPM25, CWDEP_PMf, -1) & - , depmap( PPM25_FIRE, CWDEP_PMf, -1) & - , depmap( PPM_c, CWDEP_PMc, -1) & - , depmap( SeaSalt_f, CWDEP_SSf, -1) & - , depmap( SeaSalt_c, CWDEP_SSc, -1) & - , depmap( SeaSalt_g, CWDEP_SSg, -1) & - , depmap( Dust_nat_f, CWDEP_PMf, -1) & - , depmap( Dust_nat_c, CWDEP_PMc, -1) & - , depmap( Pb210, CWDEP_PMf, -1) & + depmap( IXADV_HNO3, CWDEP_HNO3, -1) & + , depmap( IXADV_HONO, CWDEP_HNO3, -1) & + , depmap( IXADV_HCHO, CWDEP_HCHO, -1) & + , depmap( IXADV_H2O2, CWDEP_H2O2, -1) & + , depmap( IXADV_SO2, CWDEP_SO2, -1) & + , depmap( IXADV_SO4, CWDEP_SO4, -1) & + , depmap( IXADV_NH3, CWDEP_NH3, -1) & + , depmap( IXADV_NO3_f, CWDEP_PMf, -1) & + , depmap( IXADV_NO3_c, CWDEP_PMc, -1) & + , depmap( IXADV_NH4_f, CWDEP_PMf, -1) & + , depmap( IXADV_V1702A02B_f, CWDEP_PMf, -1) & + , depmap( IXADV_V1702A02B_c, CWDEP_PMc, -1) & + , depmap( IXADV_POM_f_WOOD, CWDEP_PMf, -1) & + , depmap( IXADV_POM_f_FFUEL, CWDEP_PMf, -1) & + , depmap( IXADV_POM_c_FFUEL, CWDEP_PMc, -1) & + , depmap( IXADV_EC_f_WOOD_new, CWDEP_ECfn, -1) & + , depmap( IXADV_EC_f_WOOD_age, CWDEP_PMf, -1) & + , depmap( IXADV_EC_c_WOOD, CWDEP_PMc, -1) & + , depmap( IXADV_EC_f_FFUEL_new, CWDEP_ECfn, -1) & + , depmap( IXADV_EC_f_FFUEL_age, CWDEP_PMf, -1) & + , depmap( IXADV_EC_c_FFUEL, CWDEP_PMc, -1) & + , depmap( IXADV_REMPPM25, CWDEP_PMf, -1) & + , depmap( IXADV_REMPPM_c, CWDEP_PMc, -1) & + , depmap( IXADV_FFIRE_OM, CWDEP_PMf, -1) & + , depmap( IXADV_FFIRE_BC, CWDEP_PMf, -1) & + , depmap( IXADV_FFIRE_REMPPM25, CWDEP_PMf, -1) & + , depmap( IXADV_ASOC_ng100, CWDEP_PMf, -1) & + , depmap( IXADV_ASOC_ug1, CWDEP_PMf, -1) & + , depmap( IXADV_ASOC_ug10, CWDEP_PMf, -1) & + , depmap( IXADV_ASOC_ug1e2, CWDEP_PMf, -1) & + , depmap( IXADV_ASOC_ug1e3, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_ASOA_ng100, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_ASOA_ug1, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_ASOA_ug10, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_ASOA_ug1e2, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_ASOA_ug1e3, CWDEP_PMf, -1) & + , depmap( IXADV_BSOC_ng100, CWDEP_PMf, -1) & + , depmap( IXADV_BSOC_ug1, CWDEP_PMf, -1) & + , depmap( IXADV_BSOC_ug10, CWDEP_PMf, -1) & + , depmap( IXADV_BSOC_ug1e2, CWDEP_PMf, -1) & + , depmap( IXADV_BSOC_ug1e3, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_BSOA_ng100, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_BSOA_ug1, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_BSOA_ug10, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_BSOA_ug1e2, CWDEP_PMf, -1) & + , depmap( IXADV_NON_C_BSOA_ug1e3, CWDEP_PMf, -1) & + , depmap( IXADV_SeaSalt_f, CWDEP_SSf, -1) & + , depmap( IXADV_SeaSalt_c, CWDEP_SSc, -1) & + , depmap( IXADV_DUST_ROAD_F, CWDEP_PMf, -1) & + , depmap( IXADV_DUST_ROAD_C, CWDEP_PMc, -1) & + , depmap( IXADV_Dust_wb_f, CWDEP_PMf, -1) & + , depmap( IXADV_Dust_wb_c, CWDEP_PMc, -1) & + , depmap( IXADV_Dust_sah_f, CWDEP_PMf, -1) & + , depmap( IXADV_Dust_sah_c, CWDEP_PMc, -1) & + , depmap( IXADV_Pb210, CWDEP_PMf, -1) & /) diff --git a/CellMet_ml.f90 b/CellMet_ml.f90 index eed88db..1c38596 100644 --- a/CellMet_ml.f90 +++ b/CellMet_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -44,7 +44,7 @@ module CellMet_ml use MetFields_ml, only: cc3dmax, nwp_sea, sdepth,ice_nwp, surface_precip, & fh,fl,z_mid, z_bnd, q, roa, rh2m, rho_surf, th, pzpbl, t2_nwp, ustar_nwp,& zen, coszen, Idirect, Idiffuse -use ModelConstants_ml, only : KMAX_MID, KMAX_BND, PT +use ModelConstants_ml, only : KMAX_MID, KMAX_BND, PT, USE_ZREF use PhysicalConstants_ml, only : PI, RGAS_KG, CP, GRAV, KARMAN, CHARNOCK, T0 use SoilWater_ml, only : fSW use SubMet_ml, only : Get_SubMet @@ -92,7 +92,15 @@ subroutine Get_CellMet(i,j,debug_flag) Grid%i = i Grid%j = j Grid%psurf = ps(i,j,1) ! Surface pressure, Pa - Grid%z_ref = z_mid(i,j,KMAX_MID) ! NB! Approx, updated every 3h + Grid%z_mid = z_mid(i,j,KMAX_MID) ! NB! Approx, updated every 3h + + ! Have option to use a different reference ht: + if ( USE_ZREF ) then + Grid%z_ref = & + min( 0.1*pzpbl(i,j), z_mid(i,j,KMAX_MID) ) ! within or top of SL + else + Grid%z_ref = z_mid(i,j,KMAX_MID) ! within or top of SL + end if ! More exact for thickness of bottom layer, since used for emissions ! from dp = g. rho . dz and d sigma = dp/pstar @@ -115,6 +123,7 @@ subroutine Get_CellMet(i,j,debug_flag) Grid%ustar = ustar_nwp(i,j) ! u* Grid%t2 = t2_nwp(i,j,1) ! t2 , K Grid%t2C = Grid%t2 - 273.15 ! deg C + Grid%theta_ref = th(i,j,KMAX_MID,1) Grid%rh2m = rh2m(i,j,1) ! Grid%rho_s = rho_surf(i,j) ! Should replace Met_ml calc. in future @@ -122,7 +131,6 @@ subroutine Get_CellMet(i,j,debug_flag) Grid%is_allNWPsea = ( nwp_sea(i,j) .and. LandCover(i,j)%ncodes == 1) Grid%sdepth = sdepth(i,j,1) Grid%ice_nwp = max( ice_nwp(i,j,1), ice_landcover(i,j) ) - !bug Grid%snowice = ( Grid%sdepth > 0.0 .or. Grid%ice_nwp > 0.0 ) Grid%snowice = ( Grid%sdepth > 1.0e-10 .or. Grid%ice_nwp > 1.0e-10 ) Grid%fSW = fSW(i,j) diff --git a/CheckStop_ml.f90 b/CheckStop_ml.f90 index 87a95e5..e1e770c 100644 --- a/CheckStop_ml.f90 +++ b/CheckStop_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute diff --git a/ChemFunctions_ml.f90 b/ChemFunctions_ml.f90 index 60fe972..9b981f2 100644 --- a/ChemFunctions_ml.f90 +++ b/ChemFunctions_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -31,6 +31,10 @@ module ChemFunctions_ml ! Including Troe, sine and cosine curves, ! bilinear-interpolation routines, ! and Standard Atmosphere p -> H conversion +! +! Where possible, reference to the EMEP documentation paper, Simpson +! et al., ACP, 2012, are given, indicated by ACP: +! !____________________________________________________________________ ! !** includes @@ -46,7 +50,8 @@ module ChemFunctions_ml public :: troe public :: troeInLog ! When log(Fc) provided - public :: IUPAC_troe ! Using the approximate expression for F from Atkinson et al., 2006 (ACP6, 3625) + public :: IUPAC_troe ! Using the approximate expression for F from + ! Atkinson et al., 2006 (ACP6, 3625) public :: kaero public :: kaero2 ! for testing public :: RiemerN2O5 @@ -55,14 +60,14 @@ module ChemFunctions_ml ! weighting factor for N2O5 hydrolysis -! Mass of sulfate relative to sulfate+nitrate -! according to Riemer N, Vogel H, Vogel B, -! Schell B, Ackermann I, Kessler C, Hass H -! JGR 108 (D4): FEB 27 2003 +! Some help factors (VOLFAC) pre-defined here. 0.068e-6 is +! number median radius, assumed for fine aerosol +! 1.2648 is the term 3* exp( -2.5 * (log(sig=1.8))**2 ) used below +! We also assume generic aerosol median number radius of 0.068um - real, parameter, public :: VOLFACSO4 = 96.0/(AVOG) * 0.90236 *0.02/0.034e-6 - real, parameter, public :: VOLFACNO3 = 62.0/(AVOG) * 0.90236 *0.02/0.034e-6 - real, parameter, public :: VOLFACNH4 = 18.0/(AVOG) * 0.90236 *0.02/0.034e-6 + real, parameter, public :: VOLFACSO4 = 96.0/(AVOG) * 1.2648 *0.02/0.068e-6 + real, parameter, public :: VOLFACNO3 = 62.0/(AVOG) * 1.2648 *0.02/0.068e-6 + real, parameter, public :: VOLFACNH4 = 18.0/(AVOG) * 1.2648 *0.02/0.068e-6 !======================================== @@ -129,7 +134,7 @@ elemental function troeInLog(k0,kinf,LogFc,M) result (rctroe) !+ Calculates Troe expression ! ----------------------------------------------------------- - ! ds note - this isn't checked or optimised yet. Taken from + ! note - this isn't optimised yet. Taken from ! Seinfeld+Pandis, 1998, pp 283, eqn. 5.98. ! Input arguments are intended to represent: @@ -170,12 +175,13 @@ elemental function IUPAC_troe(k0,kinf,Fc,M,N) result (rctroe) !+ Calculates Troe expression ! ----------------------------------------------------------- - ! rb note - this isn't checked or optimised yet. Taken from + ! note - this isn't optimised yet. Taken from ! Atkinson et al. ACP 2006, 6, 3625-4055. ! Input arguments are intended to represent: ! M may be O2+N2 or just N2 or just O2. - ! NOTE that in the IUPAC nomenclature k0 already contains [M] so the k0(IUPAC)=k0*M here + ! NOTE that in the IUPAC nomenclature k0 already contains [M] so + ! the k0(IUPAC)=k0*M here ! N=[0.75-1.27*log10(Fc)] real, intent(in) :: k0,kinf,Fc,M,N @@ -211,67 +217,71 @@ end function IUPAC_troe !=========================================================================== ! N2O5 -> nitrate calculation. Some constants for ! calculation of volume fraction of sulphate aerosol, and rate of uptake +! Mass of sulfate relative to sulfate+nitrate according to Riemer N, +! Vogel H, Vogel B, Schell B, Ackermann I, Kessler C, Hass H +! JGR 108 (D4): FEB 27 2003 ! ! ! The first order reaction coefficient K (corrected for gas phase diffusion, ! Schwartz, 1986) is given by ! -! K= A* alpha* v/4 +! K= S* alpha* v/4 ACP:44 ! alpha=sticking coeff. for N2O5 =0.02 ! v=mean molecular speed for N2O5 -! A=aerosol surfac +! S=aerosol surfac ! ! The surface area of the aerosols can be calculated as ! -! A = V * surface/volume of aerosols +! S = V * surface/volume of aerosols ! V=volume fraction of sulphate (cm3 aerosol/cm3 air) ! (similar for nitrate and ammonium): ! -! e.g. +! e.g. simplest form (not used) would be: ! V = (so4 in moleculescm-3) x atw sulphate ! --------------------------------------------------------- ! AVOG X specific density of aerosols (assumed 2g/cm3*rh correction) ! -! Or, shorter, V = S x M0/(AVOG*rho) -! -! where S is conc. e.g. sulphate (molecule/cm3), M0 is molwt. -! +! Or, shorter, V = C x M0/(AVOG*rho) ! +! where C is conc. e.g. sulphate (molecule/cm3), M0 is molwt. ! We do not want to include concentrations or rho yet, so: ! ! Let VOL = M0/AVOG ! +! E12:47 ! The surface/volume ratio is calculated using Whitby particle distribution -! with number mean radius 0.034 and standars deviation (Sigma)=2. +! with number mean radius rgn=0.068 and standard deviation (Sigma)=2. ! Then surface/volume=3/r * exp( -5/2 *(lnSigma)^2)=26.54 -! 3* exp( -5/2 *(lnSigma)^2)=0.90236 +! 3* exp( -5/2 *(lnSigma)^2)=1.2648 for sigma=1.8 ! (monodisperse aerosols; 4*pi*r^2/(4/3 pi*r^3)= 3/r =88.2) ! ! Then -! A = VOL * S * 0.90236 /(0.034e-6*rho) +! A = VOL * C * 1.24648 /(0.068e-6*rho) ! and -! K = VOL * S * 0.90236 /(0.034e-6*rho) * alpha* v/4 +! K = VOL * C * 1.24648 /(0.068e-6*rho) * alpha* v/4 ! Set -! VOLFAC= VOL*0.90236/0.034e-6 *alpha +! VOLFAC= VOL*1.24648/0.068e-6 *alpha ! Then -! K = VOLFAC *S *v/(4*rho) +! K = VOLFAC *C *v/(4*rho) ! ! rcmisc k=v/(4*rho) ! -! K = VOLFAC *rcmisc() *S +! K = VOLFAC *rcmisc() *C +! ! According to Riemer et al, 2003, we weight the reaction probability ! according to the composition of the aerosol ! -! alpha(N2O5)=f*alpha1 +(1-f)alpha2 +! alpha(N2O5)=f*alpha1 +(1-f)alpha2 ACP:45 ! alpha1=0.02 ! alpha2=0.002 -! f= Mso4/(Mso4+Mno3), M=aerosol mass concentration +! f= Mso4/(Mso4+Mno3), M=aerosol mass concentration ACP:46 ! N2O5 -> aerosol based upon based on Riemer 2003 and -! (May 2011) updated based upon results shown in Riemer et al., 2009. -! We do not attempt to model OC, but simply reduce the rate by +! In testing, we had also tried a simple acounting for +! results shown in Riemer et al., 2009. +! We did not attempt to model OC, but simply reduce the rate by ! a factor of two to loosely account for this effect. -! J08 - changed from use of more accurate xnew to xn_2d, since +! June08 - changed from use of more accurate xnew to xn_2d, since ! surface area won't change so much, and anyway the uncertainties ! are large. (and xn_2d leads to fewer dependencies) @@ -288,14 +298,16 @@ function RiemerN2O5() result(rate) if ( rh(k) > 0.4) then xNO3 = x(NO3_f,k) + x(NO3_c,k) - rc = sqrt(3.0 * RGAS_J * itemp(k) / 0.108) & ! mean mol. speed,m/s - /(4*(2.5 - rh(k)*1.25)) !density, corrected for rh (moderate approx.) + !mean molec speed of N2O5 (MW 108), m/s + ! with density corrected for rh (moderate approx.) + rc = sqrt(3.0 * RGAS_J * itemp(k) / 0.108) & ! mol.speed (m/s) + /(4*(2.5 - rh(k)*1.25)) ! density f = 96.0*x(SO4,k)/( 96.*x(SO4,k) + 62.0* xNO3 + EPSIL ) rate(k) = (0.9*f + 0.1) * rc * & - 0.5 * & ! very loosely based on OC effects from Reimer 2009 + !TEST 0.5 * & ! v. loosely based on Reimer 2009 ( VOLFACSO4 * x(SO4,k) + VOLFACNO3 * xNO3 & + VOLFACNH4 * x(NH4_f,k) ) !SIA aerosol surface else @@ -344,16 +356,18 @@ end function kaero2 !--------------------------------------------------------------------- function ec_ageing_rate() result(rate) -!.. Sets ageing rates for fresh EC based on Riemer et al.; ACP (2004). + !.. Sets ageing rates for fresh EC [1/s] loosely based on Riemer etal. ACP(2004) + ! See also Tsyro et al, JGR, 112, D23S19, 2007 + ! --------------------------------- real, dimension(K1:K2) :: rate if ( Grid%izen <= DAY_ZEN ) then ! daytime - rate (K2-2 : K2) = 3.5e-5 ! t= 2h - rate (K1 : K2-3) = 1.4e-4 ! t= 8h + rate (K2-2 : K2) = 3.5e-5 ! half-lifetime ~ 8h + rate (K1 : K2-3) = 1.4e-4 ! ~ 2h else - rate (K1 : K2 ) = 9.2e-6 ! t= 30h + rate (K1 : K2 ) = 9.2e-6 ! ~ 30h endif end function ec_ageing_rate diff --git a/Chem_ml.f90 b/Chem_ml.f90 index a158e34..7713b78 100644 --- a/Chem_ml.f90 +++ b/Chem_ml.f90 @@ -63,23 +63,54 @@ module Chemfields_ml ! model, as well as cfac (converts from 50m to 1m/3m output) ! !---------------------------------------------------------------------! - real, save, public :: & - xn_adv (NSPEC_ADV,MAXLIMAX,MAXLJMAX,KMAX_MID) = 0.0 & - ,xn_shl (NSPEC_SHL,MAXLIMAX,MAXLJMAX,KMAX_MID) = 0.0 & - ,xn_bgn (NSPEC_BGN,MAXLIMAX,MAXLJMAX,KMAX_MID) = 0.0 & - ,PM25_water (MAXLIMAX,MAXLJMAX,KMAX_MID) = 0.0 & !3D PM water - ,PM25_water_rh50 (MAXLIMAX,MAXLJMAX) = 0.0 !gravimetric PM water + real, save, allocatable, public :: & + xn_adv(:,:,:,:) & + ,xn_shl(:,:,:,:) & + ,xn_bgn(:,:,:,:) & + ,PM25_water(:,:,:) & !3D PM water + ,PM25_water_rh50(:,:) !gravimetric PM water - real, public, dimension(MAXLIMAX,MAXLJMAX) :: AOD + real, public, save, allocatable:: Fgas3d (:,:,:,:) ! for SOA - real, save, public :: & - cfac (NSPEC_ADV,MAXLIMAX,MAXLJMAX) = 1.0 + real, public, save, allocatable, dimension(:,:) :: AOD - real, save, public :: & - so2nh3_24hr(MAXLIMAX,MAXLJMAX) = 0.0 !hf CoDep + real, save, allocatable, public :: & + cfac (:,:,:) - real, save, public :: & - Grid_snow(MAXLIMAX,MAXLJMAX) = 0.0 !snow_flag fraction in grid + real, save, allocatable, public :: & + so2nh3_24hr(:,:)!hf CoDep + + real, save, allocatable, public :: & + Grid_snow(:,:) !snow_flag fraction in grid + + public ::alloc_ChemFields + +contains + + subroutine alloc_ChemFields + + implicit none + + allocate(xn_adv(NSPEC_ADV,MAXLIMAX,MAXLJMAX,KMAX_MID)) + xn_adv=0.0 + allocate(xn_shl(NSPEC_SHL,MAXLIMAX,MAXLJMAX,KMAX_MID)) + xn_shl=0.0 + allocate(xn_bgn(NSPEC_BGN,MAXLIMAX,MAXLJMAX,KMAX_MID)) + xn_bgn=0.0 + allocate(PM25_water(MAXLIMAX,MAXLJMAX,KMAX_MID)) + PM25_water=0.0 + allocate(PM25_water_rh50(MAXLIMAX,MAXLJMAX)) + PM25_water_rh50=0.0 + allocate(AOD(MAXLIMAX,MAXLJMAX)) + allocate(cfac(NSPEC_ADV,MAXLIMAX,MAXLJMAX)) + cfac=1.0 + allocate(so2nh3_24hr(MAXLIMAX,MAXLJMAX)) + so2nh3_24hr=0.0 + allocate(Grid_snow(MAXLIMAX,MAXLJMAX)) + Grid_snow=0.0 + + + end subroutine alloc_ChemFields !_____________________________________________________________________________ diff --git a/CoDep_ml.f90 b/CoDep_ml.f90 index ccf44fd..baba371 100644 --- a/CoDep_ml.f90 +++ b/CoDep_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -39,8 +39,7 @@ module CoDep_ml !--------------------------------------------------------------------------- ! For basic reference and methods, see ! - ! Fagerli et al., 2011, in preperation for Rbs_SO2 - ! Simpson et al. 2011, in preperation for general model documentation + ! Simpson et al. 2012, ACP, 12, for general model documentation ! ! Also, ! RIS: Smith, R.I., Fowler, D., Sutton, M.A., Flechard, C: and Coyle, M. @@ -62,8 +61,8 @@ module CoDep_ml !/** Some parameters for the so2nh3_24hr calculations integer, private :: nhour - real, private, save :: & ! 24hr average ratio - so2nh3_hr(24,MAXLIMAX,MAXLJMAX)=1.0 !Predefined to 1.0 to make first hours + real, private, save,allocatable :: & ! 24hr average ratio + so2nh3_hr(:,:,:) !Predefined to 1.0 to make first hours !reasonable !/** Some parameters for the Rns calculations @@ -131,6 +130,8 @@ subroutine CoDep_factors( so2nh3ratio24hr,so2nh3ratio, Ts_C, frh, & call Tabulate() my_first_call = .false. + allocate(so2nh3_hr(24,MAXLIMAX,MAXLJMAX)) + so2nh3_hr=1.0 if( debug_proc ) write(*,"(a,2es12.4,f7.2,f7.3,L1)") "First CoDep call, ", & so2nh3ratio24hr,so2nh3ratio, Ts_C, frh, forest diff --git a/Convection_ml.f90 b/Convection_ml.f90 index 72d2d6b..a7a4c5e 100644 --- a/Convection_ml.f90 +++ b/Convection_ml.f90 @@ -19,7 +19,7 @@ module Convection_ml use ModelConstants_ml, only : KMAX_BND,KMAX_MID,PT use MetFields_ml , only : ps,sdot,SigmaKz,u_xmj,v_xmi,cnvuf,cnvdf use GridValues_ml, only : dA, dB, sigma_bnd - use Par_ml, only : MAXLIMAX,MAXLJMAX,limax,ljmax + use Par_ml, only : MAXLIMAX,MAXLJMAX,limax,ljmax,li0,li1,lj0,lj1 use PhysicalConstants_ml, only : GRAV @@ -48,8 +48,8 @@ subroutine convection_pstar(ps3d,dt_conv) !UPWARD - do j=1,LJMAX - do i=1,LIMAX + do j=lj0,lj1 + do i=li0,li1 xn_in_core = 0.0!concentration null below surface mass=0.0 ! diff --git a/Country_ml.f90 b/Country_ml.f90 index 1f43904..f73ccf2 100644 --- a/Country_ml.f90 +++ b/Country_ml.f90 @@ -72,7 +72,7 @@ module Country_ml integer, parameter, public :: IC_AT = 2 ! Austria integer, parameter, public :: IC_BE = 3 ! Belgium integer, parameter, public :: IC_BG = 4 ! Bulgaria - integer, parameter, public :: IC_CS = 5 ! Former Yugoslavia + integer, parameter, public :: IC_FCS = 5 ! Former Czechoslovakia integer, parameter, public :: IC_DK = 6 ! Denmark integer, parameter, public :: IC_FI = 7 ! Finland integer, parameter, public :: IC_FR = 8 ! France @@ -96,7 +96,7 @@ module Country_ml integer, parameter, public :: IC_SU = 26 ! Former USSE integer, parameter, public :: IC_GB = 27 ! United Kingdom integer, parameter, public :: IC_VUL = 28 ! Vulcanoes - integer, parameter, public :: IC_REM = 29 ! Remaining Areas + integer, parameter, public :: IC_REM = 29 ! Remaining Areas integer, parameter, public :: IC_BAS = 30 ! The Baltic Sea integer, parameter, public :: IC_NOS = 31 ! The North Sea integer, parameter, public :: IC_ATL = 32 ! NE Atlantic Ocean (within EMEP domain) @@ -118,7 +118,7 @@ module Country_ml integer, parameter, public :: IC_SI = 48 ! Slovenia integer, parameter, public :: IC_HR = 49 ! Croatia integer, parameter, public :: IC_BA = 50 ! Bosnia - integer, parameter, public :: IC_YU = 51 ! Yugoslavia + integer, parameter, public :: IC_CS = 51 ! Serbia and Montenegro integer, parameter, public :: IC_MK = 52 ! Macedonia integer, parameter, public :: IC_KZ = 53 ! Kazakstan integer, parameter, public :: IC_GE = 54 ! Georgia @@ -141,6 +141,11 @@ module Country_ml integer, parameter, public :: IC_RUX = 71 ! RU outside old EMEP domain integer, parameter, public :: IC_RS = 72 ! Serbia integer, parameter, public :: IC_ME = 73 ! Montenegro + integer, parameter, public :: IC_RUE = 93 ! Russian Federation in the extended EMEP domain (RU+RFE+RUX) + +!Extra cc for rest CityZen + integer, parameter, public :: IC_RAA = 170 ! Rest of Africa and Asia + integer, parameter, public :: IC_SEA = 171 ! Ship ! Biomass-burnung (Wild-fires etc.) allocated to a country-number ! Allows easy use of emissplits to allocate speciation @@ -260,7 +265,7 @@ subroutine Country_Init() Country( IC_AT ) = cc( "AT " , 2 ,F, 2, 1 , "Austria " ) Country( IC_BE ) = cc( "BE " , 3 ,F, 3, 1 , "Belgium " ) Country( IC_BG ) = cc( "BG " , 4 ,F, 4, 2 , "Bulgaria " ) -Country( IC_CS ) = cc( "CS " , 5 ,F, 5, 1 , "Former Czechoslovakia " ) +Country( IC_FCS ) = cc( "FCS " , 5 ,F, 5, 1 , "Former Czechoslovakia " ) Country( IC_DK ) = cc( "DK " , 6 ,F, 6, 1 , "Denmark " ) Country( IC_FI ) = cc( "FI " , 7 ,F, 7, 2 , "Finland " ) Country( IC_FR ) = cc( "FR " , 8 ,F, 8, 1 , "France " ) @@ -326,7 +331,7 @@ subroutine Country_Init() Country( IC_SI ) = cc( "SI " , 48 ,F, 48, 1 , "Slovenia " ) Country( IC_HR ) = cc( "HR " , 49 ,F, 49, 1 , "Croatia " ) Country( IC_BA ) = cc( "BA " , 50 ,F, 50, 1 , "Bosnia and Herzegovina " ) -Country( IC_YU ) = cc( "YU " , 51 ,F, 51, 1 , "Yugoslavia " ) +Country( IC_CS ) = cc( "CS " , 51 ,F, 51, 1 , "Serbia and Montenegro " ) Country( IC_MK ) = cc( "MK " , 52 ,F, 52, 1 , "Macedonia, The F.Yugo.Rep. of " ) Country( IC_KZ ) = cc( "KZ " , 53 ,F, 53, 6 , "Kazakstan " ) Country( IC_GE ) = cc( "GE " , 54 ,F, 54, 4 , "Georgia " ) @@ -350,7 +355,7 @@ subroutine Country_Init() Country( IC_RUX) = cc( "RUX" , 71 ,F, 42, 4 , "Russian Fed. outside emep " ) Country( IC_RS) = cc( "RS " , 72 ,F, 72, 1 , "Serbia " ) Country( IC_ME) = cc( "ME " , 73 ,F, 73, 1 , "Montenegro " ) - +Country( IC_RUE) = cc( "RUE" , 93 ,F, 93, -100 , "Russian Federeation (all) " ) ! Biomass burning Country( IC_BB) = cc( "BB ", 101,F, 101, 0 , "Biomass burning (wild) " ) @@ -428,6 +433,9 @@ subroutine Country_Init() ! b) Domain x = -16-132 y = -11-0 Country( IC_NAX ) = cc( "NAX" , 91 ,F, 91, 1 ,"EMEP-external part of North Africa " ) +!Extra cc for rest CityZen +Country( IC_RAA ) = cc( "RAA" , 170 ,F, 170, 1, "Rest of Africa and Asia" ) +Country( IC_SEA ) = cc( "SEA" , 171 ,F, 171, 1, "Ships" ) end subroutine Country_Init end module Country_ml diff --git a/DO3SE_ml.f90 b/DO3SE_ml.f90 index fcb3644..0d19ad7 100644 --- a/DO3SE_ml.f90 +++ b/DO3SE_ml.f90 @@ -238,14 +238,9 @@ subroutine g_stomatal(iLC, debug_flag) !..5) Calculate f_swp !--------------------------------------- - !/ Use SWP_Mpa to get f_swp. We just need this updated - ! once per day, but for simplicity we do it every time-step. - - !ds f_swp = do3se(iLC)%f_min + & - !ds (1-do3se(iLC)%f_min)*(do3se(iLC)%PWP-L%SWP)/ & - !ds (do3se(iLC)%PWP-do3se(iLC)%SWP_max) - !ds f_swp = min(1.0,f_swp) - ! Aug 2010: use HIRLAM's SW, and simple "DAM" function + !/ Soil water effects. We now used the soil-moisture + ! index from ECMWF if possible, otherwise some equivalent. + ! Once per day, but for simplicity we do it every time-step. ! ************************************ if ( USE_SOILWATER ) f_swp = L%fSW diff --git a/Derived_ml.f90 b/Derived_ml.f90 index d91d5a8..915d207 100644 --- a/Derived_ml.f90 +++ b/Derived_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -52,13 +52,14 @@ module Derived_ml use My_Derived_ml, only : & COLUMN_MOLEC_CM2, & COLUMN_LEVELS , & - OutputConcs, & ! added Feb 2011 - WDEP_WANTED, & ! added Jan 2011 + OutputFields, & + nOutputFields, & + WDEP_WANTED, & D3_OTHER -use My_Emis_ml, only: EMIS_NAME +use Aero_Vds_ml, only: diam !aerosol MMD (um) use AOTx_ml, only: Calc_GridAOTx -use Biogenics_ml, only: EmisNat +use Biogenics_ml, only: EmisNat, NEMIS_BioNat, EMIS_BioNat use CheckStop_ml, only: CheckStop, StopAll use Chemfields_ml, only: xn_adv, xn_shl, cfac,xn_bgn, AOD, & PM25_water, PM25_water_rh50 @@ -66,19 +67,21 @@ module Derived_ml use ChemSpecs_adv_ml ! Use NSPEC_ADV amd any of IXADV_ indices use ChemSpecs_shl_ml use ChemSpecs_tot_ml -use ChemChemicals_ml, only: species +use ChemChemicals_ml, only: species,species_adv use Chemfields_ml , only: so2nh3_24hr,Grid_snow use DerivedFields_ml, only: MAXDEF_DERIV2D, MAXDEF_DERIV3D, & def_2d, def_3d, f_2d, f_3d, d_2d, d_3d use EcoSystem_ml, only: DepEcoSystem, NDEF_ECOSYSTEMS, & EcoSystemFrac,FULL_ECOGRID +use EmisDef_ml, only: EMIS_FILE use Emissions_ml, only: SumSnapEmis use GridValues_ml, only: debug_li, debug_lj, debug_proc, sigma_mid, xm2, & GRIDWIDTH_M, GridArea_m2 use Io_Progs_ml, only: datewrite -use MetFields_ml, only: roa,pzpbl,Kz_m2s,th,zen, ustar_nwp, z_bnd,u_ref,ws_10m +use MetFields_ml, only: roa,pzpbl,Kz_m2s,th,zen, ustar_nwp, z_bnd,u_ref,& + ws_10m, rh2m use MetFields_ml, only: ps, t2_nwp -use MetFields_ml, only: SoilWater_deep, Idirect, Idiffuse +use MetFields_ml, only: SoilWater_deep, SoilWater_uppr, Idirect, Idiffuse use ModelConstants_ml, only: & KMAX_MID & ! => z dimension ,NPROC & ! No. processors @@ -87,9 +90,12 @@ module Derived_ml ,PPTINV & ! 1.0e12, for conversion of units ,MFAC & ! converts roa (kg/m3 to M, molec/cm3) ,DEBUG_i, DEBUG_j & - ,DEBUG_AOT & + ,DEBUG_AOT & ,DEBUG => DEBUG_DERIVED, DEBUG_COLUMN, MasterProc & ,SOURCE_RECEPTOR & + ,USE_SOILNOX & + ,USE_SOILNH3 & + ,USE_EMERGENCY,DEBUG_EMERGENCY & ,PT & ,FORECAST & ! only dayly (and hourly) output on FORECAST mode ,NTDAY & ! Number of 2D O3 to be saved each day (for SOMO) @@ -103,8 +109,10 @@ module Derived_ml gi0,gj0,IRUNBEG,JRUNBEG,&! for i_fdom, j_fdom li0,lj0,limax, ljmax ! => used x, y area use PhysicalConstants_ml, only : PI,KAPPA -use SmallUtils_ml, only: find_index, LenArray, NOT_SET_STRING -use TimeDate_ml, only : day_of_year,daynumber,current_date +!FUTURE use Pollen_ml, only: AreaPOLL +use SmallUtils_ml, only: find_index, LenArray, NOT_SET_STRING +use TimeDate_ml, only: day_of_year,daynumber,current_date +use Units_ml, only: Units_Scale,Group_Units implicit none private @@ -117,7 +125,6 @@ module Derived_ml private :: Setups private :: write_debug private :: write_debugadv - private :: Units_Scale ! selects unt factor public :: Derived ! Calculations of sums, avgs etc. private :: voc_2dcalc ! Calculates sum of VOC for 2d fields @@ -149,8 +156,12 @@ module Derived_ml ! save O3 every hour during one day to find running max - real, save, public :: & ! to be used for SOMO35 - D2_O3_DAY( MAXLIMAX, MAXLJMAX, NTDAY) = 0. + real, save , allocatable , public :: & ! to be used for SOMO35 + D2_O3_DAY( :,:,:) + + ! Fraction of NO3_c below 2.5 um (v. crude so far) + + real, save, private :: fracPM25 ! Counters to keep track of averaging @@ -159,12 +170,6 @@ module Derived_ml integer, public, allocatable, dimension(:,:), save :: nav_2d integer, public, allocatable, dimension(:,:), save :: nav_3d - ! Note - previous versions did not have the LENOUT2D dimension - ! for wet and dry deposition. Why not? Are annual or daily - ! depositions never printed? Since I prefer to keep all 2d - ! fields as similar as posisble, I have kept this dimension - ! for now - ds - !-- some variables for the VOC sum done for ozone models ! (have no effect in non-ozone models - leave in code) @@ -179,49 +184,75 @@ module Derived_ml integer, private :: i,j,k,n, ivoc, index ! Local loop variables + integer, private, save :: iadv_O3=-999,iadv_NO3_C=-999, & ! Avoid hard codded IXADV_SPCS + iadv_EC_C_WOOD=-999,iadv_EC_C_FFUEL=-999,iadv_POM_C_FFUEL=-999 + integer, private, save :: ug_NO3_C=-999.0, & ! Avoid hard codded molwt + ug_EC_C_WOOD=-999.0,ug_EC_C_FFUEL=-999.0,ug_POM_C_FFUEL=-999.0 + contains - !========================================================================= - subroutine Init_Derived() - - integer :: alloc_err - if(MasterProc .and. DEBUG ) write(*,*) "INIT My DERIVED STUFF" - call Init_My_Deriv() !-> wanted_deriv2d, wanted_deriv3d - - ! get lengths of wanted arrays (excludes notset values) - num_deriv2d = LenArray(wanted_deriv2d,NOT_SET_STRING) - num_deriv3d = LenArray(wanted_deriv3d,NOT_SET_STRING) - - call CheckStop(num_deriv2d<1,"num_deriv2d<1 !!") - - if ( num_deriv2d > 0 ) then - if(DEBUG .and. MasterProc ) write(*,*) "Allocate arrays for 2d:",& - num_deriv2d - allocate(f_2d(num_deriv2d),stat=alloc_err) - call CheckStop(alloc_err,"Allocation of f_2d") - allocate(d_2d(num_deriv2d,MAXLIMAX,MAXLJMAX,LENOUT2D),stat=alloc_err) - call CheckStop(alloc_err,"Allocation of d_2d") - call CheckStop(alloc_err,"Allocation of d_3d") - allocate(nav_2d(num_deriv2d,LENOUT2D),stat=alloc_err) - call CheckStop(alloc_err,"Allocation of nav_2d") - nav_2d = 0 - end if - if ( num_deriv3d > 0 ) then - if(DEBUG .and. MasterProc ) write(*,*) "Allocate arrays for 3d: ",& - num_deriv3d - allocate(f_3d(num_deriv3d),stat=alloc_err) - call CheckStop(alloc_err,"Allocation of f_3d") - allocate(d_3d(num_deriv3d,MAXLIMAX,MAXLJMAX,KMAX_MID,LENOUT3D),& - stat=alloc_err) - allocate(nav_3d(num_deriv3d,LENOUT3D),stat=alloc_err) - call CheckStop(alloc_err,"Allocation of nav_3d") - nav_3d = 0 - end if - - call Define_Derived() - call Setups() - - end subroutine Init_Derived + !========================================================================= + subroutine Init_Derived() + integer :: alloc_err + + allocate(D2_O3_DAY( MAXLIMAX, MAXLJMAX, NTDAY)) + D2_O3_DAY = 0.0 + + if(MasterProc .and. DEBUG ) write(*,*) "INIT My DERIVED STUFF" + call Init_My_Deriv() !-> wanted_deriv2d, wanted_deriv3d + + ! get lengths of wanted arrays (excludes notset values) + num_deriv2d = LenArray(wanted_deriv2d,NOT_SET_STRING) + num_deriv3d = LenArray(wanted_deriv3d,NOT_SET_STRING) + + call CheckStop(num_deriv2d<1,"num_deriv2d<1 !!") + + if(num_deriv2d > 0) then + if(DEBUG .and. MasterProc ) write(*,*) "Allocate arrays for 2d:",& + num_deriv2d + allocate(f_2d(num_deriv2d),stat=alloc_err) + call CheckStop(alloc_err,"Allocation of f_2d") + allocate(d_2d(num_deriv2d,MAXLIMAX,MAXLJMAX,LENOUT2D),stat=alloc_err) + call CheckStop(alloc_err,"Allocation of d_2d") + call CheckStop(alloc_err,"Allocation of d_3d") + allocate(nav_2d(num_deriv2d,LENOUT2D),stat=alloc_err) + call CheckStop(alloc_err,"Allocation of nav_2d") + nav_2d = 0 + endif + if(num_deriv3d > 0) then + if(DEBUG .and. MasterProc ) write(*,*) "Allocate arrays for 3d: ",& + num_deriv3d + allocate(f_3d(num_deriv3d),stat=alloc_err) + call CheckStop(alloc_err,"Allocation of f_3d") + allocate(d_3d(num_deriv3d,MAXLIMAX,MAXLJMAX,KMAX_MID,LENOUT3D),& + stat=alloc_err) + allocate(nav_3d(num_deriv3d,LENOUT3D),stat=alloc_err) + call CheckStop(alloc_err,"Allocation of nav_3d") + nav_3d = 0 + endif + + ! Avoid hard codded IXADV_SPCS + iadv_O3 =find_index('O3' ,species_adv(:)%name ) + iadv_NO3_C =find_index('NO3_C' ,species_adv(:)%name ) + iadv_EC_C_WOOD =find_index('EC_C_WOOD' ,species_adv(:)%name ) + iadv_EC_C_FFUEL =find_index('EC_C_FFUEL' ,species_adv(:)%name ) + iadv_POM_C_FFUEL=find_index('POM_C_FFUEL',species_adv(:)%name ) + if(iadv_NO3_C >0)ug_NO3_C =Units_Scale('ug', iadv_NO3_C ) + if(iadv_EC_C_WOOD >0)ug_EC_C_WOOD =Units_Scale('ug', iadv_EC_C_WOOD ) + if(iadv_EC_C_FFUEL >0)ug_EC_C_FFUEL =Units_Scale('ug', iadv_EC_C_FFUEL ) + if(iadv_POM_C_FFUEL>0)ug_POM_C_FFUEL=Units_Scale('ug', iadv_POM_C_FFUEL) + + call Define_Derived() + call Setups() ! just for VOC now + + select case(nint(diam(2)*1e7)) + case(25);fracPM25=0.37 + case(30);fracPM25=0.27 + endselect + if(DEBUG)print *, ' CFAC INIT PMFRACTION ', fracPM25, diam(2), nint(1.0e7*diam(2)) + call CheckStop( fracPM25 < 0.01, "NEED TO SET FRACPM25") + + end subroutine Init_Derived !========================================================================= subroutine AddNewDeriv( name,class,subclass,txt,unit,index,f2d,& @@ -244,6 +275,7 @@ subroutine AddNewDeriv( name,class,subclass,txt,unit,index,f2d,& logical, intent(in), optional :: Is3D type(Deriv) :: inderiv +if( trim(name) == "HMIX" .and. MasterProc ) print *, "ADDNEWDERIVE", iotype !NOV2011 inderiv = Deriv(trim(name),trim(class),trim(subclass),& trim(txt),trim(unit),index,f2d,dt_scale, scale,& avg,iotype) @@ -298,12 +330,13 @@ subroutine Define_Derived() real :: unitscale logical :: volunit ! set true for volume units, e.g. ppb - logical :: outmm, outdd, outhh ! sets time-intervals + logical :: outmm, outdd ! sets time-intervals character(len=30) :: dname, txt, txt2, class character(len=10) :: unittxt character(len=3) :: subclass character(len=TXTLEN_SHORT) :: outname, outunit, outtyp, outdim + integer :: outind integer :: ind, iadv, itot, idebug, n, n2, iLC, igrp, iout @@ -371,146 +404,167 @@ subroutine Define_Derived() ! NOT YET: Scale pressure by 0.01 to get hPa call AddNewDeriv( "PSURF ","PSURF", "SURF","-", "hPa", & - -99, -99, F, 1.0, T, IOU_DAY ) + -99, -99, F, 1.0, T, IOU_DAY ) -call AddNewDeriv( "HMIX ","HMIX", "-","-", "m", & - -99, -99, F, 1.0, T, IOU_DAY ) call AddNewDeriv( "Snow_m","SNOW", "-","-", "m", & - -99, -99, F, 1.0, T, IOU_DAY ) + -99, -99, F, 1.0, T, IOU_DAY ) -! "HMIX00","HMIX12", .... call AddNewDeriv( "USTAR_NWP","USTAR_NWP", "-","-", "m/s", & - -99, -99, F, 1.0, T, IOU_DAY ) -call AddNewDeriv( "ws_10m","ws_10m", "-","-", "m/s", & - -99, -99, F, 1.0, T, IOU_DAY ) -call AddNewDeriv( "u_ref","u_ref", "-","-", "m/s", & - -99, -99, F, 1.0, T, IOU_DAY ) + -99, -99, F, 1.0, T, IOU_DAY ) +!Added for TFMM scale runs +call AddNewDeriv( "Kz_m2s","Kz_m2s", "-","-", "m2/s", & + -99, -99, F, 1.0, T, IOU_DAY ) + +!Most met params are now better specified in My_Derived. +!MOVED call AddNewDeriv( "ws_10m","ws_10m", "-","-", "m/s", & +!MOVED call AddNewDeriv( "HMIX ","HMIX", "-","-", "m", & +! "HMIX00","HMIX12", .... -call AddNewDeriv( "SoilWater_deep","SoilWater_deep", "-","-", "m", & +call AddNewDeriv( "u_ref","u_ref", "-","-", "m/s", & -99, -99, F, 1.0, T, IOU_DAY ) +!call AddNewDeriv( "SoilWater_deep","SoilWater_deep", "-","-", "m", & +! -99, -99, F, 1.0, T, IOU_DAY ) +!call AddNewDeriv( "SoilWater_uppr","SoilWater_uppr", "-","-", "m", & +! -99, -99, F, 1.0, T, IOU_DAY ) + !Deriv(name, class, subc, txt, unit !Deriv index, f2d, dt_scale, scale, avg? rho Inst Yr Mn Day atw call AddNewDeriv( "T2m","T2m", "-","-", "deg. C", & - -99, -99, F, 1.0, T, IOU_DAY ) + -99, -99, F, 1.0, T, IOU_DAY ) call AddNewDeriv( "Idirect","Idirect", "-","-", "W/m2", & -99, -99, F, 1.0, T, IOU_DAY ) call AddNewDeriv( "Idiffuse","Idiffuse", "-","-", "W/m2", & -99, -99, F, 1.0, T, IOU_DAY ) -! OutputConcs can contain both 2d and 3d specs. We automatically +! OutputFields can contain both 2d and 3d specs. We automatically ! set 2d if 3d wanted -do ind = 1, size( OutputConcs(:)%txt1 ) +do ind = 1, nOutputFields !!!!size( OutputFields(:)%txt1 ) - outname = trim( OutputConcs(ind)%txt1 ) - outunit= trim( OutputConcs(ind)%txt2 ) ! eg ugN, which gives unitstxt ugN/m3 - outdim = trim( OutputConcs(ind)%txt3 ) ! 2d or 3d - outtyp = trim( OutputConcs(ind)%txt5 ) ! SPEC or GROUP + outname = trim( OutputFields(ind)%txt1 ) + outunit= trim( OutputFields(ind)%txt2 ) ! eg ugN, which gives unitstxt ugN/m3 + outdim = trim( OutputFields(ind)%txt3 ) ! 2d or 3d + outtyp = trim( OutputFields(ind)%txt5 ) ! SPEC or GROUP + outind = OutputFields(ind)%ind ! H, D, M - fequency of output txt2 = "-" ! not needed? - if ( outtyp == "SPEC" ) then ! Simple species - - itot = find_index( trim( outname ) , species(:)%name ) - iout = itot - NSPEC_SHL ! set to iadv - - if( MasterProc .and. itot <0 ) then - write(*,*) "ERROR! My_Derived has asked for a species to be output",& -& " that isn't in the CM_ChemSpecs list (below). FIX!" - do i =1, size( species(:)%name ) - write(*,"(a,i4,2a12)") "CONCLIST ", i, trim(species(i)%name ), trim(outname) - end do - call CheckStop(itot<0, "OutputConcs Species not found " // trim(dname) ) - end if - txt = "SURF_UG" - - else if ( outtyp == "GROUP" ) then ! groups of species - - igrp = find_index( trim( outname ), GROUP_ARRAY(:)%name ) - - txt = "SURF_UG_GROUP" ! ppb not implementde yet - itot = -1 - iout = igrp - else - - call StopAll("OutputConcs Error " // trim( outtyp ) ) - end if - - call Units_Scale( outunit , itot, unitscale, unittxt, volunit ) - - class = "SURF_MASS_" // trim(outtyp) - if ( volunit .and. itot > 0 ) class = "SURF_PPB_" // trim(outtyp) - if ( volunit .and. itot < 1 ) call StopAll(& - "SURF_PPB_GROUPS not implemented yet:"// trim(dname) ) - - dname = "SURF_" // trim( outunit ) // "_" // trim( outname ) - - if( DEBUG.and.MasterProc ) write(*,"(a,2i4,3(1x,a),2L3,i4,es10.2)") & - "ADD ", ind, iout, trim(dname),";", trim(class), outmm, outdd, & - OutputConcs(ind)%ind,unitscale - - call AddNewDeriv( dname, class, "-", "-", trim( unittxt ) , & - iout , -99, F, unitscale, T, OutputConcs(ind)%ind ) - - if ( outdim == "3d" ) then - - class = "3D_MASS_" // trim(outtyp) - if ( volunit .and. itot > 0 ) class = "3D_PPB_" // trim(outtyp) - - dname = "D3_" // trim( outunit ) // "_" // trim( outname ) - - ! Always print out 3D info. Good to help avoid using 3d unless really needed! - if( MasterProc ) write(*,"(a,3(1x,a),a,L3,a,L3,i4,es10.2)") " ADDED 3D outputs", & - trim(dname)," ; class =", trim(class), ', monthly =',outmm,', daily =',outdd - !, OutputConcs(ind)%ind,unitscale - - call AddNewDeriv( dname, class, "-", "-", trim( unittxt ) , & - iout , -99, F, unitscale, T, OutputConcs(ind)%ind, & - Is3D=.true. ) - - end if ! 3d -end do ! OutputConcs - - -do ind = 1, size( WDEP_WANTED(:)%txt1 ) - - if ( WDEP_WANTED(ind)%txt2 == "PREC" ) then - - dname = "WDEP_" // trim(WDEP_WANTED( ind )%txt1) ! just for printout below - call AddNewDeriv( "WDEP_PREC","PREC ","-","-", "mm", & - -1, -99, F, 1.0, F, IOU_DAY ) - - else if ( WDEP_WANTED(ind)%txt2 == "GROUP" ) then - - ! just get units text here - call Units_Scale(WDEP_WANTED( ind )%txt3, -1, unitscale, unittxt, volunit) - - dname = "WDEP_" // trim(WDEP_WANTED( ind )%txt1) - call AddNewDeriv( dname, "WDEP ","-","-", unittxt , & - -1, -99, F, 1.0e6, F, IOU_DAY ) - - else ! SPEC - - itot = find_index( trim(WDEP_WANTED(ind)%txt1) , species(:)%name ) - iadv = itot - NSPEC_SHL - - ! Without units for now: - dname = "WDEP_" // trim(WDEP_WANTED( ind )%txt1) - call CheckStop(itot<0, "WDEP_WANTED Species not found " // trim(dname) ) - - call Units_Scale(WDEP_WANTED( ind )%txt3, itot, unitscale, unittxt, volunit) - call AddNewDeriv( dname, "WDEP", "-", "-", unittxt , & - iadv , -99, F, unitscale, F, IOU_DAY ) - end if - if(MasterProc) write(*,*) "Wet deposition output: ", trim(dname), " ", trim(unittxt) -end do + if ( outtyp == "MISC" ) then ! Simple species + + iout = -99 ! find_index( wanted_deriv2d(i), def_2d(:)%name ) + class = trim(OutputFields(ind)%txt4) + unitscale = 1.0 + if(outunit=="ppb") unitscale = PPBINV + if(any(class==(/"PM25 ","PM25X ",& + "PM25_rh50 ","PM25X_rh50","PM10_rh50 "/)))then + iadv = -1 ! Units_Scale(iadv=-1) returns 1.0 + ! uggroup_calc gets the unit conversion factor from Group_Units + unitscale = Units_Scale(outunit, iadv, unittxt, volunit) + if(MasterProc) write(*,*)"FRACTION UNITSCALE ", unitscale + endif -call AddNewDeriv( "SURF_ppbC_VOC", "VOC", "-", "-", "ppb", & - -1 , -99, F, PPBINV, T, IOU_DAY ) + if(MasterProc ) write(*,"(i3,a,i4,a)") me, & + "Deriv:D2MET " // trim(outname), outind, trim(class) + + call AddNewDeriv( outname,class, "-","-", outunit, & + iout, -99, F, unitscale, T, outind ) + + else ! SPEC and GROUPS of specs. + + select case(outtyp) + case("SPEC") ! Simple species + iadv = find_index(outname, species_adv(:)%name ) + call CheckStop(iadv<0,"OutputFields Species not found "//trim(outname)) + txt = "SURF_UG" + iout = iadv + case("GROUP") ! groups of species + iadv = -1 ! Units_Scale(iadv=-1) returns 1.0 + ! uggroup_calc gets the unit conversion factor from Group_Units + igrp = find_index(outname, GROUP_ARRAY(:)%name ) +!-- Emergency: Volcanic Eruption. Skipp groups if not found + if(outname(1:3)=="ASH")then + if(MasterProc.and.USE_EMERGENCY.and.DEBUG_EMERGENCY)& + write(*,"(A,1X,I0,':',A)")'EMERGENCY: group ',igrp,trim(outname) + if(igrp<1)cycle + endif + call CheckStop(igrp<0,"OutputFields Group not found "//trim(outname)) + txt = "SURF_UG_GROUP" ! ppb not implementde yet + iout = igrp + case default + call StopAll("Derived:OutputFields Error "//trim(outtyp)//":"//trim(outname)) + endselect + + unitscale = Units_Scale(outunit, iadv, unittxt, volunit) + + class = "SURF_MASS_" // trim(outtyp) + if(volunit) class = "SURF_PPB_" // trim(outtyp) + call CheckStop(class=="SURF_PPB_GROUP",& + "SURF_PPB_GROUPS not implemented yet:"// trim(dname) ) + + dname = "SURF_" // trim( outunit ) // "_" // trim( outname ) + + if( DEBUG.and.MasterProc ) write(*,"(a,2i4,3(1x,a),2L3,i4,es10.2)") & + "ADD ", ind, iout, trim(dname),";", trim(class), outmm, outdd, & + OutputFields(ind)%ind,unitscale + + call AddNewDeriv( dname, class, "-", "-", trim( unittxt ) , & + iout , -99, F, unitscale, T, OutputFields(ind)%ind ) + + if(outdim == "3d") then + + class = "3D_MASS_"//trim(outtyp) + if(volunit .and. iadv > 0) class = "3D_PPB_"//trim(outtyp) + + dname = "D3_"//trim(outunit)//"_"//trim(outname) + + ! Always print out 3D info. Good to help avoid using 3d unless really needed! + if( MasterProc ) write(*,"(a,3(1x,a),a,L3,a,L3,i4,es10.2)") " ADDED 3D outputs", & + trim(dname)," ; class =", trim(class), ', monthly =',outmm,', daily =',outdd + !, OutputFields(ind)%ind,unitscale + + call AddNewDeriv(dname, class, "-", "-", trim( unittxt ) , & + iout , -99, F, unitscale, T, OutputFields(ind)%ind, & + Is3D=.true. ) + endif ! 3d + + endif +enddo ! OutputFields + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +do ind = 1, size(WDEP_WANTED(:)%txt1) + dname = "WDEP_"//trim(WDEP_WANTED(ind)%txt1) + select case(WDEP_WANTED(ind)%txt2) + case("PREC") + call AddNewDeriv("WDEP_PREC","PREC ","-","-", "mm", & + -1, -99, F, 1.0, F, IOU_DAY ) + case("SPEC") + iadv = find_index(WDEP_WANTED(ind)%txt1, species_adv(:)%name) + call CheckStop(iadv<1, "WDEP_WANTED Species not found " // trim(dname) ) + + unitscale = Units_Scale(WDEP_WANTED(ind)%txt3, iadv, unittxt) + call AddNewDeriv( dname, "WDEP", "-", "-", unittxt , & + iadv, -99, F, unitscale, F, IOU_DAY) + case("GROUP") + igrp = find_index(dname, chemgroups(:)%name) + call CheckStop(igrp<1, "WDEP_WANTED Group not found " // trim(dname) ) + + ! Just get units text here. + ! Init_WetDep gets the unit conversion factors from Group_Scale. + unitscale = Units_Scale(WDEP_WANTED(ind)%txt3, -1, unittxt) + call AddNewDeriv( dname, "WDEP ","-","-", unittxt , & + igrp, -99, F, 1.0, F, IOU_DAY) + case default + call CheckStop("Unknown WDEP_WANTED type " // trim(WDEP_WANTED(ind)%txt2) ) + endselect + if(MasterProc) write(*,*)"Wet deposition output: ",trim(dname)," ",trim(unittxt) +enddo !Emissions: ! We use mg/m2 outputs for consistency with depositions @@ -520,23 +574,22 @@ subroutine Define_Derived() ! BVOC called every dt_advec, so use dt_scale=1.0e6 to get from kg/m2/s to ! mg/m2 accumulated (after multiplication by dt_advec) - !Deriv(name, class, subc, txt, unit - !Deriv index, f2d, dt_scale, scale, avg? rho Inst Yr Mn Day atw + ! AddNewDeriv( name,class,subclass,txt,unit, + ! index,f2d, dt_scale,scale, avg,iotype,Is3D) - do ind = 1, size(BVOC_GROUP) - itot = BVOC_GROUP(ind) - dname = "Emis_mgm2_" // trim(species(itot)%name) + do ind = 1, NEMIS_BioNat !DSA12 size(BVOC_GROUP) + dname = "Emis_mgm2_BioNat" // trim(EMIS_BioNat(ind) ) call AddNewDeriv( dname, "NatEmis", "-", "-", "mg/m2", & - ind , -99, T , 1.0e6, F, IOU_DAY ) + ind , -99, T , 1.0e6, F, IOU_DAY ) end do ! SNAP emissions called every hour, given in kg/m2/s, but added to -! d_2d every advection step, so get kg/m2. +! d_2d every advection step, so get kg/m2. ! Need 1.0e6 to get from kg/m2 to mg/m2 accumulated. ! ! Future option - might make use of Emis_Molwt to get mg(N)/m2 -do ind = 1, size(EMIS_NAME) - dname = "Emis_mgm2_" // trim(EMIS_NAME(ind)) +do ind = 1, size(EMIS_FILE) + dname = "Emis_mgm2_" // trim(EMIS_FILE(ind)) call AddNewDeriv( dname, "SnapEmis", "-", "-", "mg/m2", & ind , -99, T, 1.0e6, F, IOU_DAY ) end do ! ind @@ -544,19 +597,21 @@ subroutine Define_Derived() call AddNewDeriv("SURF_PM25water", "PM25water", "-", "-", "-", & -99 , -99, F, 1.0, T, IOU_DAY ) +!call AddNewDeriv("SURF_PM25", "PM25", "-", "-", "-", & +! -99 , -99, F, 1.0, T, IOU_DAY ) call AddNewDeriv("AOD", "AOD", "-", "-", "-", & - -99 , -99, F, 1.0, T, IOU_DAY ) + -99 , -99, F, 1.0, T, IOU_DAY ) + ! As for GRIDAOT, we can use index for the threshold call AddNewDeriv( "SOMO35","SOMO", "SURF","-", "ppb.day", & - 35, -99, F, 1.0, F, IOU_MON ) + 35, -99, F, 1.0, F, IOU_MON ) call AddNewDeriv( "SOMO0 ","SOMO", "SURF","-", "ppb.day", & - 0 , -99, F, 1.0, F, IOU_MON ) - + 0 , -99, F, 1.0, F, IOU_MON ) +if(iadv_o3>0) & call AddNewDeriv( "SURF_MAXO3","MAXADV", "O3","-", "ppb", & - IXADV_O3, -99, F, PPBINV, F, IOU_DAY) - + iadv_o3, -99, F, PPBINV, F, IOU_DAY) !-- 3-D fields @@ -594,8 +649,15 @@ subroutine Define_Derived() ind = find_index( wanted_deriv2d(i), def_2d(:)%name ) if (ind>0) then f_2d(i) = def_2d(ind) + if ( found_ind2d(ind) > 0 ) then + print *, "YYYY", me, trim( wanted_deriv2d(i) ) + do n = 1, size(def_2d(:)%name) + print *, "YYYY def2d", n, trim( def_2d(n)%name ) + end do + call CheckStop ( found_ind2d(ind) > 0, & "REQUESTED 2D DERIVED ALREADY DEFINED: " // trim( def_2d(ind)%name) ) + end if found_ind2d(ind) = 1 else print *,"OOOPS wanted_deriv2d not found: ", wanted_deriv2d(i) @@ -644,12 +706,14 @@ subroutine Define_Derived() if (SOURCE_RECEPTOR.and..not.FORECAST)& ! We assume that no daily & hourly outputs iou_max=IOU_MON ! are wanted on SOURCE_RECEPTOR mode - if (SOURCE_RECEPTOR) & ! We need yearly for SR always + if (SOURCE_RECEPTOR) & ! We need yearly for SR always iou_min=IOU_YEAR ! if (FORECAST) & ! Only dayly & hourly outputs iou_min=IOU_DAY ! are wanted on FORECAST mode + if (MasterProc) print "(a,2i4)","IOU_MAX ", iou_max, iou_min + end subroutine Define_Derived !========================================================================= subroutine Setups() @@ -684,7 +748,8 @@ subroutine Setups() end if end do !==================================================================== - if (DEBUG .and. MasterProc )then + !if (DEBUG .and. MasterProc )then + if ( MasterProc )then write(6,*) "Derived VOC setup returns ", nvoc, "vocs" write(6,"(a12,/,(20i3))") "indices ", voc_index(1:nvoc) write(6,"(a12,/,(20i3))") "carbons ", voc_carbon(1:nvoc) @@ -721,9 +786,11 @@ subroutine Derived(dt,End_of_Day) real, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: inv_air_density3D ! Inverse of No. air mols/cm3 = 1/M ! where M = roa (kgair m-3) * MFAC when ! scale in ug, else 1 - logical :: first_call = .true. + logical, save :: first_call = .true. integer :: ipm25, ipmc ! will save some calcs for pm10 - integer :: igrp, ngrp ! DS new group methods + integer :: igrp, ngrp ! group methods + integer, save :: ind_pmfine = -999, ind_pmwater = -999, & !needed for PM25 + ind_pm10 = -999 timefrac = dt/3600.0 thour = current_date%hour+current_date%seconds/3600.0 @@ -732,7 +799,7 @@ subroutine Derived(dt,End_of_Day) current_date%day) - ! Jan 2011 - just calculate once, and use where needed + ! Just calculate once, and use where needed forall ( i=1:limax, j=1:ljmax ) density(i,j) = roa(i,j,KMAX_MID,1) @@ -773,8 +840,9 @@ subroutine Derived(dt,End_of_Day) end if index = f_2d(n)%index - if ( DEBUG .and. MasterProc .and. first_call ) then - write(*,"(a,i4,a,i4,a)") "DEBUG Derived 2d", n, & + !if ( DEBUG .and. MasterProc .and. first_call ) then + if ( MasterProc .and. first_call ) then + write(*,"(a,i4,a,i4,a)") "1st call Derived 2d", n, & trim(f_2d(n)%name), index, trim(typ) end if @@ -783,25 +851,38 @@ subroutine Derived(dt,End_of_Day) forall ( i=1:limax, j=1:ljmax ) d_2d( n, i,j,IOU_INST) = ustar_nwp(i,j) end forall + case ( "Kz_m2s" ) + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = Kz_m2s(i,j,KMAX_MID) + end forall case ( "ws_10m" ) forall ( i=1:limax, j=1:ljmax ) d_2d( n, i,j,IOU_INST) = ws_10m(i,j,1) end forall + case ( "rh2m" ) + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = rh2m(i,j,1) + end forall case ( "u_ref" ) forall ( i=1:limax, j=1:ljmax ) d_2d( n, i,j,IOU_INST) = u_ref(i,j) end forall - case ( "SoilWater_deep" ) + !case ( "SoilWater_deep" ) + case ( "SMI_deep" ) forall ( i=1:limax, j=1:ljmax ) d_2d( n, i,j,IOU_INST) = SoilWater_deep(i,j,1) end forall if ( debug_flag ) call write_debug(n,index, "SoilWater_DEEP") + !if(debug_flag) print *, "SOILW_DEEP ", n, SoilWater_deep(2,2,1) - case ( "SoilWater" ) ! Not used so far. (=shallow) + !case ( "SoilWater_uppr" ) ! Not used so far. (=shallow) + case ( "SMI_uppr" ) forall ( i=1:limax, j=1:ljmax ) - d_2d( n, i,j,IOU_INST) = SoilWater_deep(i,j,1) + d_2d( n, i,j,IOU_INST) = SoilWater_uppr(i,j,1) end forall + if ( debug_flag ) call write_debug(n,index, "SoilWater_uppr") + !if(debug_flag) print *, "SOILW_UPPR ", n, SoilWater_uppr(2,2,1) case ( "T2m" ) forall ( i=1:limax, j=1:ljmax ) @@ -866,23 +947,124 @@ subroutine Derived(dt,End_of_Day) forall ( i=1:limax, j=1:ljmax ) d_2d( n, i,j,IOU_INST) = PM25_water_rh50(i,j) end forall + ind_pmwater = n + + case ( "PM25" ) ! Need to add PMFINE + fraction NO3_c + if(first_call)then + call CheckStop(f_2d(n)%unit/="ug","Wrong unit for "//trim(typ)) + call CheckStop(iadv_NO3_C<1,"Unknown specie NO3_C") + endif + + !scale = 62.0 + ! All this size class has the same cfac. + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = d_2d(ind_pmfine,i,j,IOU_INST) + & + fracPM25 * & + ( xn_adv(iadv_NO3_C,i,j,KMAX_MID) * ug_NO3_C & + ) * cfac(iadv_NO3_C,i,j) * density(i,j) + end forall + + case ( "PM25_rh50" ) ! Need to add PMFINE + fraction NO3_c + if(first_call)then + call CheckStop(f_2d(n)%unit/="ug","Wrong unit for "//trim(typ)) + call CheckStop(iadv_NO3_C<1,"Unknown specie NO3_C") + endif + + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = d_2d(ind_pmfine ,i,j,IOU_INST) & +! + PM25_water_rh50(i,j)*ATWAIR/PPBINV & + + d_2d(ind_pmwater,i,j,IOU_INST) & + + fracPM25 * & + ( xn_adv(iadv_NO3_C,i,j,KMAX_MID) * ug_NO3_C & + ) * cfac(iadv_NO3_C,i,j) * density(i,j) + end forall + + case ( "PM25X" ) ! Need to add PMFINE + fraction NO3_c + if(first_call)then + call CheckStop(f_2d(n)%unit/="ug","Wrong unit for "//trim(typ)) + call CheckStop(iadv_NO3_C <1,"Unknown specie NO3_C") + call CheckStop(iadv_EC_C_WOOD <1,"Unknown specie EC_C_WOOD") + call CheckStop(iadv_EC_C_FFUEL <1,"Unknown specie EC_C_FFUEL") + call CheckStop(iadv_POM_C_FFUEL<1,"Unknown specie POM_C_FFUEL") + endif + + !scale = 62.0 + ! All this size class has the same cfac. + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = d_2d(ind_pmfine,i,j,IOU_INST) + & + fracPM25 * & + ( xn_adv(iadv_NO3_C ,i,j,KMAX_MID) * ug_NO3_C & + + xn_adv(iadv_EC_C_WOOD ,i,j,KMAX_MID) * ug_EC_C_WOOD & + + xn_adv(iadv_EC_C_FFUEL ,i,j,KMAX_MID) * ug_EC_C_FFUEL & + + xn_adv(iadv_POM_C_FFUEL,i,j,KMAX_MID) * ug_POM_C_FFUEL & + ) * cfac(iadv_NO3_C,i,j) * density(i,j) + end forall + + case ( "PM25X_rh50" ) ! Need to add PMFINE + fraction NO3_c + water + if(first_call)then + call CheckStop(f_2d(n)%unit/="ug","Wrong unit for "//trim(typ)) + call CheckStop(iadv_NO3_C <1,"Unknown specie NO3_C") + call CheckStop(iadv_EC_C_WOOD <1,"Unknown specie EC_C_WOOD") + call CheckStop(iadv_EC_C_FFUEL <1,"Unknown specie EC_C_FFUEL") + call CheckStop(iadv_POM_C_FFUEL<1,"Unknown specie POM_C_FFUEL") + endif + + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = d_2d(ind_pmfine ,i,j,IOU_INST) & +! + PM25_water_rh50(i,j)*ATWAIR/PPBINV & + + d_2d(ind_pmwater,i,j,IOU_INST) & + + fracPM25 * & + ( xn_adv(iadv_NO3_C ,i,j,KMAX_MID) * ug_NO3_C & + + xn_adv(iadv_EC_C_WOOD ,i,j,KMAX_MID) * ug_EC_C_WOOD & + + xn_adv(iadv_EC_C_FFUEL ,i,j,KMAX_MID) * ug_EC_C_FFUEL & + + xn_adv(iadv_POM_C_FFUEL,i,j,KMAX_MID) * ug_POM_C_FFUEL & + ) * cfac(iadv_NO3_C,i,j) * density(i,j) + end forall + + case ( "PM10_rh50" ) ! Need to add PMFINE + fraction NO3_c + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = d_2d(ind_pm10 ,i,j,IOU_INST) & +! + PM25_water_rh50(i,j)*ATWAIR/PPBINV & + + d_2d(ind_pmwater,i,j,IOU_INST) + end forall + + if(DEBUG.and. debug_proc ) then + if(first_call)then + call CheckStop(f_2d(n)%unit/="ug","Wrong unit for "//trim(typ)) + call CheckStop(iadv_NO3_C <1,"Unknown specie NO3_C") + call CheckStop(iadv_EC_C_WOOD <1,"Unknown specie EC_C_WOOD") + call CheckStop(iadv_EC_C_FFUEL <1,"Unknown specie EC_C_FFUEL") + call CheckStop(iadv_POM_C_FFUEL<1,"Unknown specie POM_C_FFUEL") + endif + write(*,*) "FRACTION PM25", n, ind_pmfine, ind_pmwater + i= debug_li; j=debug_lj + write(*,"(a,2i4,4es12.3)") "Adding PM25FRACTIONS:", n, ind_pmfine, & +! PM25_water_rh50(i,j)* ATWAIR/PPBINV, & + d_2d(ind_pmwater,i,j,IOU_INST), & + d_2d(ind_pmfine ,i,j,IOU_INST), d_2d( n, i,j,IOU_INST), & + ug_NO3_C * xn_adv(iadv_NO3_C,i,j,KMAX_MID) & + * cfac(iadv_NO3_C,i,j) * density(i,j) + write(*,"(a,i4,f5.2,4es12.3)") "CFAC PM25FRACTIONS:", n, fracPM25, & + cfac(iadv_NO3_C ,i,j), cfac(iadv_POM_C_FFUEL,i,j), & + cfac(iadv_EC_C_WOOD,i,j), cfac(iadv_EC_C_FFUEL ,i,j) + endif case ( "AOD" ) !/ Aerosol Optical Depth forall ( i=1:limax, j=1:ljmax ) - d_2d( n, i,j,IOU_INST) = AOD(i,j) + d_2d( n, i,j,IOU_INST) = AOD(i,j) end forall case ( "MAXADV" ) - if ( f_2d(n)%unit == "ppb" ) then + if ( f_2d(n)%unit == "ppb" ) then d_2d( n, 1:limax,1:ljmax,IOU_DAY) = & max( d_2d( n, 1:limax,1:ljmax,IOU_DAY), & xn_adv(index,1:limax,1:ljmax,KMAX_MID) & * cfac(index,1:limax,1:ljmax) ) txt2 = "MAXADV ppb for " // trim( f_2d(n)%name) - else + else d_2d( n, 1:limax,1:ljmax,IOU_DAY) = & max( d_2d( n, 1:limax,1:ljmax,IOU_DAY), & xn_adv(index,1:limax,1:ljmax,KMAX_MID) & @@ -943,9 +1125,11 @@ subroutine Derived(dt,End_of_Day) call voc_2dcalc() - case( "GRIDAOT" ) ! Hardly used these days. The vegetation-specific + case( "GRIDAOT" )! Hardly used these days. The vegetation-specific ! AOTs are handled in the Mosaic class and as ! part of the dry dep calculations. + if(first_call)& + call CheckStop(iadv_o3<1,"Unknown specie O3") d_2d(n, 1:limax, 1:ljmax, IOU_INST) = & Calc_GridAOTx( f_2d(n)%index, debug_proc,"DERIVAOT") @@ -953,13 +1137,14 @@ subroutine Derived(dt,End_of_Day) if( DEBUG_AOT .and. debug_proc ) then call datewrite("AOTDEBUG" // trim(f_2d(n)%name), n, & (/ zen(debug_li,debug_lj), real(f_2d(n)%index), & - xn_adv(IXADV_O3,debug_li,debug_lj,KMAX_MID)*& - cfac(IXADV_O3,debug_li,debug_lj)*PPBINV, & + xn_adv(iadv_O3,debug_li,debug_lj,KMAX_MID)*& + cfac(iadv_O3,debug_li,debug_lj)*PPBINV, & d_2d(n, debug_li, debug_lj, IOU_INST ) /) ) end if case( "SOMO" ) - + if(first_call)& + call CheckStop(iadv_o3<1,"Unknown specie O3") !dt/7200: half a dt time step in hours !dayfrac "points" to the middle of the integration step @@ -969,12 +1154,12 @@ subroutine Derived(dt,End_of_Day) !last value (not averaged): D2_O3_DAY( : , : , ntime) =& - xn_adv(IXADV_O3,:,:,KMAX_MID)*cfac(IXADV_O3,:,:)*PPBINV + xn_adv(iadv_o3,:,:,KMAX_MID)*cfac(iadv_o3,:,:)*PPBINV if(dayfrac<0)then !only at midnight: write on d_2d - call somo_calc( n, f_2d(n)%index, DEBUG .and. debug_proc ) + call somo_calc( n, f_2d(n)%index, DEBUG .and. debug_proc ) d_2d(n,:,:,IOU_MON ) = d_2d(n,:,:,IOU_MON ) + d_2d(n,:,:,IOU_DAY) ! if(current_date%month>=4.and.current_date%month<=9)then @@ -1022,7 +1207,6 @@ subroutine Derived(dt,End_of_Day) d_2d( n, debug_li, debug_lj, IOU_INST) - !case ( "ECOAREA" ) case ( "EcoFrac" ) ! ODD TO HAVE FRAC AND AREA BELOW:"ECOAREA" ) if( .not. first_call ) cycle ! Only need to do once @@ -1047,13 +1231,13 @@ subroutine Derived(dt,End_of_Day) case ( "NatEmis" ) !emissions in kg/m2/s converted?? forall ( i=1:limax, j=1:ljmax ) - d_2d(n,i,j,IOU_INST) = EmisNat( i,j, f_2d(n)%Index) + d_2d(n,i,j,IOU_INST) = EmisNat( f_2d(n)%Index,i,j ) end forall !Not done, keep mg/m2 * GridArea_m2(i,j) if ( debug_flag ) call write_debug(n,f_2d(n)%Index, "NatEmis") if( debug_flag ) & call datewrite("NatEmis-in-Derived, still kg/m2/s", & - f_2d(n)%Index, (/ EmisNat( debug_li,debug_lj, f_2d(n)%Index) /) ) + f_2d(n)%Index, (/ EmisNat( f_2d(n)%Index, debug_li,debug_lj) /) ) case ( "SnapEmis" ) !emissions in kg/m2/s converted?? @@ -1075,22 +1259,44 @@ subroutine Derived(dt,End_of_Day) n, f_2d(n)%name, " is ", d_2d(n,debug_li,debug_lj,IOU_INST) - case ( "SURF_MASS_GROUP" ) ! - igrp = f_2d(n)%index + case ( "SURF_MASS_GROUP" ) ! + igrp = f_2d(n)%index call CheckStop(igrp<1, "NEG GRP "//trim(f_2d(n)%name) ) call CheckStop(igrp>size( GROUP_ARRAY(:)%name ), & "Outside GRP "//trim(f_2d(n)%name) ) ngrp = GROUP_ARRAY(igrp)%Ngroup + + if( GROUP_ARRAY(igrp)%name == "PMFINE" .and. ind_pmfine<0 ) then + ind_pmfine = n + if( MasterProc) write(*,"(a,2i4,2a15)") "FOUND FINE FRACTION ",& + n, ind_pmfine, & + trim(GROUP_ARRAY(igrp)%name), trim(f_2d(n)%name) + end if + if( GROUP_ARRAY(igrp)%name == "PM10" .and. ind_pm10<0 ) then + ind_pm10 = n + if( MasterProc) write(*,"(a,2i4,2a15)") "FOUND PM10 FRACTION ",& + n, ind_pm10, & + trim(GROUP_ARRAY(igrp)%name), trim(f_2d(n)%name) + end if if(DEBUG.and. MasterProc ) then write(*,*) "CASEGRP ", n, igrp, ngrp, trim(typ) write(*,*) "CASENAM ", trim(f_2d(n)%name) - write(*,*) "CASEGRP:", GROUP_ARRAY(igrp)%itot(1:ngrp) + write(*,*) "CASEGRP:", GROUP_ARRAY(igrp)%itot(1:ngrp) write(*,*) "CASEunit", trim(f_2d(n)%unit) end if - call uggroup_calc( d_2d(n,:,:,IOU_INST), n, typ, & - GROUP_ARRAY(igrp)%itot(1:ngrp) , density, 0, & - GROUP_ARRAY(igrp)%name ) + call uggroup_calc(d_2d(n,:,:,IOU_INST), density, & + f_2d(n)%unit, 0, igrp) + if(DEBUG.and. debug_proc .and. n==ind_pmfine ) then + i= debug_li; j=debug_lj + write(*,"(a,2i4,3es12.3)") "PMFINE FRACTION:", n, ind_pmfine, & + d_2d(ind_pmfine,i,j,IOU_INST) + end if + if(DEBUG.and. debug_proc .and. n==ind_pm10 ) then + i= debug_li; j=debug_lj + write(*,"(a,2i4,3es12.3)") "PM10 FRACTION:", n, ind_pm10, & + d_2d(ind_pm10,i,j,IOU_INST) + end if case default @@ -1130,14 +1336,17 @@ subroutine Derived(dt,End_of_Day) d_2d(n,:,:,IOU_YEAR ) + af*d_2d(n,:,:,IOU_INST) if ( f_2d(n)%avg ) nav_2d(n,IOU_YEAR) = nav_2d(n,IOU_YEAR) + 1 - if( debug_flag .and. n == 27 ) & ! C5H8 BvocEmis: - call datewrite("NatEmis-end-Derived", n, (/ af, & - SumSnapEmis( debug_li,debug_lj, f_2d(n)%Index), & - d_2d(n,debug_li,debug_lj,IOU_INST), & - d_2d(n,debug_li,debug_lj,IOU_DAY), & - d_2d(n,debug_li,debug_lj,IOU_MON), & - d_2d(n,debug_li,debug_lj,IOU_YEAR) & - /) ) + !if( debug_flag .and. n == 27 ) then ! C5H8 BvocEmis: + !if( n == 27 ) then ! C5H8 BvocEmis: + ! print *, " TESTING NatEmis ", n, af, f_2d(n)%Index, f_2d(n) + ! call datewrite("NatEmis-end-Derived", n, (/ af, & + ! SumSnapEmis( debug_li,debug_lj, f_2d(n)%Index), & + ! d_2d(n,debug_li,debug_lj,IOU_INST), & + ! d_2d(n,debug_li,debug_lj,IOU_DAY), & + ! d_2d(n,debug_li,debug_lj,IOU_MON), & + ! d_2d(n,debug_li,debug_lj,IOU_YEAR) & + ! /) ) + !end if end do ! num_deriv2d @@ -1153,7 +1362,7 @@ subroutine Derived(dt,End_of_Day) index = f_3d(n)%index - if ( f_3d(n)%unit == "ppb" ) then + if ( f_3d(n)%unit == "ppb" ) then inv_air_density3D(:,:,:) = 1.0 else !OLD if ( f_3d(n)%rho ) then forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) @@ -1194,17 +1403,17 @@ subroutine Derived(dt,End_of_Day) d_3d( n, i,j,k,IOU_INST) = th(i,j,k,1) end forall - case ("T " ) ! Absolute Temperature + case ("T " ) ! Absolute Temperature forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) d_3d( n, i,j,k,IOU_INST) = th(i,j,k,1)& *exp(KAPPA*log((PT+sigma_mid(k)*(ps(i,j,1) - PT))*1.e-5)) - !NB: PT and PS in Pa + !NB: PT and PS in Pa end forall case ( "MAX3DSHL" ) ! Daily maxima - short-lived - if ( f_3d(n)%unit == "ppb" ) then + if ( f_3d(n)%unit == "ppb" ) then call CheckStop("Asked for MAX3DSHL ppb ") else forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) @@ -1253,8 +1462,8 @@ subroutine Derived(dt,End_of_Day) end forall if ( debug_flag ) call write_debugadv(n,index, 1.0, "3D UG OUTS") - case ( "3D_MASS_GROUP" ) ! - igrp = f_3d(n)%index + case ( "3D_MASS_GROUP" ) ! + igrp = f_3d(n)%index call CheckStop(igrp<1, "NEG GRP "//trim(f_3d(n)%name) ) call CheckStop(igrp>size( GROUP_ARRAY(:)%name ), & "Outside GRP "//trim(f_3d(n)%name) ) @@ -1262,15 +1471,13 @@ subroutine Derived(dt,End_of_Day) if(DEBUG.and. MasterProc ) then write(*,*) "3DCASEGRP ", n, igrp, ngrp, trim(typ) write(*,*) "3DCASENAM ", trim(f_3d(n)%name) - write(*,*) "3DCASEGRP:", GROUP_ARRAY(igrp)%itot(1:ngrp) + write(*,*) "3DCASEGRP:", GROUP_ARRAY(igrp)%itot(1:ngrp) write(*,*) "3DCASEunit", trim(f_3d(n)%unit) - end if - + endif do k=1,KMAX_MID - call uggroup_calc( d_3d(n,:,:,k,IOU_INST), n, typ, & - GROUP_ARRAY(igrp)%itot(1:ngrp) , & - roa(:,:,k,1), k, GROUP_ARRAY(igrp)%name ) - end do + call uggroup_calc(d_3d(n,:,:,k,IOU_INST), roa(:,:,k,1), & + f_3d(n)%unit, k, igrp) + enddo case ( "Kz" ) @@ -1403,13 +1610,13 @@ subroutine ResetDerived(period) integer, intent(in) :: period ! Either IOU_DAY or IOU_MON if ( period <= LENOUT2D ) then - nav_2d (:,period) = 0.0 + nav_2d (:,period) = 0 d_2d(:,:,:,period) = 0.0 end if if ( num_deriv3d > 0 .and. period <= LENOUT3D ) then - nav_3d (:,period) = 0.0 + nav_3d (:,period) = 0 d_3d(:,:,:,:,period) = 0.0 end if @@ -1458,78 +1665,37 @@ subroutine voc_3dcalc() end subroutine voc_3dcalc !========================================================================= - subroutine uggroup_calc( ug_2d, n, class, group, density, ik, gname) +subroutine uggroup_calc( ug_2d, density, unit, ik, igrp) !/-- calulates e.g. SIA = SO4 + pNO3_f + pNO3_c + aNH4 ! (only SIA converted to new group system so far, rv3_5_6 ) !/-- calulates also PM10 = SIA + PPM2.5 + PPMCOARSE - real, dimension(:,:), intent(inout) :: ug_2d ! i,j section of d_2d arrays - character(len=*) :: class ! Type of data - integer, intent(in) :: n ! - !character(len=*) :: unit ! - integer, intent(in), dimension(:) :: group + real, dimension(:,:), intent(out) :: ug_2d ! i,j section of d_2d arrays real, intent(in), dimension(MAXLIMAX,MAXLJMAX) :: density - integer, intent(in) :: ik - character(len=*),intent(in), optional :: gname ! group name - integer :: ig, iadv, itot,k - real :: scale - character(len=10) :: unit="" - - if(DEBUG .and. debug_proc) then - write(*,"(a,i4,L1,2i4)") "DEBUG GROUP-PM-N", size(group),debug_proc,me,ik - if ( present(gname ) ) write(*,*) " GNAME ", trim(gname) - end if - - if (ik==0 .and. n<=num_deriv2d) then - k=KMAX_MID - unit=f_2d(n)%unit - elseif (ik/=0 .and. n<=num_deriv3d) then - k=ik - unit=f_3d(n)%unit + character(len=*), intent(in) :: unit + integer, intent(in) :: ik,igrp + + integer, pointer, dimension(:) :: gspec=>null() ! group array of indexes + real, pointer, dimension(:) :: gunit_conv=>null() ! & unit conv. factors + + if(DEBUG.and.debug_proc) & + write(*,"(a,L1,2i4)") "DEBUG GROUP-PM-N",debug_proc,me,ik + call CheckStop(unit(1:2)/="ug","uggroup: Invalid deriv/level") + call Group_Units(igrp,unit,gspec,gunit_conv,debug=DEBUG.and.debug_proc) + + if(ik==0)then + forall(i=1:limax,j=1:ljmax) & + ug_2d(i,j) = dot_product(xn_adv(gspec(:),i,j,KMAX_MID),& + cfac(gspec(:),i,j)*gunit_conv(:)) & + * density(i,j) else - k=-1 - unit="not_found" + forall(i=1:limax,j=1:ljmax) & + ug_2d(i,j) = dot_product(xn_adv(gspec(:),i,j,ik),gunit_conv(:)) & + * density(i,j) endif - - ug_2d( :,:) = 0.0 - scale = 0.0 ! safety - do ig = 1, size(group) - itot = group(ig) - iadv = group(ig) - NSPEC_SHL - - select case (trim(unit)) - case("ug/m3" ); scale = species(itot)%molwt - case("ugN/m3"); scale = species(itot)%nitrogens - case default - if(ik==0) print *, "uggroup Wrong Units 2d "//trim(f_2d(n)%name) - if(ik/=0) print *, "uggroup Wrong Units 3d "//trim(f_3d(n)%name) - call StopAll("uggroup called with wrong unit='"//unit//"'!") - end select - - if(ik==0)then - forall ( i=1:limax, j=1:ljmax ) - ug_2d( i,j) = ug_2d( i,j) + xn_adv(iadv,i,j,k) *scale * cfac(iadv,i,j) - end forall - else - forall ( i=1:limax, j=1:ljmax ) - ug_2d( i,j) = ug_2d( i,j) + xn_adv(iadv,i,j,k) *scale - end forall - endif - - if(DEBUG .and. debug_proc) then - i=debug_li - j=debug_lj - write(*,"(a,i4,a,2i4,f6.1,2es12.3)") "DEBUG GROUP-PM", ig, & - trim(species(itot)%name), iadv, species(itot)%molwt,& - scale, xn_adv(iadv,i,j,k), ug_2d(i,j) - end if - end do !n - forall ( i=1:limax, j=1:ljmax ) - ug_2d( i,j) = ug_2d( i,j) * density(i,j) - end forall - - end subroutine uggroup_calc + deallocate(gspec,gunit_conv) +end subroutine uggroup_calc !========================================================================= subroutine somo_calc( n, iX, debug_flag ) @@ -1570,7 +1736,7 @@ subroutine somo_calc( n, iX, debug_flag ) if ( debug_flag .and. i==debug_li .and. j==debug_lj ) then write(*,"(a,2i4,f12.3)") "SOMO DEBUG ", n, iX, o3 end if - + o3 = max( o3 - iX , 0.0 ) ! Definition of SOMOs @@ -1606,52 +1772,4 @@ subroutine write_debug(n,index,txt) end subroutine write_debug !========================================================================= - subroutine Units_Scale(txt,itot,unitscale,unitstxt, volunit) - character(len=*), intent(in) :: txt - integer, intent(in) :: itot ! species index, used if > 0 - real, intent(out) :: unitscale - character(len=*), intent(out) :: unitstxt - logical, intent(out) :: volunit - - real, save :: ugSm3 = atwS*PPBINV/ATWAIR - real, save :: ugNm3 = atwN*PPBINV/ATWAIR - real, save :: ugCm3 = 12*PPBINV/ATWAIR - real, save :: ugXm3 = PPBINV/ATWAIR ! will be multiplied by molwwt(X) -!ds real, save :: ugPM = PPBINV /ATWAIR ! No multiplication needed - - volunit = .false. - - if ( txt .eq. "ugS" ) then - unitscale = ugSm3 - unitstxt = "ugS/m3" - else if ( txt .eq. "ugN" ) then - unitscale = ugNm3 - unitstxt = "ugN/m3" - else if ( txt .eq. "ugC" ) then - unitscale = ugCm3 - unitstxt = "ugC/m3" - else if ( txt .eq. "ug" ) then - unitscale = ugXm3 ! will be multplied by species(itot)%molwt later - unitstxt = "ug/m3" - if( itot>0) unitscale = ugXm3 * species(itot)%molwt - - else if ( txt .eq. "ppb" ) then - unitscale = PPBINV - unitstxt = "ppb" - volunit = .true. - - else if ( txt .eq. "mgS" ) then ! For wet deposition - unitscale = 1.0e6 - unitstxt = "mgS/m2" - else if ( txt .eq. "mgN" ) then - unitscale = 1.0e6 - unitstxt = "mgN/m2" - else if ( txt .eq. "mgSS" ) then - unitscale = 1.0e6 - unitstxt = "mg/m2" - else - call StopAll("Units Scale Error "// txt ) - end if - end subroutine Units_Scale - end module Derived_ml diff --git a/DryDep_ml.f90 b/DryDep_ml.f90 index 135a54a..601b056 100644 --- a/DryDep_ml.f90 +++ b/DryDep_ml.f90 @@ -3,7 +3,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -50,7 +50,16 @@ module DryDep_ml ! and improving the EMEP ozone deposition module", Atmos.Env.,38,2373-2385 ! ! Also, handling of dry/wet and co-dep procedure changed following discussions - ! with CEH: Fagerli et al., in preperation.... + ! with CEH: + + ! Latest documentation and ACP eqn references in code below from + ! Simpson, D., Benedictow, A., Berge, H., Bergstr\"om, R., Emberson, L. D., + ! Fagerli, H., Flechard, C. R., Hayman, G. D., Gauss, M., Jonson, J. E., + ! Jenkin, M. E., Ny\'{\i}ri, A., Richter, C., Semeena, V. S., Tsyro, S., + ! Tuovinen, J.-P., Valdebenito, \'{A}., and Wind, P.: + ! The EMEP MSC-W chemical transport model -- technical description, + ! Atmos. Chem. Phys., 12, 7825--7865, 2012. + use My_Aerosols_ml, only : NSIZE @@ -76,7 +85,7 @@ module DryDep_ml use LocalVariables_ml,only : Grid, Sub, L, iL ! Grid and sub-scale Met/Veg data use MassBudget_ml, only : totddep use MetFields_ml, only : u_ref, rh2m - use MetFields_ml, only : tau, sdepth, SoilWater, SoilWater_deep, th,pzpbl + use MetFields_ml, only : tau, sdepth, SoilWater_deep, th,pzpbl use MicroMet_ml, only : AerRes, Wind_at_h use ModelConstants_ml,only : dt_advec,PT,KMAX_MID, KMAX_BND ,& DEBUG_i, DEBUG_j, NPROC, & @@ -88,7 +97,7 @@ module DryDep_ml use MosaicOutputs_ml, only : Add_MosaicOutput, MMC_RH use OwnDataTypes_ml, only : depmap - use Par_ml, only : li0,li1,lj0,lj1, me + use Par_ml, only : limax,ljmax, me,li0,li1,lj0,lj1 use PhysicalConstants_ml, only : PI, KARMAN, GRAV, RGAS_KG, CP, AVOG, NMOLE_M3 use Rb_ml, only : Rb_gas use Rsurface_ml @@ -140,6 +149,8 @@ module DryDep_ml ! The actual species used and their relation to the CDDEP_ indices ! above will be defined in Init_DepMap + !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + include 'CM_DryDep.inc' !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx @@ -179,8 +190,8 @@ subroutine init_drydep ! use EcoSystem_ml, only :: EcoSystemFrac, Is_EcoSystem EcoSystemFrac(:,:,:) = 0.0 - do j = lj0, lj1 - do i = li0, li1 + do j = 1, ljmax + do i = 1, limax debug_flag = ( DEBUG_ECOSYSTEMS .and. debug_proc .and. & i == debug_li .and. j == debug_lj ) @@ -409,7 +420,6 @@ subroutine DryDep(i,j) call datewrite("DRYDEP VS",NSIZE,(/ Grid%t2, Grid%rho_ref, Vs /) ) ! if( maxval(Vs) > 0.02 ) write(*,*) "DRYDEP LIM!" end if - ! Vs(:) = min( Vs(:), 0.02) !/ And start the sub-grid stuff over different landuse (iL) @@ -432,16 +442,15 @@ subroutine DryDep(i,j) L = Sub(iL) ! ! Assign e.g. Sub(iL)ustar to ustar - if ( DEBUG_DRYDEP .and. debug_flag ) then write(6,"(a,3i3,f6.1,2i4,3f7.3,i4,i2,2f6.2)") "DVEG: ", & nlu,iiL, iL, glat(i,j), L%SGS, L%EGS, & L%coverage, L%LAI, L%hveg,daynumber, & Grid%sdepth, fSW(i,j),L%t2C !ACB Grid%snow_flag - write(6,"(a,i4,2f7.2,2es10.2,3f8.3)") "DMET SUB", & - iL, Grid%ustar, L%ustar, Grid%invL, & - L%invL, L%Ra_ref, L%Ra_3m,L%rh + write(6,"(a,i4,3f7.2,7es10.2)") "DMET SUB", & + iL, Grid%ustar, L%ustar, L%rh, Grid%invL, & + L%invL, L%Ra_ref, L%Ra_3m end if @@ -474,28 +483,30 @@ subroutine DryDep(i,j) if ( LandType(iL)%is_forest ) then ! Vds NOV08 !/ Use eqn *loosely* derived from Petroff results + ! ACP67-69 Vds = GPF_Vds300(L%ustar,L%invL, L%SAI ) - if (n==CDDEP_PMfN .and. L%invL<0.0 ) then ! We allow nitrate to deposit x 2 - Vds = Vds * 2.0 ! for nitrate-like - end if - else !!! + else !!! ! ACP67-68 !/ Use Wesely et al for other veg & sea ! Vds = Nemitz2004( 0.4, L%ustar, L%invL ) Vds = Wesely300( L%ustar, L%invL ) - ! We allow nitrate to deposit x 2 - if (n==CDDEP_PMfN .and. L%invL<0.0 ) then - Vds = Vds * 2.0 ! for nitrate-like - end if end if - ! Use non-electrical-analogy version of Venkatram+Pleim (AE,1999) - Vg_ref(n) = Vs(nae)/ ( 1.0 - exp( -( L%Ra_ref + 1.0/Vds)* Vs(nae))) - Vg_3m (n) = Vs(nae)/ ( 1.0 - exp( -( L%Ra_3m + 1.0/Vds)* Vs(nae))) + ! We allow fine N-patricles to deposit x 3, in + ! unstable conditions. (F_N in ACP68) + if (n==CDDEP_PMfN .and. L%invL<0.0 ) then + Vds = Vds * 3.0 ! for nitrate-like + end if + + ! Use non-electrical-analogy version of Venkatram+Pleim (AE,1999) + ! ACP70 + + Vg_ref(n) = Vs(nae)/ ( 1.0 - exp( -( L%Ra_ref + 1.0/Vds)* Vs(nae))) + Vg_3m (n) = Vs(nae)/ ( 1.0 - exp( -( L%Ra_3m + 1.0/Vds)* Vs(nae))) if ( DEBUG_VDS ) then @@ -547,14 +558,14 @@ subroutine DryDep(i,j) !QUERY - do we need Gsur for anything now?! Sub(iL)%Gsur(n) = 1.0/Rsur(n) ! Note iL, not iiL - Sub(iL)%Gns(n) = Gns(n) ! Note iL, not iiL + Sub(iL)%Gns(n) = Gns(n) ! Note iL, not iiL !SUB0 Grid%Gsur(n) = Grid%Gsur(n) + L%coverage / Rsur(n) !SUB0 Grid%Gns(n) = Grid%Gns(n)+ L%coverage * Gns(n) Sub(0)%Gsur(n) = Sub(0)%Gsur(n) + L%coverage / Rsur(n) Sub(0)%Gns(n) = Sub(0)%Gns(n) + L%coverage * Gns(n) endif - end do !species loop + end do !species loop Sumcover = Sumcover + L%coverage @@ -578,8 +589,9 @@ subroutine DryDep(i,j) call datewrite("DEPO3 ", iL, & (/ Vg_ref(n), Sub(iL)%Vg_ref(n) /) ) !(/ Mosaic_VgRef(n,iL) , Vg_ref(n), Sub(iL)%Vg_ref(n) /) ) - call datewrite("DEPDVG", iL, (/ L%coverage, 1.0*n,& ! gs in cm/s : - L%LAI,100.0*L%g_sto, L%Ra_ref, Rb(n), min( 999.0,Rsur(n) ), & + call datewrite("DEPDVGA", iL, (/ L%coverage, 1.0*n,& + L%LAI,100.0*L%g_sto, L%Ra_ref, Rb(n), min( 999.0,Rsur(n) ) /) ) + call datewrite("DEPDVGB", iL, (/ L%coverage, 1.0*n,& 100.0*Vg_3m(n), 100.0*Vg_ref(n), Vg_ratio(n) /) ) end do @@ -700,6 +712,10 @@ subroutine DryDep(i,j) if ( DepLoss(nadv) < 0.0 .or. & DepLoss(nadv)>xn_2d(ntot,KMAX_MID) ) then + print "(a,2i4,a,es12.4,2f8.4,9es11.4)", "NEGXN ", ntot, ncalc, & + trim(species(ntot)%name), xn_2d(ntot,KMAX_MID), & + Fgas(ntot,KMAX_MID), Fpart(ntot,KMAX_MID), & + DepLoss(nadv), vg_fac(ncalc) call CheckStop("NEGXN DEPLOSS" ) end if @@ -810,16 +826,20 @@ subroutine DryDep(i,j) end if end do GASLOOP2 ! n - ! DryDep Budget terms convfac = convfac/amk(KMAX_MID) - do n = 1, NDRYDEP_ADV - nadv = DDepMap(n)%ind - totddep( nadv ) = totddep (nadv) + DepLoss(nadv)*convfac - enddo - convfac2 = convfac * xm2(i,j) * inv_gridarea + ! DryDep Budget terms + !do not include values on outer frame + if(.not.(ili1.or.jlj1))then + + do n = 1, NDRYDEP_ADV + nadv = DDepMap(n)%ind + totddep( nadv ) = totddep (nadv) + DepLoss(nadv)*convfac + enddo + endif + convfac2 = convfac * xm2(i,j) * inv_gridarea !.. Add DepLoss to budgets if needed: diff --git a/DustProd_ml.f90 b/DustProd_ml.f90 index 7f63614..c10fd23 100644 --- a/DustProd_ml.f90 +++ b/DustProd_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -41,29 +41,41 @@ module DustProd_ml ! content from JRC used here) in this version ! foundSoilWater = .false. from Met_ml.f90 (see comments below) +! REFS: FMB99 = F\'ecan, F., Marticorena, B. and Bergametti, +! G. (1999). Parameterization of the increase of the aeolian erosion +! threshold wind friction velocity to soil moisture for arid and semi-arid +! areas. Ann. Geophysicae, 17,149-157. + + use Biogenics_ml, only : EmisNat, EMIS_BioNat use CheckStop_ml, only : CheckStop - use EmisDef_ml, only : NDU, QDUFI, QDUCO use Functions_ml, only : ERFfunc use ChemChemicals_ml, only : species - use ChemSpecs_tot_ml, only : DUST_NAT_F use GridValues_ml, only : glat, glon, glat_fdom, glon_fdom, i_fdom, j_fdom - use Io_ml, only : PrintLog + use GridValues_ml, only : debug_proc, debug_li, debug_lj + use Io_ml, only : PrintLog, datewrite use Landuse_ml, only : LandCover, NLUMAX + use Landuse_ml, only : water_fraction ! DSA12 use LandDefs_ml, only: LandType use LocalVariables_ml, only : Sub, Grid use MetFields_ml, only : z_bnd, z_mid, u_ref, ustar_nwp, roa, & t2_nwp, sdepth, fh, ps, surface_precip, & - rho_surf, SoilWater, foundSoilWater, & + rho_surf, & + SoilWater => SoilWater_uppr, & + foundSoilWater => foundSoilWater_uppr, & foundws10_met, ws_10m, & - clay_frac, sand_frac !ACB snow_flag + clay_frac, sand_frac, & + pwp, fc, SoilWaterSource use ModelConstants_ml, only : KMAX_MID, KMAX_BND, dt_advec, METSTEP, & - NPROC, MasterProc, USE_DUST + NPROC, MasterProc, USE_DUST, DEBUG_DUST use MicroMet_ml, only : Wind_at_h use Par_ml, only : me,MAXLIMAX,MAXLJMAX + use Par_ml, only : limax, ljmax ! Debugging use PhysicalConstants_ml, only : GRAV, AVOG, PI, KARMAN, RGAS_KG, CP !! ECO_CROP, ECO_SEMINAT, Desert=13, Urban=17 - use TimeDate_ml, only : daynumber + use Setup_1dfields_ml, only : rcemis use Setup_1dfields_ml, only : rh + use SmallUtils_ml, only : find_index + use TimeDate_ml, only : daynumber !----------------------------------------------- implicit none @@ -71,15 +83,23 @@ module DustProd_ml public :: WindDust - real, public :: DU_prod (NDU,MAXLIMAX,MAXLJMAX) - real, public :: DUST_flux (MAXLIMAX,MAXLJMAX) real, private, save :: kg2molecDU, m_to_nDU, frac_fine, frac_coar, & soil_dns_dry, help_ustar_th real, parameter :: soil_dens = 2650.0 ! [kg/m3] logical, private, save :: my_first_call = .true. - integer, save :: dry_period(MAXLIMAX, MAXLJMAX) = 72 - logical, parameter, private :: DEBUG_DUST = .false. + logical, private, save :: dust_found + integer, private, save :: ipoll + integer, allocatable, save :: dry_period(:,:) character(len=20) :: soil_type + real, parameter :: SMALL=1.0e-10 + + ! Indices for the species defined in this routine. Only set if found + ! Hard-coded 2-mode for now. Could generalise later + integer, private, save :: inat_DUf , inat_DUc + integer, private, save :: itot_DUf , itot_DUc + integer, private, dimension(2), save :: dust_indices ! indices in EmisNat + + contains !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @@ -93,7 +113,7 @@ subroutine WindDust (i,j,debug_flag) integer, parameter :: Ndust = 2, & ! number of size classes DU_F = 1, DU_C = 2 - integer, parameter :: LU_DESERT = 13 + integer, parameter :: LU_DESERT = 13 ! REMOVE HARD-CODE real , parameter :: Ro_water = 1000.0 real, parameter, dimension(Ndust) :: & dsoil = (/ 1.5, 6.7/) & ! diameter of dust particles [mkm] @@ -107,11 +127,11 @@ subroutine WindDust (i,j,debug_flag) z10 = 10.0 ! Z=10m real :: Mflux = 0.0 real :: cover, z0, vh2o_sat, gr_h2o, v_h2o, ustar_moist_cor & - , gwc_thr, dust_lim, soil_dns_dry, ustar_z0_cor & - , alfa, ustar_th, uratio, ustar, clay & + , gwc_thr, dust_lim, soil_dns_dry, ustar_z0_cor, u10 & + , u10g_2, u10_gust, alfa, ustar_th, uratio, ustar, clay & , frac_fin, frac_coa, flx_hrz_slt, flx_vrt_dst - logical :: arable, dust_prod = .false. + logical :: arable, dust_prod = .false., debug integer :: nlu, ilu, lu !_______________________________________________________ @@ -121,53 +141,84 @@ subroutine WindDust (i,j,debug_flag) end if if ( my_first_call ) then - write(6,*)'*** Call for init_dust *** ' - call init_dust + ipoll = find_index("DUST_WB_F", species(:)%name ) + dust_found = .true. + if( ipoll < 1 ) then + call PrintLog( "WARNING: Dust asked for, but not found"& + ,MasterProc) + dust_found = .false. + else + + if(MasterProc) write(6,*)'*** Call for init_dust *** ' + + call init_dust + + kg2molecDU = 1.0e-3 * AVOG / species(ipoll)%molwt + + end if + if(DEBUG_DUST.and.MasterProc) print *, "DUSTI ", ipoll, dust_found, debug_proc + !FEB2012 call CheckStop( ipoll < 1, "Dust asked for, but not found") - kg2molecDU = 1.0e-3 * AVOG / species(DUST_NAT_F)%molwt my_first_call = .false. end if ! my_first_call !_______________________________________________________ - if(DEBUG_DUST .and. debug_flag ) write(6,*)'*** WINDBLOWN DUST', & - i_fdom(i), j_fdom(j) + !++++++++++++++++++++++++++++ + if ( .not. dust_found .or. & + (glat(i,j)>65.0 .and. glon(i,j)>50.0)) then ! Avoid dust production in N. Siberia + EmisNat( inat_DUf,i,j) = 0.0 + EmisNat( inat_DUc,i,j) = 0.0 + rcemis( itot_DUf,KMAX_MID) = 0.0 + rcemis( itot_DUc,KMAX_MID) = 0.0 + return + end if + !++++++++++++++++++++++++++++ + - if ((glat(i,j)>65.0 .and. glon(i,j)>50.0)) return ! Avoid dust production in N. Siberia !/.. landuse types .......... - DU_prod (:,i,j) = 0.0 - DUST_flux (i,j) = 0.0 + EmisNat(dust_indices ,i,j) = 0.0 flx_vrt_dst = 0.0 ! vertical dust flux Mflux = 0.0 + debug = ( DEBUG_DUST .and. debug_flag) + if( debug ) write(6,"(a,2i5,a,i5,es12.3)")'*** WINDBLOWN DUST', & + i_fdom(i), j_fdom(j), '>> RAIN >>', dry_period(i,j),surface_precip(i,j) !/.. Crude assumption: dust generation if Pr < 2.4 mm per day (surpace_prec[mm/h]) NO_PRECIP: if (surface_precip(i,j) < 0.1) then dry_period(i,j) = dry_period(i,j) + 1 - if(DEBUG_DUST .and. debug_flag) write(6,'(a30,i5,es12.3)')'>> NO RAIN >>', & + if(debug) write(6,'(a30,i5,es12.3)')'>> NO RAIN >>', & dry_period(i,j),surface_precip(i,j) !/.. Crude assumption: Dry soil after 48 hours since precipitation DRY: if (dry_period(i,j)*dt_advec/3600.0 >= 48.0) then - if(DEBUG_DUST .and. debug_flag) & + if(debug) & write(6,'(a30,f10.4)')'>> DRY period>>', dry_period(i,j)*dt_advec/3600.0 !/.. No dust production when soil is frozen, or covered by snow, !/.. or wet (crude approximation by surface Rh) - FROST: if ( Grid%t2C > 0.0 .and. Grid%sdepth == 0.0 .and. & +!DSA12 QUERY: Why "FROST" term? + !RV4TEST FROST: if ( Grid%t2C > 0.0 .and. Grid%sdepth == 0.0 .and. & + FROST: if ( Grid%t2C > SMALL .and. Grid%sdepth < SMALL .and. & rh(KMAX_MID) < 0.85) then - if(DEBUG_DUST .and. debug_flag) write(6,'(a25,2f10.2,i4)') & + if(debug) write(6,'(a25,2f10.2,i4)') & '>> FAVOURABLE for DUST>>', Grid%t2C, rh(KMAX_MID), Grid%sdepth -!ACB Grid%snow +!DSA12 + if ( water_fraction(i,j) > 0.99) then ! skip dust calcs + if(DEBUG_DUST) call datewrite("DUST: Skip SEA! ", & + (/ i_fdom(i), j_fdom(j) /), (/ fc(i,j), water_fraction(i,j) /) ) + return + end if !== Land-use loop =============================================== @@ -189,8 +240,8 @@ subroutine WindDust (i,j,debug_flag) DUST: if (arable .or. lu == LU_DESERT) then - if(DEBUG_DUST .and. debug_flag) write(6,'(a15,i5,f10.3)') & - '-----> Landuse', lu, cover + if( debug ) write(6,'(a,i5,f10.3)') & + 'DUST: -----> Landuse', lu, cover flx_hrz_slt = 0.0 @@ -220,8 +271,8 @@ subroutine WindDust (i,j,debug_flag) ustar_th = help_ustar_th / sqrt(roa(i,j,KMAX_MID,1)) ! [m s-1] - if(DEBUG_DUST .and. debug_flag) write(6,'(a20,3f15.5)') & - '>> U*/U*th/ro >>', ustar,ustar_th,roa(i,j,KMAX_MID,1) + if( debug) write(6,'(a,3f15.5)') & + 'DUST: >> U*/U*th/ro >>', ustar,ustar_th,roa(i,j,KMAX_MID,1) !//___ Inhibition of saltation by soil moisture (Fecan et al., 1999) @@ -229,36 +280,73 @@ subroutine WindDust (i,j,debug_flag) ustar_moist_cor = 1.0 !//__ Minimal soil moisture at which U*_thresh icreases - gwc_thr = (0.17 + 0.14 * clay)* clay ! [kg/kg] [m3 m-3] - gwc_thr = max ( gwc_thr, 0.1) ! Lower threshold limit (Vautard, AE, 2005) + if(SoilWaterSource /= "IFS")then + gwc_thr = (0.17 + 0.14 * clay)* clay ! [kg/kg] [m3 m-3] + gwc_thr = max ( gwc_thr, 0.1) ! Lower threshold limit (Vautard, AE, 2005) + else + !use a threshold consistent with the one IFS uses + gwc_thr=pwp(i,j) + endif if (foundSoilWater) then ! Soil Moisture in met data !__ Saturated volumetric water content (sand-dependent) vh2o_sat = 0.489-0.126 * sand_frac(i,j) ! [m3 m-3] + !__ Bulk density of dry surface soil [Zender, (8)] soil_dns_dry = soil_dens * (1.0 - vh2o_sat) ! [kg m-3] + !__ Volumetric soil water content [m3/m3] - v_h2o = SoilWater(i,j,1) - !-- Note, in HIRLAM SoilWater is in [m/0.072m] -> conversion - ! if ( SoilWater_in_meter ) v_h2o = SoilWater(i,j,1)/0.072 +!Now we have soil moisture index, SMI = (SW-PWP)/(FC-PWP) +! v_h2o = SoilWater(i,j,1) +!-- Note, in HIRLAM SoilWater is in [m/0.072m] -> conversion +! if ( SoilWater_in_meter ) v_h2o = SoilWater(i,j,1)/0.072 +! +! *** BUT *** the following is using IFS pwp. This is likely +! the best we can do for the grid-average, but for dust it might be more +! appropriate to calculate for specific landcover PWP values. +! +! (Note, v_h2o should not end up negative here, see Met_ml.f90) + + v_h2o = pwp(i,j) + SoilWater(i,j,1) * (fc(i,j)-pwp(i,j) ) + ! call CheckStop(v_h2o <= 0.0 , "DUSTY DRY" ) + if( v_h2o < SMALL ) then + print "(a,2i4,9f10.4)"," DUSTY DRY!!", i_fdom(i), j_fdom(j), & + v_h2o, pwp(i,j), fc(i,j), SoilWater(i,j,1), water_fraction(i,j) + ! v_h2o = max( 1.0e-12, v_h2o) + call CheckStop(v_h2o <= 0.0 , "DUSTY DRY" ) + end if + if( v_h2o > fc(i,j) ) then + write(*,"(a,2i4,9f10.4)")," DUSTY WET!!", i_fdom(i), j_fdom(j), & + v_h2o, pwp(i,j), fc(i,j), SoilWater(i,j,1), water_fraction(i,j) + + if( v_h2o > fc(i,j)+0.00001 ) then + call CheckStop(v_h2o > fc(i,j), "DUSTY WET" ) + end if + + end if !__ Gravimetric soil water content [kg kg-1] - gr_h2o = v_h2o * Ro_water/soil_dns_dry + gr_h2o = v_h2o * Ro_water/soil_dns_dry + +!__ Put also gwc_thr (=pwp) in same unit + if(SoilWaterSource == "IFS")then + gwc_thr=gwc_thr* Ro_water/soil_dns_dry + endif - if(DEBUG_DUST .and. debug_flag) then - write(6,'(a30,f8.2,2f12.4)') 'Sand/Water_sat/soil_dens', & - sand_frac(i,j),vh2o_sat,soil_dns_dry - write(6,'(a30,3f15.5)') ' SW/VolW/GrW/ ',SoilWater(i,j,1),v_h2o,gr_h2o - endif ! Soil water correction if (gr_h2o > gwc_thr) & ustar_moist_cor = sqrt(1.0 + 1.21 * & (100.*(gr_h2o - gwc_thr))**0.68) ! [frc] FMB99 p.155(15) - if(DEBUG_DUST .and. debug_flag) write(6,'(a25,2f10.4)') & - '>> U*_moist_corr >>',gwc_thr, ustar_moist_cor + if( debug ) then + write(6,'(a,f8.2,2f12.4)') 'DUST: Sand/Water_sat/soil_dens', & + sand_frac(i,j),vh2o_sat,soil_dns_dry + write(6,'(a,3f15.5)') 'DUST: SW/VolW/GrW/ ',SoilWater(i,j,1),v_h2o,gr_h2o + write(6,'(a,3f15.5)') 'DUST: SW COMPS ',SoilWater(i,j,1), fc(i,j), pwp(i,j) + write(6,'(a,2f10.4)') 'DUST >> U*_moist_corr >>',gwc_thr, ustar_moist_cor + endif else !.. No SoilWater in met.input; Moisture correction for U*t will be 1. @@ -266,10 +354,9 @@ subroutine WindDust (i,j,debug_flag) ! 1.1-1.75 for sand (gr_h2o = 0.1-2%) ; 1.5-2.5 for loam (gr_h2o = 4-10%) and ! for clay (gr_h2o = 9-15%) - if(DEBUG_DUST .and. debug_flag) then - write(6,'(a30,f8.2,2f12.4)') '++ No SoilWater in meteorology++' - write(6,'(a25,f10.4)') & - '>> U*_moist_corr >>', ustar_moist_cor + if( debug ) then + write(6,'(a,f8.2,2f12.4)') 'DUST ++ No SoilWater in meteorology++' + write(6,'(a,f10.4)') 'DUST: >> U*_moist_corr >>', ustar_moist_cor endif endif @@ -286,6 +373,7 @@ subroutine WindDust (i,j,debug_flag) if ( (glat(i,j) > 36.0 .and. glon(i,j) < 0.0) .or. & (glat(i,j) > 37.0 .and. glon(i,j) < 45.0) ) then soil_type = 'European Arid' + z0 = 0.5e-4 !TEST dust_lim = 0.05 alfa = 1.3e-5 ! alfa = 1.5e-5 ! As for TFMM spring 2005 @@ -317,8 +405,7 @@ subroutine WindDust (i,j,debug_flag) ustar_z0_cor = 1.0 - & ! [frc] MaB95 p. 16420, GMB98 p. 6207 log(z0 / Z0s) / log( 0.35 * (0.1/Z0s)**0.8 ) - if(DEBUG_DUST .and. debug_flag) write(6,'(a20,es12.3)') & - '>> ustar_zo_corr >>', ustar_z0_cor + if( debug ) write(6,'(a,es12.3)') '>> ustar_zo_corr >>', ustar_z0_cor ustar_z0_cor = min ( 1.0, max(0.0001,ustar_z0_cor) ) @@ -327,8 +414,7 @@ subroutine WindDust (i,j,debug_flag) ustar_z0_cor = 1.0 / ustar_z0_cor ! [frc] - if(DEBUG_DUST .and. debug_flag) write(6,'(a25,3es12.3)') & - '>> U*_zo_corr >>',z0, Z0s, ustar_z0_cor + if( debug ) write(6,'(a,3es12.3)') '>> U*_zo_corr >>',z0, Z0s, ustar_z0_cor !//___ Final threshold friction velocity @@ -342,19 +428,30 @@ subroutine WindDust (i,j,debug_flag) !//__ Account for wind gustiness under free convection (Beljaars,QJRMS,1994) - +!!!!!!! Under Testing !!!!!!! +! ! if (foundws10_met) then ! u10=ws_10m(i,j,1) ! else ! u10 = Wind_at_h (Grid%u_ref, Grid%z_ref, Z10, Sub(lu)%d, & ! Sub(lu)%z0, Sub(lu)%invL) ! end if -! ustar = KARMAN/log(10.0/z0) * & -! sqrt(u10*u10 + 1.44 *Grid%wstar*Grid%wstar) +! +! u10g_2 = u10*u10 + 1.44 *Grid%wstar*Grid%wstar +! +! if ( u10g_2 > 0.0 ) then +! u10_gust = sqrt(u10*u10 + 1.44 *Grid%wstar*Grid%wstar) +! else +! u10_gust = u10 ! endif +! +! ustar = KARMAN/log(10.0/z0) * & +! sqrt(u10_gust*u10_gust + 1.44 *Grid%wstar*Grid%wstar) + !.. Gives too low U*; Sub(lu)%ustar=0.1 always-> both too low to generate dust !//__ U* from NWP model ____ + ustar = Grid%ustar if (DEBUG_DUST .and. debug_flag) then @@ -371,17 +468,17 @@ subroutine WindDust (i,j,debug_flag) if(DEBUG_DUST .and. debug_flag) write(6,'(a30,f8.2)') & ' Saltation occur U*th/U* => ', ustar_th/ustar -!// Increase of friction velocity =========== NOT USED ========== NOT USED -! by surface roughness length and friction speeds (Owens effect) - - !== Saltation roughens the boundary layer, AKA "Owen's effect" - ! GMB98 p. 6206 Fig. 1 shows observed/computed u* dependence on observed U(1 m) - ! GMB98 p. 6209 (12) has u* in cm s-1 and U, Ut in m s-1, personal communication, - ! D. Gillette, 19990529 - ! With everything in MKS, the 0.3 coefficient in GMB98 (12) becomes 0.003 - ! Increase in friction velocity due to saltation varies as square of - ! difference between reference wind speed and reference threshold speed - +!---- !!!!!!! Under Testing !!!!!!! -------------------------- +!// Increase of friction velocity by surface roughness length +! and friction speeds (Owens effect) +!== Saltation roughens the boundary layer, AKA "Owen's effect" +! GMB98 p. 6206 Fig. 1 shows observed/computed u* dependence on observed U1m +! GMB98 p. 6209 (12) has u* in cm s-1 and U, Ut in m s-1 (pers. comm.) +! D. Gillette, 19990529 +! With everything in MKS, the 0.3 coefficient in GMB98 (12) becomes 0.003 +! Increase in friction velocity due to saltation varies as square of +! difference between reference wind speed and reference threshold speed + !//__ Threshold 10 m wind speed [m s-1] for saltation ! u_th10 = ustar_th/KARMAN * log(z10/z0) !!..or u_th10 = u10 * ustar_th / ustar ! [m s-1] @@ -390,8 +487,7 @@ subroutine WindDust (i,j,debug_flag) ! ustar = ustar + owens ! [m s-1] Saltating friction velocity ! if(DEBUG_DUST .and. debug_flag) write(6,'(a20,3f10.3)') & ! 'Owens effect ',ustar-owens, owens , ustar -! ============================================ NOT USED ========== NOT USED - +!---------------------------------------------------------------------- !//__ Calculate U*th / U* ratio uratio = ustar_th / ustar @@ -404,10 +500,8 @@ subroutine WindDust (i,j,debug_flag) if (DEBUG_DUST .and. debug_flag) then write(6,*)' ' write(6,'(a35,es12.3)') ' Horizontal Flux => ', flx_hrz_slt - endif - - if(DEBUG_DUST .and. debug_flag) then - write(6,'(/a25,4f8.2)') soil_type,glat(i,j),glon(i,j),glat_fdom(i,j),glon_fdom(i,j) + write(6,'(/a25,4f8.2)') soil_type,glat(i,j),glon(i,j),& + glat_fdom(i,j),glon_fdom(i,j) write(6,'(a25,3f10.3,es10.2)') '>> U*/U*t/Klim,alfa >>', & ustar,ustar_th, dust_lim, alfa write(6,'(a15,f10.3,2es12.3)') 'FLUXES:',uratio, flx_hrz_slt*1000.0, & @@ -436,7 +530,7 @@ subroutine WindDust (i,j,debug_flag) !.. Mass flus for test output Mflux = Mflux + flx_hrz_slt * alfa * dust_lim - if(DEBUG_DUST .and. debug_flag) then + if( debug ) then write(6,'(a35,es12.3/)') ' Vertical Flux => ', Mflux write(6,'(a35,es12.3,i4,f8.3)') 'DUST Flux => ', flx_vrt_dst, lu, cover write(6,'(a15,f10.3,2es12.3)') 'FLUXES:',uratio, flx_hrz_slt*1000., flx_vrt_dst*1000. @@ -454,7 +548,7 @@ subroutine WindDust (i,j,debug_flag) else ! PREC dry_period(i,j) = 0 - if(DEBUG_DUST .and. debug_flag) write(6,'(a30,i5,es12.3)') & + if( debug ) write(6,'(a30,i5,es12.3)') & '>> RAIN-RAIN >>', dry_period(i,j),surface_precip(i,j) endif NO_PRECIP @@ -472,22 +566,25 @@ subroutine WindDust (i,j,debug_flag) frac_fine = 0.05 ! fine fraction 0.10 was found too large frac_coar = 0.20 ! coarse fraction also 0.15-0.23 was tested !!.. vertical dust flux [kg/m2/s] -> [kg/m3/s]*AVOG/M e-3 -> [molec/cm3/s] - DU_prod(DU_F,i,j) = frac_fine * flx_vrt_dst * kg2molecDU /Grid%DeltaZ - DU_prod(DU_C,i,j) = frac_coar * flx_vrt_dst * kg2molecDU /Grid%DeltaZ + + rcemis( itot_DUf, KMAX_MID ) = frac_fine * flx_vrt_dst * kg2molecDU /Grid%DeltaZ + rcemis( itot_DUc, KMAX_MID ) = frac_coar * flx_vrt_dst * kg2molecDU /Grid%DeltaZ + +! Need kg/m2/hr for EmisNat + EmisNat( inat_DUf,i,j) = frac_fine * flx_vrt_dst * 3600.0 + EmisNat( inat_DUc,i,j) = frac_coar * flx_vrt_dst * 3600.0 !//__Dust flux [kg/m2/s] for check - DUST_flux(i,j) = flx_vrt_dst ! * (frac_fin + frac_coar) dust_prod = .false. ! Zero-setting - if(DEBUG_DUST .and. debug_flag) write(6,'(//a15,2es12.4,a15,e12.4,2f6.3)') & - '<< DUST OUT>>', DU_prod(DU_F,i,j), DU_prod(DU_C,i,j), ' > TOTAL >', & - DUST_flux(i,j), frac_fin, frac_coa + if( debug ) write(6,'(//a15,2es12.4,a15,e12.4,2f6.3)') & + '<< DUST OUT>>', EmisNat( inat_DUf,i,j), EmisNat( inat_DUc,i,j), & + ' > TOTAL >', sum( EmisNat( dust_indices, i,j )),frac_fin, frac_coa endif ! dust_prod - if(DEBUG_DUST .and. debug_flag) write(6,*) & - '<< No DUST production>> > TOTAL >', DUST_flux(i,j) + if( debug ) write(6,*) '<< No DUST production TOTAL >>', sum( EmisNat( dust_indices, i,j )) end subroutine WindDust @@ -524,11 +621,23 @@ subroutine init_dust ! real, dimension (3) :: sig_soil= (/ 1.7 , 1.6 , 1.5 /) ! [frc] GSD !--------------------------------------------- + inat_DUf = find_index( "DUST_WB_F", EMIS_BioNat(:) ) + inat_DUc = find_index( "DUST_WB_C", EMIS_BioNat(:) ) + itot_DUf = find_index( "DUST_WB_F", species(:)%name ) + itot_DUc = find_index( "DUST_WB_C", species(:)%name ) + + dust_indices = (/ inat_DUf, inat_DUc /) + if (DEBUG_DUST .and. MasterProc) then write(6,*) - write(6,*) ' >> DUST init <<',soil_dens + write(6,*) ' >> DUST init <<',soil_dens, inat_DUf, inat_DUc , itot_DUf, itot_DUc endif + + allocate(dry_period(MAXLIMAX, MAXLJMAX)) + dry_period = 72 + + !//__ Reynold's number ( uses D_opt[cm] ) Re_opt=0.38 + 1331. *(100.*D_opt)**1.56 ! [frc] "B" MaB95 p. 16417 (5) @@ -538,33 +647,30 @@ subroutine init_dust k_help1 = 1.0 + 6.e-7 / ( soil_dens *GRAV *(D_opt**2.5) ) ! SQUARED k_help2 = soil_dens * GRAV * D_opt ! SQUARED - if (DEBUG_DUST .and. MasterProc) write(6,'(a25,f5.1,3e12.4)') & - 'ROsoil/Re_opt/K1/K2 ',soil_dens,Re_opt, k_help1, k_help2 + if (DEBUG_DUST .and. MasterProc) write(6,'(a,f6.1,3e12.4)') & + 'DUST:ROsoil/Re_opt/K1/K2 ',soil_dens,Re_opt, k_help1, k_help2 !//__ U_star_threshold if ( Re_opt < 0.03 ) then - stop 'Dust: Reynolds < 0.03' + call CheckStop( 'ERROR: Dust: Reynolds < 0.03' ) else if ( Re_opt < 10.0 ) then help_ust = 1.928 * Re_opt**0.0922 - 1.0 ! [frc] IvW82 p. 114 (3), MaB95 p. 16417 (6) help_ust = 0.129 * 0.129 / help_ust ! [frc] SQUARED - if (DEBUG_DUST .and. MasterProc) write(6,'(a20,e12.4)') 'U* =', help_ust - else help_ust = 1.0- 0.0858 * exp(-0.0617 *(Re_opt-10.0)) ! [frc] IvW82 p. 114(3), ! MaB95 p. 16417 (7) help_ust = 0.12*0.12 * help_ust*help_ust ! [frc] SQUARED - if (DEBUG_DUST .and. MasterProc) write(6,'(a20,e12.4)') 'U* =', help_ust - endif ! Re_opt < 0.03 - + !//__ This method minimizes the number of square root computations performed help_ustar_th = sqrt (k_help1 * k_help2 * help_ust) - if (DEBUG_DUST .and. MasterProc) write(6,'(a20,e12.4)') 'U*t help =', help_ustar_th + if (DEBUG_DUST .and. MasterProc) write(6,'(a,2e12.4)') 'DUST: U*, U*t help =',& + help_ust, help_ustar_th !// ======================================= !TEST sand_frac = 0.6 ! sand fraction in soil @@ -577,8 +683,8 @@ subroutine init_dust if (DEBUG_DUST .and. MasterProc) then write(6,*) - write(6,*) ' >> DUST fractions <<', Nsoil, Ndust - write(6,'(a15,3e12.4)') 'Sigma =', (sig_soil(i),i=1,Nsoil) + write(6,*) 'DUST: >> fractions <<', Nsoil, Ndust + write(6,'(a,3e12.4)') 'DUST: Sigma =', (sig_soil(i),i=1,Nsoil) endif sum_soil(:) = 0.0 @@ -592,7 +698,7 @@ subroutine init_dust x1 = log ( d1(idu) / dsoil(isoil) ) / y x2 = log ( d2(idu) / dsoil(isoil) ) / y - if (DEBUG_DUST .and. MasterProc) write (6,'(a,4e12.4)') 'DUST TEST 3', & + if (DEBUG_DUST .and. MasterProc) write (6,'(a,4e12.4)') 'DUST: TEST 3', & x1,x2,ERFfunc(x1),ERFfunc(x2) help_diff(isoil,idu) = 0.5 * ( ERFfunc(x2) - ERFfunc(x1) ) & @@ -609,11 +715,11 @@ subroutine init_dust if (DEBUG_DUST .and. MasterProc) then do idu = 1,Ndust - write (6,'(a25,2f8.4,3(f8.3),2f12.3)') ' Dust frac in bins:', & + write (6,'(a25,2f8.4,3(f8.3),2f12.3)') 'DUST: frac in bins:', & d1(idu), d2(idu), (help_diff(isoil,idu), isoil=1,3), & sum_soil(idu),sum_soil(idu)/tot_soil enddo - write (6,'(a30,2f8.4)') ' ** FINE / COARSE **',frac_fine, frac_coar + write (6,'(a,2f8.4)') 'DUST: ** FINE / COARSE **',frac_fine, frac_coar endif end subroutine init_dust diff --git a/EcoSystem_ml.f90 b/EcoSystem_ml.f90 index 91383e5..10e72e1 100644 --- a/EcoSystem_ml.f90 +++ b/EcoSystem_ml.f90 @@ -45,8 +45,8 @@ module EcoSystem_ml logical, public, dimension(NDEF_ECOSYSTEMS,NLANDUSEMAX), & save :: Is_EcoSystem - real, public, dimension(NDEF_ECOSYSTEMS,MAXLIMAX,MAXLJMAX), & - save :: EcoSystemFrac + real, public, dimension(:,:,:), & + save,allocatable :: EcoSystemFrac contains !<--------------------------------------------------------------------------- @@ -57,6 +57,8 @@ subroutine Init_EcoSystems() integer :: iEco logical, parameter :: T = .true., F = .false. ! shorthands only + allocate(EcoSystemFrac(NDEF_ECOSYSTEMS,MAXLIMAX,MAXLJMAX)) + if( MasterProc ) & write(*,*) "Defining ecosystems: ",(trim(DEF_ECOSYSTEMS(iEco))," ",iEco = 1, NDEF_ECOSYSTEMS) do iEco = 1, NDEF_ECOSYSTEMS diff --git a/EmisDef_ml.f90 b/EmisDef_ml.f90 index 99fc85c..c822f76 100644 --- a/EmisDef_ml.f90 +++ b/EmisDef_ml.f90 @@ -73,7 +73,7 @@ module EmisDef_ml - integer, public, parameter :: NCMAX = 11 ! Max. No. countries per grid + integer, public, parameter :: NCMAX = 11 ! Max. No. countries per grid point integer, public, parameter :: FNCMAX = 20 ! Max. No. countries (with ! flat emissions) per grid @@ -86,56 +86,27 @@ module EmisDef_ml ! hb NH3emis (ISNAP_AGR, ISNAP_TRAF) integer, public, parameter :: & ANTROP_SECTORS=10, & ! Non-natural sectors + ISNAP_DOM = 2, & ! Domestic/residential, for degree-day Timefactors ISNAP_NAT = 11, & ! SNAP index for volcanoe emissions ISNAP_SHIP = 8, & ! SNAP index for flat emissions, e.g ship ISNAP_AGR = 10, & ! Note that flat emissions do NOT necessarily ISNAP_TRAF = 7 ! belong to the same SNAP sector -! Vertical allocation from SNAP sectors - - integer, public, parameter :: NEMISLAYERS = 7 - real, public, parameter, & - dimension(NEMISLAYERS,NSECTORS) :: & - - VERTFAC = & ! Vertical distribution of SNAP emissions - reshape ( & ! Vertical distribution of SNAP emissions -! Ground , ... High - (/ 0.0 , 0.00, 0.15, 0.40, 0.30, 0.15, 0.00, & ! SNAP1 - 0.9 , 0.10, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP2 - 0.1 , 0.10, 0.15, 0.30, 0.30, 0.05, 0.0, & ! SNAP3 - 0.9 , 0.10, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP4 - 0.9 , 0.10, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP5 - 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP6 - 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP7 - 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP8 - 0.1 , 0.15, 0.40, 0.35, 0.00, 0.00, 0.0, & ! SNAP9 - 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP10 - 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0 & ! SNAP11 - /), & - (/NEMISLAYERS,NSECTORS /) ) - !(/ 0.0 , 0.00, 0.08, 0.46, 0.29, 0.17, 0.00, & ! SNAP1 - ! 0.5 , 0.50, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP2 - ! 0.0 , 0.04, 0.19, 0.41, 0.30, 0.06, 0.0, & ! SNAP3 - ! 0.9 , 0.10, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP4 - ! 0.9 , 0.10, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP5 - ! 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP6 - ! 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP7 - ! 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP8 - ! 0.1 , 0.15, 0.40, 0.35, 0.00, 0.00, 0.0, & ! SNAP9 - ! 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0, & ! SNAP10 - ! 1.0 , 0.00, 0.00, 0.00, 0.00, 0.00, 0.0 & ! SNAP11 - - !SeaSalt - integer, public, parameter :: NSS = 3 & ! number of sea salt size modes - ,QSSFI = 1 & ! production of fine SS - ,QSSCO = 2 & ! production of coarse SS - ,QSSGI = 3 ! production of 'giant' SS !Dust - integer, public, parameter :: NDU = 2 & ! number of dust size modes - ,QDUFI = 1 & ! production of fine dust - ,QDUCO = 2 ! production of coarse dust +! integer, public, parameter :: NDU = 2 & ! number of dust size modes +! ,QDUFI = 1 & ! production of fine dust +! ,QDUCO = 2 ! production of coarse dust + !Road Dust + integer, public, parameter :: NROADDUST = 2 & ! number of road dust size modes + ,QROADDUST_FI = 1 & ! production of fine road dust + ,QROADDUST_CO = 2 ! production of coarse road dust + real, public, parameter :: ROADDUST_FINE_FRAC = 0.1 ! PM2.5 fraction of PM10-road dust emission + + !Pollen + integer, public, parameter :: NPOL = 1 & ! number of dust size modes + ,QPOL = 1 !Volcanos. logical, public, parameter :: VOLCANOES_LL = .true. ! Read Volcanoes @@ -145,6 +116,19 @@ module EmisDef_ml integer, public, parameter :: IQ_DMS = 35 ! code for DMS emissions + ! Names of emis files, generated by GenChem: + + include 'CM_EmisFiles.inc' + + ! Road dust emission files (should perhaps be added to GenChem in the future?) + + integer, parameter, public :: NROAD_FILES = 2 + character(len=11), save, dimension(NROAD_FILES), public:: & + ROAD_FILE = (/ "HIGHWAYplus", "NONHIGHWAY" /) + character(len=21), save, public:: & + ROADDUST_CLIMATE_FILE = "ROADDUST_CLIMATE_FAC" + + ! FUTURE work ! NMR-NH3 project specific variables ! NH3 emissions set by meteorology and special activity data @@ -152,6 +136,7 @@ module EmisDef_ml real, public, save :: dknh3_agr ! reported nh3emis (IC_NMR) ! read from gridXXfile + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< ! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD end module EmisDef_ml diff --git a/EmisGet_ml.f90 b/EmisGet_ml.f90 index 0b3521e..9c9627f 100644 --- a/EmisGet_ml.f90 +++ b/EmisGet_ml.f90 @@ -41,19 +41,21 @@ module EmisGet_ml use Country_ml, only: NLAND, IC_NAT, IC_VUL, Country, & ! NMR-NH3 specific variables (hb NH3Emis) IC_NMR - use My_Emis_ml, only: NEMIS_FILES, EMIS_NAME use EmisDef_ml, only: NSECTORS, ANTROP_SECTORS, NCMAX, FNCMAX, & + NEMIS_FILE, EMIS_FILE, & ISNAP_SHIP, ISNAP_NAT, VOLCANOES_LL, & ! NMR-NH3 specific variables (for FUTURE ) - NH3EMIS_VAR,dknh3_agr,ISNAP_AGR,ISNAP_TRAF + NH3EMIS_VAR,dknh3_agr,ISNAP_AGR,ISNAP_TRAF, & + NROADDUST use GridAllocate_ml, only: GridAllocate use Io_ml, only: open_file, NO_FILE, ios, IO_EMIS, & - Read_Headers, read_line + Read_Headers, read_line, PrintLog use KeyValue_ml, only: KeyVal use ModelConstants_ml, only: NPROC, TXTLEN_NAME, DEBUG => DEBUG_GETEMIS, & DEBUG_i, DEBUG_j, & + KMAX_MID, & SEAFIX_GEA_NEEDED, & ! only if emission problems over sea - MasterProc,DEBUG_GETEMIS,USE_FOREST_FIRES + MasterProc,DEBUG_GETEMIS,DEBUG_ROADDUST,USE_ROADDUST use Par_ml, only: me use SmallUtils_ml, only: wordsplit, find_index use Volcanos_ml @@ -65,6 +67,9 @@ module EmisGet_ml public :: EmisGet ! Collects emissions of each pollutant public :: EmisSplit ! => emisfrac, speciation of voc, pm25, etc. + public :: EmisHeights ! => nemis_kprofile, emis_kprofile + ! vertical emissions profile + public :: RoadDustGet ! Collects road dust emission potentials private :: femis ! Sets emissions control factors private :: CountEmisSpecs ! @@ -72,24 +77,29 @@ module EmisGet_ml INCLUDE 'mpif.h' INTEGER STATUS(MPI_STATUS_SIZE),INFO logical, private, save :: my_first_call = .true. - + logical, private, save :: my_first_road = .true. ! e_fact is the emission control factor (increase/decrease/switch-off) ! e_fact is read in from the femis file and applied within EmisGet real, private, save, & - dimension(NSECTORS,NLAND,NEMIS_FILES) :: e_fact + dimension(NSECTORS,NLAND,NEMIS_FILE) :: e_fact ! emisfrac is used at each time-step of the model run to split ! emissions such as VOC, PM into species. integer, public, parameter :: NMAX = NSPEC_ADV integer, public, save :: nrcemis, nrcsplit - integer, public, dimension(NEMIS_FILES) , save :: emis_nsplit + integer, public, dimension(NEMIS_FILE) , save :: emis_nsplit real, public,allocatable, dimension(:,:,:), save :: emisfrac integer, public,allocatable, dimension(:), save :: iqrc2itot integer, public, dimension(NSPEC_TOT), save :: itot2iqrc - integer, public, dimension(NEMIS_FILES), save :: Emis_MolWt + integer, public, dimension(NEMIS_FILE), save :: Emis_MolWt real, public,allocatable, dimension(:), save :: emis_masscorr + real, public,allocatable, dimension(:), save :: roaddust_masscorr + + ! vertical profiles for SNAP emis, read from EmisHeights.txt + integer, public, save :: nemis_kprofile + real, public,allocatable, dimension(:,:), save :: emis_kprofile ! some common variables character(len=40), private :: fname ! File name @@ -243,7 +253,7 @@ subroutine EmisGet(iemis,emisname,IRUNBEG,JRUNBEG,GIMAX,GJMAX, & !...................................................... sumemis(ic,iemis) = sumemis(ic,iemis) & - + 0.001 * globemis_flat(i,j,flat_iland) + + 0.001 * e_fact(ISNAP_SHIP,ic,iemis) * tmpsec(ISNAP_SHIP) cycle READEMIS endif !ship emissions @@ -311,7 +321,11 @@ subroutine EmisGet(iemis,emisname,IRUNBEG,JRUNBEG,GIMAX,GJMAX, & ! Sum over all sectors, store as Ktonne: sumemis(ic,iemis) = sumemis(ic,iemis) & - + 0.001 * sum (globemis (:,i,j,iland)) + + 0.001 * sum (e_fact(:,ic,iemis)*tmpsec(:)) + +!rb: Old version (below) does not work if same grid point occurs several times in emis-file +! Probably the same problem for ship emissions etc. Not changed now! +! + 0.001 * sum (globemis (:,i,j,iland)) end do READEMIS @@ -348,7 +362,7 @@ subroutine femis() ,isec, isec1 , isec2 & ! loop vars: emis sectors ,ncols, n, oldn ! No. cols. in "femis" integer, parameter :: NCOLS_MAX = 20 ! Max. no. cols. in "femis" - integer, dimension(NEMIS_FILES) :: qc ! index for sorting femis columns + integer, dimension(NEMIS_FILE) :: qc ! index for sorting femis columns real, dimension(NCOLS_MAX):: e_f ! factors read from femis character(len=200) :: txt ! For read-in character(len=20), dimension(NCOLS_MAX):: polltxt ! to read line 1 @@ -362,7 +376,7 @@ subroutine femis() if ( ios == NO_FILE ) then ios = 0 - print *, "ERROR: NO FEMIS FILE" + write( *,*) "WARNING: NO FEMIS FILE" return !/** if no femis file, e_fact=1 as default **/ endif call CheckStop( ios < 0 ,"EmisGet:ios error in femis.dat") @@ -394,12 +408,12 @@ subroutine femis() n = 0 COLS: do ic=1,ncols oldn = n - EMLOOP: do ie=1, NEMIS_FILES - if ( polltxt(ic+2) == trim ( EMIS_NAME(ie) ) ) then + EMLOOP: do ie=1, NEMIS_FILE + if ( polltxt(ic+2) == trim ( EMIS_FILE(ie) ) ) then qc(ie) = ic n = n + 1 if(DEBUG_GETEMIS)write(unit=6,fmt=*) "In femis: ", & - polltxt(ic+2), " assigned to ", ie, EMIS_NAME(ie) + polltxt(ic+2), " assigned to ", ie, EMIS_FILE(ie) exit EMLOOP end if end do EMLOOP ! ie @@ -407,7 +421,7 @@ subroutine femis() write(unit=6,fmt=*) "femis: ",polltxt(ic+2)," NOT assigned" end do COLS ! ic - call CheckStop( n < NEMIS_FILES , "EmisGet: too few femis items" ) + call CheckStop( n < NEMIS_FILE , "EmisGet: too few femis items" ) n = 0 @@ -426,9 +440,9 @@ subroutine femis() "landcode =", inland, ", sector code =",isec, & " (sector 0 applies to all sectors) :" write(unit=6,fmt="(a,14(a,a,F5.2,a))") " ", (trim(polltxt(qc(ie)+2)),& - " =",e_f(qc(ie)), ", ", ie=1,NEMIS_FILES-1), & + " =",e_f(qc(ie)), ", ", ie=1,NEMIS_FILE-1), & (trim(polltxt(qc(ie)+2))," =",e_f(qc(ie))," ", & - ie=NEMIS_FILES,NEMIS_FILES) + ie=NEMIS_FILE,NEMIS_FILE) if (inland == 0 ) then ! Apply factors to all countries iland1 = 1 @@ -461,7 +475,7 @@ subroutine femis() end if - do ie = 1,NEMIS_FILES + do ie = 1,NEMIS_FILE do iq = iland1, iland2 do isec = isec1, isec2 @@ -470,7 +484,7 @@ subroutine femis() end do !iq if (DEBUG ) then - write(unit=6,fmt=*) "IN NEMIS_FILES LOOP WE HAVE : ", ie, & + write(unit=6,fmt=*) "IN NEMIS_FILE LOOP WE HAVE : ", ie, & qc(ie), e_f( qc(ie) ) write(unit=6,fmt=*) "loops over ", isec1, isec2, iland1, iland2 end if ! DEBUG @@ -483,16 +497,50 @@ subroutine femis() if(DEBUG_GETEMIS)write(unit=6,fmt=*) "In femis, read ", n, "records from femis." if ( DEBUG.and.MasterProc ) then ! Extra checks write(unit=6,fmt=*) "DEBUG_EMISGET: UK femis gives: " - write(unit=6,fmt="(6x, 30a10)") (EMIS_NAME(ie), ie=1,NEMIS_FILES) + write(unit=6,fmt="(6x, 30a10)") (EMIS_FILE(ie), ie=1,NEMIS_FILE) do isec = 1, 11 write(unit=6,fmt="(i6, 30f10.4)") isec, & - (e_fact(isec,27,ie),ie=1,NEMIS_FILES) + (e_fact(isec,27,ie),ie=1,NEMIS_FILE) end do end if ! DEBUG ios = 0 end subroutine femis ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine EmisHeights() + integer :: snap, k, allocerr + real :: tmp(KMAX_MID) ! values + character(len=200) :: txtinput ! For read-in + character(len=20) :: txt1 + call open_file(IO_EMIS,"r","EmisHeights.txt",needed=.true.) + + do + call read_line(IO_EMIS,txtinput,ios,'EmisHeight') + if(me==1) print *, "EMIS HEIGHTS " // trim(txtinput)!, ios + if ( ios < 0 ) exit ! End of file + if( index(txtinput,"#")>0 ) then ! Headers + call PrintLog(trim(txtinput),MasterProc) + cycle + else if( index(txtinput,"Nklevels")>0 ) then ! Number levels + read(txtinput,fmt=*,iostat=ios) txt1, nemis_kprofile + call PrintLog(trim(txtinput),MasterProc) + allocate(emis_kprofile(nemis_kprofile,NSECTORS),stat=allocerr) + call CheckStop(allocerr, "Allocation error for emis_kprofile") + emis_kprofile(:,:) = -999.9 + cycle + else + read(txtinput,fmt=*,iostat=ios) snap, (tmp(k),k=1, nemis_kprofile) + if( DEBUG ) write(*,*) "VER=> ",snap, tmp(1), tmp(3) + emis_kprofile(:,snap) = tmp(:) + end if + end do + + call CheckStop(nemis_kprofile < 1,"EmisGet: No EmisHeights set!!") + call CheckStop( any( emis_kprofile(:,:) < 0 ), "EmisHeight read failure" ) + + close(IO_EMIS) + end subroutine EmisHeights +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> subroutine EmisSplit() !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> @@ -514,7 +562,7 @@ subroutine EmisSplit() !------------------------------------------------------------------------- !-- local - integer :: ie ! emission index in EMIS_NAME (1..NEMIS_FILES) + integer :: ie ! emission index in EMIS_FILE (1..NEMIS_FILE) integer :: itot ! Index in IX_ arrays integer :: iqrc ! index of split compound in emisfrac @@ -545,7 +593,7 @@ subroutine EmisSplit() iqrc = 0 ! Starting index in emisfrac array nrcsplit= 0 ! - do ie = 1, NEMIS_FILES + do ie = 1, NEMIS_FILE IDEF_LOOP: do idef = 0, 1 @@ -553,7 +601,7 @@ subroutine EmisSplit() if ( defaults ) then - fname = trim( "emissplit.defaults." // EMIS_NAME(ie) ) + fname = trim( "emissplit.defaults." // EMIS_FILE(ie) ) call open_file(IO_EMIS,"r",fname,needed=.true.) call CheckStop( ios, "EmisGet: ioserror:split.defaults " ) @@ -561,15 +609,13 @@ subroutine EmisSplit() else !** If specials exists, they will overwrite the defaults - fname = trim( "emissplit.specials." // EMIS_NAME(ie) ) + fname = trim( "emissplit.specials." // EMIS_FILE(ie) ) call open_file(IO_EMIS,"r",fname,needed=.false.) if ( ios == NO_FILE ) then ios = 0 if(MasterProc) & - write(*,fmt=*) "emis_split: no specials for:",EMIS_NAME(ie) - call CheckStop(trim(EMIS_NAME(ie))=='voc'.and.USE_FOREST_FIRES & - , "emissplit.specials.voc must exist if FOREST_FIRES used" ) + write(*,fmt=*) "emis_split: no specials for:",EMIS_FILE(ie) exit IDEF_LOOP endif @@ -598,7 +644,7 @@ subroutine EmisSplit() write(unit=6,fmt=*) "Will try to split ", nsplit , " times" write(unit=6,fmt=*) "Emis_MolWt = ", Emis_MolWt(ie) end if - write(unit=6,fmt=*) "Splitting ", trim(EMIS_NAME(ie)), & + write(unit=6,fmt=*) "Splitting ", trim(EMIS_FILE(ie)), & " emissions into ",& (trim(Headers(i+2)),' ',i=1,nsplit),'using ',trim(fname) end if @@ -618,8 +664,16 @@ subroutine EmisSplit() iqrc = iqrc + 1 emis_nsplit(ie) = emis_nsplit(ie) + 1 - call CheckStop( itot<1, & - "EmisSplit FAILED "//trim(intext(idef,i)) ) + if ( me ==0 .and. itot<1 ) then + print *, "EmisSplit FAILED idef ", me, idef, i, nsplit, trim( intext(idef,i) ) + print *, " Failed Splitting ", trim(EMIS_FILE(ie)), & + " emissions into ",& + (trim(Headers(n+2)),' ',n=1,nsplit),'using ',trim(fname) + print "(a, i3,30a10)", "EmisSplit FAILED headers ", me, (intext(idef,n),n=1,nsplit) + call CheckStop( itot<1, & + "EmisSplit FAILED "//trim(intext(idef,i)) //& + " possible incorrect Chem in run script?" ) + end if ! FAILURE tmp_iqrc2itot(iqrc) = itot itot2iqrc(itot) = iqrc @@ -735,15 +789,16 @@ subroutine EmisSplit() ! chemical scheme: do ie = 1, NEMIS_SPECS - !if ( MasterProc .and. ( EmisSpecFound(ie) .eqv. .false.) ) then - if ( ( EmisSpecFound(ie) .eqv. .false.) ) then - print *, "ERROR: EmisSpec not found!! " // trim(EMIS_SPECS(ie)) - print *, "ERROR: EmisSpec - emissions of this compound were specified",& + if ( MasterProc .and. ( EmisSpecFound(ie) .eqv. .false.) ) then + call PrintLog("WARNING: EmisSpec not found in snapemis. Ok if in forest fire!! " // trim(EMIS_SPECS(ie)) ) + write(*,*) "WARNING: EmisSpec - emissions of this compound were specified",& & " in the CM_reactions files, but not found in the ",& & " emissplit.defaults files. Make sure that the sets of files",& & " are consistent." - call CheckStop ( any( EmisSpecFound .eqv. .false.), & - "EmisSpecFound Error" ) + ! Emissions can now be found in ForestFire module. No need to + ! stop + ! call CheckStop ( any( EmisSpecFound .eqv. .false.), & + ! "EmisSpecFound Error" ) end if end do @@ -760,6 +815,19 @@ subroutine EmisSplit() iqrc2itot(:) = tmp_iqrc2itot(1:nrcemis) emis_masscorr(:) = tmp_emis_masscorr(1:nrcemis) +!rb: not ideal place for this but used here for a start +! Temporary solution! Need to find the molweight from the +! GenChem input but just to get something running first set +! a hard coded molar mass of 200. + if(USE_ROADDUST)THEN + allocate(roaddust_masscorr(NROADDUST),stat=allocerr) + call CheckStop(allocerr, "Allocation error for emis_masscorr") + if(MasterProc) & + write(*,fmt=*)"NOTE! WARNING! Molar mass assumed to be 200.0 for all road dust components. Emissions will be in ERROR if another value is set in the GenChem input!" + do ie=1,NROADDUST + roaddust_masscorr(ie)=1.0/200. + enddo + endif end subroutine EmisSplit !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< @@ -775,4 +843,129 @@ subroutine CountEmisSpecs( inspec ) end subroutine CountEmisSpecs +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine RoadDustGet(iemis,emisname,IRUNBEG,JRUNBEG,GIMAX,GJMAX, & + sumroaddust, & + globroad_dust_pot,road_globnland,road_globland) + +!....................................................................... +! DESCRIPTION: +! Reads in Road Dust emission potentials from one file, specified by iemis. +! The arrays read in here are the global arrays (allocatable) +!....................................................................... + + !--arguments + integer, intent(in) :: iemis ! emis index + character(len=*), intent(in) :: emisname ! emission name + integer, intent(in) :: IRUNBEG,JRUNBEG,GIMAX,GJMAX ! domain limits + real, intent(out), dimension(:,:,:) :: globroad_dust_pot ! Road dust emission potentials + integer, intent(inout), dimension(:,:,:):: & + road_globland !Road emis.codes + integer, intent(inout), dimension(:,:) :: & + road_globnland ! No. flat emitions in grid + real, intent(inout), dimension(:,:) :: sumroaddust ! Emission potential sums per country + + !--local + integer :: i, j, isec, iland, & ! loop variables + iic,ic ! country code (read from file) + real :: tmpdust ! for reading road dust emission potential file + integer, save :: ncmaxfound = 0 ! Max no. countries found in grid + character(len=300) :: inputline + + !>============================ + + if ( my_first_road ) then + if(DEBUG_ROADDUST)WRITE(*,*)"initializing sumroaddust!" + sumroaddust(:,:) = 0.0 ! initialize sums + ios = 0 + my_first_road = .false. + endif + + !>============================ + + globroad_dust_pot(:,:,:) = 0.0 + + if (DEBUG_ROADDUST) write(unit=6,fmt=*) "Called RoadDustGet with index, name", & + iemis, trim(emisname) +! fname = "emislist." // emisname + fname = emisname + call open_file(IO_EMIS,"r",fname,needed=.true.) + call CheckStop(ios,"RoadDustGet: ios error1 in emission file") + + read(unit=IO_EMIS,fmt="(a200)",iostat=ios) inputline + if( inputline(1:1) .ne. "#" ) then ! Is a comment + write(*,*)'ERROR in road dust emission file!' + write(*,*)'First line should be a comment line, starting with #' + else + write(*,*)'I read the comment line:',inputline + endif + +READEMIS: do ! ************* Loop over emislist files ******************* + + read(unit=IO_EMIS,fmt=*,iostat=ios) iic,i,j, tmpdust + +! write(*,*)'dust to dust',iic,i,j, tmpdust + + if( DEBUG_ROADDUST .and. i==DEBUG_i .and. j==DEBUG_j ) write(*,*) & + "DEBUG RoadDustGet "//trim(emisname) // ":" , iic, tmpdust + if ( ios < 0 ) exit READEMIS ! End of file + call CheckStop(ios > 0,"RoadDustGet: ios error2 in emission file") + + ! Check if country code in emisfile (iic) is in the country list + ! from Countries_ml, i.e. corresponds to numbering index ic + + do ic=1,NLAND + if((Country(ic)%index==iic))& + goto 654 + enddo + write(unit=errmsg,fmt=*) & + "COUNTRY CODE NOT RECOGNIZED OR UNDEFINED ", iic + call CheckStop(errmsg) + ic=0 +654 continue + + i = i-IRUNBEG+1 ! for RESTRICTED domain + j = j-JRUNBEG+1 ! for RESTRICTED domain + + if ( i <= 0 .or. i > GIMAX .or. & + j <= 0 .or. j > GJMAX .or. & + ic <= 0 .or. ic > NLAND )& + cycle READEMIS + + ! .......................................................... + ! generate new land allocation in 50 km grid. First, we check if + ! country "ic" has already been found within that grid. If not, + ! then ic is added to landcode and nlandcode increased by one. + + call GridAllocate("ROAD"// trim ( emisname ),i,j,ic,NCMAX, & + iland,ncmaxfound,road_globland,road_globnland) + + globroad_dust_pot(i,j,iland) = globroad_dust_pot(i,j,iland) & + + tmpdust + if( DEBUG_ROADDUST .and. i==DEBUG_i .and. j==DEBUG_j ) write(*,*) & + "DEBUG RoadDustGet iland, globrdp",iland,globroad_dust_pot(i,j,iland) + +! NOTE!!!! A climatological factor is still missing for the road dust! +! should increase the emissions in dry areas by up to a factor of ca 3.3 +! Will be based on soil water content +! (Fixed later....) + + ! Sum over all sectors, store as Ktonne: +! if(tmpdust.lt.0.)write(*,*)'neg dust!', tmpdust + sumroaddust(ic,iemis) = sumroaddust(ic,iemis) & + + 0.001 * tmpdust +! if(sumroaddust(ic,iemis).lt.0.)write(*,*) & +! 'We are on a road to nowhere', ic,iemis,tmpdust + + end do READEMIS + + if(DEBUG_ROADDUST) write(*,*)'done one, got sumroaddust=',sumroaddust(:,iemis) + + close(IO_EMIS) + ios = 0 + end subroutine RoadDustGet + + + end module EmisGet_ml diff --git a/Emissions_ml.f90 b/Emissions_ml.f90 index f2cadd9..44b5763 100644 --- a/Emissions_ml.f90 +++ b/Emissions_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -38,55 +38,76 @@ module Emissions_ml ! with the 3D model. !_____________________________________________________________________________ - use CheckStop_ml,only : CheckStop + use Biogenics_ml, only : SoilNOx, AnnualNdep + use CheckStop_ml,only : CheckStop,StopAll use ChemSpecs_shl_ml, only: NSPEC_SHL use ChemSpecs_tot_ml, only: NSPEC_TOT,NO2 use ChemChemicals_ml, only: species - use Country_ml, only : NLAND,Country_Init,Country, IC_NAT - use My_Emis_ml, only : NEMIS_FILES & ! No. emission files - ,EMIS_NAME ! Names of species ("sox ",...) + use Country_ml, only : NLAND,Country_Init,Country,IC_NAT,IC_FI,IC_NO,IC_SE use EmisDef_ml, only : NSECTORS & ! No. sectors - ,NEMISLAYERS & ! No. vertical layers for emission + ,NEMIS_FILE & ! No. emission files + ,EMIS_FILE & ! Names of species ("sox ",...) ,NCMAX & ! Max. No. countries per grid ,FNCMAX & ! Max. No. countries (with flat emissions) ! per grid + ,ISNAP_DOM & ! snap index for domestic/resid emis + ,ISNAP_TRAF & ! snap index for road-traffic (SNAP7) ,ISNAP_SHIP & ! snap index for ship emissions ,ISNAP_NAT & ! snap index for nat. (dms) emissions ,IQ_DMS & ! code for DMS emissions - ,VERTFAC ! vertical emission split - use EmisGet_ml, only : EmisGet, EmisSplit, & - nrcemis, nrcsplit, emisfrac & ! speciation routines and array + ,NROAD_FILES & ! No. road dust emis potential files + ,ROAD_FILE & ! Names of road dust emission files + ,NROADDUST & ! No. road dust components + ,QROADDUST_FI & ! fine road dust emissions (PM2.5) + ,QROADDUST_CO & ! coarse road dust emis + ,ROADDUST_FINE_FRAC & ! fine (PM2.5) fraction of road dust emis + , ROADDUST_CLIMATE_FILE ! TEMPORARY! file for road dust climate factors + use EmisGet_ml, only : EmisGet, EmisSplit & + ,EmisHeights & ! Generates vertical distrib + ,nrcemis, nrcsplit, emisfrac & ! speciation routines and array + ,nemis_kprofile, emis_kprofile &! Vertical emissions profile ,iqrc2itot & ! maps from split index to total index ,emis_masscorr & ! 1/molwt for most species - ,emis_nsplit ! No. species per emis file + ,emis_nsplit & ! No. species per emis file + ,RoadDustGet & + ,roaddust_masscorr ! 1/200. Hard coded at the moment, needs proper setting in EmisGet_ml... use GridValues_ml, only: GRIDWIDTH_M & ! size of grid (m) ,xm2 & ! map factor squared ,debug_proc,debug_li,debug_lj & - ,sigma_bnd, xmd, glat, glon,dA,dB + ,sigma_bnd, xmd, glat, glon,dA,dB,i_fdom,j_fdom use Io_Nums_ml, only : IO_LOG, IO_DMS, IO_EMIS use Io_Progs_ml, only : ios, open_file, datewrite - use MetFields_ml, only : roa, ps, z_bnd ! ps in Pa, roa in kg/m3 + use MetFields_ml, only : roa, ps, z_bnd, surface_precip ! ps in Pa, roa in kg/m3 + use MetFields_ml, only : t2_nwp ! DS_TEST SOILNO - was zero! use ModelConstants_ml,only : KMAX_MID, KMAX_BND, PT ,dt_advec, & IS_GLOBAL, & NBVOC, & ! > 0 if forest voc wanted + INERIS_SNAP2 , & ! INERIS/TFMM HDD20 method DEBUG => DEBUG_EMISSIONS, MasterProc, & - DEBUG_SOILNO, & + DEBUG_SOILNOX , DEBUG_EMISTIMEFACS, & + DEBUG_ROADDUST , & + DEBUG_I,DEBUG_J, & + USE_DEGREEDAY_FACTORS, & NPROC, IIFULLDOM,JJFULLDOM , & - USE_AIRCRAFT_EMIS, & - USE_SOIL_NOX + USE_LIGHTNING_EMIS,USE_AIRCRAFT_EMIS,USE_ROADDUST, & + USE_SOILNOX, USE_GLOBAL_SOILNOX ! one or the other + use NetCDF_ml, only : ReadField_CDF use Par_ml, only : MAXLIMAX,MAXLJMAX,me,gi0,gi1,gj0,gj1, & GIMAX, GJMAX, IRUNBEG, JRUNBEG, & - limax,ljmax,li0,lj0,li1,lj1, & + limax,ljmax, & MSG_READ1,MSG_READ7 use PhysicalConstants_ml, only : GRAV, AVOG + use Setup_1dfields_ml, only : rcemis ! ESX + use ReadField_ml, only : ReadField ! Reads ascii fields - use TimeDate_ml, only : nydays, nmdays, date, current_date ! No. days per - ! year, date-type + use TimeDate_ml, only : nydays, nmdays, date, current_date, &! No. days per + daynumber,day_of_week ! year, date-type, weekday use Timefactors_ml, only : & NewDayFactors & ! subroutines - ,timefac, day_factor ! time-factors - use Timefactors_ml, only : timefactors & ! subroutine - ,fac_emm, fac_edd, day_factor ! time-factors + ,DegreeDayFactors & ! degree-days used for SNAP-2 + ,Gridded_SNAP2_Factors, gridfac_HDD & + ,fac_min,timefactors & ! subroutine + ,fac_ehh24x7 ,fac_emm, fac_edd, timefac ! time-factors use Volcanos_ml @@ -106,30 +127,36 @@ module Emissions_ml INCLUDE 'mpif.h' INTEGER STATUS(MPI_STATUS_SIZE),INFO - + ! land-code information in each grid square - needed to know which country ! is emitting. ! nlandcode = No. countries in grid square ! landcode = Country codes for that grid square - integer, private, save, dimension(MAXLIMAX,MAXLJMAX) :: nlandcode - integer, private, save, dimension(MAXLIMAX,MAXLJMAX,NCMAX) :: landcode + integer, private, save, allocatable, dimension(:,:) :: nlandcode + integer, private, save, allocatable, dimension(:,:,:) :: landcode ! for flat emissions, i.e. no vertical extent: - integer, private, save, dimension(MAXLIMAX,MAXLJMAX) :: flat_nlandcode - integer, private, save, dimension(MAXLIMAX,MAXLJMAX,FNCMAX):: flat_landcode + integer, private, save, allocatable, dimension(:,:) :: flat_nlandcode + integer, private, save, allocatable, dimension(:,:,:):: flat_landcode + ! for road dust emission potentials: + integer, private, save, allocatable, dimension(:,:) :: road_nlandcode + integer, private, save, allocatable, dimension(:,:,:) :: road_landcode ! ! The output emission matrix for the 11-SNAP data is snapemis: ! - real, private, dimension(NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,NEMIS_FILES) & + real, private, allocatable, dimension(:,:,:,:,:) & , save :: snapemis ! main emission arrays, in kg/m2/s - real, private, dimension(MAXLIMAX,MAXLJMAX,FNCMAX,NEMIS_FILES) & + real, private, allocatable, dimension(:,:,:,:) & , save :: snapemis_flat ! main emission arrays, in kg/m2/s + real, private, allocatable, dimension(:,:,:,:) & ! Not sure if it is really necessary to keep the country info; gives rather messy code but consistent with the rest at least (and can do the seasonal scaling for Nordic countries in the code instead of as preprocessing) + , save :: roaddust_emis_pot ! main road dust emission potential arrays, in kg/m2/s (to be scaled!) + ! We store the emissions for output to d_2d files and netcdf in kg/m2/s - real, public, dimension(MAXLIMAX,MAXLJMAX,NEMIS_FILES), save :: SumSnapEmis + real, public, allocatable, dimension(:,:,:), save :: SumSnapEmis logical, save, private :: first_dms_read @@ -137,124 +164,181 @@ module Emissions_ml ! KEMISTOP added to avoid hard-coded KMAX_MID-3: - integer, public, parameter :: KEMISTOP = KMAX_MID - NEMISLAYERS + 1 + !integer, public, parameter :: KEMISTOP = KMAX_MID - NEMISLAYERS + 1 + integer, public, save :: KEMISTOP ! not defined yet= KMAX_MID - nemis_kprofile + 1 real, public, allocatable, save, dimension(:,:,:,:) :: & gridrcemis & ! varies every time-step (as ps changes) ,gridrcemis0 ! varies every hour + real, public, allocatable, save, dimension(:,:,:) :: & + gridrcroadd & ! Road dust emissions + ,gridrcroadd0 ! varies every hour ! and for budgets (not yet used - not changed dimension) real, public, save, dimension(NSPEC_SHL+1:NSPEC_TOT) :: totemadd - real, public, save, dimension(MAXLIMAX,MAXLJMAX) :: SoilNOx integer, private, save :: iemCO ! index of CO emissions, for debug + logical, parameter ::USE_OLDSCHEME_ROADDUST=.false. !temporary until the new scheme is validated + contains !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - subroutine Emissions(year) - - - ! Calls main emission reading routines - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - !*********************************************************************** - ! DESCRIPTION: - ! 0) Call set_molwts and set_emisconv_and_iq, followed by - ! consistency check - ! 1) Call some setups: - ! Country_Init - ! timefactors: monthly and daily factors, + time zone - ! -> fac_emm, fac_edd arrays, timezone - ! 2) Read in emission correction file femis - ! 3) Call emis_split for speciations - ! 4) Read the annual emission totals in each grid-square, converts - ! units and corrects using femis data. - ! - ! The output emission matrix for the 11-SNAP data is snapemis: - ! - ! real snapemis (NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,NEMIS_FILES) - ! - !********************************************************************** - - !--arguments - integer, intent(in) :: year ! Year ( 4-digit) - - !-- local variables - real :: conv ! Conversion factor - integer :: i, j ! Loop variables - real :: tonne_to_kgm2s ! Converts tonnes/grid to kg/m2/s - real :: ccsum ! Sum of emissions for one country - - ! arrays for whole EMEP area: - ! additional arrays on host only for landcode, nlandcode - ! BIG arrays ... will be needed only on me=0. Make allocatable - ! to reduce static memory requirements. - - real, allocatable, dimension(:,:,:,:) :: globemis - integer, allocatable, dimension(:,:) :: globnland - integer, allocatable, dimension(:,:,:) :: globland - real, allocatable, dimension(:,:,:) :: globemis_flat - integer, allocatable, dimension(:,:) :: flat_globnland - integer, allocatable, dimension(:,:,:) :: flat_globland - integer :: err1, err2, err3, err4, err5, err6 ! Error messages - integer :: fic - integer :: ic ! country codes - integer :: isec ! loop variables: emission sectors - integer :: iem ! loop variable over pollutants (1..NEMIS_FILES) + subroutine Emissions(year) + + + ! Calls main emission reading routines + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !*********************************************************************** + ! DESCRIPTION: + ! 0) Call set_molwts and set_emisconv_and_iq, followed by + ! consistency check + ! 1) Call some setups: + ! Country_Init + ! timefactors: monthly and daily factors, + time zone + ! -> fac_emm, fac_edd arrays, timezone + ! 2) Read in emission correction file femis + ! 3) Call emis_split for speciations + ! 4) Read the annual emission totals in each grid-square, converts + ! units and corrects using femis data. + ! + ! The output emission matrix for the 11-SNAP data is snapemis: + ! + ! real snapemis (NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,NEMIS_FILES) + ! + !********************************************************************** + + !--arguments + integer, intent(in) :: year ! Year ( 4-digit) + + !-- local variables + real :: conv ! Conversion factor + integer :: i, j ! Loop variables + real :: tonne_to_kgm2s ! Converts tonnes/grid to kg/m2/s + real :: ccsum ! Sum of emissions for one country + + ! arrays for whole EMEP area: + ! additional arrays on host only for landcode, nlandcode + ! BIG arrays ... will be needed only on me=0. Make allocatable + ! to reduce static memory requirements. + real, allocatable, dimension(:,:,:,:) :: globemis + integer, allocatable, dimension(:,:) :: globnland + integer, allocatable, dimension(:,:,:) :: globland + real, allocatable, dimension(:,:,:) :: globemis_flat + integer, allocatable, dimension(:,:) :: flat_globnland + integer, allocatable, dimension(:,:,:) :: flat_globland + real, allocatable, dimension(:,:,:) :: globroad_dust_pot ! Road dust emission potentials + integer, allocatable, dimension(:,:) :: road_globnland + integer, allocatable, dimension(:,:,:) :: road_globland + real, allocatable, dimension(:,:) :: RoadDustEmis_climate_factor ! Climatic factor for scaling road dust emissions (in TNO model based on yearly average soil water) + integer :: err1, err2, err3, err4, err5, err6, err7, err8, err9 ! Error messages + integer :: fic ,insec,inland,iemis + integer :: iic,ic,n ! country codes + integer :: isec ! loop variables: emission sectors + integer :: iem ! loop variable over pollutants (1..NEMIS_FILE) + character(len=40) :: fname ! File name + character(len=300) :: inputline + real :: tmpclimfactor + + ! Emission sums (after e_fact adjustments): + real, dimension(NEMIS_FILE) :: emsum ! Sum emis over all countries + real, dimension(NLAND,NEMIS_FILE) :: sumemis, sumemis_local ! Sum of emissions per country + + ! Road dust emission potential sums (just for testing the code, the actual emissions are weather dependent!) + real, dimension(NROAD_FILES) :: roaddustsum ! Sum emission potential over all countries + real, dimension(NLAND,NROAD_FILES) :: sumroaddust ! Sum of emission potentials per country + real, dimension(NLAND,NROAD_FILES) :: sumroaddust_local ! Sum of emission potentials per country in subdomain + real :: fractions(MAXLIMAX,MAXLJMAX,NCMAX),SMI(MAXLIMAX,MAXLJMAX),SMI_roadfactor + logical ::SMI_defined=.false. + real, allocatable ::emis_tot(:,:) + character(len=40) :: varname + logical ::CDF_emis=.false.!experimental + + if (MasterProc) write(6,*) "Reading emissions for year", year + + ! 0) set molwts, conversion factors (e.g. tonne NO2 -> tonne N), and + ! emission indices (IQSO2=.., ) + + allocate(nlandcode(MAXLIMAX,MAXLJMAX),landcode(MAXLIMAX,MAXLJMAX,NCMAX)) + nlandcode=0 + landcode=0 + allocate(flat_nlandcode(MAXLIMAX,MAXLJMAX),flat_landcode(MAXLIMAX,MAXLJMAX,FNCMAX)) + flat_nlandcode=0 + flat_landcode=0 + allocate(road_nlandcode(MAXLIMAX,MAXLJMAX),road_landcode(MAXLIMAX,MAXLJMAX,NCMAX)) + road_nlandcode=0 + road_landcode=0 + allocate(snapemis(NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,NEMIS_FILE)) + snapemis=0.0 + allocate(snapemis_flat(MAXLIMAX,MAXLJMAX,FNCMAX,NEMIS_FILE)) + snapemis_flat=0.0 + allocate(roaddust_emis_pot(MAXLIMAX,MAXLJMAX,NCMAX,NROAD_FILES)) + roaddust_emis_pot=0.0 + allocate(SumSnapEmis(MAXLIMAX,MAXLJMAX,NEMIS_FILE)) + SumSnapEmis=0.0 - ! Emission sums (after e_fact adjustments): - real, dimension(NEMIS_FILES) :: emsum ! Sum emis over all countries - real, dimension(NLAND,NEMIS_FILES) :: sumemis ! Sum of emissions per country + !========================= + call Country_Init() ! In Country_ml, => NLAND, country codes and + ! names, timezone + !========================= - if (MasterProc) write(6,*) "Reading emissions for year", year + call consistency_check() ! Below + !========================= + + ios = 0 - ! 0) set molwts, conversion factors (e.g. tonne NO2 -> tonne N), and - ! emission indices (IQSO2=.., ) + if ( USE_DEGREEDAY_FACTORS ) & + call DegreeDayFactors(0) ! See if we have gridded SNAP-2 - !========================= - call Country_Init() ! In Country_ml, => NLAND, country codes and - ! names, timezone - !========================= + call EmisHeights() ! vertical emissions profile + KEMISTOP = KMAX_MID - nemis_kprofile + 1 - call consistency_check() ! Below - !========================= + if( MasterProc) then !::::::: ALL READ-INS DONE IN HOST PROCESSOR :::: - ios = 0 + write(6,*) "Reading monthly and daily timefactors" + !========================= + call timefactors(year) ! => fac_emm, fac_edd + !========================= - if( MasterProc) then !::::::: ALL READ-INS DONE IN HOST PROCESSOR :::: + endif - write(6,*) "Reading monthly and daily timefactors" !========================= - call timefactors(year) ! => fac_emm, fac_edd, day_factor + call EmisSplit() ! In EmisGet_ml, => emisfrac !========================= + call CheckStop(ios, "ioserror: EmisSplit") + + + ! #################################### + ! Broadcast monthly and Daily factors (and hourly factors if needed/wanted) + CALL MPI_BCAST( fac_emm ,8*NLAND*12*NSECTORS*NEMIS_FILE,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST( fac_edd ,8*NLAND*7*NSECTORS*NEMIS_FILE,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST( fac_ehh24x7 ,8*NSECTORS*24*7,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) + + !define fac_min for all processors + do iemis = 1, NEMIS_FILE + do insec = 1, NSECTORS + do inland = 1, NLAND + fac_min(inland,insec,iemis) = minval( fac_emm(inland,:,insec,iemis) ) + enddo + enddo + enddo + if(INERIS_SNAP2 )THEN ! INERIS do not use any base-line for SNAP2 + fac_min(:,ISNAP_DOM,:) = 0. + end if - endif - - !========================= - call EmisSplit() ! In EmisGet_ml, => emisfrac - !========================= - call CheckStop(ios, "ioserror: EmisSplit") - - - ! #################################### - ! Broadcast monthly and Daily factors - CALL MPI_BCAST( fac_emm ,8*NLAND*12*NSECTORS*NEMIS_FILES,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST( fac_edd ,8*NLAND*7*NSECTORS*NEMIS_FILES,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST( day_factor ,8*2*NSECTORS,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) + !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: + ! c4b) Set up DMS factors here - to be used in newmonth + ! Taken from IQ_DMS=35 for SO2 nature (sector 11) + ! first_dms_read is true until first call to newmonth finished. - !:::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::: - ! c4b) Set up DMS factors here - to be used in newmonth - ! Taken from IQ_DMS=35 for SO2 nature (sector 11) - ! first_dms_read is true until first call to newmonth finished. + first_dms_read = .true. - first_dms_read = .true. - - ! 4) Read emission files + ! 4) Read emission files - ! allocate for me=0 only: + ! allocate for me=0 only: - err1 = 0 - if ( MasterProc ) then + err1 = 0 + if ( MasterProc ) then if (DEBUG) write(unit=6,fmt=*) "TTT me ", me , "pre-allocate" allocate(globnland(GIMAX,GJMAX),stat=err1) @@ -272,6 +356,17 @@ subroutine Emissions(year) call CheckStop(err5, "Allocation error 5 - globland") call CheckStop(err6, "Allocation error 6 - globland") + if(USE_ROADDUST)then + allocate(road_globnland(GIMAX,GJMAX),stat=err7) + allocate(road_globland(GIMAX,GJMAX,NCMAX),stat=err8) + allocate(globroad_dust_pot(GIMAX,GJMAX,NCMAX),stat=err9) + allocate(RoadDustEmis_climate_factor(GIMAX,GJMAX),stat=err1) + + call CheckStop(err7, "Allocation error 7 - globroadland") + call CheckStop(err8, "Allocation error 8 - globroadland") + call CheckStop(err9, "Allocation error 9 - globroad_dust_pot") + call CheckStop(err1, "Allocation error 1 - RoadDustEmis_climate_factor") + endif ! road dust ! Initialise with 0 globnland(:,:) = 0 @@ -281,134 +376,396 @@ subroutine Emissions(year) flat_globland(:,:,:)=0 globemis_flat(:,:,:) =0 - end if - - do iem = 1, NEMIS_FILES - ! now again test for me=0 - if ( MasterProc ) then - - ! read in global emissions for one pollutant - ! ***************** - call EmisGet(iem,EMIS_NAME(iem),IRUNBEG,JRUNBEG,GIMAX,GJMAX, & - globemis,globnland,globland,sumemis,& - globemis_flat,flat_globnland,flat_globland) - ! ***************** - - - emsum(iem) = sum( globemis(:,:,:,:) ) + & - sum( globemis_flat(:,:,:) ) ! hf - endif ! MasterProc + if(USE_ROADDUST)then + road_globnland(:,:)=0 + road_globland(:,:,:)=0 + globroad_dust_pot(:,:,:)=0. + RoadDustEmis_climate_factor(:,:)=1.0 ! default, no scaling + endif ! road dust - call CheckStop(ios, "ios error: EmisGet") - - ! Send data to processors - ! as e.g. snapemis (NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,iem) - ! send to nodes + end if - call global2local(globemis,snapemis(1,1,1,1,iem),MSG_READ1, & + do iem = 1, NEMIS_FILE + ! now again test for me=0 + if(.not.CDF_emis)then + if ( MasterProc ) then + + ! read in global emissions for one pollutant + ! ***************** + call EmisGet(iem,EMIS_FILE(iem),IRUNBEG,JRUNBEG,GIMAX,GJMAX, & + globemis,globnland,globland,sumemis,& + globemis_flat,flat_globnland,flat_globland) + ! ***************** + + + emsum(iem) = sum( globemis(:,:,:,:) ) + & + sum( globemis_flat(:,:,:) ) ! hf + endif ! MasterProc + + call CheckStop(ios, "ios error: EmisGet") + + ! Send data to processors + ! as e.g. snapemis (NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,iem) + ! send to nodes + + call global2local(globemis,snapemis(1,1,1,1,iem),MSG_READ1, & NSECTORS,GIMAX,GJMAX,NCMAX,1,1) - - call global2local(globemis_flat,snapemis_flat(1,1,1,iem),MSG_READ1, & + + call global2local(globemis_flat,snapemis_flat(1,1,1,iem),MSG_READ1, & 1,GIMAX,GJMAX,FNCMAX,1,1) + else + !use grid independent netcdf emission file + !experimental so far. Needs a lot of reorganization + if(.not.allocated(emis_tot))then + allocate(emis_tot(MAXLIMAX,MAXLJMAX)) + endif +77 format(A,I2.2) + sumemis_local(:,iem)=0.0 + do isec=1,NSECTORS + + if(iem==1)varname='SOx_sec' + if(iem==2)varname='NOx_sec' + if(iem==3)varname='CO_sec' + if(iem==4)varname='NMVOC_sec' + if(iem==5)varname='NH3_sec' + if(iem==6)varname='PM25_sec' + if(iem==7)varname='PMco_sec' + write(varname,77)trim(varname),isec + call ReadField_CDF('/global/work/mifapw/emep/Data/Emis_TNO7.nc',varname,emis_tot(1,1),& + nstart=1,interpol='mass_conservative', & + fractions_out=fractions,CC_out=landcode,Ncc_out=nlandcode,needed=.true.,debug_flag=.true.,Undef=0.0) + + do j=1,ljmax + do i=1,limax + if(nlandcode(i,j)>NCMAX)then + write(*,*)"To many emitter countries in one gridcell: ", me,i,j,nlandcode(i,j) + call StopAll("To many countries in one gridcell ") + endif + do n=1,nlandcode(i,j) + snapemis(isec,i,j,n,iem)=snapemis(isec,i,j,n,iem)+fractions(i,j,n)*emis_tot(i,j) + ic=1 + if(landcode(i,j,n)<=NLAND)ic=landcode(i,j,n)!most country_index are equal to country_code + if(Country(ic)%index/=landcode(i,j,n))then + !if not equal, find which index correspond to country_code + do ic=1,NLAND + if((Country(ic)%index==landcode(i,j,n)))exit + enddo + if(ic>NLAND)then + write(*,*)"COUNTRY CODE NOT RECOGNIZED OR UNDEFINED: ", landcode(i,j,n) + call StopAll("COUNTRY CODE NOT RECOGNIZED ") + endif + endif + sumemis_local(ic,iem)= sumemis_local(ic,iem)+0.001*snapemis(isec,i,j,n,iem)!for diagnostics, mass balance + enddo + enddo + enddo + + + enddo!sectors + CALL MPI_REDUCE(sumemis_local(1,iem),sumemis(1,iem),NLAND,MPI_REAL8,MPI_SUM,0,MPI_COMM_WORLD,INFO) + emsum(iem)= sum(sumemis(:,iem)) + endif + + + end do ! iem = 1, NEMIS_FILE-loop + + if(USE_ROADDUST) then + + if(USE_OLDSCHEME_ROADDUST)then + !use scheme with ASCII and grid dependent input data + + ! First Temporary/Test handling of climate factors. Read from file. Should be enough to do this on MasterProc + + if ( MasterProc )then + ! if(.true.)then + if (DEBUG_ROADDUST) write(unit=6,fmt=*) "Setting road dust climate scaling factors from", & + trim(roaddust_climate_file) + fname = roaddust_climate_file + call open_file(IO_EMIS,"r",fname,needed=.true.) + call CheckStop(ios,"RoadDust climate file: ios error in emission file") + + read(unit=IO_EMIS,fmt="(a200)",iostat=ios) inputline + if( inputline(1:1) .ne. "#" ) then ! Is a comment + write(*,*)'ERROR in road dust climate factor file!' + write(*,*)'First line should be a comment line, starting with #' + else + IF(DEBUG_ROADDUST) write(*,*)'I read the comment line:',inputline + endif + + READCLIMATEFACTOR: do ! ************* Loop over emislist files ******************* + + read(unit=IO_EMIS,fmt=*,iostat=ios) i,j, tmpclimfactor + + if ( ios < 0 ) exit READCLIMATEFACTOR ! End of file + call CheckStop(ios > 0,"RoadDust climate file: ios error2 in climate factor file") + + i = i-IRUNBEG+1 ! for RESTRICTED domain + j = j-JRUNBEG+1 ! for RESTRICTED domain + + if ( i <= 0 .or. i > GIMAX .or. & + j <= 0 .or. j > GJMAX )& + cycle READCLIMATEFACTOR + + RoadDustEmis_climate_factor(i,j) = tmpclimfactor + + + if( DEBUG_ROADDUST .and. i==DEBUG_i .and. j==DEBUG_j ) write(*,*) & + "DEBUG RoadDust climate factor (read from file)", RoadDustEmis_climate_factor(i,j) + + enddo READCLIMATEFACTOR + ! else + ! write(unit=6,fmt=*) "Test run set road dust climate factor to 1 everywhere!" + ! RoadDustEmis_climate_factor(:,:) = 1.0 + ! endif + + endif !MasterProc + + do iem = 1, NROAD_FILES + ! now again test for me=0 + if ( MasterProc ) then - end do ! iem = 1, NEMIS_FILES-loop - + ! read in road dust emission potentials from one file + ! There will be two road dust files; one for highways(plus some extras) and one for non-highways + ! Each file contains spring (Mar-May) and rest-of-the-year (June-February) emission potentials + ! However, this will be changed so that only "rest-of-the-year" data are read and the spring scaling + ! for the Nordic countries is handled in the EmisSet routine! + ! Emission potentials are for PM10 so should be split into PM-fine (10%) and PM-coarse (90%) + ! There should also be some modifications to take into account temporal variations due to different + ! traffic intensities and differences due to surface wetness (handled in EmisSet) + ! and a climatological factor (handled here). + + ! ***************** + call RoadDustGet(iem,ROAD_FILE(iem),IRUNBEG,JRUNBEG,GIMAX,GJMAX, & + sumroaddust,& + globroad_dust_pot,road_globnland,road_globland) + ! ***************** + + roaddustsum(iem) = sum( globroad_dust_pot(:,:,:) ) ! + + ! ToDo-2012-0913 + + do i=1,GIMAX + do j=1,GJMAX + if(DEBUG_ROADDUST)then + WRITE(*,*)"i,j,RDECF:",i,j,RoadDustEmis_climate_factor(i,j) + endif + globroad_dust_pot(i,j,:)=RoadDustEmis_climate_factor(i,j)*globroad_dust_pot(i,j,:) + enddo + enddo + + + endif ! MasterProc + + call CheckStop(ios, "ios error: RoadDustGet") + + ! Send data to processors + ! as e.g. snapemis (NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,iem) + ! send to nodes + + call global2local(globroad_dust_pot,roaddust_emis_pot(1,1,1,iem),MSG_READ1, & + 1,GIMAX,GJMAX,NCMAX,1,1) + + end do ! iem = 1, NROAD_FILES-loop + + + call global2local_int(road_globnland,road_nlandcode,326,& + GIMAX,GJMAX,1,1,1) !extra array + call global2local_int(road_globland,road_landcode,326,& + GIMAX,GJMAX,NCMAX,1,1) + + + else + !Use grid-independent Netcdf input files + + do iem = 1, NROAD_FILES + !Read data from NetCDF file + if(iem==1)varname='HighwayRoadDustPM10_Jun-Feb' + if(iem==2)varname='nonHighwayRoadDustPM10_Jun-Feb' + call CheckStop(iem>2, "TOO MANY ROADFILES") + + roaddust_emis_pot(:,:,:,iem)=0.0 + call ReadField_CDF('RoadMap.nc',varname,roaddust_emis_pot(1,1,1,iem),& + nstart=1,interpol='mass_conservative', & + fractions_out=fractions,CC_out=road_landcode,Ncc_out=road_nlandcode,needed=.true.,debug_flag=.true.,Undef=0.0) + if(.not.SMI_defined)then + varname='SMI1' + call ReadField_CDF('AVG_SMI_2005_2010.nc',varname,SMI,nstart=1,& + interpol='conservative',needed=.true.,debug_flag=.true.) + SMI_defined=.true. + endif + + do i=1,LIMAX + do j=1,LJMAX + SMI_roadfactor=3.325-(min(1.0,max(0.5,SMI(i,j)))-0.5) *2*(3.325-1.0)!Peter: Rough estimate to get something varying between 3.325 (SMI<0.5) and 1.0 (SMI>1) + if(DEBUG_ROADDUST)then + ! WRITE(*,*)"i,j,RDECF:",i_fdom(i)-IRUNBEG+1,j_fdom(j)-JRUNBEG+1,SMI_roadfactor + endif + do iic=road_nlandcode(i,j),1,-1 + roaddust_emis_pot(i,j,iic,iem)=roaddust_emis_pot(i,j,1,iem)*fractions(i,j,iic)*SMI_roadfactor + enddo + enddo + enddo + sumroaddust_local(:,iem)=0.0 + do i=1,LIMAX + do j=1,LJMAX + do iic=1,road_nlandcode(i,j) + ic=1 + if(road_landcode(i,j,iic)<=NLAND)ic=road_landcode(i,j,iic)!most country_index are equal to country_code + if(Country(ic)%index/=road_landcode(i,j,iic))then + !if not equal, find which index correspond to country_code + do ic=1,NLAND + if((Country(ic)%index==road_landcode(i,j,iic)))exit + enddo + if(ic>NLAND)then + write(*,*)"COUNTRY CODE NOT RECOGNIZED OR UNDEFINED: ", road_landcode(i,j,iic) + call StopAll("COUNTRY CODE NOT RECOGNIZED ") + + endif + endif + + sumroaddust_local(ic,iem)=sumroaddust_local(ic,iem)+0.001*roaddust_emis_pot(i,j,iic,iem) + + enddo + enddo + enddo + + end do ! iem = 1, NROAD_FILES-loop + + sumroaddust=0.0 + CALL MPI_REDUCE(sumroaddust_local,sumroaddust,NLAND*NROAD_FILES,MPI_REAL8,MPI_SUM,0,MPI_COMM_WORLD,INFO) + + endif + + end if !USE_ROADDUST if ( MasterProc ) then - write(unit=6,fmt=*) "Total emissions by countries:" - write(unit=IO_LOG,fmt=*) "Total emissions by countries:" - write(unit=6,fmt="(2a4,11x,30a12)") " N "," CC ",(EMIS_NAME(iem),iem=1,NEMIS_FILES) - write(unit=IO_LOG,fmt="(2a4,11x,30a12)") " N "," CC ",(EMIS_NAME(iem),iem=1,NEMIS_FILES) - - do ic = 1, NLAND - ccsum = sum( sumemis(ic,:) ) - if ( ccsum > 0.0 ) then - write(unit=6,fmt="(i3,1x,a4,3x,30f12.2)") & - ic, Country(ic)%code, (sumemis(ic,i),i=1,NEMIS_FILES) - write(unit=IO_LOG,fmt="(i3,1x,a4,3x,30f12.2)")& - ic, Country(ic)%code, (sumemis(ic,i),i=1,NEMIS_FILES) - end if - end do + write(unit=6,fmt=*) "Total emissions by countries:" + write(unit=IO_LOG,fmt=*) "Total emissions by countries:" + write(unit=6,fmt="(2a4,11x,30a12)") " N "," CC ",(EMIS_FILE(iem),iem=1,NEMIS_FILE) + write(unit=IO_LOG,fmt="(2a4,11x,30a12)") " N "," CC ",(EMIS_FILE(iem),iem=1,NEMIS_FILE) + + do ic = 1, NLAND + ccsum = sum( sumemis(ic,:) ) + if ( ccsum > 0.0 ) then + write(unit=6,fmt="(i3,1x,a4,3x,30f12.2)") & + ic, Country(ic)%code, (sumemis(ic,i),i=1,NEMIS_FILE) + write(unit=IO_LOG,fmt="(i3,1x,a4,3x,30f12.2)")& + ic, Country(ic)%code, (sumemis(ic,i),i=1,NEMIS_FILE) + end if + end do + + if(USE_ROADDUST)THEN + + write(unit=6,fmt=*) "Total road dust emission potentials by countries (before precipitation and land corrections):" + write(unit=IO_LOG,fmt=*) "Total road dust emission potentials by countries (before precipitation and land corrections):" + write(unit=6,fmt="(2a4,11x,30a12)") " N "," CC ",(ROAD_FILE(iem),iem=1,NROAD_FILES) + write(unit=IO_LOG,fmt="(2a4,11x,30a12)") " N "," CC ",(ROAD_FILE(iem),iem=1,NROAD_FILES) + + do ic = 1, NLAND + ccsum = sum( sumroaddust(ic,:) ) + if ( ccsum > 0.0 ) then + write(unit=6,fmt="(i3,1x,a4,3x,30f12.2)") & + ic, Country(ic)%code, (sumroaddust(ic,i),i=1,NROAD_FILES) + write(unit=IO_LOG,fmt="(i3,1x,a4,3x,30f12.2)")& + ic, Country(ic)%code, (sumroaddust(ic,i),i=1,NROAD_FILES) + end if + end do + endif ! ROAD DUST end if ! now all values are read, snapemis is distributed, globnland and ! globland are ready for distribution ! print *, "calling glob2local_int for iem", iem, " me ", me - call global2local_int(globnland,nlandcode,326, GIMAX,GJMAX,1,1,1) - call global2local_int(globland, landcode ,326, GIMAX,GJMAX,NCMAX,1,1) - - call global2local_int(flat_globnland,flat_nlandcode,326,& - GIMAX,GJMAX,1,1,1) !extra array - call global2local_int(flat_globland,flat_landcode,326,& - GIMAX,GJMAX,FNCMAX,1,1) - - ! Broadcast volcanoe info derived in EmisGet - - CALL MPI_BCAST(nvolc,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(i_volc,4*nvolc,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(j_volc,4*nvolc,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(emis_volc,8*nvolc,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + if(.not.CDF_emis)then + call global2local_int(globnland,nlandcode,326, GIMAX,GJMAX,1,1,1) + call global2local_int(globland, landcode ,326, GIMAX,GJMAX,NCMAX,1,1) + + call global2local_int(flat_globnland,flat_nlandcode,326,& + GIMAX,GJMAX,1,1,1) !extra array + call global2local_int(flat_globland,flat_landcode,326,& + GIMAX,GJMAX,FNCMAX,1,1) + else + !emissions directly defined into + !nlandcode,landcode and snapemis + endif + ! Broadcast volcanoe info derived in EmisGet + CALL MPI_BCAST(nvolc,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(i_volc,4*nvolc,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(j_volc,4*nvolc,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(emis_volc,8*nvolc,MPI_BYTE,0,MPI_COMM_WORLD,INFO) -! Conversions -! -! The emission-data file are so far in units of -! tonnes per grid-square. The conversion factor from tonnes per 50*50km2 -! annual emission values to surface flux (kg/m2/s) is found by division -! with (nydays*24*60*60)s and (h*h)m2 and multiply by 1.e+3. -! The conversion factor then equals 1.27e-14 - + ! Conversions + ! + ! The emission-data file are so far in units of + ! tonnes per grid-square. The conversion factor from tonnes per 50*50km2 + ! annual emission values to surface flux (kg/m2/s) is found by division + ! with (nydays*24*60*60)s and (h*h)m2 and multiply by 1.e+3. + ! The conversion factor then equals 1.27e-14 tonne_to_kgm2s = 1.0e3 / (nydays * 24.0 * 3600.0 * & - GRIDWIDTH_M * GRIDWIDTH_M) + GRIDWIDTH_M * GRIDWIDTH_M) if ( DEBUG .and. MasterProc ) then - write(unit=6,fmt=*) "CONV:me, nydays, gridwidth = ",me,nydays,GRIDWIDTH_M - write(unit=6,fmt=*) "No. days in Emissions: ", nydays - write(unit=6,fmt=*) "tonne_to_kgm2s in Emissions: ", tonne_to_kgm2s - write(unit=6,fmt=*) "Emissions sums:" - do iem = 1, NEMIS_FILES - write(unit=6,fmt="(a15,f12.2)") EMIS_NAME(iem),emsum(iem) - end do + write(unit=6,fmt=*) "CONV:me, nydays, gridwidth = ",me,nydays,GRIDWIDTH_M + write(unit=6,fmt=*) "No. days in Emissions: ", nydays + write(unit=6,fmt=*) "tonne_to_kgm2s in Emissions: ", tonne_to_kgm2s + write(unit=6,fmt=*) "Emissions sums:" + do iem = 1, NEMIS_FILE + write(unit=6,fmt="(a15,f12.2)") EMIS_FILE(iem),emsum(iem) + end do endif - - do iem = 1, NEMIS_FILES + + do iem = 1, NEMIS_FILE conv = tonne_to_kgm2s - if ( trim(EMIS_NAME(iem)) == "co" ) iemCO = iem ! save this index - - if ( DEBUG .and. debug_proc .and. iem == iemCO ) then - write(*,"(a,2es10.3)") "SnapPre:" // trim(EMIS_NAME(iem)), & - sum( snapemis (:,debug_li,debug_lj,:,iem) ) & - ,sum( snapemis_flat (debug_li,debug_lj,:,iem) ) - end if + if ( trim(EMIS_FILE(iem)) == "co" ) iemCO = iem ! save this index + + if ( DEBUG .and. debug_proc .and. iem == iemCO ) then + write(*,"(a,2es10.3)") "SnapPre:" // trim(EMIS_FILE(iem)), & + sum( snapemis (:,debug_li,debug_lj,:,iem) ) & + ,sum( snapemis_flat (debug_li,debug_lj,:,iem) ) + end if - forall (ic=1:NCMAX, j=lj0:lj1, i=li0:li1, isec=1:NSECTORS) + forall (ic=1:NCMAX, j=1:ljmax, i=1:limax, isec=1:NSECTORS) snapemis (isec,i,j,ic,iem) = & - snapemis (isec,i,j,ic,iem) * conv * xm2(i,j) + snapemis (isec,i,j,ic,iem) * conv * xm2(i,j) end forall - forall (fic=1:FNCMAX, j=lj0:lj1, i=li0:li1) + forall (fic=1:FNCMAX, j=1:ljmax, i=1:limax) snapemis_flat(i,j,fic,iem) = & - snapemis_flat(i,j,fic,iem) * conv * xm2(i,j) + snapemis_flat(i,j,fic,iem) * conv * xm2(i,j) end forall - if ( DEBUG .and. debug_proc .and. iem == iemCO ) then - write(*,"(a,2es10.3)") "SnapPos:" // trim(EMIS_NAME(iem)), & - sum( snapemis (:,debug_li,debug_lj,:,iem) ) & - ,sum( snapemis_flat (debug_li,debug_lj,:,iem) ) - end if + + if ( DEBUG .and. debug_proc .and. iem == iemCO ) then + write(*,"(a,2es10.3)") "SnapPos:" // trim(EMIS_FILE(iem)), & + sum( snapemis (:,debug_li,debug_lj,:,iem) ) & + ,sum( snapemis_flat (debug_li,debug_lj,:,iem) ) + end if enddo !iem -! if ( VOLCANOES ) then - - ! Read Volcanos.dat or VolcanoesLL.dat to get volcano height - ! and magnitude in the case of VolcanoesLL.dat - call VolcGet(height_volc) - -! endif ! VOLCANOES + if(USE_ROADDUST)THEN + do iem = 1, NROAD_FILES + conv = tonne_to_kgm2s + + forall (ic=1:NCMAX, j=1:ljmax, i=1:limax) + roaddust_emis_pot(i,j,ic,iem) = & + roaddust_emis_pot(i,j,ic,iem) * conv * xm2(i,j) + end forall + enddo ! iem + endif !road dust + + + ! if ( VOLCANOES ) then + + ! Read Volcanos.dat or VolcanoesLL.dat to get volcano height + ! and magnitude in the case of VolcanoesLL.dat + call VolcGet(height_volc) + + ! endif ! VOLCANOES err1 = 0 if ( MasterProc ) then @@ -420,21 +777,37 @@ subroutine Emissions(year) deallocate(flat_globland,stat=err5) deallocate(globemis_flat,stat=err6) + if(USE_ROADDUST)THEN + deallocate(road_globnland,stat=err7) + deallocate(road_globland,stat=err8) + deallocate(globroad_dust_pot,stat=err9) + endif + call CheckStop(err1, "De-Allocation error 1 - globland") call CheckStop(err2, "De-Allocation error 2 - globland") call CheckStop(err3, "De-Allocation error 3 - globland") call CheckStop(err4, "De-Allocation error 4 - globland") call CheckStop(err5, "De-Allocation error 5 - globland") call CheckStop(err6, "De-Allocation error 6 - globland") - + if(USE_ROADDUST)THEN + call CheckStop(err7, "De-Allocation error 7 - roadglob") + call CheckStop(err8, "De-Allocation error 8 - roadglob") + call CheckStop(err9, "De-Allocation error 9 - roadglob") + endif end if ! now we have nrecmis and can allocate for gridrcemis: ! print *, "ALLOCATING GRIDRC", me, NRCEMIS - allocate(gridrcemis(NRCEMIS,KEMISTOP:KMAX_MID,MAXLIMAX,MAXLJMAX),stat=err1) - allocate(gridrcemis0(NRCEMIS,KEMISTOP:KMAX_MID,MAXLIMAX,MAXLJMAX),stat=err2) - call CheckStop(err1, "Allocation error 1 - gridrcemis") - call CheckStop(err2, "Allocation error 2 - gridrcemis0") + allocate(gridrcemis(NRCEMIS,KEMISTOP:KMAX_MID,MAXLIMAX,MAXLJMAX),stat=err1) + allocate(gridrcemis0(NRCEMIS,KEMISTOP:KMAX_MID,MAXLIMAX,MAXLJMAX),stat=err2) + call CheckStop(err1, "Allocation error 1 - gridrcemis") + call CheckStop(err2, "Allocation error 2 - gridrcemis0") + if(USE_ROADDUST)THEN + allocate(gridrcroadd(NROADDUST,MAXLIMAX,MAXLJMAX),stat=err3) + allocate(gridrcroadd0(NROADDUST,MAXLIMAX,MAXLJMAX),stat=err4) + call CheckStop(err3, "Allocation error 3 - gridrcroadd") + call CheckStop(err4, "Allocation error 4 - gridrcroadd0") + endif end subroutine Emissions @@ -447,7 +820,7 @@ subroutine consistency_check() character(len=30) :: errormsg errormsg = "ok" - if ( size(EMIS_NAME) /= NEMIS_FILES ) errormsg = " size EMISNAME wrong " + if ( size(EMIS_FILE) /= NEMIS_FILE ) errormsg = " size EMISNAME wrong " call CheckStop(errormsg,"Failed consistency check") @@ -482,8 +855,7 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour ! ! Monthly and weekday factors are pre-multiplied and stored in: ! real timefac(NLAND,NSECTORS,NEMIS_FILES) - ! And day-night factors are applied here: - ! day_factor(11,0:1) ! 0=night, 1=day + ! And day-hour factors in fac_ehh24x7 ! !************************************************************************* @@ -495,11 +867,12 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour integer :: ficc,fncc ! No. of countries with integer :: iqrc ! emis indices integer :: isec ! loop variables: emission sectors - integer :: iem ! loop variable over 1..NEMIS_FILES + integer :: iem ! loop variable over 1..NEMIS_FILE integer :: itot ! index in xn() ! Save daytime value between calls, initialise to zero integer, save, dimension(NLAND) :: daytime = 0 ! 0=night, 1=day + integer, save, dimension(NLAND) :: localhour = 1 ! 1-24 local hour in the different countries, ? How to handle Russia, with multiple timezones??? integer :: hourloc ! local hour logical :: hourchange ! real, dimension(NRCEMIS) :: tmpemis ! local array for emissions @@ -514,9 +887,12 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour integer :: flat_iland ! country codes (countries with flat emissions) integer, save :: oldday = -1, oldhour = -1 + integer, save :: wday , wday_loc ! wday = day of the week 1-7 + real :: oldtfac + logical :: debug_tfac, debug_kprof ! If timezone=-100, calculate daytime based on longitude rather than timezone - integer :: daytime_longitude, daytime_iland + integer :: daytime_longitude, daytime_iland, hour_longitude, hour_iland ! Initialize ehlpcom0(:)=0.0 @@ -528,7 +904,6 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour ! Scaling for totemadd: dtgrid = dt_advec * GRIDWIDTH_M * GRIDWIDTH_M - ! The emis array only needs to be updated every full hour. The ! time-factor calculation needs to know if a local-time causes a shift ! from day to night. In addition, we reset an overall day's time-factors @@ -544,12 +919,23 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour !========================== call NewDayFactors(indate) + if ( USE_DEGREEDAY_FACTORS) & + call DegreeDayFactors(daynumber) ! => fac_emm, fac_edd !========================== + ! for ROADDUST + wday=day_of_week(indate%year,indate%month,indate%day) + if(wday==0)wday=7 ! Sunday -> 7 + oldday = indate%day endif end if + if( DEBUG_EMISTIMEFACS .and. MasterProc ) then + write(*,"(a,2f8.3)") " EmisSet traffic 24x7", & + fac_ehh24x7(ISNAP_TRAF,1,4),fac_ehh24x7(ISNAP_TRAF,13,4) + end if + !.......................................... ! Look for day-night changes, after local time correction @@ -560,6 +946,8 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour daytime(iland) = 0 hourloc = indate%hour + Country(iland)%timezone + localhour(iland) = hourloc ! here from 0 to 23 + if ( hourloc >= 7 .and. hourloc <= 18 ) daytime(iland)=1 end do ! iland @@ -570,22 +958,24 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour totemadd(:) = 0. gridrcemis0(:,:,:,:) = 0.0 SumSnapEmis(:,:,:) = 0.0 - + gridrcroadd0(:,:,:) = 0.0 !.......................................... ! Process each grid: - do j = lj0,lj1 - do i = li0,li1 + do j = 1,ljmax + do i = 1,limax ncc = nlandcode(i,j) ! No. of countries in grid + debug_tfac = ( DEBUG_EMISTIMEFACS .and. debug_proc .and. & + i==DEBUG_li .and. j==DEBUG_lj ) ! find the approximate local time: hourloc= mod(nint(indate%hour+24*(1+glon(i,j)/360.0)),24) + hour_longitude=hourloc daytime_longitude=0 if( hourloc>=7.and.hourloc<= 18) daytime_longitude=1 - - + !************************************************* ! First loop over non-flat (one sector) emissions !************************************************* @@ -597,9 +987,32 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour if(Country(iland)%timezone==-100)then daytime_iland=daytime_longitude + hour_iland=hour_longitude + 1 ! add 1 to get 1..24 else daytime_iland=daytime(iland) + hour_iland=localhour(iland) + 1 endif + !if( hour_iland > 24 ) hour_iland = 1 !DSA12 + wday_loc=wday + if( hour_iland > 24 ) then + hour_iland = hour_iland - 24 + wday_loc=wday + 1 + if(wday_loc==0)wday_loc=7 ! Sunday -> 7 + if(wday_loc>7 )wday_loc=1 + end if + + call CheckStop( hour_iland < 1, & + "ERROR: HOUR Zero in EmisSet") + + if( debug_tfac ) then + write(*,"(a,i4,2i3,i5,2i4,3x,4i3)") "EmisSet DAYS times ", daynumber, & + wday, wday_loc, iland, daytime_longitude, daytime_iland,& + hour_longitude, hour_iland, hourloc, Country(iland)%timezone + call datewrite("EmisSet DAY 24x7:", & + (/ icc, iland, wday, wday_loc, hour_iland /), & + (/ fac_ehh24x7(ISNAP_TRAF,hour_iland,wday_loc) /) ) + end if + ! As each emission sector has a different diurnal profile ! and possibly speciation, we loop over each sector, adding @@ -614,10 +1027,36 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour iqrc = 0 ! index over emisfrac - do iem = 1, NEMIS_FILES + do iem = 1, NEMIS_FILE + + tfac = timefac(iland_timefac,isec,iem) * & + fac_ehh24x7(isec,hour_iland,wday_loc) + + if( debug_tfac .and. iem == 1 ) then + write(*,"(a,2i4,f8.3)") "EmisSet DAY TFAC:", & + isec, hour_iland, tfac + end if - tfac = timefac(iland_timefac,isec,iem) * & - day_factor(isec,daytime_iland) + !Degree days - only SNAP-2 + if ( USE_DEGREEDAY_FACTORS .and. & + isec == ISNAP_DOM .and. Gridded_SNAP2_Factors ) then + + oldtfac = tfac + + ! If INERIS_SNAP2 set, the fac_min will be zero, otherwise + ! we make use of a baseload even for SNAP2 + + tfac = ( fac_min(iland,isec,iem) + & ! constant baseload + ( 1.0-fac_min(iland,isec,iem) )* gridfac_HDD(i,j) ) & + * fac_ehh24x7(isec,hour_iland,wday_loc) + + if ( debug_tfac .and. indate%hour == 12 .and. iem==1 ) then ! + write(*,"(a,2i3,2i4,7f8.3)") "SNAPHDD tfac ", & + isec, iland, daynumber, indate%hour, & + timefac(iland_timefac,isec,iem), t2_nwp(i,j,2)-273.15, & + fac_min(iland,isec,iem), gridfac_HDD(i,j), tfac + end if + end if ! =============== HDD s = tfac * snapemis(isec,i,j,icc,iem) @@ -638,12 +1077,21 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour ! Assign to height levels 1-KEMISTOP + !do k=KEMISTOP,KMAX_MID do k=KEMISTOP,KMAX_MID do iqrc =1, nrcemis gridrcemis0(iqrc,k,i,j) = & gridrcemis0(iqrc,k,i,j) + tmpemis(iqrc)* & - ehlpcom0(k)*VERTFAC(KMAX_BND-k,isec) & + ehlpcom0(k)*emis_kprofile(KMAX_BND-k,isec) & + !ehlpcom0(k)*VERTFAC(KMAX_BND-k,isec) & * emis_masscorr(iqrc) + !if( debug_tfac.and. iqrc==1 ) then + ! write(*,"(a,2i3,2f8.3)") "KPROF ", & + ! isec, KMAX_BND-k, & + ! VERTFAC(KMAX_BND-k,isec), & + ! emis_kprofile(KMAX_BND-k,isec) + !end if + end do ! iem end do ! k @@ -658,7 +1106,7 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour tmpemis(:)=0. fncc = flat_nlandcode(i,j) ! No. of countries with flat ! emissions in grid - + do ficc = 1, fncc flat_iland = flat_landcode(i,j,ficc) ! 30=BAS etc. @@ -679,7 +1127,7 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour iqrc = 0 ! index over emis - do iem = 1, NEMIS_FILES + do iem = 1, NEMIS_FILE sf = snapemis_flat(i,j,ficc,iem) @@ -711,25 +1159,100 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour ! ================================================== end do !ficc + + if(USE_ROADDUST)then + NO_PRECIP: if(surface_precip(i,j) < 0.1) then ! Limit as in TNO-model (but Lotos/Euros has precip in mm/3h) In the EMEP case this is in mm/h, so should be equivalent with 2.4mm per day + +! should use the temporal variation for road dust (SNAP_HOURFAC(HH,7)) +! and a weekday factor (initially taken from TNO model, could use country +! dependent factor in the future) + +! Temporal variation taken from TNO -> No monthly variation and a single +! weekday and diurnal variation (same for all countries) +! -> Need to know day_of_week +! Relatively weak variation with day of week so use a simplified approach +! + +! if( DEBUG_ROADDUST .and. debug_proc .and. i==DEBUG_li .and. j==DEBUG_lj )THEN +! write(*,*)"DEBUG ROADDUST! Dry! ncc=", road_nlandcode(i,j) +! endif + + ncc = road_nlandcode(i,j) ! number of countries in grid point + do icc = 1, ncc + iland = road_landcode(i,j,icc) + + if(Country(iland)%timezone==-100)then + hour_iland=hour_longitude+1 + else + hour_iland=localhour(iland)+1 + endif + + wday_loc = wday ! DS added here also, for fac_ehh24x7 + if( hour_iland > 24 ) then + hour_iland = 1 + if(wday_loc==0)wday_loc=7 ! Sunday -> 7 + if(wday_loc>7 )wday_loc=1 + end if + + if(((icc.eq.IC_FI).or.(icc.eq.IC_NO).or.(icc.eq.IC_SE)).and. & ! Nordic countries + ((indate%month.eq.3).or.(indate%month.eq.4).or.(indate%month.eq.5)))then ! spring road dust + tfac = fac_ehh24x7(ISNAP_TRAF,hour_iland,wday_loc) *2.0 ! Doubling in Mar-May (as in TNO model) + else + tfac = fac_ehh24x7(ISNAP_TRAF,hour_iland,wday_loc) + endif + + do iem = 1, NROAD_FILES + s = tfac * roaddust_emis_pot(i,j,icc,iem) + if( DEBUG_ROADDUST .and. debug_proc .and. i==DEBUG_li .and. j==DEBUG_lj )THEN + write(*,*)"DEBUG ROADDUST! iem,tfac,icc,roaddust_emis_pot,s", & + iem,tfac,icc,roaddust_emis_pot(i,j,icc,iem),s + endif + + gridrcroadd0(QROADDUST_FI,i,j)=gridrcroadd0(QROADDUST_FI,i,j)+ & + ROADDUST_FINE_FRAC*s + gridrcroadd0(QROADDUST_CO,i,j)=gridrcroadd0(QROADDUST_CO,i,j)+ & + (1.-ROADDUST_FINE_FRAC)*s + + if ( DEBUG_ROADDUST .AND. debug_proc .and.i==debug_li .and. j==debug_lj) then ! + write(*,*)"gridrcroadfine",gridrcroadd0(QROADDUST_FI,i,j) + write(*,*)"gridrcroadcoarse",gridrcroadd0(QROADDUST_CO,i,j) + end if + + + enddo ! nroad files + + enddo ! icc + +! should pick the correct emissions (spring or rest of year) +! and add the emissions from HIGHWAYplus and NONHIGHWAYS, +! using correct fine and coarse fractions. + else ! precipitation + gridrcroadd0(:,i,j)=0. + endif NO_PRECIP + + endif ! ROADDUST + end do ! i end do ! j if ( DEBUG .and. debug_proc ) then ! emis sum kg/m2/s - call datewrite("SnapSum, kg/m2/s:" // trim(EMIS_NAME(iemCO)), & + call datewrite("SnapSum, kg/m2/s:" // trim(EMIS_FILE(iemCO)), & (/ SumSnapEmis(debug_li,debug_lj,iemCO) /) ) end if call Set_Volc !set hourly volcano emission(rcemis_volc0) + end if ! hourchange ! We now scale gridrcemis to get emissions in molecules/cm3/s do k= KEMISTOP, KMAX_MID - do j = lj0,lj1 - do i = li0,li1 + do j = 1,ljmax + do i = 1,limax ehlpcom= roa(i,j,k,1)/(ps(i,j,1)-PT) +!RB: This should also be done for the road dust emissions do iqrc =1, NRCEMIS gridrcemis(iqrc,k,i,j) = & gridrcemis0(iqrc,k,i,j)* ehlpcom @@ -738,6 +1261,28 @@ subroutine EmisSet(indate) ! emission re-set every time-step/hour end do ! j end do ! k + if(USE_ROADDUST)THEN + if( DEBUG_ROADDUST .and. debug_proc)then + write(*,*)"Before the unit scaling", & + gridrcroadd(1,DEBUG_li,DEBUG_lj), & + gridrcroadd(2,DEBUG_li,DEBUG_lj) + endif + do j = 1,ljmax + do i = 1,limax + ehlpcom= roa(i,j,KMAX_MID,1)/(ps(i,j,1)-PT) + do iqrc =1, NROADDUST + gridrcroadd(iqrc,i,j) = & + gridrcroadd0(iqrc,i,j)* ehlpcom * ehlpcom0(KMAX_MID) * roaddust_masscorr(iqrc) + enddo ! iqrc + end do ! i + end do ! j + if( DEBUG_ROADDUST .and. debug_proc)then + write(*,*)"After the unit scaling", & + gridrcroadd(1,DEBUG_li,DEBUG_lj), & + gridrcroadd(2,DEBUG_li,DEBUG_lj) + endif + endif + ! Scale volc emissions to get emissions in molecules/cm3/s (rcemis_volc) call Scale_Volc @@ -764,39 +1309,37 @@ subroutine newmonth integer i, j,k, iyr integer n, flat_ncmaxfound ! Max. no. countries w/flat emissions real :: rdemis(MAXLIMAX,MAXLJMAX) ! Emissions read from file - character*20 fname + character(len=20) :: fname real ktonne_to_kgm2s, tonnemonth_to_kgm2s ! Units conversion - integer :: IQSO2 ! Index of sox in EMIS_NAME + integer :: IQSO2 ! Index of sox in EMIS_FILE integer errcode real, allocatable, dimension(:,:,:,:) :: globemis integer :: month,iem,ic,iic,isec, err3,icc real :: duml,dumh,tmpsec(NSECTORS),conv logical , save :: first_call=.true. - real, dimension(NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,NEMIS_FILES) & + real, dimension(NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,NEMIS_FILE) & :: snapemis_month ! monthly emissions tonne/month + logical :: needed_found ! For now, only the global runs use the Monthly files logical, parameter :: MONTHLY_GRIDEMIS= IS_GLOBAL integer :: kstart,kend,nstart,Nyears real :: buffer(MAXLIMAX,MAXLJMAX),SumSoilNOx,SumSoilNOx_buff - + + if(.not.allocated(airn).and.(USE_LIGHTNING_EMIS.or.USE_AIRCRAFT_EMIS))then + allocate(airn(KCHEMTOP:KMAX_MID,MAXLIMAX,MAXLJMAX)) + endif + if( USE_AIRCRAFT_EMIS )then -airn = 0.0 !ssp8W -!AIRCRAFT -kstart=KCHEMTOP -kend=KMAX_MID -do k=KEMISTOP,KMAX_MID -do j=1,ljmax -do i=1,limax - -airn(k,i,j)=0.0 + !AIRCRAFT + airn = 0.0 + kstart=KCHEMTOP + kend=KMAX_MID -enddo -enddo -enddo -call ReadField_CDF('AircraftEmis_FL.nc','NOx',airn,nstart=current_date%month,kstart=kstart,kend=kend,interpol='mass_conservative', & - needed=.true.,debug_flag=.true.) + call ReadField_CDF('AircraftEmis_FL.nc','NOx',airn,& + nstart=current_date%month,kstart=kstart,kend=kend,& + interpol='mass_conservative', needed=.true.,debug_flag=.false.) ! convert from kg(NO2)/month into molecules/cm3/s ! from kg to molecules: 0.001*AVOG/species(NO2)%molwt @@ -820,82 +1363,95 @@ subroutine newmonth endif -!Soil NOx emissions -if(USE_SOIL_NOX)then +if(USE_SOILNOX)then ! Global Soil NOx emissions + ! read in map of annual N-deposition produced from pre-runs of EMEP model + ! with script mkcdo.annualNdep + ! + call ReadField_CDF('annualNdep.nc',& + 'Ndep_m2',AnnualNdep,1, interpol='zero_order',needed=.true.,debug_flag=.false.,UnDef=0.0) -do j=1,ljmax + if (DEBUG_SOILNOX .and. debug_proc ) then + write(*,"(a,4es12.3)") "SOILNOX AnnualDEBUG ", & + AnnualNdep(debug_li, debug_lj), maxval(AnnualNdep), minval(AnnualNdep) + end if + call CheckStop(USE_GLOBAL_SOILNOX, "SOILNOX - cannot use global with Euro") + ! We then calculate SoulNOx in Biogenics_ml +else + + do j=1,ljmax do i=1,limax SoilNOx(i,j)=0.0 buffer(i,j)=0.0 enddo -enddo + enddo -nstart=(current_date%year-1996)*12 + current_date%month -if(nstart>0.and.nstart<=120)then + nstart=(current_date%year-1996)*12 + current_date%month + if(nstart>0.and.nstart<=120)then !the month is defined call ReadField_CDF('nox_emission_1996-2005.nc','NOX_EMISSION',SoilNOx,nstart=nstart,& - interpol='conservative',known_projection="lon lat",needed=.true.,debug_flag=.true.) - if ( DEBUG_SOILNO.and.debug_proc ) write(*,*) "PROPER YEAR of SOILNO ", current_date%year, nstart -else + interpol='conservative',known_projection="lon lat",needed=.true.,debug_flag=.false.) + if ( DEBUG_SOILNOX .and.debug_proc ) write(*,*) "PROPER YEAR of SOILNO ", current_date%year, nstart + else !the year is not defined; average over all years Nyears=10 !10 years defined do iyr=1,Nyears nstart=12*(iyr-1) + current_date%month call ReadField_CDF('nox_emission_1996-2005.nc','NOX_EMISSION',buffer,nstart=nstart,& - interpol='conservative',known_projection="lon lat",needed=.true.,debug_flag=.true.,UnDef=0.0) + interpol='conservative',known_projection="lon lat",needed=.true.,debug_flag=.false.,UnDef=0.0) do j=1,ljmax do i=1,limax SoilNOx(i,j)=SoilNOx(i,j)+buffer(i,j) end do end do - if ( DEBUG_SOILNO.and.debug_proc ) then + if ( DEBUG_SOILNOX .and.debug_proc ) then write(*,"(a,2i6,es10.3,a,2es10.3)") "Averaging SOILNO inputs", & 1995+(i-1), nstart,SoilNOx(debug_li, debug_lj), & "max: ", maxval(buffer), maxval(SoilNOx) - !else if ( DEBUG_SOILNO ) then + !else if ( DEBUG_SOILNOX ) then ! write(*,"(a,2i6,a,es10.3)") & ! "Averaging SOILNO inputs", 1995+(i-1), nstart, "max: ", maxval(SoilNOx) end if enddo SoilNOx=SoilNOx/Nyears -endif -if ( DEBUG_SOILNO .and. debug_proc ) then - write(*,"(a,i3,2es10.3)") "After SOILNO ", me, maxval(SoilNOx), SoilNOx(debug_li, debug_lj) -!else if ( DEBUG_SOILNO ) then -! write(*,"(a,i3,es10.3, 2f8.2)") "After SOILNO ", me, maxval(SoilNOx), gb(1,1), gl(1,1) -end if + endif + + if ( DEBUG_SOILNOX ) then !!! .and. debug_proc ) then + write(*,"(a,i3,3es10.3)") "After Global SOILNO ", me, maxval(SoilNOx), SoilNOx(3, 3), t2_nwp(2,2,2) + end if ! SOIL_N +end if ! DS_TEST !for testing, compute total soil NOx emissions within domain !convert from g/m2/day into kg/day -SumSoilNOx_buff=0.0 -SumSoilNOx=0.0 -do j=1,ljmax +if ( USE_GLOBAL_SOILNOX ) then + SumSoilNOx_buff=0.0 + SumSoilNOx=0.0 + SoilNOx = 0.0 ! Stops the NEGs! + do j=1,ljmax do i=1,limax SumSoilNOx_buff=SumSoilNOx_buff+0.001*SoilNOx(i,j)*gridwidth_m**2*xmd(i,j) enddo -enddo -CALL MPI_ALLREDUCE(SumSoilNOx_buff, SumSoilNOx , 1, & + enddo + CALL MPI_ALLREDUCE(SumSoilNOx_buff, SumSoilNOx , 1, & MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) -if(MasterProc)write(*,*)'Soil NOx emissions this month within domain',SumSoilNOx,' kg per day' - -! convert from g(N)/m2/day into molecules/cm3/s -! from g to molecules: AVOG/14 14=molweight N -! use roa to find dz for consistency with other emissions -! (otherwise could have used z_bnd directly) -! dz=dP/(roa*GRAV) dP=dA(k) + dB(k)*ps(i,j,1) -! dV=dz*1e6 (1e6 for m3->cm3) -! from month to seconds: ndaysmonth*24*3600 - -conv=AVOG/14.0*GRAV*1.0e-6/(24*3600) -k=KMAX_MID!surface -do j=1,ljmax + if(MasterProc)write(*,*)'GLOBAL Soil NOx emissions this month within domain',& + SumSoilNOx,' kg per day' + + ! convert from g(N)/m2/day into molecules/cm3/s from g to molecules: + ! AVOG/14 14=molweight N, use roa to find dz for consistency with other + ! emissions (otherwise could have used z_bnd directly) dz=dP/(roa*GRAV) + ! dP=dA(k) + dB(k)*ps(i,j,1) dV=dz*1e6 (1e6 for m3->cm3) from month to + ! seconds: ndaysmonth*24*3600 + + conv=AVOG/14.0*GRAV*1.0e-6/(24*3600) + k=KMAX_MID!surface + do j=1,ljmax do i=1,limax SoilNOx(i,j)=SoilNOx(i,j)*conv*(roa(i,j,k,1))/(dA(k) + dB(k)*ps(i,j,1)) enddo -enddo + enddo -endif +end if ! DMS @@ -928,8 +1484,8 @@ subroutine newmonth ! Natural SO2 emissions IQSO2 = 0 - do i = 1, NEMIS_FILES - if ( trim( EMIS_NAME(i) ) == "sox" ) IQSO2 = i + do i = 1, NEMIS_FILE + if ( trim( EMIS_FILE(i) ) == "sox" ) IQSO2 = i end do if ( IQSO2 < 1 ) then @@ -940,50 +1496,55 @@ subroutine newmonth ! We have so2 emission so need DMS also if ( MasterProc ) then - - write(fname,fmt='(''natso2'',i2.2,''.dat'')') & - current_date%month - write(6,*) 'Reading DMS emissions from ',trim(fname) - endif - - call ReadField(IO_DMS,fname,rdemis) - - errcode = 0 - do j=1,ljmax - do i=1,limax - -! Add DMS for country code IQ_DMS=35 to snap sector 11=Nature. -! First time we read we must add DMS to the "countries" -! contributing within the grid square. - - ! - for flat emissions: - - if ( first_dms_read ) then - flat_nlandcode(i,j) = flat_nlandcode(i,j) + 1 - n = flat_nlandcode(i,j) - flat_landcode(i,j,n) = IQ_DMS ! country code 35 - if ( n > flat_ncmaxfound ) then - flat_ncmaxfound = n - if (DEBUG) write(6,*)'DMS Increased flat_ncmaxfound to ',n - call CheckStop( n > FNCMAX, "IncreaseFNCMAX for dms") - endif - else ! We know that DMS lies last in the array, so: - n = flat_nlandcode(i,j) - call CheckStop(flat_landcode(i,j,n), IQ_DMS, & - "Newmonth:DMS not last!") - endif - - snapemis_flat(i,j,n,IQSO2) = rdemis(i,j) * ktonne_to_kgm2s & - * xm2(i,j) - enddo ! i - enddo ! j - - - if ( first_dms_read ) then - if (DEBUG) write(6,*)'me ',me, ' Increased flat_ncmaxfound to ' & - ,flat_ncmaxfound - first_dms_read = .false. - end if + + write(fname,fmt='(''natso2'',i2.2,''.dat'')') & + current_date%month + write(6,*) 'Reading DMS emissions from ',trim(fname) + endif + + needed_found=.false. + call ReadField(IO_DMS,fname,rdemis,needed_found) + if(needed_found)then + errcode = 0 + do j=1,ljmax + do i=1,limax + + ! Add DMS for country code IQ_DMS=35 to snap sector 11=Nature. + ! First time we read we must add DMS to the "countries" + ! contributing within the grid square. + + ! - for flat emissions: + + if ( first_dms_read ) then + flat_nlandcode(i,j) = flat_nlandcode(i,j) + 1 + n = flat_nlandcode(i,j) + flat_landcode(i,j,n) = IQ_DMS ! country code 35 + if ( n > flat_ncmaxfound ) then + flat_ncmaxfound = n + if (DEBUG) write(6,*)'DMS Increased flat_ncmaxfound to ',n + call CheckStop( n > FNCMAX, "IncreaseFNCMAX for dms") + endif + else ! We know that DMS lies last in the array, so: + n = flat_nlandcode(i,j) + call CheckStop(flat_landcode(i,j,n), IQ_DMS, & + "Newmonth:DMS not last!") + endif + + snapemis_flat(i,j,n,IQSO2) = rdemis(i,j) * ktonne_to_kgm2s & + * xm2(i,j) + enddo ! i + enddo ! j + + + if ( first_dms_read ) then + if (DEBUG) write(6,*)'me ',me, ' Increased flat_ncmaxfound to ' & + ,flat_ncmaxfound + first_dms_read = .false. + end if + else!no dms file found + if ( MasterProc ) write(6,*) 'WARNING: NO DMS emissions found ' + if ( MasterProc ) write(unit=IO_LOG,fmt=*) "WARNING: NO DMS emissions found " + end if end if ! IQSO2>0 @@ -993,8 +1554,8 @@ subroutine newmonth !Read monthly emission files if(first_call)then - do j=lj0,lj1 - do i=li0,li1 + do j=1,ljmax + do i=1,limax nlandcode(i,j)=nlandcode(i,j)+1 icc=nlandcode(i,j) landcode(i,j,icc)=67 @@ -1010,7 +1571,7 @@ subroutine newmonth allocate(globemis(NSECTORS,GIMAX,GJMAX,NCMAX),stat=err3) call CheckStop(err3, "Allocation error err3 - globland") end if - do iem = 1, NEMIS_FILES + do iem = 1, NEMIS_FILE ! if (trim(EMIS_NAME(iem)).ne.'nox' .and. trim(EMIS_NAME(iem)).ne.'co'.and.& ! trim(EMIS_NAME(iem)).ne.'pm25'.and.& ! trim(EMIS_NAME(iem)).ne.'voc'.and.trim(EMIS_NAME(iem)).ne.'nh3'.and.trim(EMIS_NAME(iem)).ne.'sox')cycle ! @@ -1020,7 +1581,7 @@ subroutine newmonth globemis = 0.0 write(fname,fmt='(''grid'',A,i2.2)') & - trim(EMIS_NAME(iem))//'.',month + trim(EMIS_FILE(iem))//'.',month write(6,*) 'filename for GLOBAL emission',fname call open_file(IO_EMIS,"r",fname,needed=.true.) call CheckStop( ios , "ios error: emislist" // fname ) @@ -1058,14 +1619,14 @@ subroutine newmonth end do ! iem = 1, NEMIS-loop ic=1 - do iem = 1, NEMIS_FILES + do iem = 1, NEMIS_FILE ! write(*,*)'iem=',iem ! if (trim(EMIS_NAME(iem)).ne.'nox' .and. trim(EMIS_NAME(iem)).ne.'co'.and.& ! trim(EMIS_NAME(iem)).ne.'pm25'.and.& ! trim(EMIS_NAME(iem)).ne.'voc'.and.trim(EMIS_NAME(iem)).ne.'nh3'.and.trim(EMIS_NAME(iem)).ne.'sox')cycle ! conv = tonnemonth_to_kgm2s - do j=lj0,lj1 - do i=li0,li1 + do j=1,ljmax + do i=1,limax icc=nlandcode(i,j) !67 do isec=1,NSECTORS snapemis (isec,i,j,icc,iem) = & diff --git a/ForestFire_ml.f90 b/ForestFire_ml.f90 index 81eca3d..f415f17 100644 --- a/ForestFire_ml.f90 +++ b/ForestFire_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -28,39 +28,53 @@ module ForestFire_ml !---------------------------------------------------------------- - ! Uses emissions from GFED 3 (Global Forest Emission database) + ! Uses emissions from either: + ! + ! 1) FINNv1 daily data 2002 - 2011 + ! REFERENCE: + ! Wiedinmyer, C., Akagi, S. K., Yokelson, R. J., Emmons, L. K., Al-Saadi, + ! J. A., Orlando, J. J., and Soja, A. J.: The Fire INventory from NCAR (FINN) + ! - a high resolution global model to estimate the emissions from open + ! burning, Geosci. Model Dev. Discuss., 3, 2439-2476, + ! doi:10.5194/gmdd-3-2439-2010, 2010. + ! http://www.geosci-model-dev-discuss.net/3/2439/2010/gmdd-3-2439-2010.html + ! + ! 2) GFED 3 (Global Forest Emission database) ! http://www.falw.vu/~gwerf/GFED/ ! Currently programmed for 8-daily data (available for 2001 - 2007) + ! + ! 3) GFASv1 Real-Time Fire Emissions + ! Daily data. Available since 2003 or 2011, depending on version, from MARS + ! http://www.gmes-atmosphere.eu/about/project_structure/input_data/d_fire/ProductsInMARS/ + ! REFERENCE: + ! Kaiser, J.W., Heil, A., Andreae, M.O., Benedetti, A., Chubarova, N., + ! Jones, L., Morcrette, J.-J., Razinger, M., Schultz, M. G., Suttie, M., + ! and van der Werf, G. R.: Biomass burning emissions estimated with a global + ! fire assimilation system based on observed fire radiative power, + ! Biogeosciences, 9, 527-554, doi:10.5194/bg-9-527-2012, 2012. !---------------------------------------------------------------- use CheckStop_ml, only : CheckStop use ChemChemicals_ml, only : species - use ChemSpecs_tot_ml, only : NO, CO - use Country_ml, only : IC_BB ! FFIRE - use EmisDef_ml, only : ISNAP_NAT ! Fires are assigned to SNAP-11 usually - use My_Emis_ml, only : & - NEMIS_FILES & - ,EMIS_NAME ! lets us know which pollutants are wanted, e.g. sox, pm25 - - use EmisGet_ml, only : & - nrcemis, nrcsplit, emisfrac & ! speciation routines and array - ,iqrc2itot & !maps from split index to total index - ,emis_nsplit ! No. spec per file, e.g. nox has 2, for NO and NO2 - - use GridValues_ml, only : i_fdom, j_fdom, debug_li, debug_lj, debug_proc - use Io_ml, only : PrintLog + use ChemSpecs_tot_ml + + use GridValues_ml, only : i_fdom, j_fdom, debug_li, debug_lj, & + debug_proc,xm2,GRIDWIDTH_M + use Io_ml, only : PrintLog, datewrite use MetFields_ml, only : z_bnd use ModelConstants_ml, only : MasterProc, KMAX_MID, & - USE_FOREST_FIRES, DEBUG_FORESTFIRE, & + USE_FOREST_FIRES, DEBUG_FORESTFIRE, FORECAST, & IOU_INST,IOU_HOUR,IOU_HOUR_MEAN, IOU_YEAR - use NetCDF_ml, only : ReadField_CDF, Out_netCDF, Real4 ! Reads, writes + use NetCDF_ml, only : ReadField_CDF, Out_netCDF,Real4 ! Reads, writes use OwnDataTypes_ml, only : Deriv, TXTLEN_SHORT - use Par_ml, only : MAXLIMAX, MAXLJMAX, li0, li1, lj0, lj1, me + use Par_ml, only : MAXLIMAX, MAXLJMAX, & + me,limax,ljmax use PhysicalConstants_ml, only : AVOG - use ReadField_ml, only : ReadField ! Reads ascii fields use Setup_1dfields_ml, only : rcemis use SmallUtils_ml, only : find_index - use TimeDate_ml,only : nydays, nmdays, date, current_date ! No. days per year, date-type -implicit none + ! No. days per year, date-type : + use TimeDate_ml,only : nydays, nmdays, date, current_date + use TimeDate_ExtraUtil_ml, only: date2string + implicit none ! Unimod calls just call Fire_Emis(daynumber) ! and put the day-testing code here. This lets the module decide if new @@ -71,456 +85,355 @@ module ForestFire_ml public :: Fire_rcemis private :: Export_FireNc - logical, public, dimension(MAXLIMAX,MAXLJMAX), save :: burning + logical, public, allocatable, dimension(:,:), save :: burning real, private, allocatable, dimension(:,:,:), save :: BiomassBurningEmis - integer, private, save :: ieCO ! index for CO - - logical, private, save, dimension(NEMIS_FILES) :: fires_found - - real, private, allocatable, dimension(:), save :: unitsfac - - !/ We use some integers from the general EMEP emission system: - - integer, private :: & - iem &! index for emis file, e.g. sox=1,nox=2 - ,iqrc &! index of species among speciated, e.g. SO2=1, SO4=2,NO=3 etc. - ,itot ! index of species in xn_2d. Use iqrc2itot array to map - - character(len=TXTLEN_SHORT), private :: emep_poll, gfed_poll - - type, private :: BB_Defs - character(len=TXTLEN_SHORT) :: emep ! e.g. nox - character(len=TXTLEN_SHORT) :: gfed ! e.g. NOx - real :: MW ! mol wt. assumed in emission file - end type - - ! GFED table ============================================================ - integer, private, parameter :: NDEFINED_EMEP = 16 ! No pollutants in file - - !/ Defintions of GFED data. If known, we assign the GFED pollutant which - ! corresponds to each possible EMEP emission file. Simply add EMEP - ! lines as required - be consistent with EmisDefs though. (We can - ! have more definitions than used in EmisDefs, but not vice.versa. - - ! Assign mol. wts of the GFED data where known. If mol. wt set to - ! zero, the code in Fire-rcemis will use the values from the - ! ChemSpecs_ml, species()%molwt. - ! - ! If GFED doesn't have emissionss, set a "-" for GFED, then the - ! desired emission factor (g/kg DW), and then follow the - ! example in Fire_setups for NH3: - ! - - type(BB_Defs), private, dimension(NDEFINED_EMEP) :: gfed_defs = (/ & - BB_Defs("sox ", "SO2 ", 64.0 ), & - BB_Defs("co ", "CO ", 28.0 ), & - BB_Defs("pm25 ", "PM25 ", 0 ), & ! species(PPM25)%molwt ), & - BB_Defs("nox ", "NOx ", 30.0 ), & ! as NO in GFED, assign 100% in emissplit - BB_Defs("nh3 ", "- ", 1.0 ), & ! NH3 not available in GFED. Use 1 g/kg DW - BB_Defs("pocffl", "- ", 0.0 ), & ! rb: is this really needed? - BB_Defs("poccfl", "- ", 0.0 ), & ! rb: is this really needed? - BB_Defs("pocfwd", "- ", 0.0 ), & ! rb: is this really needed? - BB_Defs("eccwd ", "- ", 0.0 ), & ! rb: is this really needed? - BB_Defs("ecfwd ", "- ", 0.0 ), & ! rb: is this really needed? - BB_Defs("ecffl ", "- ", 0.0 ), & ! rb: is this really needed? - BB_Defs("eccfl ", "- ", 0.0 ), & ! rb: is this really needed? - BB_Defs("voc ", "NMHC ", 0 ), & - BB_Defs("forfbc", "BC ", 12.0 ), & - BB_Defs("forfoc", "OC ", 0 ), & - BB_Defs("pmco ", "TPM ", 0 ) /) ! nearest. QUERY pm25< NBB_DEFS, NEMEPSPECS, FF_defs(NBB_DEFS) - if (current_date%year<2001) then - if( my_first_call .and. MasterProc ) then - call PrintLog("NO 8d GFED FOREST FIRES BEFORE 2001") - end if - my_first_call = .false. - return - end if - if (current_date%year>2007) then - if( my_first_call .and. MasterProc ) then - call PrintLog("NO 8d GFED FOREST FIRES AFTER 2007") - end if - my_first_call = .false. - return - end if + include 'BiomassBurningMapping.inc' - if ( DEBUG_FORESTFIRE .and. MasterProc ) then - write(*,*) "Into the FIRE days:", current_date%year, & - daynumber, dd_old, mod ( daynumber, 8 ), my_first_call - end if + !---------------------------------------------- + ! matrix to get from forest-fire species to EMEP ones - if (dd_old == daynumber) return ! Only calculate once per day max + integer, private, save :: emep_used(NEMEPSPECS) = 0 + real , private, save :: sum_emis(NEMEPSPECS) = 0 + ! ======================================================================= - ! Fire emissions are called at 8 days intervals (1, 9, 17, ....) - ! 46 values available each year: day 361 is the last one. - ! Return unless new period - if ( .not. my_first_call .and. mod ( daynumber, 8 ) /= 1 ) return - dd_old= daynumber +contains +subroutine Fire_Emis(daynumber) +!..................................................................... +!** DESCRIPTION: +! Reads forest-fire emissions. So far set up for GFED 8d, but in +! principal we can re-code by simply adding alternative +! subroutines, e.g. to cope with pre-2001 monthly emissions + integer, intent(in) :: daynumber ! daynumber (1,..... ,365) + + + real,allocatable :: rdemis(:,:) ! Emissions read from file + integer :: i,j,nstart, alloc_err, iBB + logical, save :: my_first_call = .true. ! DSFF + logical :: my_first_defs = .true. + integer :: dd_old = -1, n + real :: fac, to_kgm2s + + integer :: ind, ne + integer :: loc_maxemis(2) ! debug + + character(len=*), parameter :: & + GFED_PATTERN = 'GFED_ForestFireEmis.nc',& + FINN_PATTERN = 'FINN_ForestFireEmis_YYYY.nc',& + GFAS_PATTERN = 'GFAS_ForestFireEmis_YYYY.nc' + character(len=len(GFAS_PATTERN)) :: fname = '' + logical :: my_debug=.false. + integer, parameter :: verbose = 1 + + if(my_first_call) & + call PrintLog("Biomass Mapping: "//trim(BiomassBurningMapping),MasterProc) + + select case(verbose) + case(:0);my_debug=.false. + case(1) ;my_debug=DEBUG_FORESTFIRE.and.MasterProc.and.my_first_call + case(2) ;my_debug=DEBUG_FORESTFIRE.and.MasterProc + case(3) ;my_debug=DEBUG_FORESTFIRE + case(4:);my_debug=.true. + endselect + + nstart = -1 ! reset for GFED + select case(BiomassBurningMapping(1:4)) + + case("GFED") ! 8-day values + + if(DEBUG_FORESTFIRE.and.MasterProc) write(*,*) "FIRE selects GFED" + select case(current_date%year) + case(2001:2007) + if(MasterProc)& + write(*,*) "WARNING! FFIRE GFED USED! May not be working properly check results!" + case default + if(my_first_call)& + call PrintLog("8d GFED Forest Fires: only between 2001--2007",MasterProc) + call CheckStop("GFED not available. Use other FF data, or set USE_FOREST_FIRES .false. in ModelConstants") + my_first_call = .false. + return + endselect + if(DEBUG_FORESTFIRE.and.MasterProc) & + write(*,*) "GFED FIRE days:", current_date%year, & + daynumber, dd_old, mod(daynumber,8), my_first_call + + ! GFED Fire emissions are called at 8 days intervals (1, 9, 17, ....) + ! 46 values available each year: day 361 is the last one. + ! Return unless new period + + if(.not.my_first_call.and.mod(daynumber,8)/= 1) return nstart=(current_date%year-2001)*46+(daynumber+7)/8 - if(DEBUG_FORESTFIRE .and. MasterProc) & - write(*,*) "FOREST_FIRE: ", daynumber,nstart - - ! We need to look for forest-fire emissions which are equivalent - ! to the standard emission files: - - ieCO = -999 - fires_found(:) = .false. - - do iem = 1, NEMIS_FILES - - emep_poll = EMIS_NAME(iem) - n = find_index(emep_poll, gfed_defs(:)%emep ) - gfed_poll = gfed_defs(n)%gfed - - if(DEBUG_FORESTFIRE .and. MasterProc) then - write(*,"(a,i3,1x,2a8,2i3,a)") "FIRE SETUP: ", & - iem, trim(emep_poll), trim(gfed_poll), len_trim(gfed_poll) & - ,n, trim(gfed_defs(n)%gfed) - end if - - if ( len_trim(gfed_poll) > 1 ) then - - fires_found(iem) = .true. - - call ReadField_CDF('GLOBAL_ForestFireEmis.nc',gfed_poll,& - rdemis,nstart,interpol='zero_order',needed=.true.) - - if ( my_first_call ) then ! Assume NEMIS_FILES for now - allocate(BiomassBurningEmis(NEMIS_FILES,MAXLIMAX,MAXLJMAX),& - stat=alloc_err) - call CheckStop( alloc_err, "BB alloc problem") - - call Fire_setup() ! Gets InvMolwWtFac - - my_first_call = .false. - - end if - - !/ CO is special. Keep the index - if ( trim(gfed_poll) == "CO" ) ieCO = iem - - ! Assign and convert units: GFED [g/m2/month]->[kg/m2/s] - - BiomassBurningEmis(iem,:,:) = rdemis(:,:) * to_kgm2s - - call PrintLog("ForestFire_ml :: Assigns " // & - trim(gfed_poll) , MasterProc) - - else - call PrintLog("ForestFire_ml :: No GFED emis for " // & - trim(gfed_poll) , MasterProc) - end if - end do - - !/ If GFED doesn't have emissions, we create them from CO - - do iem = 1, NEMIS_FILES - emep_poll = EMIS_NAME(iem) - n = find_index(emep_poll, gfed_defs(:)%emep ) - gfed_poll = gfed_defs(n)%gfed - - if ( gfed_poll == "-" ) then ! Use CO. unitsfac will convert later - - BiomassBurningEmis(iem,:,:) = BiomassBurningEmis(ieCO,:,:) - - fires_found(iem) = .true. !??? not really used yet - call PrintLog("ForestFire_ml :: Estimates " // trim(emep_poll), & - MasterProc) - - end if - end do - - !/ Logical to let Unimod know if there is any emission here to - ! worry about - - burning(:,:) = ( BiomassBurningEmis(ieCO,:,:) > 1.0e-19 ) - - - end subroutine Fire_Emis -!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - subroutine Fire_setup() - - ! Pre-calculate conversion factors to get from BiomassBurning's kg/m2/s - ! to molecules/cm3/s. An important array (assigned elswhere) is emisfrac - ! which assigns species such as NOx or VOC to NO, NO2, C3H6 etc.. These - ! values must be set in the emissplit.specials. files if different from - ! the default SNAP-11 speciation. - ! - ! We need to assign the correct mol. wt., sometimes from GFED assumptions, - ! sometimes from EMEP species. - ! - ! We also handle the case where GFED doesn't have emissions, but an - ! emission factor can be assumed (e.g. NH3). - - integer :: ie, f, n, alloc_err - real :: efCO = 100.0 ! Emission factor of CO for scaling, g/mg DW - - allocate( unitsfac(nrcemis), stat=alloc_err) - call CheckStop( alloc_err, "BB MWF alloc problem") - - iqrc = 0 ! index over emisfrac - - do ie = 1, NEMIS_FILES - - emep_poll = EMIS_NAME(ie) - n = find_index(emep_poll, gfed_defs(:)%emep ) ! row in gfed table - gfed_poll = gfed_defs(n)%gfed - - do f = 1, emis_nsplit( ie ) - - iqrc = iqrc + 1 - itot = iqrc2itot(iqrc) !index in xn_2d array - - if ( len_trim(gfed_poll) > 1 ) then - - if ( gfed_defs(n)%MW > 0 ) then ! use GFED's MW - - unitsfac(iqrc) = emisfrac(iqrc,ISNAP_NAT,IC_BB) / & - gfed_defs(n)%MW - - else ! use EMEP model's MW - - unitsfac(iqrc) = emisfrac(iqrc,ISNAP_NAT,IC_BB) / & - species(itot)%molwt - - end if - - else if ( gfed_poll == "-" ) then - - ! Factors to get from CO to emissions of other species, here NH3 - ! - ! GFED assumes CO emission is ca. efCO = 100 g/kg(DM) for extra-trop forest - ! Andreae+Merlet 2001 have NH3 emission of ca. 1 g/kg as NH3 - - unitsfac(iqrc) = & - gfed_defs(n)%MW/efCO & ! When "-", MW is really emis factor - * emisfrac(iqrc,ISNAP_NAT,IC_BB) / & - species(itot)%molwt - - else - - call CheckStop( gfed_poll, "GFED case not found") - - end if - if(DEBUG_FORESTFIRE .and. MasterProc) then - write(*,"(a,3i3,1x,3a8,2es10.3)") "ForestFire_ml :: Setup-fac " , & - iem, f, iqrc, trim(emep_poll), trim(gfed_poll), & - trim(species(itot)%name), & - emisfrac(iqrc,ISNAP_NAT,IC_BB), unitsfac(iqrc) - end if - end do ! f and iqrc - end do ! ie - - - !// And one final conversion factor. - !// fires [kg/m2/s] -> [kg/m3/s] -> [molec/cm3/s] (after division by DeltaZ and MW) - ! 1 kg -> 1.0e3 g - ! /m2 -> 1.0e-6 /cm2 - ! Need MW in g/mole and delta-z in cm - - unitsfac(:) = unitsfac(:) * 0.001 * AVOG - - end subroutine Fire_setup -!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - subroutine Fire_rcemis(i,j) - + case("FINN") + if(DEBUG_FORESTFIRE.and.MasterProc) write(*,*) "FIRE selects FINN" + + case("GFAS") + if(DEBUG_FORESTFIRE.and.MasterProc) write(*,*) "FIRE selects GFAS" + + case default + call CheckStop("Unknown B.B.Mapping: "//trim(BiomassBurningMapping)) + endselect + + if(DEBUG_FORESTFIRE.and.MasterProc) & + write(*,*) "Starting FIRE days:", current_date%year, & + daynumber, dd_old, mod(daynumber,8), my_first_call + + if(dd_old==daynumber) return ! Only calculate once per day max + dd_old = daynumber + + if(my_first_call)then + + allocate(BiomassBurningEmis(NEMEPSPECS,MAXLIMAX,MAXLJMAX),& + burning(MAXLIMAX,MAXLJMAX),stat=alloc_err) + call CheckStop(alloc_err,"ForestFire BiomassBurningEmis alloc problem") + my_first_call = .false. + ne = 0 ! number-index of emep species + + do n=1, NBB_DEFS ! Only unique EMEP SPECS in emep_used + iemep = FF_defs(n)%emep + if(find_index(iemep,emep_used(:))>0) cycle + + ne = ne + 1 + emep_used(ne) = iemep + + ! CO is special. Keep the index + if(species(iemep)%name=="CO") ieCO=ne + + if(MasterProc) write(*,"(a,2i4,a17)") "FFIRE Mapping EMEP ", & + ne, iemep, trim(species(iemep)%name) + enddo !n + call CheckStop(ieCO<0,"No mapping for 'CO' found on "//BiomassBurningMapping) + call CheckStop(any(emep_used<0),"UNSET FFIRE EMEP "//BiomassBurningMapping) + + endif !my first call + allocate(rdemis(MAXLIMAX,MAXLJMAX),stat=alloc_err) + call CheckStop(alloc_err,"ForestFire rdemis alloc problem") + + if(DEBUG_FORESTFIRE.and.MasterProc) write(*,*) "FOREST_FIRE: ", daynumber,nstart + + BiomassBurningEmis(:,:,:) = 0.0 + + ! We need to look for forest-fire emissions which are equivalent + ! to the standard emission files: + + do iBB = 1, NBB_DEFS + FF_poll = FF_defs(iBB)%BBname + iemep = FF_defs(iBB)%emep ! + ind = find_index( iemep, emep_used ) ! Finds 1st emep in BiomassBurning + + if(DEBUG_FORESTFIRE.and.MasterProc) & + write(*,"( a,3i5, a8,i3)") "FIRE SETUP: ", iBB,iemep,ind, & + trim(FF_poll), len_trim(FF_poll) + + ! FORECAST mode: if file/variable/timestep not found it should not crash + rdemis(:,:)=0.0 + + select case(BiomassBurningMapping(1:4)) + case("GFED") + fname = date2string(GFED_PATTERN,current_date) + if(my_debug) & + write(*,*) "FFIRE GFED ", me, iBB, nstart, trim(FF_poll), trim(fname) + call ReadField_CDF(fname,FF_poll,rdemis,nstart,interpol='zero_order',& + needed=.not.FORECAST,UnDef=0.0,debug_flag=DEBUG_FORESTFIRE) + !unit conversion to GFED [g/m2/8day]->[kg/m2/s] + to_kgm2s = 1.0e-3 /(8*24.0*3600.0) + forall(j=1:ljmax,i=1:limax) rdemis(i,j)=rdemis(i,j)*to_kgm2s + + case("FINN") + fname = date2string(FINN_PATTERN,current_date) + if(my_debug) & + write(*,*) "FFIRE FINN ", me, iBB, daynumber, trim(FF_poll), trim(fname) + call ReadField_CDF(fname,FF_poll,rdemis,daynumber,interpol='mass_conservative',& + needed=.not.FORECAST,UnDef=0.0,debug_flag=DEBUG_FORESTFIRE) + !unit conversion to FINN: Can be negative if REMPPM to be calculated + fac=FF_defs(iBB)%unitsfac * FF_defs(iBB)%frac ! --> [kg/day] + fac=fac/(GRIDWIDTH_M*GRIDWIDTH_M*24.0*3600.0) ! [kg/day]->[kg/m2/s] + forall(j=1:ljmax,i=1:limax) rdemis(i,j)=rdemis(i,j)*fac*xm2(i,j) + + case("GFAS") + fname = date2string(GFAS_PATTERN,current_date) + nstart = daynumber +! something more sophisticated is needed for YYYY_ or YYYYMM_ files, +! e.g. use ReadTimeCDF and nctime2idate/idate2nctime to find the right record: +! nstart=FindTimeCDFRecord(fname,current_date,prec_ss=3600.0*12) + if(my_debug) & + write(*,*) "FFIRE GFAS ", me, iBB, n, nstart, trim(FF_poll), trim(fname) + call ReadField_CDF(fname,FF_poll,rdemis,nstart,interpol='conservative',& + needed=.not.FORECAST,debug_flag=DEBUG_FORESTFIRE) + ! GFAS units are [kg/m2/s]. No further unit conversion is needed. + ! However, fac can be /=1, e.g. when REMPPM is calculated + fac=FF_defs(iBB)%unitsfac * FF_defs(iBB)%frac + if(fac/=1.0) forall(j=1:ljmax,i=1:limax) rdemis(i,j)=rdemis(i,j)*fac + endselect + + + ! Assign . units should be [kg/m2/s] here + forall(j=1:ljmax,i=1:limax) + BiomassBurningEmis(ind,i,j) = BiomassBurningEmis(ind,i,j) + rdemis(i,j) + endforall + + if(my_debug) write(*,"(3a10,i4,f8.3,es12.3)") "FFIRE SUMS:", & + trim(FF_poll), trim( species(iemep)%name), ind, & + species(iemep)%molwt, sum( BiomassBurningEmis(ind,:,:) ) + + + if(my_first_defs) call PrintLog(& + "ForestFire_ml :: Assigns "//trim(FF_poll) , MasterProc) + + if(DEBUG_FORESTFIRE) sum_emis(ind)=sum_emis(ind)+sum(BiomassBurningEmis(ind,:,:)) + enddo ! BB_DEFS + + my_first_defs = .false. + deallocate(rdemis) + + ! For cases where REMPPM25 s derived as the difference between PM25 and (BC+1.7*OC) + ! we need some safety: + + BiomassBurningEmis(:,:,:) = max( BiomassBurningEmis(:,:,:), 0.0 ) + + ! Logical to let Unimod know if there is any emission here to worry about + burning(:,:) = ( BiomassBurningEmis(ieCO,:,:) > 1.0e-19 ) + + + ! Some databases (e.g. FINN, GFED) have both total PM25 and EC, OC. The difference + ! REMPPM25, is created by the BiomasBurning mapping procedure, but we just + ! check here + if(DEBUG_FORESTFIRE.and.debug_proc) then + n = ieCO + loc_maxemis = maxloc(BiomassBurningEmis(n,:,: ) ) + call datewrite("SUM_FF CHECK CO: ", & + (/ daynumber, n, i_fdom(loc_maxemis(1)), j_fdom(loc_maxemis(2)) /) ,& + (/ sum_emis(n), maxval(BiomassBurningEmis(n,:,: ) ), & + BiomassBurningEmis(n,debug_li,debug_lj) /) ) + endif ! debug_proc +endsubroutine Fire_Emis + +!============================================================================= + +subroutine Fire_rcemis(i,j) ! Disperses the fire emissions vertically and converts to molecules/cm3/s. !// Injection height: here over 8 levels. Alternative could be PBL ! or equally upto ca. 2*PBL (suggested by Sofiev, GEMS) -!ds QUERY - should the emissions be divided equally by level? +! QUERY - should the emissions be divided equally by level? ! - will give a higher mixing ratio for thinner levels - integer, intent(in) :: i,j - - integer, parameter :: KEMISFIRE = 12 - real, dimension(KEMISFIRE:KMAX_MID) :: invDeltaZfac ! height of layer in m div 9 - integer :: k, f - - integer, parameter :: N_LEVELS = KMAX_MID - KEMISFIRE + 1 ! = 9.0 here - - - real :: origrc, bbe - logical :: debug_flag - + integer, intent(in) :: i,j - debug_flag = ( DEBUG_FORESTFIRE .and. & - debug_proc .and. i == debug_li .and. j == debug_lj ) + integer, parameter :: KEMISFIRE = 12 + real, dimension(KEMISFIRE:KMAX_MID) :: invDeltaZfac ! height of layer in m div 9 + integer :: k, n, iem - if ( debug_flag ) then - write(*,"(a,5i4,es12.3,f9.3)") "Burning ", me, i,j, & - i_fdom(i), j_fdom(j), BiomassBurningEmis(ieCO,i,j) - end if + integer, parameter :: N_LEVELS = KMAX_MID - KEMISFIRE + 1 ! = 9.0 here - !/ Here we just divide by the number of levels. Biased towards - ! different levels since thickness and air content differ. Simple though. + real :: origrc, bbe, fac + logical :: debug_flag - do k = KEMISFIRE, KMAX_MID - invDeltaZfac(k) = 1.0/ (z_bnd(i,j,k) - z_bnd(i,j,k+1)) /N_LEVELS - end do + debug_flag = (DEBUG_FORESTFIRE.and.debug_proc .and.& + i==debug_li.and.j==debug_lj) + if(debug_flag.and.BiomassBurningEmis(ieCO,i,j) > 1.0e-10) & + write(*,"(a,5i4,es12.3,f9.3)") "BurningDEBUG ", me, i,j, & + i_fdom(i), j_fdom(j), BiomassBurningEmis(ieCO,i,j) - iqrc = 0 ! index over emisfrac - EMLOOP : do iem = 1, NEMIS_FILES + !// last conversion factors: + ! The biomassBurning array is kept in kg/m2/s for consistency with other + ! emissions. We here convert to molecules/cm3/s after spreading + ! through a vertical distance dz + ! + ! If we had E in kg/m2/s, we would then take + ! E*1.0e3 -> g/m2/s + ! E*0.1 -> g/cm2/s + ! E*0.1 /MW * Av -> molec/cm2/s + ! E*0.001 /MW * Av / DZ -> molec/cm3/s where DZ is spread in m + ! i.e. fmap should be 0.001*Av/MW + ! (plus account for the fraction of the inventory assigned to EMEP species) - do f = 1, emis_nsplit( iem ) - iqrc = iqrc + 1 + !/ Here we just divide by the number of levels. Biased towards + ! different levels since thickness and air content differ. Simple though. - if ( .not. fires_found(iem) ) cycle EMLOOP - - itot = iqrc2itot(iqrc) !index in xn_2d array - - bbe = BiomassBurningEmis(iem,i,j) * unitsfac( iqrc ) - - - origrc = rcemis( itot, KMAX_MID ) ! just for printout - - ! distribute vertically: - - do k = KEMISFIRE, KMAX_MID - rcemis( itot, k ) = rcemis( itot, k ) + bbe * invDeltaZfac(k) - end do !k - - if ( debug_flag ) then - k=KMAX_MID - write(*,"(a,i3,1x,a8,f7.3,i4,es10.2,4es10.2)") "FIRERC ",& - iem, trim(species(itot)%name), emisfrac(iqrc,ISNAP_NAT,IC_BB), & - k, BiomassBurningEmis(iem,i,j),& - unitsfac(iqrc), invDeltaZfac(k), origrc, rcemis( itot, k ) - end if - - !-- Add up emissions in ktonne ...... - ! totemadd(itot) = totemadd(itot) + & - ! tmpemis(iqrc) * dtgrid * xmd(i,j) - - end do ! f - end do EMLOOP ! iem - - end subroutine Fire_rcemis -!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - subroutine Export_FireNc() - type(Deriv) :: def1 ! definition of fields + do k = KEMISFIRE, KMAX_MID + invDeltaZfac(k) = 1.0/ (z_bnd(i,j,k) - z_bnd(i,j,k+1)) /N_LEVELS + enddo + + do n = 1, NEMEPSPECS + iem = emep_used(n) + origrc = rcemis(iem,KMAX_MID) ! just for printout + fac = 0.001 * AVOG /species(iem)%molwt ! MW scale if needed + + ! distribute vertically: + do k = KEMISFIRE, KMAX_MID + rcemis(iem,k) = rcemis(iem,k) + BiomassBurningEmis(n,i,j)*invDeltaZfac(k)*fac + enddo !k + + if(debug_flag) then + k=KMAX_MID + write(*,"(a,2i3,1x,a8,i4,es10.2,4es10.2)") "FIRERC ",& + n, iem, trim(species(iem)%name), k, BiomassBurningEmis(iem,i,j),& + invDeltaZfac(k), origrc, rcemis(iem,k) + endif + +!DSBB !-- Add up emissions in ktonne ...... +!DSBB ! totemadd(iem) = totemadd(iem) + & +!DSBB ! tmpemis(iqrc) * dtgrid * xmd(i,j) + + enddo ! n + ! call Export_FireNc() ! Caused problems on last attempt + +endsubroutine Fire_rcemis +!============================================================================= +subroutine Export_FireNc() + type(Deriv) :: def1 ! definition of fields - def1%class='ForestFireEmis' !written - def1%avg=.false. !not used - def1%index=0 !not used - def1%scale=1.0 !not used -!FEB2011 def1%inst=.true. !not used -!FEB2011 def1%year=.false. !not used -!FEB2011 def1%month=.false. !not used -!FEB2011 def1%day=.false. !not used - def1%name='NOx' !written - def1%unit='g/m2' !written - def1%name='NOx_zero' - def1%name='CO_ASCII' - - call Out_netCDF(IOU_INST,def1,2,1, BiomassBurningEmis(ieCO,:,:),1.0,& - CDFtype=Real4,fileName_given='FF.nc') - end subroutine Export_FireNc - -end module ForestFire_ml - -!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< -!ncdump -h /global/work/mifapw/emep/Data/ForestFire/ForestFireEmis.nc: -!--------------------------------------------------------------- -! netcdf ForestFireEmis { -! dimensions: -! lon = 360 ; -! lat = 180 ; -! time = UNLIMITED ; // (322 currently) -! variables: -! double lon(lon) ; -! lon:standard_name = "longitude" ; -! lon:long_name = "longitude" ; -! lon:units = "degrees_east" ; -! double lat(lat) ; -! lat:standard_name = "latitude" ; -! lat:long_name = "latitude" ; -! lat:units = "degrees_north" ; -! int time(time) ; -! time:units = "days since 1900-1-1 0:0:0" ; -! double map_factor_i(lat, lon) ; -! map_factor_i:long_name = "mapping factor in i direction" ; -! map_factor_i:units = "" ; -! double map_factor_j(lat, lon) ; -! map_factor_j:long_name = "mapping factor in j direction" ; -! map_factor_j:units = "" ; -! float PM25(time, lat, lon) ; -! PM25:long_name = "PM25" ; -! PM25:units = "g/m2/8days" ; -! PM25:numberofrecords = 322 ; -! PM25:_FillValue = 9.96921e+36f ; -! float BC(time, lat, lon) ; -! BC:long_name = "BC" ; -! BC:units = "g/m2/8days" ; -! BC:numberofrecords = 322 ; -! BC:_FillValue = 9.96921e+36f ; -! float NMHC(time, lat, lon) ; -! NMHC:long_name = "NMHC" ; -! NMHC:units = "g/m2/8days" ; -! NMHC:numberofrecords = 322 ; -! NMHC:_FillValue = 9.96921e+36f ; -! float CO(time, lat, lon) ; -! CO:long_name = "CO" ; -! CO:units = "g/m2/8days" ; -! CO:numberofrecords = 322 ; -! CO:_FillValue = 9.96921e+36f ; -! float OC(time, lat, lon) ; -! OC:long_name = "OC" ; -! OC:units = "g/m2/8days" ; -! OC:numberofrecords = 322 ; -! OC:_FillValue = 9.96921e+36f ; -! float NOx(time, lat, lon) ; -! NOx:long_name = "NOx" ; -! NOx:units = "g/m2/8days" ; -! NOx:numberofrecords = 322 ; -! NOx:_FillValue = 9.96921e+36f ; -! float SO2(time, lat, lon) ; -! SO2:long_name = "SO2" ; -! SO2:units = "g/m2/8days" ; -! SO2:numberofrecords = 322 ; -! SO2:_FillValue = 9.96921e+36f ; -! float TPM(time, lat, lon) ; -! TPM:long_name = "TPM" ; -! TPM:units = "g/m2/8days" ; -! TPM:numberofrecords = 322 ; -! TPM:_FillValue = 9.96921e+36f ; -! -! // global attributes: -! :Conventions = "CF-1.0" ; -! :projection = "lon lat" ; -! :vert_coord = "sigma: k ps: PS ptop: PT" ; -! :Grid_resolution = 111177.473352039 ; -! :created_date = "20091021" ; -! :created_hour = "143950.341" ; -! :lastmodified_date = "20091021" ; -! :lastmodified_hour = "145458.652" ; -! } + def1%class='ForestFireEmis' !written + def1%avg=.false. !not used + def1%index=0 !not used + def1%scale=1.0 !not used + def1%name='CO' !written + def1%unit='g/m2' !written + def1%name='CO_zero' + def1%name='CO_ASCII' + + call Out_netCDF(IOU_INST,def1,2,1, BiomassBurningEmis(ieCO,:,:),1.0,& + CDFtype=Real4,fileName_given='FF.nc') +endsubroutine Export_FireNc + +endmodule ForestFire_ml +!============================================================================= diff --git a/Functions_ml.f90 b/Functions_ml.f90 index 17a34d2..561ef73 100644 --- a/Functions_ml.f90 +++ b/Functions_ml.f90 @@ -1,9 +1,9 @@ ! -!*****************************************************************************! -!* +!*****************************************************************************! +!* !* Copyright (C) 2007-2011 met.no -!* +!* !* Contact information: !* Norwegian Meteorological Institute !* Box 43 Blindern @@ -11,24 +11,24 @@ !* NORWAY !* email: emep.mscw@met.no !* http://www.emep.int -!* +!* !* 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 Functions_ml !____________________________________________________________________ ! Miscellaneous collection of "standard" (or guessed ) functions -! Including Troe, sine and cosine curves, +! Including Troe, sine and cosine curves, ! and Standard Atmosphere p -> H conversion !____________________________________________________________________ ! @@ -49,6 +49,8 @@ module Functions_ml public :: great_circle_distance!distance between two points following the surface on a unit sphere + public :: heaviside ! The heaviside function, 0 for x<0 and 1 for x>0 (x==0?) + !/- Exner subroutines: ------------------------------------------------------ public :: Exner_nd ! (p/P0)**KAPPA @@ -61,7 +63,7 @@ module Functions_ml !/- Interpolation constants real, private, parameter :: & - PINC=1000.0 & + PINC=1000.0 & ,P0 =1.0e5 & ! Standard pressure ,PBAS=-PINC @@ -84,7 +86,7 @@ function Daily_cosine(mean, amp, dmax, ndays) result (daily) integer, intent(in) :: ndays ! No. days per year (365/366) real, dimension(ndays) :: daily - integer :: d + integer :: d real, save :: twopi ! Could use PhysiclConstants_ml twopi = 8.0 * atan(1.0) ! but I prefer to keep Functions_ml ! standalone @@ -94,7 +96,7 @@ function Daily_cosine(mean, amp, dmax, ndays) result (daily) end do end function Daily_cosine - + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< function Daily_sine(mean, amp, dmax, ndays) result (daily) @@ -108,8 +110,8 @@ function Daily_sine(mean, amp, dmax, ndays) result (daily) integer, intent(in) :: ndays ! No. days per year (365/366) real, dimension(ndays) :: daily - integer :: d - real, save :: shift ! Shifts sine curve to give max + integer :: d + real, save :: shift ! Shifts sine curve to give max ! when d = dmax real, save :: twopi ! Could use PhysiclConstants_ml twopi = 8.0 * atan(1.0) ! but I prefer to keep Functions_ml @@ -121,7 +123,7 @@ function Daily_sine(mean, amp, dmax, ndays) result (daily) end do end function Daily_sine - + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< function Daily_halfsine(base, amp, ndays) result (daily) @@ -133,7 +135,7 @@ function Daily_halfsine(base, amp, ndays) result (daily) integer, intent(in) :: ndays ! No. days per year (365/366) real, dimension(ndays) :: daily - integer :: d + integer :: d real, save :: pi ! Could use PhysiclConstants_ml pi = 4.0 * atan(1.0) ! but I prefer to keep Functions_ml ! standalone @@ -165,9 +167,9 @@ elemental function StandardAtmos_km_2_kPa(h_km) result (p_kPa) p_kPa = 101.325*exp(-5.255876*log(288.15/(288.15-6.5*h_km))) else p_kPa = 22.632*exp(-0.1576884*(h_km - 11.0) ) - + end if - + end function StandardAtmos_km_2_kPa !======================================================================= @@ -259,7 +261,7 @@ elemental function Tpot_2_T(p) result(fTpot) integer :: ix1 x1 = (p-PBAS)/PINC - ix1 = x1 + ix1 = int( x1 ) fTpot = tab_exf(ix1) + (x1-ix1)*(tab_exf(ix1+1) - tab_exf(ix1)) end function Tpot_2_T @@ -273,7 +275,7 @@ elemental function T_2_Tpot(p) result(fT) integer :: ix1 x1 = (p-PBAS)/PINC - ix1 = x1 + ix1 = int( x1 ) exf = tab_exf(ix1) + (x1-ix1)*(tab_exf(ix1+1) - tab_exf(ix1)) fT = 1.0/exf @@ -298,7 +300,7 @@ real function ERFfunc(x) end function ERFfunc !-------------------------------------------------------------------- - + subroutine calerf(arg,result,jint) !-------------------------------------------------------------------- ! This packet evaluates erf(x), erfc(x), and exp(x*x)*erfc(x) @@ -306,26 +308,26 @@ subroutine calerf(arg,result,jint) ! subprograms: erf, erfc, and erfcx (or derf, derfc, and derfcx), ! and one subroutine type subprogram, calerf. The calling ! statements for the primary entries are: - + ! y=erf(x) (or y=derf(x)), ! y=erfc(x) (or y=derfc(x)), ! and ! y=erfcx(x) (or y=derfcx(x)). - + ! The routine calerf is intended for internal packet use only, ! all computations within the packet being concentrated in this ! routine. The function subprograms invoke calerf with the ! statement ! call calerf(arg,result,jint) ! where the parameter usage is as follows - + ! Function Parameters for calerf ! Call Arg Result Jint - ! + ! ! erf(arg) any real argument erf(arg) 0 ! erfc(arg) abs(arg) < xbig erfc(arg) 1 ! erfcx(arg) xneg < arg < xmax erfcx(arg) 2 - + ! The main computation evaluates near-minimax approximations: ! from "Rational Chebyshev Approximations for the Error Function" ! by W. J. Cody, Math. Comp., 1969, pp. 631-638. This @@ -334,7 +336,7 @@ subroutine calerf(arg,result,jint) ! decimal digits. The accuracy achieved depends on the arithmetic ! system, the compiler, the intrinsic functions, and proper ! selection of the machine-dependent constants. - + ! Explanation of machine-dependent constants: ! xmin = The smallest positive floating-point number. ! xinf = The largest positive finite floating-point number. @@ -353,7 +355,7 @@ subroutine calerf(arg,result,jint) ! 1/[2*sqrt(xsmall)] ! xmax = Largest acceptable argument to erfcx; the minimum ! of xinf and 1/[sqrt(pi)*xmin]. - + ! Approximate values for some important machines are: ! xmin xinf xneg xsmall ! CDC 7600 (s.p.) 3.13e-294 1.26e+322 -27.220 7.11e-15 @@ -366,7 +368,7 @@ subroutine calerf(arg,result,jint) ! Univac 1108 (d.p.) 2.78d-309 8.98d+307 -26.615 1.73d-18 ! Vax d-format (d.p.) 2.94d-39 1.70d+38 -9.345 1.39d-17 ! Vax g-format (d.p.) 5.56d-309 8.98d+307 -26.615 1.11d-16 - + ! xbig xhuge xmax ! CDC 7600 (s.p.) 25.922 8.39e+6 1.80x+293 ! Cray-1 (s.p.) 75.326 8.39e+6 5.45e+2465 @@ -378,16 +380,16 @@ subroutine calerf(arg,result,jint) ! Univac 1108 (d.p.) 26.582 5.37d+8 8.98d+307 ! Vax d-format (d.p.) 9.269 1.90d+8 1.70d+38 ! Vax g-format (d.p.) 26.569 6.71d+7 8.98d+307 - + ! Error returns: ! The program returns erfc = 0 for arg >= xbig; ! erfcx = xinf for arg < xneg; ! and ! erfcx = 0 for arg >= xmax. - + ! Intrinsic functions required are: ! abs, aint, exp - + ! Author: W. J. Cody ! Mathematics And Computer Science Division ! Argonne National Laboratory @@ -397,23 +399,23 @@ subroutine calerf(arg,result,jint) integer :: i,jint real :: result, x, & arg,del,xden,xnum, y,ysq - + ! Mathematical constants real :: four = 4.,one = 1.,half = 0.5,two = 2.,zero = 0., & sqrpi = 5.6418958354775628695e-1,thresh=0.46875, & sixten=16.0 - + ! Machine-dependent constants real :: xinf=3.40e+38,xneg=-9.382e0,xsmall=5.96e-8, & xbig=9.194, xhuge=2.90e3,xmax=4.79e37 - + ! Coefficients for approximation to erf in first interval real, dimension(5) :: a =(/3.16112374387056560e00,1.13864154151050156e02, & 3.77485237685302021e02,3.20937758913846947e03, & 1.85777706184603153e-1/) real, dimension(4) :: b =(/2.36012909523441209e01,2.44024637934444173e02, & 1.28261652607737228e03,2.84423683343917062e03/) - + ! Coefficients for approximation to erfc in second interval real, dimension(9) :: c = & (/5.64188496988670089e-1, 8.88314979438837594e0, & @@ -426,7 +428,7 @@ subroutine calerf(arg,result,jint) 5.37181101862009858e02,1.62138957456669019e03, & 3.29079923573345963e03,4.36261909014324716e03, & 3.43936767414372164e03,1.23033935480374942e03/) - + ! Coefficients for approximation to erfc in third interval real, dimension(6) :: p = & (/3.05326634961232344e-1, 3.60344899949804439e-1, & @@ -436,7 +438,7 @@ subroutine calerf(arg,result,jint) (/2.56852019228982242e0 ,1.87295284992346047e0 , & 5.27905102951428412e-1,6.05183413124413191e-2, & 2.33520497626869185e-3/) - + ! Main Code x=arg y=abs(x) @@ -517,9 +519,9 @@ end subroutine calerf !------------------------------------------------------------------- - function great_circle_distance(fi1,lambda1,fi2,lambda2) result(dist) + PURE function great_circle_distance(fi1,lambda1,fi2,lambda2) result(dist) - !compute the great circle distance between to points given in + !compute the great circle distance between to points given in !spherical coordinates. Sphere has radius 1. real, intent(in) ::fi1,lambda1,fi2,lambda2 !NB: in DEGREES here real :: dist @@ -535,6 +537,25 @@ function great_circle_distance(fi1,lambda1,fi2,lambda2) result(dist) end function great_circle_distance +!----------------------------------------------------------------------- +! The heaviside function, 0 for x<0 and 1 for x>0 (x==0?) +! For x=0, one could have 0.5, but numerically this is too tricky to code +! and with double precision a very rare event. + function heaviside(x) + + real, intent(in) :: x + real :: heaviside + + + if (x<0) then + heaviside = 0.0 + else + heaviside = 1.0 + end if + + end function heaviside +!----------------------------------------------------------------------- + !program Test_exn ! use Exner_ml @@ -553,7 +574,7 @@ end function great_circle_distance ! print "(f8.3,4f12.5)", 1.0e-2*p, exf1, exf2, Tpot_2_T(p), T_2_Tpot(p) ! end do !end program Test_exn - + ! Results: ! p(mb) exf1 exf2 Tpot_2_T T_2_Tpot ! 50.000 0.42471 0.42471 0.42471 2.35455 diff --git a/GlobalBCs_ml.f90 b/GlobalBCs_ml.f90 index 16cad17..ea654aa 100644 --- a/GlobalBCs_ml.f90 +++ b/GlobalBCs_ml.f90 @@ -34,7 +34,7 @@ module GlobalBCs_ml ! Seasonal variation is often weaker at higher altitude. ! The "vmin" minimum concentration can correct for some of this. ! It is after all (we hope) the near-surface BCs which matter most. -! In principle one could specify al concentrations as complex 3-D fieldds +! In principle one could specify al concentrations as complex 3-D fields ! here, but that would need a new setup routine ! ! ----------------------------------------------------------------------- @@ -70,12 +70,12 @@ module GlobalBCs_ml ! ----------------------------------------------------------------------- !-- definitions in Jostein's grid. Generally, these will be from ! a Txx model, where xx is currently 21. -integer, parameter, public :: & ! Assume BC defined in large domain: - IGLOB = IIFULLDOM, & ! number of large domain grids cells, longitude - JGLOB = JJFULLDOM ! number of large domain grids cells, latitude +!integer, parameter, public :: & ! Assume BC defined in large domain: +! IGLOB = IIFULLDOM, & ! number of large domain grids cells, longitude +! JGLOB = JJFULLDOM ! number of large domain grids cells, latitude ! Chemical species: -! -- IBC indices text generated by perl script mkp.jost - ds +! -- IBC indices text generated by perl script mkp.jost ! ** usually only changed when global-model output changes ** integer, public, parameter :: & IBC_O3 = 1 & @@ -163,10 +163,11 @@ subroutine GetGlobalData(year,iyr_trend,month,ibc,used, & integer, intent(inout) :: errcode ! i/o number logical, save :: first_call = .true. - real, dimension(IGLOB,JGLOB,KMAX_MID) :: bc_rawdata ! Data (was rtcdmp) + real, dimension(IIFULLDOM,JJFULLDOM,KMAX_MID) :: bc_rawdata ! Data (was rtcdmp) type(UStrend):: US=UStrend(1.0,1.0,1.0) - integer, dimension(IGLOB,JGLOB), save :: lat5 ! for latfunc below +! integer, dimension(IIFULLDOM,JJFULLDOM), save :: lat5 ! for latfunc below + integer, allocatable,dimension(:,:), save :: lat5 ! for latfunc below real, dimension(NGLOB_BC,6:14), save :: latfunc ! lat. function real, save :: twopi_yr, cosfac ! for time-variations real, dimension(12) :: macehead_O3 @@ -253,12 +254,12 @@ subroutine GetGlobalData(year,iyr_trend,month,ibc,used, & ! Here we use the meteorology year to get a reaslistic O3. ! Later we use iyr_trend to adjust for other years, say for 2050. -! For 2010, 2020 "trend" runs - use 12 yr average as base-O3 +! For 2010, 2020 "trend" runs - use 13 yr average as base-O3 ! then later scale by trend_o3: - if ( iyr_trend /= year ) then ! use defaults from 1998-2009 average - macehead_O3 = (/ 40.1, 42.2, 45.6, 46.5, 43.4, 36.3, & - 30.5, 30.0, 34.0, 37.0, 39.9, 39.0 /) + if ( iyr_trend /= year ) then ! use defaults from 1998-2010 average + macehead_O3 = (/ 39.8, 41.9, 45.4, 46.5, 43.2, 36.2, & + 30.5, 30.1, 34.1, 37.0, 39.0, 38.5 /) else select case (year) case(1990) @@ -272,7 +273,7 @@ subroutine GetGlobalData(year,iyr_trend,month,ibc,used, & 28.3, 30.3, 31.3, 34.2, 36.1, 34.9/) case(1993) macehead_O3 = (/ 37.6, 40.4, 44.4, 42.6, 43.4, 29.2, & - 28.5, 29.6, 32.2, 0.0, 37.3, 38.3/) + 28.5, 29.6, 32.2, 37.3, 37.3, 38.3/) case(1994) macehead_O3 = (/ 38.6, 37.3, 45.7, 43.8, 42.9, 35.1, & 30.8, 30.5, 33.8, 36.5, 34.0, 37.3/) @@ -335,9 +336,15 @@ subroutine GetGlobalData(year,iyr_trend,month,ibc,used, & case(2009) macehead_O3 = (/ 37.7, 43.3, 46.5, 46.2, 41.6, 39.1, & 31.0, 29.0, 34.5, 34.4, 40.5, 38.4 /) - case default ! from 1998-2009 average - macehead_O3 = (/ 40.1, 42.2, 45.6, 46.5, 43.4, 36.3, & - 30.5, 30.0, 34.0, 37.0, 39.5, 39.0 /) +! 2010 Mace Head correction calculated using IE31 O3 data and +! trajectory sectors (based on ECMWF met) for 2010 + case(2010) + macehead_O3 = (/ 36.8, 38.9, 43.9, 46.4, 41.7, 35.5, & + 31.0, 31.3, 35.6, 36.7, 33.4, 33.8 /) + + case default ! from 1998-2010 average + macehead_O3 = (/ 39.8, 41.9, 45.4, 46.5, 43.2, 36.2, & + 30.5, 30.1, 34.1, 37.0, 39.0, 38.5 /) endselect endif !=========== Generated from Mace Head Data ======================= @@ -350,11 +357,11 @@ subroutine GetGlobalData(year,iyr_trend,month,ibc,used, & if ( first_call ) then ! Set up arrays to contain Logan's grid as lat/long !/ COnversions derived from emeplat2Logan etc.: - + allocate(lat5(IIFULLDOM,JJFULLDOM)) twopi_yr = 2.0 * PI / 365.25 call GlobalPosition !get glat for global domaib - forall(i=1:IGLOB,j=1:JGLOB) ! Don't bother with south pole complications + forall(i=1:IIFULLDOM,j=1:JJFULLDOM) ! Don't bother with south pole complications lat5(i,j) = glat_fdom(i,j)/5 ! lat/5 used in latfunc below lat5(i,j) = max(lat5(i,j),6) ! Min value in latfunc lat5(i,j) = min(lat5(i,j),14) ! Max value in latfunc @@ -369,7 +376,7 @@ subroutine GetGlobalData(year,iyr_trend,month,ibc,used, & SpecBC(IBC_NO2 ) = sineconc( 0.1 , 15.0, 0.03, 4.0 , 0.05, 0.04,PPB) SpecBC(IBC_PAN ) = sineconc( 0.20 ,120.0, 0.15, 999.9, 0.20, 0.1 ,PPB)!Kz change vmin SpecBC(IBC_CO ) = sineconc( 125.0, 75.0, 35.0, 25.0 , 70.0, 30.0,PPB)!JEJ-W - SpecBC(IBC_SEASALT_F)=sineconc( 0.5 , 15.0, 0.3, 1.6 , 0.01, 0.01,PPB) + SpecBC(IBC_SEASALT_F)=sineconc( 0.5 , 15.0, 0.3, 1.6 , 0.01, 0.01,PPB) SpecBC(IBC_SEASALT_C)=sineconc( 3.0 , 15.0, 1.0, 1.6 , 0.01, 0.01,PPB) SpecBC(IBC_SEASALT_G)=sineconc( 1.0 , 15.0, 0.5, 1.0 , 0.01, 0.01,PPB) SpecBC(IBC_C2H6 ) = sineconc( 2.0 , 75.0, 1.0 , 10.0 , 0.05, 0.05,PPB) @@ -449,7 +456,7 @@ subroutine GetGlobalData(year,iyr_trend,month,ibc,used, & case (IBC_O3) fname=date2string("D3_O3.MM",month=month) BCpoll='D3_O3_Logan' - call ReadBC_CDF(BCpoll,month,bc_rawdata,IGLOB,JGLOB,KMAX_MID,notfound) + call ReadBC_CDF(BCpoll,month,bc_rawdata,IIFULLDOM,JJFULLDOM,KMAX_MID,notfound) if(notfound)then call open_file(IO_GLOBBC,"r",fname,needed=.true.,skip=1) @@ -458,14 +465,14 @@ subroutine GetGlobalData(year,iyr_trend,month,ibc,used, & close(IO_GLOBBC) endif if(DEBUG_GLOBBC)print *,"dsOH READ OZONE3 ",trim(fname),": ",& - bc_rawdata(IGLOB/2,JGLOB/2,20) + bc_rawdata(IIFULLDOM/2,JJFULLDOM/2,20) ! Mace Head adjustment: get mean ozone from Eastern sector O3fix=0.0 icount=0 if(MACEHEADFIX)then - do j=1,JGLOB - do i=1,IGLOB + do j=1,JJFULLDOM + do i=1,IIFULLDOM if(glat_fdom(i,j)macehead_lat-25.0.and.& glon_fdom(i,j) !***************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -26,350 +26,993 @@ !* along with this program. If not, see . !***************************************************************************! - Module GridValues_ml - -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC -! -! Define parameters and variables associated with 3-D grid and its -! geography. -! -! History: -! March - changed folllwing Steffen's optimisation/correction of sigma_mid. -! January 2001 : Created by ds from old defconstants, made enough changes -! to get this into F90, and to make x,y inputs to the position subroutine, -! but the basic equations are untouched. -! October 2001 hf added call to ReadField (which now does global2local) -! Nov. 2001 - tidied up a bit (ds). Use statements moved to top of module -!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC - - use Functions_ml, only : great_circle_distance - - use ModelConstants_ml, only : KMAX_BND, KMAX_MID &! vertical extent - ,DEBUG_i, DEBUG_j & ! full-domain coordinate of debug-site - ,NPROC, IIFULLDOM,JJFULLDOM, PT, Pref - use Par_ml, only : & - MAXLIMAX,MAXLJMAX & ! max. possible i, j in this domain - ,limax,ljmax & ! actual max. i, j in this domain - ,li0,li1,lj0,lj1 & ! for debugging TAB - ,IRUNBEG,JRUNBEG & ! start of user-specified domain - ,gi0,gj0 & ! full-dom coordinates of domain lower l.h. corner - ,me ! local processor - use PhysicalConstants_ml, only : GRAV, PI ! gravity, pi - implicit none - private - - !-- contains subroutine: - - Public :: DefGrid ! => GRIDWIDTH_M, map-factor stuff, calls other routines - Public :: ij2lbm ! polar stereo grid to longitude latitude - Public :: lb2ijm ! longitude latitude to grid in polar stereo - Public :: ij2ijm ! polar grid1 to polar grid2 - Public :: lb2ij ! longitude latitude to (i,j) in any grid projection - - Public :: GlobalPosition - private :: Position ! => lat(glat), long (glon) +Module GridValues_ml + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + ! + ! Define parameters and variables associated with 3-D grid and its + ! geography. + ! + ! History: + ! March - changed folllwing Steffen's optimisation/correction of sigma_mid. + ! January 2001 : Created by ds from old defconstants, made enough changes + ! to get this into F90, and to make x,y inputs to the position subroutine, + ! but the basic equations are untouched. + ! October 2001 hf added call to ReadField (which now does global2local) + ! Nov. 2001 - tidied up a bit (ds). Use statements moved to top of module + !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + use CheckStop_ml, only : CheckStop,StopAll + use Functions_ml, only : great_circle_distance + use Io_Nums_ml, only: IO_LOG + + use MetFields_ml + use ModelConstants_ml, only : KMAX_BND, KMAX_MID &! vertical extent + ,DEBUG_i, DEBUG_j & ! full-domain coordinate of debug-site + ,DEBUG_GRIDVALUES & + ,MasterProc & + ,NPROC, IIFULLDOM,JJFULLDOM, RUNDOMAIN& + ,PT, Pref & + ,NMET, METSTEP + use Par_ml, only : & + MAXLIMAX,MAXLJMAX & ! max. possible i, j in this domain + ,limax,ljmax & ! actual max. i, j in this domain + ,li0,li1,lj0,lj1 & ! for debugging TAB + ,GIMAX,GJMAX & ! Size of rundomain + ,IRUNBEG,JRUNBEG & ! start of user-specified domain + ,gi0,gj0 & ! full-dom coordinates of domain lower l.h. corner + ,gi1,gj1 & ! full-dom coordinates of domain uppet r.h. corner + ,me & ! local processor + , parinit + use PhysicalConstants_ml, only : GRAV, PI ! gravity, pi + use TimeDate_ml, only : current_date, date,Init_nmdays,nmdays,startdate + use TimeDate_ExtraUtil_ml,only : nctime2idate,date2string + + implicit none + private + + !-- contains subroutine: + + Public :: DefGrid ! => GRIDWIDTH_M, map-factor stuff, calls other routines + Public :: DefDebugProc ! => sets debug_proc, debug_li, debug_lj + Public :: ij2lbm ! polar stereo grid to longitude latitude + Public :: lb2ijm ! longitude latitude to grid in polar stereo + Public :: ij2ijm ! polar grid1 to polar grid2 + Public :: lb2ij ! longitude latitude to (i,j) in any grid projection + Public :: ij2lb ! polar stereo grid to longitude latitude + + Public :: GlobalPosition + private :: Position ! => lat(glat), long (glon) + Public :: coord_in_gridbox, & ! Are coord (lon/lat) is inside gridbox(i,j)? + coord_in_processor ! Are coord (lon/lat) is inside local domain? + + public :: GridRead,Getgridparams + private :: Alloc_GridFields + private :: GetFullDomainSize !** 1) Public (saved) Variables from module: - INCLUDE 'mpif.h' - INTEGER STATUS(MPI_STATUS_SIZE),INFO - real MPIbuff + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + real MPIbuff real, public, save :: & - xp, yp & ! Coordinates of North pole (from infield) - , fi & ! projections rotation angle around y axis (from infield) - , AN & ! Distance on the map from pole to equator (No. of cells) - ,GRIDWIDTH_M &! width of grid at 60N, in meters (old "h")(from infield) - ,ref_latitude ! latitude at which projection is true (degrees) + xp, yp & ! Coordinates of North pole (from infield) + , fi & ! projections rotation angle around y axis (from infield) + , AN & ! Distance on the map from pole to equator (No. of cells) + ,GRIDWIDTH_M &! width of grid at 60N, in meters (old "h")(from infield) + ,ref_latitude ! latitude at which projection is true (degrees) -!Rotated_Spherical grid prarameters + !Rotated_Spherical grid prarameters real, public, save :: grid_north_pole_latitude,grid_north_pole_longitude + real, public, save :: dx_rot,dx_roti,x1_rot,y1_rot !/ Variables to define full-domain (fdom) coordinates of local i,j values. - integer, public, save, dimension(0:MAXLIMAX+1) :: i_fdom !fdom coordinates - integer, public, save, dimension(0:MAXLJMAX+1) :: j_fdom !of local i,j + integer, public, allocatable, save, dimension(:) :: i_fdom !fdom coordinates + integer, public, allocatable, save, dimension(:) :: j_fdom !of local i,j - ! and reverse: - integer, public, save, dimension(IIFULLDOM) :: i_local !local coordinates - integer, public, save, dimension(JJFULLDOM) :: j_local !of full-domain i,j + ! and reverse: + integer, public, allocatable, save,dimension(:) :: i_local !local coordinates + integer, public, allocatable, save,dimension(:) :: j_local !of full-domain i,j -!Parameters for Vertical Hybrid coordinates: + !Parameters for Vertical Hybrid coordinates: real, public, save, dimension(KMAX_BND) :: & - A_bnd !Unit Pa. first constant, defined at layer boundary - ! (i.e. half levels in EC nomenclature) + A_bnd !Unit Pa. first constant, defined at layer boundary + ! (i.e. half levels in EC nomenclature) real, public, save, dimension(KMAX_BND) :: & - B_bnd !Unit 1. second constant, defined at layer boundary - ! (i.e. half levels in EC nomenclature) + B_bnd !Unit 1. second constant, defined at layer boundary + ! (i.e. half levels in EC nomenclature) real, public, save, dimension(KMAX_MID) :: & - A_mid !Unit Pa. first constant, defined at middle of layer - ! (i.e. full levels in EC nomenclature) + A_mid !Unit Pa. first constant, defined at middle of layer + ! (i.e. full levels in EC nomenclature) real, public, save, dimension(KMAX_MID) :: & - B_mid !Unit 1. second constant, defined at middle of layer - ! (i.e. full levels in EC nomenclature) + B_mid !Unit 1. second constant, defined at middle of layer + ! (i.e. full levels in EC nomenclature) real, public, save, dimension(KMAX_MID) :: & - dA !Unit Pa. A_bnd(k+1)-A_bnd(k) + dA !Unit Pa. A_bnd(k+1)-A_bnd(k) real, public, save, dimension(KMAX_MID) :: & - dB !Unit 1. B_bnd(k+1)-B_bnd(k) -! P = A + B*PS -! eta = A/Pref + B + dB !Unit 1. B_bnd(k+1)-B_bnd(k) + ! P = A + B*PS + ! eta = A/Pref + B real, public, save, dimension(KMAX_BND) :: & - sigma_bnd ! sigma, layer boundary + sigma_bnd ! sigma, layer boundary real, public, save, dimension(KMAX_MID) :: & - sigma_mid ! sigma layer midpoint + sigma_mid ! sigma layer midpoint real, public, save, dimension(KMAX_MID) :: carea ! for budgets? - real, public, save, dimension(MAXLIMAX,MAXLJMAX) :: & - glon & !longitude of gridcell centers - ,glat !latitude of gridcell centers - real, public, save, dimension(0:MAXLIMAX,0:MAXLJMAX) :: & - gl_stagg & !longitude of gridcell corners - ,gb_stagg !latitude of gridcell corners -!NB: gl_stagg, gb_stagg are here defined as the average of the four -! surrounding gl gb. -! These differ slightly from the staggered points in the (i,j) grid. + real, public, save,allocatable, dimension(:,:) :: & + glon & !longitude of gridcell centers + ,glat !latitude of gridcell centers + real, public, save,allocatable, dimension(:,:) :: & + gl_stagg & !longitude of gridcell corners + ,gb_stagg !latitude of gridcell corners + !NB: gl_stagg, gb_stagg are here defined as the average of the four + ! surrounding gl gb. + ! These differ slightly from the staggered points in the (i,j) grid. - real, public, save, dimension(IIFULLDOM,JJFULLDOM) :: & - glat_fdom, & !latitude of gridcell centers - glon_fdom !longitude of gridcell centers + real, public, allocatable, dimension(:,:) :: & + glat_fdom, & !latitude of gridcell centers + glon_fdom !longitude of gridcell centers real, public, save :: gbacmax,gbacmin,glacmax,glacmin -! EMEP grid definitions (old and official) + ! EMEP grid definitions (old and official) real, public, parameter :: xp_EMEP_official=8.& - ,yp_EMEP_official=110.& - ,fi_EMEP=-32.& - ,GRIDWIDTH_M_EMEP=50000.& - ,an_EMEP = 237.7316364 &! = 6.370e6*(1.0+0.5*sqrt(3.0))/50000. - ,xp_EMEP_old = 43.0& - ,yp_EMEP_old = 121.0 + ,yp_EMEP_official=110.0& + ,fi_EMEP=-32.0& + ,ref_latitude_EMEP=60.0& + ,GRIDWIDTH_M_EMEP=50000.0& + ,an_EMEP = 237.7316364 &! = 6.370e6*(1.0+0.5*sqrt(3.0))/50000. + ,xp_EMEP_old = 43.0& + ,yp_EMEP_old = 121.0 !/** Map factor stuff: - real, public, save, dimension(0:MAXLIMAX+1,0:MAXLJMAX+1) :: & - xm_i & ! map-factor in i direction, between cell j and j+1 - ,xm_j & ! map-factor in j direction, between cell i and i+1 - ,xm2 & ! xm*xm: area factor in the middle of a cell (i,j) - ,xmd ! 1/xm2 - - real, public, save, dimension(0:MAXLJMAX+1,0:MAXLIMAX+1) :: & - xm2ji & - ,xmdji + real, public, save,allocatable, dimension(:,:) :: & + xm_i & ! map-factor in i direction, between cell j and j+1 + ,xm_j & ! map-factor in j direction, between cell i and i+1 + ,xm2 & ! xm*xm: area factor in the middle of a cell (i,j) + ,xmd ! 1/xm2 + + real, public, save,allocatable, dimension(:,:) :: & + xm2ji & + ,xmdji !/** Grid Area - real, public, save, dimension(MAXLIMAX,MAXLJMAX) :: GridArea_m2 + real, public, save,allocatable, dimension(:,:) :: GridArea_m2 integer, public, save :: & - debug_li, debug_lj ! Local Coordinates of debug-site + debug_li=-99, debug_lj=-99 ! Local Coordinates of debug-site logical, public, save :: debug_proc ! Processor with debug-site - integer, public, save :: METEOfelt=0 ! 1 if uses "old" (not CDF) meteo input - - - !/** internal parameters - - logical, private, parameter :: DEBUG_GRID = .false. ! for debugging character (len=100),public::projection integer, public, parameter :: MIN_ADVGRIDS = 5 !minimum size of a subdomain integer, public :: Poles(2) !Poles(1)=1 if North pole is found, Poles(2)=1:SP - integer, public :: Pole_included !Pole_included=1 if the grid include at least one pole + integer, public :: Pole_Singular !Pole_included=1 or 2 if the grid include at least one pole and has lat lon projection + contains + + + subroutine GridRead(cyclicgrid) + + ! the subroutine reads the grid parameters (projection, resolution etc.) + ! defined by the meteorological fields + ! + + implicit none + + integer, intent(out) :: cyclicgrid + integer :: nyear,nmonth,nday,nhour,k + integer :: KMAX,MIN_GRIDS + character (len = 100),save :: filename !name of the input file + character (len=230) :: txt + + + nyear=startdate(1) + nmonth=startdate(2) + nday=startdate(3) + nhour=0 + current_date = date(nyear, nmonth, nday, nhour, 0 ) + call Init_nmdays( current_date ) + + !*********initialize grid parameters********* +56 FORMAT(a5,i4.4,i2.2,i2.2,a3) + write(filename,56)'meteo',nyear,nmonth,nday,'.nc' + + if(MasterProc)write(*,*)'reading domain sizes from ',trim(filename) + + call GetFullDomainSize(filename,IIFULLDOM,JJFULLDOM,KMAX,Pole_Singular,projection) + + call CheckStop(KMAX_MID/=KMAX,"vertical cordinates not yet flexible") + + allocate(i_local(IIFULLDOM)) + allocate(j_local(JJFULLDOM)) + allocate(glat_fdom(IIFULLDOM,JJFULLDOM))!should be removed from code + allocate(glon_fdom(IIFULLDOM,JJFULLDOM))!should be removed from code + + !set RUNDOMAIN default values where not defined + if(RUNDOMAIN(1)<1)RUNDOMAIN(1)=1 + if(RUNDOMAIN(2)<1)RUNDOMAIN(2)=IIFULLDOM + if(RUNDOMAIN(3)<1)RUNDOMAIN(3)=1 + if(RUNDOMAIN(4)<1)RUNDOMAIN(4)=JJFULLDOM + if(MasterProc)then + 55 format(A,I5,A,I5) + write(*,55) 'FULLDOMAIN has sizes ',IIFULLDOM,' X ',JJFULLDOM + write(IO_LOG,55)'FULLDOMAIN has sizes ',IIFULLDOM,' X ',JJFULLDOM + write(*,55)'RUNDOMAIN x coordinates from ',RUNDOMAIN(1),' to ',RUNDOMAIN(2) + write(IO_LOG,55)'RUNDOMAIN x coordinates from ',RUNDOMAIN(1),' to ',RUNDOMAIN(2) + write(*,55)'RUNDOMAIN y coordinates from ',RUNDOMAIN(3),' to ',RUNDOMAIN(4) + write(IO_LOG,55)'RUNDOMAIN y coordinates from ',RUNDOMAIN(3),' to ',RUNDOMAIN(4) + endif + + + MIN_GRIDS=5 + call parinit(MIN_GRIDS,Pole_Singular) !subdomains sizes and position + + call Alloc_MetFields(MAXLIMAX,MAXLJMAX,KMAX_MID,KMAX_BND,NMET) + + call Alloc_GridFields(GIMAX,GJMAX,MAXLIMAX,MAXLJMAX,KMAX_MID,KMAX_BND) + + call Getgridparams(filename,GRIDWIDTH_M,xp,yp,fi,& + ref_latitude,sigma_mid,Nhh,nyear,nmonth,nday,nhour,nhour_first& + ,cyclicgrid) + + + if(MasterProc .and. DEBUG_GRIDVALUES)then + write(*,*)'sigma_mid:',(sigma_mid(k),k=1,20) + write(*,*)'grid resolution:',GRIDWIDTH_M + write(*,*)'xcoordinate of North Pole, xp:',xp + write(*,*)'ycoordinate of North Pole, yp:',yp + write(*,*)'longitude rotation of grid, fi:',fi + write(*,*)'true distances latitude, ref_latitude:',ref_latitude + endif + + call DefGrid()!defines: i_fdom,j_fdom,i_local, j_local,xmd,xm2ji,xmdji, + ! sigma_bnd,carea,gbacmax,gbacmin,glacmax,glacmin + + end subroutine GridRead + + + + subroutine GetFullDomainSize(filename,IIFULLDOM,JJFULLDOM,KMAX,Pole_Singular,projection) + + ! + ! Get input grid sizes + ! + + use netcdf + + implicit none + + character (len = *), intent(in) ::filename + integer, intent(out):: IIFULLDOM,JJFULLDOM,KMAX,Pole_Singular + character (len = *), intent(out) ::projection + + integer :: status,ncFileID,idimID,jdimID, kdimID,timeDimID,varid,timeVarID + integer :: GIMAX_file,GJMAX_file,KMAX_file + real,allocatable :: latitudes(:) + + + if(MasterProc)then + print *,'Defining grid properties from ',trim(filename) + !open an existing netcdf dataset + status = nf90_open(path=trim(filename),mode=nf90_nowrite,ncid=ncFileID) + if(status /= nf90_noerr) then + print *,'not found',trim(filename) + call StopAll("File not found") + endif + + ! print *,' reading ',trim(filename) + projection='' + call check(nf90_get_att(ncFileID,nf90_global,"projection",projection)) + if(trim(projection)=='Rotated_Spherical'.or.trim(projection)=='rotated_spherical'& + .or.trim(projection)=='rotated_pole'.or.trim(projection)=='rotated_latitude_longitude')then + projection='Rotated_Spherical' + endif + write(*,*)'projection: ',trim(projection) + + !get dimensions id + if(trim(projection)=='Stereographic') then + call check(nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) + elseif(trim(projection)==trim('lon lat')) then + call check(nf90_inq_dimid(ncid = ncFileID, name = "lon", dimID = idimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "lat", dimID = jdimID)) + else + ! write(*,*)'GENERAL PROJECTION ',trim(projection) + call check(nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) + endif + + call check(nf90_inq_dimid(ncid = ncFileID, name = "k", dimID = kdimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "time", dimID = timeDimID)) + call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = timeVarID)) + + !get dimensions length + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=idimID,len=GIMAX_file)) + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=jdimID,len=GJMAX_file)) + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=kdimID,len=KMAX_file)) +! call check(nf90_inquire_dimension(ncid=ncFileID,dimID=timedimID,len=Nhh)) + + write(*,*)'dimensions input grid:',GIMAX_file,GJMAX_file,KMAX_file!,Nhh + + IIFULLDOM=GIMAX_file + JJFULLDOM=GJMAX_file + KMAX =KMAX_file + + Pole_Singular=0 + if(trim(projection)==trim('lon lat')) then + !find wether poles are included (or almost included) in grid + ! + !If some cells are to narrow (Poles in lat lon coordinates), + !this will give too small time steps in the Advection, + !because of the constraint that the Courant number should be <1. + ! + !If Poles are found and lon-lat coordinates are used the Advection scheme + !will be modified to be able to cope with the singularity + !the advection routine will not work efficiently with NPROCY>2 in this case + + allocate(latitudes(JJFULLDOM)) + call check(nf90_inq_varid(ncid = ncFileID, name = "lat", varID = varID)) + call check(nf90_get_var(ncFileID, varID,latitudes )) + if(latitudes(JJFULLDOM)>88.0)then + write(*,*)'The grid is singular at North Pole' + Pole_Singular=Pole_Singular+1 + endif + if(latitudes(1)<-88.0)then + write(*,*)'The grid is singular at South Pole' + Pole_Singular=Pole_Singular+1 + endif + deallocate(latitudes) + endif + endif + CALL MPI_BCAST(IIFULLDOM ,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(JJFULLDOM ,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(KMAX ,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(Pole_Singular ,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(projection ,len(projection),MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + end subroutine GetFullDomainSize + + + subroutine Getgridparams(filename,GRIDWIDTH_M,xp,yp,fi,& + ref_latitude,sigma_mid,Nhh,nyear,nmonth,nday,nhour,nhour_first& + ,cyclicgrid) + ! + ! Get grid and time parameters as defined in the meteo file + ! Do some checks on sizes and dates + ! + ! This routine is called only once (and is therefore not optimized for speed) + ! +! use ChemSpecs_adv_ml, only: NSPEC_ADV ! => No. species +! use ChemSpecs_shl_ml, only: NSPEC_SHL ! => No. species +! use Chemfields_ml, only:xn_adv, xn_shl, xn_bgn, PM25_water, PM25_water, PM25_water_rh50& +! ,AOD,cfac,so2nh3_24hr,Grid_snow& +! ,NSPEC_BGN,NSPEC_COL + + use netcdf + + implicit none + + character (len = *), intent(in) ::filename + integer, intent(in):: nyear,nmonth,nday,nhour + real, intent(out) :: GRIDWIDTH_M,xp,yp,fi, ref_latitude,sigma_mid(KMAX_MID) + integer, intent(out):: Nhh,nhour_first,cyclicgrid + + integer :: nseconds(1),n1,i,j,im,jm,i0,j0 + integer :: ncFileID,idimID,jdimID, kdimID,timeDimID,varid,timeVarID + integer :: GIMAX_file,GJMAX_file,KMAX_file,ihh,ndate(4) + ! realdimension(-1:GIMAX+2,-1:GJMAX+2) ::xm_global,xm_global_j,xm_global_i + real,allocatable,dimension(:,:) ::xm_global,xm_global_j,xm_global_i + integer :: status,iglobal,jglobal,info,South_pole,North_pole,Ibuff(2) + real :: ndays(1),x1,x2,x3,x4 + character (len = 50) :: timeunit + + allocate(xm_global(-1:GIMAX+2,-1:GJMAX+2)) + allocate(xm_global_j(-1:GIMAX+2,-1:GJMAX+2)) + allocate(xm_global_i(-1:GIMAX+2,-1:GJMAX+2)) + + if(MasterProc)then + call CheckStop(GIMAX+IRUNBEG-1 > IIFULLDOM, "GridRead: I outside domain" ) + call CheckStop(GJMAX+JRUNBEG-1 > JJFULLDOM, "GridRead: J outside domain" ) + + call CheckStop(nhour/=0 .and. nhour /=3,& + "ReadGrid: must start at nhour=0 or 3") + + print *,'Defining grid properties from ',trim(filename) + !open an existing netcdf dataset + status = nf90_open(path=trim(filename),mode=nf90_nowrite,ncid=ncFileID) + if(status /= nf90_noerr) then + print *,'not found',trim(filename) + call StopAll("File not found") + endif + + ! print *,' reading ',trim(filename) + + !get dimensions id + if(trim(projection)=='Stereographic') then + call check(nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) + elseif(trim(projection)==trim('lon lat')) then + call check(nf90_inq_dimid(ncid = ncFileID, name = "lon", dimID = idimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "lat", dimID = jdimID)) + else + ! write(*,*)'GENERAL PROJECTION ',trim(projection) + call check(nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) + endif + + call check(nf90_inq_dimid(ncid = ncFileID, name = "k", dimID = kdimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "time", dimID = timeDimID)) + call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = timeVarID)) + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=timedimID,len=Nhh)) + + call CheckStop(24/Nhh, METSTEP, "GridRead: METSTEP != meteostep" ) + + call check(nf90_get_att(ncFileID,timeVarID,"units",timeunit)) + + ihh=1 + n1=1 + if(trim(timeunit(1:19))==trim("days since 1900-1-1"))then + write(*,*)'Date in days since 1900-1-1 0:0:0' + call check(nf90_get_var(ncFileID,timeVarID,ndays,& + start=(/ihh/),count=(/n1 /))) + call nctime2idate(ndate,ndays(1)) ! for printout: msg="meteo hour YYYY-MM-DD hh" + else + call check(nf90_get_var(ncFileID,timeVarID,nseconds,& + start=(/ihh/),count=(/n1 /))) + call nctime2idate(ndate,nseconds(1)) ! default + endif + nhour_first=ndate(4) + + call CheckStop(ndate(1), nyear, "NetCDF_ml: wrong year" ) + call CheckStop(ndate(2), nmonth, "NetCDF_ml: wrong month" ) + call CheckStop(ndate(3), nday, "NetCDF_ml: wrong day" ) + + do ihh=1,Nhh + + if(trim(timeunit(1:19))==trim("days since 1900-1-1"))then + call check(nf90_get_var(ncFileID, timeVarID, ndays,& + start=(/ ihh /),count=(/ n1 /))) + call nctime2idate(ndate,ndays(1)) + write(*,*)'ndays ',ndays(1),ndate(3),ndate(4) + else + call check(nf90_get_var(ncFileID, timeVarID, nseconds,& + start=(/ ihh /),count=(/ n1 /))) + call nctime2idate(ndate,nseconds(1)) + endif + write(*,*)ihh,METSTEP,nhour_first, ndate(4) + call CheckStop( mod((ihh-1)*METSTEP+nhour_first,24), ndate(4), & + date2string("NetCDF_ml: wrong hour YYYY-MM-DD hh",ndate)) + + enddo + + + !get global attributes + call check(nf90_get_att(ncFileID,nf90_global,"Grid_resolution",GRIDWIDTH_M)) + write(*,*)"Grid_resolution",GRIDWIDTH_M + if(trim(projection)=='Stereographic')then + call check(nf90_get_att(ncFileID,nf90_global,"ref_latitude",ref_latitude)) + call check(nf90_get_att(ncFileID, nf90_global, "xcoordinate_NorthPole" & + ,xp )) + call check(nf90_get_att(ncFileID, nf90_global, "ycoordinate_NorthPole" & + ,yp )) + call check(nf90_get_att(ncFileID, nf90_global, "fi",fi )) + + call GlobalPosition + elseif(trim(projection)==trim('lon lat')) then + ref_latitude=60. + xp=0.0 + yp=GJMAX + fi =0.0 + call check(nf90_inq_varid(ncid = ncFileID, name = "lon", varID = varID)) + call check(nf90_get_var(ncFileID, varID, glon_fdom(1:IIFULLDOM,1) )) + do i=1,IIFULLDOM + if(glon_fdom(i,1)>180.0)glon_fdom(i,1)=glon_fdom(i,1)-360.0 + if(glon_fdom(i,1)<-180.0)glon_fdom(i,1)=glon_fdom(i,1)+360.0 + enddo + do j=1,JJFULLDOM + glon_fdom(:,j)=glon_fdom(:,1) + enddo + call check(nf90_inq_varid(ncid = ncFileID, name = "lat", varID = varID)) + call check(nf90_get_var(ncFileID, varID, glat_fdom(1,1:JJFULLDOM) )) + do i=1,IIFULLDOM + glat_fdom(i,:)=glat_fdom(1,:) + enddo + else + ref_latitude=60. + xp=0.0 + yp=GJMAX + fi =0.0 + if(trim(projection)=='Rotated_Spherical')then + call check(nf90_get_att(ncFileID,nf90_global,"grid_north_pole_latitude",grid_north_pole_latitude)) + write(*,*)"grid_north_pole_latitude",grid_north_pole_latitude + call check(nf90_get_att(ncFileID,nf90_global,"grid_north_pole_longitude",grid_north_pole_longitude)) + write(*,*)"grid_north_pole_longitude",grid_north_pole_longitude + call check(nf90_inq_varid(ncid = ncFileID, name = "i", varID = varID)) + call check(nf90_get_var(ncFileID, varID, glon_fdom(1:2,1)))!note that i is one dimensional + x1_rot=glon_fdom(1,1) + dx_rot=glon_fdom(2,1)-glon_fdom(1,1) + call check(nf90_inq_varid(ncid = ncFileID, name = "j", varID = varID)) + call check(nf90_get_var(ncFileID, varID, glon_fdom(1,1)))!note that j is one dimensional + y1_rot=glon_fdom(1,1) + write(*,*)"rotated lon lat of (i,j)=(1,1)",x1_rot,y1_rot + write(*,*)"resolution",dx_rot + endif + call check(nf90_inq_varid(ncid = ncFileID, name = "lon", varID = varID)) + call check(nf90_get_var(ncFileID, varID, glon_fdom(1:IIFULLDOM,1:JJFULLDOM) )) + + call check(nf90_inq_varid(ncid = ncFileID, name = "lat", varID = varID)) + call check(nf90_get_var(ncFileID, varID, glat_fdom(1:IIFULLDOM,1:JJFULLDOM) )) + do j=1,JJFULLDOM + do i=1,IIFULLDOM + if(glon_fdom(i,j)>180.0)glon_fdom(i,j)=glon_fdom(i,j)-360.0 + if(glon_fdom(i,j)<-180.0)glon_fdom(i,j)=glon_fdom(i,j)+360.0 + enddo + enddo + + endif + !get variables + status=nf90_inq_varid(ncid=ncFileID, name="map_factor", varID=varID) + + if(status == nf90_noerr)then + !mapping factor at center of cells is defined + !make "staggered" map factors + call check(nf90_get_var(ncFileID, varID, xm_global(1:GIMAX,1:GJMAX) & + ,start=(/ IRUNBEG,JRUNBEG /),count=(/ GIMAX,GJMAX /))) + do j=1,GJMAX + do i=1,GIMAX-1 + xm_global_j(i,j)=0.5*(xm_global(i,j)+xm_global(i+1,j)) + enddo + enddo + i=GIMAX + do j=1,GJMAX + xm_global_j(i,j)=1.5*xm_global(i,j)-0.5*xm_global(i-1,j) + enddo + do j=1,GJMAX-1 + do i=1,GIMAX + xm_global_i(i,j)=0.5*(xm_global(i,j)+xm_global(i,j+1)) + enddo + enddo + j=GJMAX + do i=1,GIMAX + xm_global_i(i,j)=1.5*xm_global(i,j)-0.5*xm_global(i,j-1) + enddo + + else + !map factor are already staggered + status=nf90_inq_varid(ncid=ncFileID, name="map_factor_i", varID=varID) + + !BUGCHECK - moved here... (deleted if loop) + call CheckStop( status, nf90_noerr, "erro rreading map factor" ) + + write(*,*)GIMAX,GJMAX,IRUNBEG,JRUNBEG + call check(nf90_get_var(ncFileID, varID, xm_global_i(1:GIMAX,1:GJMAX) & + ,start=(/ IRUNBEG,JRUNBEG /),count=(/ GIMAX,GJMAX /))) + call check(nf90_inq_varid(ncid=ncFileID, name="map_factor_j", varID=varID)) + call check(nf90_get_var(ncFileID, varID, xm_global_j(1:GIMAX,1:GJMAX) & + ,start=(/ IRUNBEG,JRUNBEG /),count=(/ GIMAX,GJMAX /))) + endif + + call check(nf90_inq_varid(ncid = ncFileID, name = "k", varID = varID)) + call check(nf90_get_var(ncFileID, varID, sigma_mid )) + + call check(nf90_close(ncFileID)) + + endif !me=0 + + + + CALL MPI_BCAST(Nhh,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(GRIDWIDTH_M,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(ref_latitude,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(xp,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(yp,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(fi,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(sigma_mid,8*KMAX_MID,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(xm_global_i(1:GIMAX,1:GJMAX),8*GIMAX*GJMAX,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(xm_global_j(1:GIMAX,1:GJMAX),8*GIMAX*GJMAX,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(glat_fdom,8*IIFULLDOM*JJFULLDOM,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(glon_fdom,8*IIFULLDOM*JJFULLDOM,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(projection,len(projection),MPI_CHARACTER,0,MPI_COMM_WORLD,INFO) + + if(trim(projection)=='Rotated_Spherical')then + CALL MPI_BCAST(grid_north_pole_longitude,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(grid_north_pole_latitude,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(dx_rot,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(x1_rot,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(y1_rot,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + dx_roti=1.0/dx_rot + endif + + do j=1,MAXLJMAX + do i=1,MAXLIMAX + glon(i,j)=glon_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2) + glat(i,j)=glat_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2) + enddo + enddo + i0=0 + im=MAXLIMAX + j0=0 + jm=MAXLJMAX + if(gi0+MAXLIMAX+1+IRUNBEG-2>IIFULLDOM)im=MAXLIMAX-1!outside fulldomain + if(gi0+0+IRUNBEG-2<1)i0=1!outside fulldomain + if(gj0+MAXLJMAX+1+JRUNBEG-2>JJFULLDOM)jm=MAXLJMAX-1!outside fulldomain + if(gj0+0+JRUNBEG-2<1)j0=1!outside fulldomain + + do j=j0,jm + do i=i0,im + x1=glon_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2) + x2=glon_fdom(gi0+i+1+IRUNBEG-2,gj0+j+JRUNBEG-2) + x3=glon_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2) + x4=glon_fdom(gi0+i+1+IRUNBEG-2,gj0+j+1+JRUNBEG-2) + + !8100=90*90; could use any number much larger than zero and much smaller than 180*180 + if(x1*x2<-8100.0 .or. x1*x3<-8100.0 .or. x1*x4<-8100.0)then + !Points are on both sides of the longitude -180=180 + if(x1<0)x1=x1+360.0 + if(x2<0)x2=x2+360.0 + if(x3<0)x3=x3+360.0 + if(x4<0)x4=x4+360.0 + endif + gl_stagg(i,j)=0.25*(x1+x2+x3+x4) + + gb_stagg(i,j)=0.25*(glat_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2)+& + glat_fdom(gi0+i+1+IRUNBEG-2,gj0+j+JRUNBEG-2)+& + glat_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2)+& + glat_fdom(gi0+i+1+IRUNBEG-2,gj0+j+1+JRUNBEG-2)) + enddo + enddo + do j=0,j0 + do i=i0,im + x1=gl_stagg(i,j+1) + x2=gl_stagg(i,j+2) + if(x1*x2<-8100.0 )then + if(x1<0)x1=x1+360.0 + if(x2<0)x2=x2+360.0 + endif + gl_stagg(i,j)=2*x1-x2 + gb_stagg(i,j)=2*gb_stagg(i,j+1)-gb_stagg(i,j+2) + enddo + enddo + do j=jm,MAXLJMAX + do i=i0,im + x1=gl_stagg(i,j-1) + x2=gl_stagg(i,j-2) + if(x1*x2<-8100.0 )then + if(x1<0)x1=x1+360.0 + if(x2<0)x2=x2+360.0 + endif + gl_stagg(i,j)=2*x1-x2 + gb_stagg(i,j)=2*gb_stagg(i,j-1)-gb_stagg(i,j-2) + enddo + enddo + do j=0,MAXLJMAX + do i=0,i0 + x1=gl_stagg(i+1,j) + x2=gl_stagg(i+2,j) + if(x1*x2<-8100.0 )then + if(x1<0)x1=x1+360.0 + if(x2<0)x2=x2+360.0 + endif + gl_stagg(i,j)=2*x1-x2 + gb_stagg(i,j)=2*gb_stagg(i+1,j)-gb_stagg(i+2,j) + enddo + enddo + do j=0,MAXLJMAX + do i=im,MAXLIMAX + x1=gl_stagg(i-1,j) + x2=gl_stagg(i-2,j) + if(x1*x2<-8100.0 )then + if(x1<0)x1=x1+360.0 + if(x2<0)x2=x2+360.0 + endif + gl_stagg(i,j)=2*x1-x2 + gb_stagg(i,j)=2*gb_stagg(i-1,j)-gb_stagg(i-2,j) + enddo + enddo + !ensure that values are within [-180,+180]] + do j=0,MAXLJMAX + do i=0,MAXLIMAX + if(gl_stagg(i,j)>180.0)gl_stagg(i,j)=gl_stagg(i,j)-360.0 + if(gl_stagg(i,j)<-180.0)gl_stagg(i,j)=gl_stagg(i,j)+360.0 + enddo + enddo + + !test if the grid is cyclicgrid: + !The last cell + 1 cell = first cell + Cyclicgrid=1 !Cyclicgrid + do j=1,JJFULLDOM + if(mod(nint(glon_fdom(GIMAX,j)+360+360.0/GIMAX),360)/=& + mod(nint(glon_fdom(IRUNBEG,j)+360.0),360))then + Cyclicgrid=0 !not cyclicgrid + endif + enddo + + if(MasterProc .and. DEBUG_GRIDVALUES)write(*,*)'CYCLICGRID:',Cyclicgrid + + !complete (extrapolate) along the four lateral sides + do i=1,GIMAX + xm_global_j(i,0)=1.0/(2.0/(xm_global_j(i,1))-1.0/(xm_global_j(i,2))) + xm_global_j(i,-1)=1.0/(2.0/(xm_global_j(i,0))-1.0/(xm_global_j(i,1))) + xm_global_j(i,GJMAX+1)=1.0/(2.0/(xm_global_j(i,GJMAX))-1.0/(xm_global_j(i,GJMAX-1))) + xm_global_j(i,GJMAX+2)=1.0/(2.0/(xm_global_j(i,GJMAX+1))-1.0/(xm_global_j(i,GJMAX))) + xm_global_i(i,0)=1.0/(2.0/(xm_global_i(i,1))-1.0/(xm_global_i(i,2))) + xm_global_i(i,-1)=1.0/(2.0/(xm_global_i(i,0))-1.0/(xm_global_i(i,1))) + xm_global_i(i,GJMAX+1)=1.0/(2.0/(xm_global_i(i,GJMAX))-1.0/(xm_global_i(i,GJMAX-1))) + xm_global_i(i,GJMAX+2)=1.0/(2.0/(xm_global_i(i,GJMAX+1))-1.0/(xm_global_i(i,GJMAX))) + enddo + do j=-1,GJMAX+2 + xm_global_j(0,j)=1.0/(2.0/(xm_global_j(1,j))-1.0/(xm_global_j(2,j))) + xm_global_j(-1,j)=1.0/(2.0/(xm_global_j(0,j))-1.0/(xm_global_j(1,j))) + xm_global_j(GIMAX+1,j)=1.0/(2.0/(xm_global_j(GIMAX,j))-1.0/(xm_global_j(GIMAX-1,j))) + xm_global_j(GIMAX+2,j)=1.0/(2.0/(xm_global_j(GIMAX+1,j))-1.0/(xm_global_j(GIMAX,j))) + xm_global_i(0,j)=1.0/(2.0/(xm_global_i(1,j))-1.0/(xm_global_i(2,j))) + xm_global_i(-1,j)=1.0/(2.0/(xm_global_i(0,j))-1.0/(xm_global_i(1,j))) + xm_global_i(GIMAX+1,j)=1.0/(2.0/(xm_global_i(GIMAX,j))-1.0/(xm_global_i(GIMAX-1,j))) + xm_global_i(GIMAX+2,j)=1.0/(1.0/(2*xm_global_i(GIMAX+1,j))-1.0/(xm_global_i(GIMAX,j))) + enddo + + j=1 + i=1 + if(abs(1.5*glat_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2)-0.5*glat_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2))>89.5)then + write(*,*)'south pole' !xm is infinity + xm_global_i(:,0)=1.0E19 + xm_global_i(:,-1)=1.0E19 + endif + + + + !keep only part of xm relevant to the local domain + !note that xm has dimensions larger than local domain + + call CheckStop( MAXLIMAX+1 > limax+2, "Error in Met_ml X size definition" ) + call CheckStop( MAXLJMAX+1 > ljmax+2, "Error in Met_ml J size definition" ) + + do j=0,MAXLJMAX+1 + do i=0,MAXLIMAX+1 + iglobal=gi0+i-1 + jglobal=gj0+j-1 + xm_i(i,j)=xm_global_i(iglobal,jglobal) + xm_j(i,j)=xm_global_j(iglobal,jglobal) + !Note that xm is inverse length: interpolate 1/xm rather than xm + xm2(i,j) = 4.0*( (xm_global_i(iglobal,jglobal-1)*& + xm_global_i(iglobal,jglobal))/ & + (xm_global_i(iglobal,jglobal-1)+& + xm_global_i(iglobal,jglobal) ) ) *(& + xm_global_j(iglobal-1,jglobal)*& + xm_global_j(iglobal,jglobal) )/(& + xm_global_j(iglobal-1,jglobal)+& + xm_global_j(iglobal,jglobal) ) + enddo + enddo + + + !Look for poles + !If the northernmost or southernmost lines are poles, they are not + !considered as outer boundaries and will not be treated + !by "BoundaryConditions_ml". + !If the projection is not lat lon (i.e. the poles are not lines, but points), the poles are + !not a problem and Pole=0, even if the grid actually include a pole. + !Note that "Poles" is defined in subdomains + + North_pole=1 + do i=1,limax + if(nint(glat(i,ljmax))<=88)then + North_pole=0 !not north pole + endif + enddo + + South_pole=1 + do i=1,limax + if(nint(glat(i,1))>=-88)then + South_pole=0 !not south pole + endif + enddo + + Poles=0 + if(North_pole==1)then + Poles(1)=1 + write(*,*)me,'Found North Pole' + endif + + if(South_pole==1)then + Poles(2)=1 + write(*,*)me,'Found South Pole' + endif + + + end subroutine Getgridparams + + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> subroutine DefGrid() - !-------------------------------------------------------------------! - ! defines map parameters and fields for the model. - !-------------------------------------------------------------------! + !-------------------------------------------------------------------! + ! defines map parameters and fields for the model. + !-------------------------------------------------------------------! integer :: i, j, k, n real :: an2, x, y, x_j, y_i real :: rpol2,rpol2_i,rpol2_j ! square of (distance from pole to i,j - ! divided by AN ) + ! divided by AN ) real, dimension(0:MAXLIMAX+1,0:MAXLJMAX+1) :: & - xm ! map-factor + xm ! map-factor - ! Earth radius = 6.37e6 m, gives gridwidth: + ! Earth radius = 6.37e6 m, gives gridwidth: -! GRIDWIDTH_M = 6.370e6*(1.0+0.5*sqrt(3.0))/AN ! = 50000.0 m + ! GRIDWIDTH_M = 6.370e6*(1.0+0.5*sqrt(3.0))/AN ! = 50000.0 m -! NB! HIRLAM uses Earth radius = 6.371e6 m : -! AN = No. grids from pole to equator -! AN = 6.371e6*(1.0+0.5*sqrt(3.0))/GRIDWIDTH_M = 237.768957 + ! NB! HIRLAM uses Earth radius = 6.371e6 m : + ! AN = No. grids from pole to equator + ! AN = 6.371e6*(1.0+0.5*sqrt(3.0))/GRIDWIDTH_M = 237.768957 - !/ Define full-domain coordinates of local i,j values. We need to account for - ! the fact that each parallel domain has its starting cordinate - ! gi0, gj0, and the user may specify a set of lower-left starting - ! coordinates for running the model, IRUNBEG, JRUNBEG - ! i_fdom(i) = i + gi0 + IRUNBEG - 2 - ! j_fdom(j) = j + gj0 + JRUNBEG - 2 + !/ Define full-domain coordinates of local i,j values. We need to account for + ! the fact that each parallel domain has its starting cordinate + ! gi0, gj0, and the user may specify a set of lower-left starting + ! coordinates for running the model, IRUNBEG, JRUNBEG + ! i_fdom(i) = i + gi0 + IRUNBEG - 2 + ! j_fdom(j) = j + gj0 + JRUNBEG - 2 i_fdom = (/ (n + gi0 + IRUNBEG - 2, n=0,MAXLIMAX+1) /) j_fdom = (/ (n + gj0 + JRUNBEG - 2, n=0,MAXLJMAX+1) /) - ! And the reverse, noting that we even define for area - ! outside local domain + ! And the reverse, noting that we even define for area + ! outside local domain i_local = (/ (n - gi0 - IRUNBEG + 2, n=1, IIFULLDOM) /) j_local = (/ (n - gj0 - JRUNBEG + 2, n=1, JJFULLDOM) /) - ! -------------- Find debug coords and processor ------------------ - - do i = 1, MAXLIMAX - do j = 1, MAXLJMAX - if( i_fdom(i) == DEBUG_i .and. j_fdom(j) == DEBUG_j ) then - debug_li = i - debug_lj = j - debug_proc = .true. - end if - end do - end do - if( debug_proc ) write(*,*) "GridValues debug:", me, debug_li, debug_lj !------------------------------------------------------------------ - ! map factor, and map factor squared. - - if( METEOfelt==1)then - -!mapping factor xm and ref_latitude have not been read from the meteo file + AN = 6.370e6*(1.0+sin( ref_latitude*PI/180.))/GRIDWIDTH_M ! = 237.7316364 for GRIDWIDTH_M=50 km and ref_latitude=60 + do j=0,MAXLJMAX+1 + do i=0,MAXLIMAX+1 + xmd(i,j) = 1.0/xm2(i,j) + xm2ji(j,i) = xm2(i,j) + xmdji(j,i) = xmd(i,j) + enddo + enddo + do j=1,MAXLJMAX + do i=1,MAXLIMAX + GridArea_m2(i,j) = GRIDWIDTH_M*GRIDWIDTH_M*xmd(i,j) + enddo + enddo - ref_latitude=60. - AN = 6.370e6*(1.0+0.5*sqrt(3.0))/GRIDWIDTH_M ! = 237.7316364 for GRIDWIDTH_M=50 km - an2 = AN*AN - - do j=0,MAXLJMAX+1 ! ds - changed from ljmax+1 - y = j_fdom(j) - yp ! ds - changed from gj0+JRUNBEG-2+j - y = y*y - y_i = j_fdom(j)+0.5 - yp !in the staggered grid - y_i = y_i*y_i - do i=0,MAXLIMAX+1 - x = i_fdom(i) - xp - x_j = i_fdom(i)+0.5 - xp !in the staggered grid + ! definition of the half-sigma levels (boundaries between layers) + ! from the full levels. - rpol2 = (x*x + y)/an2 - rpol2_i = (x*x + y_i)/an2 - rpol2_j = (x_j*x_j + y)/an2 + sigma_bnd(KMAX_BND) = 1. + do k = KMAX_MID,2,-1 + sigma_bnd(k) = 2.*sigma_mid(k) - sigma_bnd(k+1) + enddo + sigma_bnd(1) = 0. - xm(i,j) = 0.5*(1.0+sin(PI/3.0))*(1.0 + rpol2) - xm_i(i,j) = 0.5*(1.0+sin(PI/3.0))*(1.0 + rpol2_i) - xm_j(i,j) = 0.5*(1.0+sin(PI/3.0))*(1.0 + rpol2_j) + !TEMPORARY: definition of A and B. Will be read from metfile in the future + do k = 1,KMAX_BND + A_bnd(k)=PT * (1-sigma_bnd(k)) + B_bnd(k)=sigma_bnd(k) + enddo + do k = 1,KMAX_MID + dA(k)=A_bnd(k+1)-A_bnd(k) + dB(k)=B_bnd(k+1)-B_bnd(k) + A_mid(k)=(A_bnd(k+1)+A_bnd(k))/2.0 + B_mid(k)=(B_bnd(k+1)+B_bnd(k))/2.0 + enddo - xm2(i,j) = xm(i,j)*xm(i,j) - end do - end do - endif - - AN = 6.370e6*(1.0+sin( ref_latitude*PI/180.))/GRIDWIDTH_M ! = 237.7316364 for GRIDWIDTH_M=50 km and ref_latitude=60 - do j=0,MAXLJMAX+1 - do i=0,MAXLIMAX+1 - xmd(i,j) = 1.0/xm2(i,j) - xm2ji(j,i) = xm2(i,j) - xmdji(j,i) = xmd(i,j) - enddo - enddo - do j=1,MAXLJMAX - do i=1,MAXLIMAX - GridArea_m2(i,j) = GRIDWIDTH_M*GRIDWIDTH_M*xmd(i,j) - enddo - enddo - -! definition of the half-sigma levels (boundaries between layers) -! from the full levels. - - sigma_bnd(KMAX_BND) = 1. - do k = KMAX_MID,2,-1 - sigma_bnd(k) = 2.*sigma_mid(k) - sigma_bnd(k+1) - enddo - sigma_bnd(1) = 0. - -!TEMPORARY: definition of A and B. Will be read from metfile in the future - do k = 1,KMAX_BND - A_bnd(k)=PT * (1-sigma_bnd(k)) - B_bnd(k)=sigma_bnd(k) - enddo - do k = 1,KMAX_MID - dA(k)=A_bnd(k+1)-A_bnd(k) - dB(k)=B_bnd(k+1)-B_bnd(k) - A_mid(k)=(A_bnd(k+1)+A_bnd(k))/2.0 - B_mid(k)=(B_bnd(k+1)+B_bnd(k))/2.0 - enddo - - - ! - ! some conversion coefficients needed for budget calculations - ! + ! + ! some conversion coefficients needed for budget calculations + ! do k=1,KMAX_MID - carea(k) = (sigma_bnd(k+1) - sigma_bnd(k))/GRAV*GRIDWIDTH_M*GRIDWIDTH_M - !write(6,*)'carea,sigma_bnd,h',carea(k),sigma_bnd(k),GRIDWIDTH_M - !su cflux(k) = (sigma_bnd(k+1) - sigma_bnd(k))/G*h + carea(k) = (sigma_bnd(k+1) - sigma_bnd(k))/GRAV*GRIDWIDTH_M*GRIDWIDTH_M + !write(6,*)'carea,sigma_bnd,h',carea(k),sigma_bnd(k),GRIDWIDTH_M + !su cflux(k) = (sigma_bnd(k+1) - sigma_bnd(k))/G*h end do - ! set latitude, longitude - ! projection='Stereographic' - call Position() + ! set latitude, longitude + ! projection='Stereographic' + call Position() - if ( DEBUG_GRID ) then + if ( DEBUG_GRIDVALUES ) then if ( me == 0 ) then - write(*,800) "GRIDTAB","me","ISM","JSM","gi0","gj0",& - "li0","li1","lix","MXI",& - "lj0","lj1","ljx"," MXJ"," ig1"," igX","jg1","jgX" - write(*,802) "GRIDLL ","me", "mingl"," maxgl"," mingb"," maxgb",& - " glat(1,1)"," glat(MAX..)" + write(*,800) "GRIDTAB","me","ISM","JSM","gi0","gj0",& + "li0","li1","lix","MXI",& + "lj0","lj1","ljx"," MXJ"," ig1"," igX","jg1","jgX" + write(*,802) "GRIDLL ","me", "mingl"," maxgl"," mingb"," maxgb",& + " glat(1,1)"," glat(MAX..)" end if write(*,804) "GRIDTAB",me,IRUNBEG,JRUNBEG,gi0,gj0,li0,li1,& - limax,MAXLIMAX,lj0,lj1,ljmax, MAXLJMAX, i_fdom(1),& - i_fdom(MAXLIMAX+1),j_fdom(1), j_fdom(MAXLJMAX+1) + limax,MAXLIMAX,lj0,lj1,ljmax, MAXLJMAX, i_fdom(1),& + i_fdom(MAXLIMAX+1),j_fdom(1), j_fdom(MAXLJMAX+1) write(*,806) "GRIDLL ",me, minval(glon), maxval(glon), minval(glat), & - maxval(glat), glat(1,1), glat(MAXLIMAX,MAXLJMAX) + maxval(glat), glat(1,1), glat(MAXLIMAX,MAXLJMAX) end if - 800 format(a10,20a4) - 802 format(a10,a4,10a12) - 804 format(a10,20i4) - 806 format(a10,i4,10f12.4) +800 format(a10,20a4) +802 format(a10,a4,10a12) +804 format(a10,20i4) +806 format(a10,i4,10f12.4) end subroutine DefGrid ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine DefDebugProc() + !-------------------------------------------------------------------! + ! -------------- Find debug coords and processor ------------------ + !-------------------------------------------------------------------! + + integer :: i, j + + debug_proc = .false. + + do i = li0, li1 + do j = lj0, lj1 + if( i_fdom(i) == DEBUG_i .and. j_fdom(j) == DEBUG_j ) then + debug_li = i + debug_lj = j + debug_proc = .true. + end if + end do + end do + + if( debug_proc ) write(*,*) "GridValues debug_proc found:", & + me, debug_li, debug_lj + if ( DEBUG_GRIDVALUES ) then + if(me==0) write(*,"(a,2a4,a3,4a4,a2,2a4,4a12)") "GridValues debug:", & + "D_i", "D_j", "me", "li0", "li1", "lj0", "lj1", & + "dp" , "d_li", "d_lj", "i_fdom(li0)","i_fdom(li1)", & + "j_fdom(lj0)", "j_fdom(lj1)" + + write(*,"(a,2i4,i3,4i4,L2,2i4,4i12)") "GridValues debug:", & + DEBUG_i, DEBUG_j, me, li0, li1, lj0, lj1, & + debug_proc , debug_li, debug_lj, & + i_fdom(li0),i_fdom(li1), j_fdom(lj0), j_fdom(lj1) + end if + + end subroutine DefDebugProc ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> subroutine Position() - !-------------------------------------------------------------------! - ! calculates l(lat),b(long) (geographical coord.) - ! in every grid point defined by the i_fdom, j_fdom arrays. - ! - ! input: xp,yp: coord. of the polar point. - ! AN: number of grid-distances from pole to equator. - ! fi: rotational angle for the x,y grid. - ! imax,jmax: number of points in x- og y- direction - ! glmin: gives min.value of geographical lenght - ! => glmin <= l <= glmin+360. - ! (example glmin = -180. or 0.) - ! if "geopos","georek" is used - ! then glmin must be the lenght i(1,1) in the - ! geographical grid (gl1 to "geopos") - ! output: gl(ii,jj): latitude glmin <= l <= glmin+360. - ! gb(ii,jj): longitude -90. <= b <= +90. - !-------------------------------------------------------------------! - ! - evaluate gl, gb over whole domain given by MAXLIMAX, MAXLJMAX - ! to safeguard against possible use of non-defined gl,bb squares. - ! - note, we could use rpol2(i,j) to save some computations here, - ! but for now we leave it. This stuff is only done once anyway + !-------------------------------------------------------------------! + ! calculates l(lat),b(long) (geographical coord.) + ! in every grid point defined by the i_fdom, j_fdom arrays. + ! + ! input: xp,yp: coord. of the polar point. + ! AN: number of grid-distances from pole to equator. + ! fi: rotational angle for the x,y grid. + ! imax,jmax: number of points in x- og y- direction + ! glmin: gives min.value of geographical lenght + ! => glmin <= l <= glmin+360. + ! (example glmin = -180. or 0.) + ! if "geopos","georek" is used + ! then glmin must be the lenght i(1,1) in the + ! geographical grid (gl1 to "geopos") + ! output: gl(ii,jj): latitude glmin <= l <= glmin+360. + ! gb(ii,jj): longitude -90. <= b <= +90. + !-------------------------------------------------------------------! + ! - evaluate gl, gb over whole domain given by MAXLIMAX, MAXLJMAX + ! to safeguard against possible use of non-defined gl,bb squares. + ! - note, we could use rpol2(i,j) to save some computations here, + ! but for now we leave it. This stuff is only done once anyway real :: glmin, glmax, om, om2, dy, dy2,rp,rb, rl, dx, dr integer :: i, j, info - !su xp,yp read in infield - !su xp = 43. - !su yp = 121. + !su xp,yp read in infield + !su xp = 43. + !su yp = 121. glmin = -180.0 glmax = glmin + 360.0 @@ -379,24 +1022,24 @@ subroutine Position() om2 = om * 2.0 - if(trim(projection)=='Stereographic') then - - do j = 1, MAXLJMAX ! - changed from ljmax - dy = yp - j_fdom(j) ! - changed from gj0+JRUNBEG-2+j - dy2 = dy*dy - do i = 1, MAXLIMAX ! - changed from limax - dx = i_fdom(i) - xp ! - changed - rp = sqrt(dx*dx+dy2) ! => distance to pole - rb = 90.0 - om2 * atan(rp/AN) ! => latitude - rl = 0.0 - if (rp > 1.0e-10) rl = fi + om*atan2(dx,dy) - if (rl < glmin) rl = rl + 360.0 - if (rl > glmax) rl = rl - 360.0 - glon(i,j)=rl ! longitude - glat(i,j)=rb ! latitude - - end do ! i - end do ! j + if(trim(projection)=='Stereographic') then + + do j = 1, MAXLJMAX ! - changed from ljmax + dy = yp - j_fdom(j) ! - changed from gj0+JRUNBEG-2+j + dy2 = dy*dy + do i = 1, MAXLIMAX ! - changed from limax + dx = i_fdom(i) - xp ! - changed + rp = sqrt(dx*dx+dy2) ! => distance to pole + rb = 90.0 - om2 * atan(rp/AN) ! => latitude + rl = 0.0 + if (rp > 1.0e-10) rl = fi + om*atan2(dx,dy) + if (rl < glmin) rl = rl + 360.0 + if (rl > glmax) rl = rl - 360.0 + glon(i,j)=rl ! longitude + glat(i,j)=rb ! latitude + + end do ! i + end do ! j endif ! test to find full-domain min and max lat/long values @@ -417,20 +1060,20 @@ subroutine Position() MPIbuff= glacmin CALL MPI_ALLREDUCE(MPIbuff, glacmin , 1, & MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, INFO) - + if(me==0) write(unit=6,fmt="(a,4f9.2)") & - " GridValues: max/min for lat,lon ", & - gbacmax,gbacmin,glacmax,glacmin + " GridValues: max/min for lat,lon ", & + gbacmax,gbacmin,glacmax,glacmin - if ( DEBUG_GRID ) then + if ( DEBUG_GRIDVALUES ) then do j = 1, MAXLJMAX - do i = 1, MAXLIMAX - if ( i_fdom(i) == DEBUG_i .and. j_fdom(j) == DEBUG_j ) then - write(*,"(a15,a30,5i4,2f8.2,f7.3)") "DEBUGPosition: ", & - " me,i,j,i_fdom,j_fdom,glon,glat,rp: ", & - me, i,j, i_fdom(i), j_fdom(j), glon(i,j), glat(i,j),rp - end if - end do + do i = 1, MAXLIMAX + if ( i_fdom(i) == DEBUG_i .and. j_fdom(j) == DEBUG_j ) then + write(*,"(a15,a30,5i4,2f8.2,f7.3)") "DEBUGPosition: ", & + " me,i,j,i_fdom,j_fdom,glon,glat,rp: ", & + me, i,j, i_fdom(i), j_fdom(j), glon(i,j), glat(i,j),rp + end if + end do end do end if @@ -442,245 +1085,359 @@ subroutine GlobalPosition real :: dr,om,om2,rb,rl,rp,dx,dy,dy2,glmax,glmin integer :: im,jm,i0,j0 - if(trim(projection)=='Stereographic') then - - glmin = -180.0 - glmax = glmin + 360.0 - - dr = PI/180.0 ! degrees to radians - om = 180.0/PI ! radians to degrees - om2 = om * 2.0 - AN = 6.370e6*(1.0+sin( ref_latitude*PI/180.))/GRIDWIDTH_M ! = 237.7316364 for GRIDWIDTH_M=50 km and ref_latitude=60 - - do j = 1, JJFULLDOM - dy = yp - j - dy2 = dy*dy - do i = 1, IIFULLDOM - dx = i - xp - rp = sqrt(dx*dx+dy2) ! => distance to pole - rb = 90.0 - om2 * atan(rp/AN) ! => latitude - rl = 0.0 - if (rp > 1.0e-10) rl = fi + om*atan2(dx,dy) - if (rl < glmin) rl = rl + 360.0 - if (rl > glmax) rl = rl - 360.0 - glon_fdom(i,j)=rl ! longitude - glat_fdom(i,j)=rb ! latitude - - end do ! i - end do ! j - - i0=0 - im=MAXLIMAX - j0=0 - jm=MAXLJMAX - if(gi0+MAXLIMAX+1+IRUNBEG-2>IIFULLDOM)im=MAXLIMAX-1!outside fulldomain - if(gi0+0+IRUNBEG-2<1)i0=1!outside fulldomain - if(gj0+MAXLJMAX+1+JRUNBEG-2>JJFULLDOM)jm=MAXLJMAX-1!outside fulldomain - if(gj0+0+JRUNBEG-2<1)j0=1!outside fulldomain - do j=j0,jm - do i=i0,im - gl_stagg(i,j)=0.25*(glon_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2)+& - glon_fdom(gi0+i+1+IRUNBEG-2,gj0+j+JRUNBEG-2)+& - glon_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2)+& - glon_fdom(gi0+i+1+IRUNBEG-2,gj0+j+1+JRUNBEG-2)) - gb_stagg(i,j)=0.25*(glat_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2)+& - glat_fdom(gi0+i+1+IRUNBEG-2,gj0+j+JRUNBEG-2)+& - glat_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2)+& - glat_fdom(gi0+i+1+IRUNBEG-2,gj0+j+1+JRUNBEG-2)) + if(trim(projection)=='Stereographic') then + + glmin = -180.0 + glmax = glmin + 360.0 + + dr = PI/180.0 ! degrees to radians + om = 180.0/PI ! radians to degrees + om2 = om * 2.0 + AN = 6.370e6*(1.0+sin( ref_latitude*PI/180.))/GRIDWIDTH_M ! = 237.7316364 for GRIDWIDTH_M=50 km and ref_latitude=60 + + do j = 1, JJFULLDOM + dy = yp - j + dy2 = dy*dy + do i = 1, IIFULLDOM + dx = i - xp + rp = sqrt(dx*dx+dy2) ! => distance to pole + rb = 90.0 - om2 * atan(rp/AN) ! => latitude + rl = 0.0 + if (rp > 1.0e-10) rl = fi + om*atan2(dx,dy) + if (rl < glmin) rl = rl + 360.0 + if (rl > glmax) rl = rl - 360.0 + glon_fdom(i,j)=rl ! longitude + glat_fdom(i,j)=rb ! latitude + + end do ! i + end do ! j + + i0=0 + im=MAXLIMAX + j0=0 + jm=MAXLJMAX + if(gi0+MAXLIMAX+1+IRUNBEG-2>IIFULLDOM)im=MAXLIMAX-1!outside fulldomain + if(gi0+0+IRUNBEG-2<1)i0=1!outside fulldomain + if(gj0+MAXLJMAX+1+JRUNBEG-2>JJFULLDOM)jm=MAXLJMAX-1!outside fulldomain + if(gj0+0+JRUNBEG-2<1)j0=1!outside fulldomain + do j=j0,jm + do i=i0,im + gl_stagg(i,j)=0.25*(glon_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2)+& + glon_fdom(gi0+i+1+IRUNBEG-2,gj0+j+JRUNBEG-2)+& + glon_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2)+& + glon_fdom(gi0+i+1+IRUNBEG-2,gj0+j+1+JRUNBEG-2)) + gb_stagg(i,j)=0.25*(glat_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2)+& + glat_fdom(gi0+i+1+IRUNBEG-2,gj0+j+JRUNBEG-2)+& + glat_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2)+& + glat_fdom(gi0+i+1+IRUNBEG-2,gj0+j+1+JRUNBEG-2)) + enddo enddo - enddo - do j=0,j0 - do i=i0,im - gl_stagg(i,j)=2*gl_stagg(i,j+1)-gl_stagg(i,j+2) - gb_stagg(i,j)=2*gb_stagg(i,j+1)-gb_stagg(i,j+2) + do j=0,j0 + do i=i0,im + gl_stagg(i,j)=2*gl_stagg(i,j+1)-gl_stagg(i,j+2) + gb_stagg(i,j)=2*gb_stagg(i,j+1)-gb_stagg(i,j+2) + enddo enddo - enddo - do j=jm,MAXLJMAX - do i=i0,im - gl_stagg(i,j)=2*gl_stagg(i,j-1)-gl_stagg(i,j-2) - gb_stagg(i,j)=2*gb_stagg(i,j-1)-gb_stagg(i,j-2) + do j=jm,MAXLJMAX + do i=i0,im + gl_stagg(i,j)=2*gl_stagg(i,j-1)-gl_stagg(i,j-2) + gb_stagg(i,j)=2*gb_stagg(i,j-1)-gb_stagg(i,j-2) + enddo enddo - enddo - do j=0,MAXLJMAX - do i=0,i0 - gl_stagg(i,j)=2*gl_stagg(i+1,j)-gl_stagg(i+2,j) - gb_stagg(i,j)=2*gb_stagg(i+1,j)-gb_stagg(i+2,j) + do j=0,MAXLJMAX + do i=0,i0 + gl_stagg(i,j)=2*gl_stagg(i+1,j)-gl_stagg(i+2,j) + gb_stagg(i,j)=2*gb_stagg(i+1,j)-gb_stagg(i+2,j) + enddo enddo - enddo - do j=0,MAXLJMAX - do i=im,MAXLIMAX - gl_stagg(i,j)=2*gl_stagg(i-1,j)-gl_stagg(i-2,j) - gb_stagg(i,j)=2*gb_stagg(i-1,j)-gb_stagg(i-2,j) + do j=0,MAXLJMAX + do i=im,MAXLIMAX + gl_stagg(i,j)=2*gl_stagg(i-1,j)-gl_stagg(i-2,j) + gb_stagg(i,j)=2*gb_stagg(i-1,j)-gb_stagg(i-2,j) + enddo enddo - enddo - + endif -end subroutine GlobalPosition + end subroutine GlobalPosition subroutine lb2ijm(imax,jmax,glon,glat,xr2,yr2,fi2,an2,xp2,yp2) !-------------------------------------------------------------------! - ! calculates coordinates xr2, yr2 (real values) from gl(lat),gb(long) + ! calculates coordinates xr2, yr2 (real values) from glat(lat),glon(long) ! - ! input: xp2,yp2: coord. of the polar point in grid2 + ! input: glon,glat: coord. of the polar point in grid1 ! an2: number of grid-distances from pole to equator in grid2. ! fi2: rotational angle for the grid2 (at i2=0). ! i1max,j1max: number of points (grid1) in x- og y- direction ! ! - ! output: i2(i1,j1): i coordinates in grid2 - ! j2(i1,j1): j coordinates in grid2 + ! output: xr2(i1,j1): i coordinates in grid2 (with decimals) + ! yr2(i1,j1): j coordinates in grid2 (with decimals) !-------------------------------------------------------------------! - - integer :: imax,jmax,i1, j1 - real :: fi2,an2,xp2,yp2 - real :: glon(imax,jmax),glat(imax,jmax) - real :: xr2(imax,jmax),yr2(imax,jmax) - + real, intent(in) :: glon(imax,jmax),glat(imax,jmax) + real, intent(out) :: xr2(imax,jmax),yr2(imax,jmax) + real, intent(in), optional :: fi2,an2,xp2,yp2 + integer, intent(in) :: imax,jmax + real :: fi_loc,an_loc,xp_loc,yp_loc real, parameter :: PI=3.14159265358979323 - real :: PId4,dr,dr2 - - - PId4 = PI/4. - dr2 = PI/180.0/2. ! degrees to radians /2 - dr = PI/180.0 ! degrees to radians - - do j1 = 1, jmax - do i1 = 1, imax - - xr2(i1,j1)=xp2+an2*tan(PId4-glat(i1,j1)*dr2) & - *sin(dr*(glon(i1,j1)-fi2)) - yr2(i1,j1)=yp2-an2*tan(PId4-glat(i1,j1)*dr2) & - *cos(dr*(glon(i1,j1)-fi2)) - - end do ! i - end do ! j + real :: PId4,dr,dr2,dist,dist2,dist3 + integer ::i,j,ip1,jp1, ir2, jr2,i1,j1 + + + if(projection=='Stereographic'.or.(present(fi2).and.present(an2).and.present(xp2).and.present(yp2)))then + PId4 =PI/4. + dr2 =PI/180.0/2. ! degrees to radians /2 + dr =PI/180.0 ! degrees to radians + fi_loc=fi + an_loc=an + xp_loc=xp + yp_loc=yp + + if(present(fi2))fi_loc=fi2 + if(present(an2))an_loc=an2 + if(present(xp2))xp_loc=xp2 + if(present(yp2))yp_loc=yp2 + do j1 = 1, jmax + do i1 = 1, imax + xr2(i1,j1)=xp_loc+an_loc*tan(PId4-glat(i1,j1)*dr2)*sin(dr*(glon(i1,j1)-fi_loc)) + yr2(i1,j1)=yp_loc-an_loc*tan(PId4-glat(i1,j1)*dr2)*cos(dr*(glon(i1,j1)-fi_loc)) + enddo + enddo + else if(projection=='lon lat')then! lon-lat grid + do j1 = 1, jmax + do i1 = 1, imax + xr2(i1,j1)=(glon(i1,j1)-glon_fdom(1,1))/(glon_fdom(2,1)-glon_fdom(1,1))+1 + if(xr2(i1,j1)<0.5)xr2=xr2+360.0/(glon_fdom(2,1)-glon_fdom(1,1)) + yr2(i1,j1)=(glat(i1,j1)-glat_fdom(1,1))/(glat_fdom(1,2)-glat_fdom(1,1))+1 + enddo + enddo + else!general projection, Use only info from glon_fdom and glat_fdom + call StopAll('lb2ijm: conversion not yet tested. (You could try the method below)') + + !VERY SLOW, specially for large grids + do j1 = 1, jmax + do i1 = 1, imax + dist=10.0!max distance is PI + do j=1,JJFULLDOM + do i=1,IIFULLDOM + if(dist>great_circle_distance(glon(i1,j1),glat(i1,j1),glon_fdom(i,j) & + ,glat_fdom(i,j)))then + dist=great_circle_distance(glon(i1,j1),glat(i1,j1),glon_fdom(i,j) & + ,glat_fdom(i,j)) + xr2(i1,j1)=i + yr2(i1,j1)=j + endif + enddo + enddo + + !find the real part of i and j by comparing distances to neighbouring cells + ! + ! C + ! /|\ + ! / | \ + ! / | \ + ! A---D---B + ! + !A=(i,j) ,B=(i+1,j), C=(glon,glat) + !dist=AC, dist2=BC, dist3=AB + !AD=(dist*dist+dist3*dist3-dist2*dist2)/(2*dist3) + ! + ir2 = nint(xr2(i1,j1)) + jr2 = nint(yr2(i1,j1)) + ip1=ir2+1 + if(ip1>IIFULLDOM)ip1=ip1-2 + dist2=great_circle_distance(glon(i1,j1),glat(i1,j1),glon_fdom(ip1,jr2),glat_fdom(ip1,jr2)) + dist3=great_circle_distance( glon_fdom(ir2,jr2), & + glat_fdom(ir2,jr2), & + glon_fdom(ip1,jr2), & + glat_fdom(ip1,jr2)) + + xr2(i1,j1)=xr2(i1,j1)+(dist*dist+dist3*dist3-dist2*dist2)/(2*dist3*dist3) + + + jp1=jr2+1 + if(jp1>JJFULLDOM)jp1=jp1-2 + + dist2=great_circle_distance(glon(i1,j1),glat(i1,j1),glon_fdom(ir2,jp1),glat_fdom(ir2,jp1)) + !GFORTRAN CHANGE + dist3=great_circle_distance( glon_fdom(ir2,jr2), & + glat_fdom(ir2,jr2), & + glon_fdom(ir2,jp1), & + glat_fdom(ir2,jp1) ) + + yr2(i1,j1)=yr2(i1,j1)+(dist*dist+dist3*dist3-dist2*dist2)/(2*dist3*dist3) + + enddo + enddo + endif end subroutine lb2ijm - subroutine lb2ij(gl2,gb2,xr2,yr2,fi2,an2,xp2,yp2) - -!Note: this routine is not supposed to be CPU optimized - !-------------------------------------------------------------------! - ! calculates coordinates xr2, yr2 (real values) from gl(lat),gb(long) - ! - ! input: xp2,yp2: coord. of the polar point in grid2 - ! an2: number of grid-distances from pole to equator in grid2. - ! fi2: rotational angle for the grid2 (at i2=0). - ! i1max,j1max: number of points (grid1) in x- og y- direction - ! - ! - ! output: i2(i1,j1): i coordinates in grid2 - ! j2(i1,j1): j coordinates in grid2 - !-------------------------------------------------------------------! + subroutine lb2ij(gl2,gb2,xr2,yr2,fi2,an2,xp2,yp2) + !Note: this routine is not yet CPU optimized + !-------------------------------------------------------------------! + ! calculates coordinates xr2, yr2 (real values) from gl(lat),gb(long) + ! + ! input: xp2,yp2: coord. of the polar point in grid2 + ! an2: number of grid-distances from pole to equator in grid2. + ! fi2: rotational angle for the grid2 (at i2=0). + ! i1max,j1max: number of points (grid1) in x- og y- direction + ! + ! + ! output: xr2(i1,j1): i coordinates in grid2 + ! yr2(i1,j1): j coordinates in grid2 + !-------------------------------------------------------------------! + real, intent(in) :: gl2,gb2 real, intent(out) :: xr2,yr2 real, intent(in), optional :: fi2,an2,xp2,yp2 real :: fi_loc,an_loc,xp_loc,yp_loc - real, parameter :: PI=3.14159265358979323 - real :: PId4,dr,dr2,dist,dist2,dist3 + real, parameter :: PI=3.14159265358979323,dr=PI/180.0,dri= 180.0/PI + real :: PId4,dr2,dist,dist2,dist3 integer ::i,j,ip1,jp1, ir2, jr2 + real ::xscen ,yscen,zsycen,zcycen ,zxmxc,zsxmxc,zcxmxc,zsysph,zsyrot,yrot,zsxrot,zcysph,zcyrot,zcxrot,xrot,dx,x1,y1 + + if(projection=='Stereographic')then + PId4 =PI/4. + dr2 =dr*0.5 ! degrees to radians /2 + fi_loc=fi + an_loc=an + xp_loc=xp + yp_loc=yp + + if(present(fi2))fi_loc=fi2 + if(present(an2))an_loc=an2 + if(present(xp2))xp_loc=xp2 + if(present(yp2))yp_loc=yp2 + + xr2=xp_loc+an_loc*tan(PId4-gb2*dr2)*sin(dr*(gl2-fi_loc)) + yr2=yp_loc-an_loc*tan(PId4-gb2*dr2)*cos(dr*(gl2-fi_loc)) + + else if(projection=='lon lat')then! lon-lat grid + + xr2=(gl2-glon_fdom(1,1))/(glon_fdom(2,1)-glon_fdom(1,1))+1 + if(xr2<0.5)xr2=xr2+360.0/(glon_fdom(2,1)-glon_fdom(1,1)) + yr2=(gb2-glat_fdom(1,1))/(glat_fdom(1,2)-glat_fdom(1,1))+1 + + else if(projection=='Rotated_Spherical')then! rotated lon-lat grid +! dx_roti=20.0 +! grid_north_pole_longitude = -170.0 +! grid_north_pole_latitude = 40.0 + xscen = grid_north_pole_longitude-180.0 + if(xscen<-180.0)xscen = xscen+360.0 + yscen = 90.0-grid_north_pole_latitude + ! xscen=grid_north_pole_longitude-180.0 + ! yscen=90.0-grid_north_pole_latitude + zsycen = sin(dr*yscen) + zcycen = cos(dr*yscen) + ! + zxmxc = dr*(gl2 - xscen) + zsxmxc = sin(zxmxc) + zcxmxc = cos(zxmxc) + zsysph = sin(dr*gb2) + zcysph = cos(dr*gb2) + zsyrot = zcycen*zsysph - zsycen*zcysph*zcxmxc + zsyrot = amax1(zsyrot,-1.0) + zsyrot = amin1(zsyrot,+1.0) + yrot = asin(zsyrot) + zcyrot = cos(yrot) + zcxrot = (zcycen*zcysph*zcxmxc +& + zsycen*zsysph)/zcyrot + zcxrot = amax1(zcxrot,-1.0) + zcxrot = amin1(zcxrot,+1.0) + zsxrot = zcysph*zsxmxc/zcyrot + xrot = acos(zcxrot) + if (zsxrot.lt.0.0) xrot = -xrot + xrot=xrot*dri + yrot=yrot*dri + if(xrotgreat_circle_distance(gl2,gb2,glon_fdom(i,j) & + ,glat_fdom(i,j)))then + dist=great_circle_distance(gl2,gb2,glon_fdom(i,j) & + ,glat_fdom(i,j)) + xr2=i + yr2=j + endif + enddo + enddo + !find the real part of i and j by comparing distances to neighbouring cells + ! + ! C + ! /|\ + ! / | \ + ! / | \ + ! A---D---B + ! + !A=(i,j) ,B=(i+1,j), C=(gl2,gb2) + !dist=AC, dist2=BC, dist3=AB + !AD=(dist*dist+dist3*dist3-dist2*dist2)/(2*dist3) + ! + ir2 = nint(xr2) + jr2 = nint(yr2) + ip1=ir2+1 + if(ip1>IIFULLDOM)ip1=ip1-2 + dist2=great_circle_distance(gl2,gb2,glon_fdom(ip1,jr2),glat_fdom(ip1,jr2)) + dist3=great_circle_distance( glon_fdom(ir2,jr2), & + glat_fdom(ir2,jr2), & + glon_fdom(ip1,jr2), & + glat_fdom(ip1,jr2)) + + xr2=xr2+(dist*dist+dist3*dist3-dist2*dist2)/(2*dist3*dist3) + + + jp1=jr2+1 + if(jp1>JJFULLDOM)jp1=jp1-2 + + dist2=great_circle_distance(gl2,gb2,glon_fdom(ir2,jp1),glat_fdom(ir2,jp1)) + !GFORTRAN CHANGE + dist3=great_circle_distance( glon_fdom(ir2,jr2), & + glat_fdom(ir2,jr2), & + glon_fdom(ir2,jp1), & + glat_fdom(ir2,jp1) ) + + yr2=yr2+(dist*dist+dist3*dist3-dist2*dist2)/(2*dist3*dist3) - if(projection=='Stereographic')then - PId4 =PI/4. - dr2 =PI/180.0/2. ! degrees to radians /2 - dr =PI/180.0 ! degrees to radians - fi_loc=fi - an_loc=an - xp_loc=xp - yp_loc=yp - - if(present(fi2))fi_loc=fi2 - if(present(an2))an_loc=an2 - if(present(xp2))xp_loc=xp2 - if(present(yp2))yp_loc=yp2 - - xr2=xp_loc+an_loc*tan(PId4-gb2*dr2)*sin(dr*(gl2-fi_loc)) - yr2=yp_loc-an_loc*tan(PId4-gb2*dr2)*cos(dr*(gl2-fi_loc)) - else if(projection=='lon lat')then! lon-lat grid - xr2=(gl2-glon_fdom(1,1))/(glon_fdom(2,1)-glon_fdom(1,1))+1 - if(xr2<0.5)xr2=xr2+360.0/(glon_fdom(2,1)-glon_fdom(1,1)) - yr2=(gb2-glat_fdom(1,1))/(glat_fdom(1,2)-glat_fdom(1,1))+1 - else!general projection, Use only info from glon_fdom and glat_fdom - !first find closest by testing all gridcells. - dist=10.0!max distance is PI - do j=1,JJFULLDOM - do i=1,IIFULLDOM - if(dist>great_circle_distance(gl2,gb2,glon_fdom(i,j) & - ,glat_fdom(i,j)))then - dist=great_circle_distance(gl2,gb2,glon_fdom(i,j) & - ,glat_fdom(i,j)) - xr2=i - yr2=j - endif - enddo - enddo -!find the real part of i and j by comparing distances to neighbouring cells -! -! C -! /|\ -! / | \ -! / | \ -! A---D---B -! -!A=(i,j) ,B=(i+1,j), C=(gl2,gb2) -!dist=AC, dist2=BC, dist3=AB -!AD=(dist*dist+dist3*dist3-dist2*dist2)/(2*dist3) -! - ir2 = nint(xr2) - jr2 = nint(yr2) - ip1=ir2+1 - if(ip1>IIFULLDOM)ip1=ip1-2 - dist2=great_circle_distance(gl2,gb2,glon_fdom(ip1,jr2),glat_fdom(ip1,jr2)) - dist3=great_circle_distance( glon_fdom(ir2,jr2), & - glat_fdom(ir2,jr2), & - glon_fdom(ip1,jr2), & - glat_fdom(ip1,jr2)) - - xr2=xr2+(dist*dist+dist3*dist3-dist2*dist2)/(2*dist3*dist3) - - - jp1=jr2+1 - if(jp1>JJFULLDOM)jp1=jp1-2 - - dist2=great_circle_distance(gl2,gb2,glon_fdom(ir2,jp1),glat_fdom(ir2,jp1)) -!GFORTRAN CHANGE - dist3=great_circle_distance( glon_fdom(ir2,jr2), & - glat_fdom(ir2,jr2), & - glon_fdom(ir2,jp1), & - glat_fdom(ir2,jp1) ) - - yr2=yr2+(dist*dist+dist3*dist3-dist2*dist2)/(2*dist3*dist3) - - endif + endif return end subroutine lb2ij subroutine ij2lbm(imax,jmax,glon,glat,fi,an,xp,yp) - !-------------------------------------------------------------------! - ! calculates l(lat),b(long) (geographical coord.) - ! in every grid point. - ! - ! input: xp,yp: coord. of the polar point. - ! an: number of grid-distances from pole to equator. - ! fi: rotational angle for the x,y grid (at i=0). - ! imax,jmax: number of points in x- og y- direction - ! glmin: gives min.value of geographical lenght - ! => glmin <= l <= glmin+360. - ! (example glmin = -180. or 0.) - ! if "geopos","georek" is used - ! then glmin must be the lenght i(1,1) in the - ! geographical grid (gl1 to "geopos") - ! output: gl(ii,jj): longitude glmin <= l <= glmin+360. - ! gb(ii,jj): latitude -90. <= b <= +90. - !-------------------------------------------------------------------! + !-------------------------------------------------------------------! + ! calculates l(lat),b(long) (geographical coord.) + ! in every grid point. + ! + ! input: xp,yp: coord. of the polar point. + ! an: number of grid-distances from pole to equator. + ! fi: rotational angle for the x,y grid (at i=0). + ! imax,jmax: number of points in x- og y- direction + ! glmin: gives min.value of geographical lenght + ! => glmin <= l <= glmin+360. + ! (example glmin = -180. or 0.) + ! if "geopos","georek" is used + ! then glmin must be the lenght i(1,1) in the + ! geographical grid (gl1 to "geopos") + ! output: gl(ii,jj): longitude glmin <= l <= glmin+360. + ! gb(ii,jj): latitude -90. <= b <= +90. + !-------------------------------------------------------------------! integer :: i, j, imax, jmax real :: glon(imax,jmax),glat(imax,jmax) @@ -700,52 +1457,104 @@ subroutine ij2lbm(imax,jmax,glon,glat,fi,an,xp,yp) dy2 = dy*dy do i = 1, imax - dx = i - xp ! ds - changed - rp = sqrt(dx*dx+dy2) ! => distance to pole - rb = 90.0 - om2 * atan(rp/AN) ! => latitude - rl = 0.0 - if (rp > 1.0e-10) rl = fi + om*atan2(dx,dy) - if (rl < glmin) rl = rl + 360.0 - if (rl > glmax) rl = rl - 360.0 - glon(i,j)=rl ! longitude - glat(i,j)=rb ! latitude + dx = i - xp ! ds - changed + rp = sqrt(dx*dx+dy2) ! => distance to pole + rb = 90.0 - om2 * atan(rp/AN) ! => latitude + rl = 0.0 + if (rp > 1.0e-10) rl = fi + om*atan2(dx,dy) + if (rl < glmin) rl = rl + 360.0 + if (rl > glmax) rl = rl - 360.0 + glon(i,j)=rl ! longitude + glat(i,j)=rb ! latitude end do ! i end do ! j end subroutine ij2lbm + subroutine ij2lb(i,j,lon,lat,fi,an,xp,yp) + !-------------------------------------------------------------------! + ! calculates l(lat),b(long) (geographical coord.) + ! from i,j coordinates in polar stereographic projection + ! + ! input: i,j + ! xp,yp: coord. of the polar point. + ! an: number of grid-distances from pole to equator. + ! fi: rotational angle for the x,y grid (at i=0). + ! imax,jmax: number of points in x- og y- direction + ! glmin: gives min.value of geographical lenght + ! => glmin <= l <= glmin+360. + ! (example glmin = -180. or 0.) + ! if "geopos","georek" is used + ! then glmin must be the lenght i(1,1) in the + ! geographical grid (gl1 to "geopos") + ! output: lon: longitude glmin <= lon <= glmin+360. + ! lat: latitude -90. <= lat <= +90. + !-------------------------------------------------------------------! + + integer :: i, j + real :: lon,lat + real :: fi, an, xp, yp + real :: om, om2, glmin, glmax,dy, dy2,rp,rb, rl, dx, dr + real, parameter :: PI=3.14159265358979323 + + glmin = -180.0 + + glmax = glmin + 360.0 + dr = PI/180.0 ! degrees to radians + om = 180.0/PI ! radians to degrees (om=Norwegian omvendt?) + om2 = om * 2.0 + + ! do j = 1, jmax + dy = yp - j + dy2 = dy*dy + ! do i = 1, imax + + dx = i - xp ! ds - changed + rp = sqrt(dx*dx+dy2) ! => distance to pole + rb = 90.0 - om2 * atan(rp/AN) ! => latitude + rl = 0.0 + if (rp > 1.0e-10) rl = fi + om*atan2(dx,dy) + if (rl < glmin) rl = rl + 360.0 + if (rl > glmax) rl = rl - 360.0 + lon=rl ! longitude + lat=rb ! latitude + ! end do ! i + ! end do ! j + + end subroutine ij2lb + subroutine ij2ijm(in_field,imaxin,jmaxin,out_field,imaxout,jmaxout, & - fiin,anin,xpin,ypin,fiout,anout,xpout,ypout) + fiin,anin,xpin,ypin,fiout,anout,xpout,ypout) -! Converts data (in_field) stored in coordinates (fiin,anin,xpin,ypin) -! into data (out_field) in coordinates (fiout,anout,xpout,ypout) -! pw august 2002 + ! Converts data (in_field) stored in coordinates (fiin,anin,xpin,ypin) + ! into data (out_field) in coordinates (fiout,anout,xpout,ypout) + ! pw august 2002 - integer, intent(in) :: imaxin,jmaxin,imaxout,jmaxout - real, intent(in) :: fiin,anin,xpin,ypin,fiout,anout,xpout,ypout - real, intent(in) :: in_field(imaxin,jmaxin)! Field to be transformed - real, intent(out) :: out_field(imaxout,jmaxout)! Field to be transformed + integer, intent(in) :: imaxin,jmaxin,imaxout,jmaxout + real, intent(in) :: fiin,anin,xpin,ypin,fiout,anout,xpout,ypout + real, intent(in) :: in_field(imaxin,jmaxin)! Field to be transformed + real, intent(out) :: out_field(imaxout,jmaxout)! Field to be transformed - real, allocatable,dimension(:,:) :: x,y,glat,glon - integer alloc_err,i,j,i2,j2 - logical :: interpolate - real :: f11,f12,f21,f22 + real, allocatable,dimension(:,:) :: x,y,glat,glon + integer alloc_err,i,j,i2,j2 + logical :: interpolate + real :: f11,f12,f21,f22 - interpolate = .true. -! interpolate = .false. + interpolate = .true. + ! interpolate = .false. - allocate(x(imaxout,jmaxout), stat=alloc_err) - allocate(y(imaxout,jmaxout), stat=alloc_err) - allocate(glat(imaxout,jmaxout), stat=alloc_err) - allocate(glon(imaxout,jmaxout), stat=alloc_err) - if ( alloc_err /= 0 ) WRITE(*,*) 'MPI_ABORT: ', "ij2ij alloc failed" - if ( alloc_err /= 0 ) call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + allocate(x(imaxout,jmaxout), stat=alloc_err) + allocate(y(imaxout,jmaxout), stat=alloc_err) + allocate(glat(imaxout,jmaxout), stat=alloc_err) + allocate(glon(imaxout,jmaxout), stat=alloc_err) + if ( alloc_err /= 0 ) WRITE(*,*) 'MPI_ABORT: ', "ij2ij alloc failed" + if ( alloc_err /= 0 ) call MPI_ABORT(MPI_COMM_WORLD,9,INFO) -! find longitude, latitude of wanted area + ! find longitude, latitude of wanted area call ij2lbm(imaxout,jmaxout,glon,glat,fiout,anout,xpout,ypout) -! find corresponding coordinates (i,j) in in_field coordinates + ! find corresponding coordinates (i,j) in in_field coordinates call lb2ijm(imaxout,jmaxout,glon,glat,x,y,fiin,anin,xpin,ypin) @@ -754,67 +1563,121 @@ subroutine ij2ijm(in_field,imaxin,jmaxin,out_field,imaxout,jmaxout, & ! should be good enough in practice) if(int(x(1,1)) < 1 .or. int(x(1,1))+1 > imaxin .or. & - int(x(imaxout,1)) < 1 .or. int(x(imaxout,1))+1 > imaxin .or. & - int(x(1,jmaxout)) < 1 .or. int(x(1,jmaxout))+1 > imaxin .or. & - int(x(imaxout,jmaxout)) < 1 .or. & - int(x(imaxout,jmaxout))+1 > imaxin .or. & - int(y(1,1)) < 1 .or. int(y(1,1))+1 > jmaxin .or. & - int(y(imaxout,1)) < 1 .or. int(y(imaxout,1))+1 > jmaxin .or. & - int(y(1,jmaxout)) < 1 .or. int(y(1,jmaxout))+1 > jmaxin .or. & - int(y(imaxout,jmaxout)) < 1 .or. & - int(y(imaxout,jmaxout))+1 > jmaxin ) then - write(*,*)'Did not find all the necessary data in in_field' - write(*,*)'values needed: ' - write(*,*)x(1,1),y(1,1) - write(*,*)x(imaxout,1),y(imaxout,1) - write(*,*)x(1,jmaxout),y(1,jmaxout) - write(*,*)x(imaxout,jmaxout),y(imaxout,jmaxout) - write(*,*)'max values found: ',imaxin ,jmaxin - write(*,*) 'MPI_ABORT: ', "ij2ij: area to small" - call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + int(x(imaxout,1)) < 1 .or. int(x(imaxout,1))+1 > imaxin .or. & + int(x(1,jmaxout)) < 1 .or. int(x(1,jmaxout))+1 > imaxin .or. & + int(x(imaxout,jmaxout)) < 1 .or. & + int(x(imaxout,jmaxout))+1 > imaxin .or. & + int(y(1,1)) < 1 .or. int(y(1,1))+1 > jmaxin .or. & + int(y(imaxout,1)) < 1 .or. int(y(imaxout,1))+1 > jmaxin .or. & + int(y(1,jmaxout)) < 1 .or. int(y(1,jmaxout))+1 > jmaxin .or. & + int(y(imaxout,jmaxout)) < 1 .or. & + int(y(imaxout,jmaxout))+1 > jmaxin ) then + write(*,*)'Did not find all the necessary data in in_field' + write(*,*)'values needed: ' + write(*,*)x(1,1),y(1,1) + write(*,*)x(imaxout,1),y(imaxout,1) + write(*,*)x(1,jmaxout),y(1,jmaxout) + write(*,*)x(imaxout,jmaxout),y(imaxout,jmaxout) + write(*,*)'max values found: ',imaxin ,jmaxin + write(*,*) 'MPI_ABORT: ', "ij2ij: area to small" + call MPI_ABORT(MPI_COMM_WORLD,9,INFO) endif -! interpolate fields if required + ! interpolate fields if required if(interpolate)then - do j = 1, jmaxout - do i = 1,imaxout - i2=int(x(i,j)) - j2=int(y(i,j)) - f11=(1.-(x(i,j)-i2))*(1.-(y(i,j)-j2)) - f12=(1.-(x(i,j)-i2))*((y(i,j)-j2)) - f21=((x(i,j)-i2))*(1.-(y(i,j)-j2)) - f22=((x(i,j)-i2))*((y(i,j)-j2)) - - out_field(i,j) = & - f11 * in_field(i2,j2) + & - f12 * in_field(i2,j2+1) + & - f21 * in_field(i2+1,j2) + & - f22 * in_field(i2+1,j2+1) - + do j = 1, jmaxout + do i = 1,imaxout + i2=int(x(i,j)) + j2=int(y(i,j)) + f11=(1.-(x(i,j)-i2))*(1.-(y(i,j)-j2)) + f12=(1.-(x(i,j)-i2))*((y(i,j)-j2)) + f21=((x(i,j)-i2))*(1.-(y(i,j)-j2)) + f22=((x(i,j)-i2))*((y(i,j)-j2)) + + out_field(i,j) = & + f11 * in_field(i2,j2) + & + f12 * in_field(i2,j2+1) + & + f21 * in_field(i2+1,j2) + & + f22 * in_field(i2+1,j2+1) + + enddo enddo - enddo else - do j = 1, jmaxout - do i = 1,imaxout - out_field(i,j) =in_field(nint(x(i,j)),nint(y(i,j))) + do j = 1, jmaxout + do i = 1,imaxout + out_field(i,j) =in_field(nint(x(i,j)),nint(y(i,j))) + enddo enddo - enddo endif - deallocate(x,stat=alloc_err) - deallocate(y,stat=alloc_err) - deallocate(glat,stat=alloc_err) - deallocate(glon,stat=alloc_err) - if ( alloc_err /= 0 ) WRITE(*,*) 'MPI_ABORT: ', "ij2ijde-alloc_err" - if ( alloc_err /= 0 ) call MPI_ABORT(MPI_COMM_WORLD,9,INFO) - - end subroutine ij2ijm + deallocate(x,stat=alloc_err) + deallocate(y,stat=alloc_err) + deallocate(glat,stat=alloc_err) + deallocate(glon,stat=alloc_err) + if ( alloc_err /= 0 ) WRITE(*,*) 'MPI_ABORT: ', "ij2ijde-alloc_err" + if ( alloc_err /= 0 ) call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + + end subroutine ij2ijm ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + function coord_in_gridbox(lon,lat,i,j) result(in) + !-------------------------------------------------------------------! + ! Is coord (lon/lat) is inside gridbox(i,j)? + !-------------------------------------------------------------------! + real, intent(in) :: lon,lat + integer, intent(in) :: i,j + logical :: in + in=gl_stagg(i-1,j)<=lon.and.lon !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute diff --git a/Io_Progs_ml.f90 b/Io_Progs_ml.f90 index db478aa..432686e 100644 --- a/Io_Progs_ml.f90 +++ b/Io_Progs_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -44,7 +44,7 @@ module Io_Progs_ml use ModelConstants_ml, only: DEBUG_IOPROG, DEBUG_i, DEBUG_j, DomainName, & MasterProc, IIFULLDOM, JJFULLDOM use KeyValue_ml, only: KeyVal, KeyValue, LENKEYVAL -use Par_ml, only: me, li0, li1, lj0, lj1 +use Par_ml, only: me, limax,ljmax use SmallUtils_ml, only: wordsplit, WriteArray use TimeDate_ml, only: date,current_date use TimeDate_ExtraUtil_ml, only: date2string @@ -64,7 +64,8 @@ module Io_Progs_ml public :: PrintLog ! writes message to both RunLog and unit 6 public :: datewrite ! writes date then data - helper sub private :: datewrite_ia,& ! int, array vesion - datewrite_a ! array versions + datewrite_iia,& ! array of ints and reals version + datewrite_a ! array of reals public :: Self_Test logical, public :: fexist ! true if file exists @@ -75,7 +76,7 @@ module Io_Progs_ml integer, private, parameter :: MAXHEADERS = 900 ! Max No. headers interface datewrite - module procedure datewrite_ia,datewrite_a + module procedure datewrite_ia,datewrite_iia,datewrite_a end interface datewrite contains @@ -164,7 +165,7 @@ subroutine check_file(fname,fexist,needed,errmsg) if(DEBUG_IOPROG)write(unit=6,fmt=*) "check_file::: ", fname if ( .not. fexist .and. .not. needed ) then - write(unit=6,fmt=*) "not needed, skipping....." + write(unit=6,fmt=*) "not needed, skipping....." // trim(fname) ios = 0 elseif ( .not. fexist .and. needed ) then ios = -1 @@ -174,7 +175,7 @@ subroutine check_file(fname,fexist,needed,errmsg) end if end subroutine check_file !------------------------------------------------------------------------- -subroutine open_file(io_num,mode,fname,needed,skip) +subroutine open_file(io_num,mode,fname,needed,skip,iostat) ! Checks for the existence of a file and opens if present. If the ! file is specified as "needed", and missing, an error message is ! printed and the run is stopped. @@ -184,6 +185,7 @@ subroutine open_file(io_num,mode,fname,needed,skip) character (len=*), intent(in) :: fname ! file name logical, optional, intent(in) :: needed ! see below integer, optional, intent(in) :: skip ! No. text lines to be skipped + integer, optional, intent(out) :: iostat ! return ios integer :: i ! local loop counter @@ -218,6 +220,7 @@ subroutine open_file(io_num,mode,fname,needed,skip) print *, "OPEN FILE: Incorrect mode: ", trim(mode) ios = -1 end select + if(present(iostat))iostat=ios end subroutine open_file !------------------------------------------------------------------------- subroutine Read_Headers(io_num,io_msg,NHeaders,NKeys,Headers,Keyvalues,& @@ -389,7 +392,7 @@ subroutine Read2D(fname,data2d,idata2d) i = i_local(i_fdom) ! Convert to local coordinates j = j_local(j_fdom) - if ( i >= li0 .and. i <= li1 .and. j >= lj0 .and. j <= lj1 ) then + if ( i >= 1 .and. i <= limax .and. j >= 1 .and. j <= ljmax ) then Nused = Nused + 1 if ( DEBUG_IOPROG .and. i_fdom==DEBUG_i .and. j_fdom==DEBUG_j ) & write(*,*) "READ TXTINPUT", me, i_fdom, j_fdom," => ",& @@ -496,7 +499,7 @@ subroutine Read2DN(fname,Ndata,data2d,CheckValues,HeadersRead) i = i_local(i_fdom) ! Convert to local coordinates j = j_local(j_fdom) - if ( i >= 1 .and. i <= li1 .and. j >=1 .and. j <= lj1 ) then + if ( i >= 1 .and. i <= limax .and. j >=1 .and. j <= ljmax ) then if ( DEBUG_IOPROG .and. i_fdom==DEBUG_i .and. j_fdom == DEBUG_j )& write(*,*)"READ TXTINPUT", me, i_fdom, j_fdom, " => ", i,j,tmp(1) data2d(i,j,1:Ndata) = tmp(1:Ndata) @@ -521,7 +524,7 @@ subroutine datewrite_ia (txt,ii,array,txt_pattern) write(*,"(a,1x, i0, 20es11.2)") "dw:" // date2string(txt,current_date), & ii, array else - write(*,"(a,3i3,i5,1x, i0, 20es11.2)") "dw:" // trim(txt), & + write(*,"(a,3i3,i5,1x, i0, 20es14.5)") "dw:" // trim(txt), & current_date%month, current_date%day, current_date%hour, & current_date%seconds, ii, array endif @@ -534,14 +537,38 @@ subroutine datewrite_a (txt,array,txt_pattern) logical :: use_pattern=.false. use_pattern=.false.;if(present(txt_pattern))use_pattern=txt_pattern if(use_pattern)then - write(*,"(a,1x, 20es10.0)") "dw:" // date2string(txt,current_date), & + write(*,"(a,1x, 20es11.0)") "dw:" // date2string(txt,current_date), & array else - write(*,"(a,3i3,i5,1x, 20es10.3)") "dw:" // trim(txt), & + write(*,"(a,3i3,i5,1x, 20es11.3)") "dw:" // trim(txt), & current_date%month, current_date%day, current_date%hour, & current_date%seconds, array endif end subroutine datewrite_a +subroutine datewrite_iia (txt,ii,array,txt_pattern) + ! to write out date, integer + supplied data array + character(len=*), intent(in) :: txt + integer, dimension(:), intent(in) :: ii ! arrays of integers, max 5 + real, dimension(:), intent(in) :: array + logical, intent(in), optional :: txt_pattern + logical :: use_pattern=.false. + integer :: Ni + integer, dimension(5):: iout ! arrays of integers, max 5 + Ni = size(ii) + call CheckStop(Ni>5, "Too many integers in datewrite: only coded for 5") + call CheckStop(maxval(ii)>9999, "Too big integer in datewrite_iia: only coded for i5") + iout = -1 + iout(1:Ni) = ii + use_pattern=.false.;if(present(txt_pattern))use_pattern=txt_pattern + if(use_pattern)then + write(*,"(a,1x, 5i5, 20es11.2)") "dw:" // date2string(txt,current_date), & + iout, array + else + write(*,"(a,3i3,i5,1x, 5i5, 20es11.2)") "dw:" // trim(txt), & + current_date%month, current_date%day, current_date%hour, & + current_date%seconds, iout, array + endif +end subroutine datewrite_iia !------------------------------------------------------------------------- subroutine Self_Test() ! The input files are designed to read nicely in gnumeric and other spread- diff --git a/LandPFT_ml.f90 b/LandPFT_ml.f90 index e7a761d..d93a4cc 100644 --- a/LandPFT_ml.f90 +++ b/LandPFT_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2010-2011 met.no +!* Copyright (C) 2010-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -84,10 +84,10 @@ subroutine MapPFT_LAI(month) real :: lpj(MAXLIMAX,MAXLJMAX) ! Emissions read from file logical :: my_first_call = .true. - integer :: n, pft + integer :: pft character(len=20) :: varname -return ! JAN31TEST. This code will be completed during 2011 +return ! JAN31TEST. This code needs to be completed still ***** if ( my_first_call ) then allocate ( pft_lai(MAXLIMAX,MAXLJMAX,N_PFTS) ) my_first_call = .false. diff --git a/Landuse_ml.f90 b/Landuse_ml.f90 index d7b0f8d..516ad5b 100644 --- a/Landuse_ml.f90 +++ b/Landuse_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !***************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -45,7 +45,8 @@ module Landuse_ml USE_PFT_MAPS, DEBUG_LANDPFTS, & DEBUG_LANDUSE, NPROC, IIFULLDOM, JJFULLDOM, & DomainName, MasterProc -use Par_ml, only: li0, lj0, li1, lj1, MAXLIMAX, MAXLJMAX, & +use NetCDF_ml, only: ReadField_CDF,printcdf +use Par_ml, only: MAXLIMAX, MAXLJMAX, & limax, ljmax, me use SmallUtils_ml, only: find_index, NOT_FOUND, WriteArray use TimeDate_ml, only: daynumber, effectivdaynumber, nydays, current_date @@ -93,17 +94,19 @@ module Landuse_ml ,old_gsun ! also for flux end type LandCov !============================================= - type(LandCov), public, save, dimension(MAXLIMAX,MAXLJMAX) :: LandCover + type(LandCov), public, save, allocatable,dimension(:,:) :: LandCover !============================================= - integer, public,save,dimension(MAXLIMAX,MAXLJMAX) :: & + logical, public,save, allocatable,dimension(:,:) :: likely_coastal + + integer, public,save, allocatable,dimension(:,:) :: & WheatGrowingSeason ! Growing season (days), IAM_WHEAT =1 for true ! For some flux work, experimental - real,public,save,dimension(MAXLIMAX,MAXLJMAX) :: water_cover, ice_landcover - logical,public,save :: water_cover_set = .false. + real,public,save, allocatable,dimension(:,:) :: water_fraction, ice_landcover + logical,public,save :: water_frac_set = .false. character(len=80), private :: errmsg @@ -112,15 +115,104 @@ module Landuse_ml !========================================================================== subroutine InitLanduse() - logical :: filefound - + logical :: filefound + real, parameter ::water_fraction_THRESHOLD=0.5 + integer ::i,j,ilu,lu + logical :: debug_flag = .false. !===================================== - call ReadLandUse(filefound) !=> Land_codes, Percentage cover per grid - call CheckStop(.not.filefound,"InitLanduse failed!") + !ALLOCATE ARRAYS + allocate(LandCover(MAXLIMAX,MAXLJMAX)) + allocate(likely_coastal(MAXLIMAX,MAXLJMAX) ) + likely_coastal = .false. + allocate(WheatGrowingSeason(MAXLIMAX,MAXLJMAX)) + allocate(water_fraction(MAXLIMAX,MAXLJMAX), ice_landcover(MAXLIMAX,MAXLJMAX)) + + + !ReadLandUse_CDF to be used as default when glc2000 data is improved? + + + filefound=.false. + call ReadLandUse(filefound) !=> Land_codes, Percentage cover per grid + + !ReadLandUse_CDF use Max Posch 5km landuse over emep area and glc200 where this dat is not defined. + if(.not.filefound)call ReadLandUse_CDF(filefound) !=> Land_codes, Percentage cover per grid + + call CheckStop(.not.filefound,"InitLanduse failed!") + + call Init_LandDefs(Land_codes) ! => LandType, LandDefs + + + ! effectiv daynumber to shift 6 month when in southern hemisphere + effectivdaynumber=daynumber + + + !/ -- Calculate growing seasons where needed and water_fraction + ! (for Rn emissions) + + water_fraction(:,:) = 0.0 !for Pb210 + ice_landcover(:,:) = 0.0 !for Pb210 + likely_coastal(:,:) = .false. ! already done, but just for clarity + + do i = 1, limax + do j = 1, ljmax + + debug_flag = ( debug_proc .and. i == debug_li .and. j == debug_lj ) + do ilu= 1, LandCover(i,j)%ncodes + lu = LandCover(i,j)%codes(ilu) + call CheckStop( lu < 0 .or. lu > NLANDUSEMAX , & + "SetLandUse out of range" ) + + if ( LandDefs(lu)%SGS50 > 0 ) then ! need to set growing seasons + + call Growing_season( lu,abs(glat(i,j)),& + LandCover(i,j)%SGS(ilu),LandCover(i,j)%EGS(ilu) ) + else + LandCover(i,j)%SGS(ilu) = LandDefs(lu)%SGS50 + LandCover(i,j)%EGS(ilu) = LandDefs(lu)%EGS50 + end if + if ( DEBUG_LANDUSE .and. debug_flag ) & + write(*,"(a,i3,a20,2i4)")"LANDUSE: LU_SETGS", & + lu, LandDefs(lu)%name,& + LandCover(i,j)%SGS(ilu),LandCover(i,j)%EGS(ilu) + + + !/ for landuse classes with bulk-resistances, we only + ! need to specify height once. Dummy values are assigned + ! to LAI and gpot: + + if ( LandType(lu)%is_bulk ) then + LandCover(i,j)%hveg(ilu) = LandDefs(lu)%hveg_max + LandCover(i,j)%LAI(ilu) = 0.0 + LandCover(i,j)%fphen(ilu) = 0.0 + end if + + if ( LandType(lu)%is_water ) water_fraction(i,j) = & + LandCover(i,j)%fraction(ilu) + if ( LandType(lu)%is_ice ) ice_landcover(i,j) = & + LandCover(i,j)%fraction(ilu) + + + end do ! ilu + +!set default values for nwp_sea + if(water_fraction(i,j)>water_fraction_THRESHOLD) & + nwp_sea(i,j) = .true. - call Init_LandDefs(Land_codes) ! => LandType, LandDefs + ! We don't want to trust some squares with a mixture of sea + ! and land for micromet purposes, e.g. T2 can be very wrong + ! We mark these as likely coastal: + if ( nwp_sea(i,j) ) then + if ( water_fraction(i,j) < 1.0 ) likely_coastal(i,j) = .true. + else if ( water_fraction(i,j) > 0.2 ) then + likely_coastal(i,j) = .true. + end if ! + end do ! j + end do ! i + + water_frac_set = .true. ! just to inform other routines + end subroutine InitLanduse !========================================================================== subroutine ReadLanduse(filefound) @@ -203,13 +295,15 @@ subroutine ReadLanduse(filefound) else filefound=.false. + if(MasterProc)Write(*,*)'Inputs.Landuse not found' + return call StopAll('Inputs.Landuse not found') endif - +! call printCDF('LU', landuse_in(:,:,1),'??') - do i = li0, li1 - do j = lj0, lj1 + do i = 1, limax + do j = 1, ljmax debug_flag = ( debug_proc .and. i == debug_li .and. j == debug_lj ) do lu = 1, NLanduse_DEF if ( landuse_in(i,j,lu) > 0.0 ) then @@ -234,8 +328,8 @@ subroutine ReadLanduse(filefound) if ( sumfrac < 0.99 .or. sumfrac > 1.01 ) then write(unit=errmsg,fmt="(a19,3i4,f12.4,8i4)") & "Land SumFrac Error ", me, & - i_fdom(i),j_fdom(j), sumfrac, li0, li1, lj0, lj1, & - i_fdom(li0), j_fdom(lj0), i_fdom(li1), j_fdom(lj1) + i_fdom(i),j_fdom(j), sumfrac, limax, ljmax, & + i_fdom(1), j_fdom(1), i_fdom(limax), j_fdom(ljmax) call CheckStop(errmsg) end if @@ -247,6 +341,111 @@ subroutine ReadLanduse(filefound) end subroutine ReadLanduse + subroutine ReadLanduse_CDF(filefound) + !Read data in other grid and interpolate to present grid + ! + !So far only basic version for use in TNO7. Under construction + ! + implicit none + logical :: filefound + integer :: i,j,lu, index_lu, maxlufound + logical :: debug_flag + real :: sumfrac + + + ! temporary arrays used. Will re-write one day.... + real, dimension(MAXLIMAX,MAXLJMAX,NLANDUSEMAX):: landuse_in ! tmp, with all data + real, dimension(MAXLIMAX,MAXLJMAX):: landuse_tmp ! tmp, with all data + real, dimension(MAXLIMAX,MAXLJMAX,NLUMAX):: landuse_data ! tmp, with all data + integer, dimension(MAXLIMAX,MAXLJMAX):: landuse_ncodes ! tmp, with all data + integer, dimension(MAXLIMAX,MAXLJMAX,NLUMAX):: landuse_codes ! tmp, with all data + + if ( DEBUG_LANDUSE .and. MasterProc ) & + write(*,*) "LANDUSE: Starting ReadLandUse " + + + if (MasterProc ) write(*,*) "LANDUSE_CDF: experimental so far" +! filefound=.false. +! return + + maxlufound = 0 + + landuse_ncodes(:,:) = 0 !/** initialise **/ + landuse_codes(:,:,:) = 0 !/** initialise **/ + landuse_data (:,:,:) = 0.0 !/** initialise **/ + + !hardcoded so far -> to softimize + + NLanduse_DEF=19 + Land_codes(1) = 'CF' + Land_codes(2) = 'DF' + Land_codes(3) = 'NF' + Land_codes(4) = 'BF' + Land_codes(5) = 'TC' + Land_codes(6) = 'MC' + Land_codes(7) = 'RC' + Land_codes(8) = 'SNL' + Land_codes(9) = 'GR' + Land_codes(10) = 'MS' + Land_codes(11) = 'WE' + Land_codes(12) = 'TU' + Land_codes(13) = 'DE' + Land_codes(14) = 'W' + Land_codes(15) = 'ICE' + Land_codes(16) = 'U' + Land_codes(17) = 'IAM_CR' + Land_codes(18) = 'IAM_DF' + Land_codes(19) = 'IAM_MF' + do lu=1,NLanduse_DEF + ! + if(me==0)write(*,*)'Reading landuse ',trim(Land_codes(lu)) + ! call ReadField_CDF('/global/work/mifapw/emep/Data/LanduseGLC.nc',&!fast but unprecise + call ReadField_CDF('Landuse_PS_5km.nc',& !SLOW! + Land_codes(lu),landuse_in(1,1,lu),1,interpol='conservative', & + needed=.true.,debug_flag=.false.,UnDef=-9.9E19) !NB: Undef must be largenegative, +! because it is averagad over many points, and the final result must still be negative + call ReadField_CDF('LanduseGLC.nc',& + Land_codes(lu),landuse_tmp,1,interpol='conservative', & + needed=.true.,debug_flag=.false.) + do j = 1, ljmax + do i = 1, limax + if(landuse_in(i,j,lu)<-0.1)landuse_in(i,j,lu)=landuse_tmp(i,j) + end do !j + end do !i + enddo + ! call printCDF('LU_cdf', landuse_in(:,:,1),'??') + + do i = 1, limax + do j = 1, ljmax + do lu = 1, NLanduse_DEF + if ( landuse_in(i,j,lu) > 0.0 ) then + + call GridAllocate("LANDUSE",i,j,lu,NLUMAX, & + index_lu, maxlufound, landuse_codes, landuse_ncodes) + landuse_data(i,j,index_lu) = & + landuse_data(i,j,index_lu) + landuse_in(i,j,lu)!already in fraction unit + endif + end do ! lu + LandCover(i,j)%ncodes = landuse_ncodes(i,j) + LandCover(i,j)%codes(:) = landuse_codes(i,j,:) + LandCover(i,j)%fraction(:) = landuse_data(i,j,:) + sumfrac = sum( LandCover(i,j)%fraction(:) ) + + if ( sumfrac < 0.99 .or. sumfrac > 1.01 ) then + write(unit=errmsg,fmt="(a19,3i4,f12.4,8i4)") & + "Land SumFrac Error ", me, & + i_fdom(i),j_fdom(j), sumfrac, limax, ljmax, & + i_fdom(1), j_fdom(1), i_fdom(limax), j_fdom(ljmax) + call CheckStop(errmsg) + end if + + end do !j + end do !i + + filefound=.true. + + end subroutine ReadLanduse_CDF + !========================================================================= subroutine SetLandUse() integer :: i,j,ilu,lu ! indices @@ -256,8 +455,7 @@ subroutine SetLandUse() logical :: debug_flag = .false. real :: hveg, lat_factor real :: xSAIadd - real, parameter ::water_fraction_THRESHOLD=0.5 - integer :: pft + integer :: pft ! Treatment of growing seasons in the southern hemisphere: ! all the static definitions (SGS,EGS...) refer to northern hemisphere, @@ -270,69 +468,13 @@ subroutine SetLandUse() write(*,*) "LANDUSE: SetLandUse, me, day ", me, daynumber, debug_proc end if + !====================================================================== if ( my_first_call ) then - - ! effectiv daynumber to shift 6 month when in southern hemisphere - effectivdaynumber=daynumber - - - !/ -- Calculate growing seasons where needed and water_fraction - ! (for Rn emissions) - - water_cover(:,:) = 0.0 !for Pb210 - ice_landcover(:,:) = 0.0 !for Pb210 - - do i = li0, li1 - do j = lj0, lj1 - - debug_flag = ( debug_proc .and. i == debug_li .and. j == debug_lj ) - do ilu= 1, LandCover(i,j)%ncodes - lu = LandCover(i,j)%codes(ilu) - call CheckStop( lu < 0 .or. lu > NLANDUSEMAX , & - "SetLandUse out of range" ) - - if ( LandDefs(lu)%SGS50 > 0 ) then ! need to set growing seasons - - call Growing_season( lu,abs(glat(i,j)),& - LandCover(i,j)%SGS(ilu),LandCover(i,j)%EGS(ilu) ) - else - LandCover(i,j)%SGS(ilu) = LandDefs(lu)%SGS50 - LandCover(i,j)%EGS(ilu) = LandDefs(lu)%EGS50 - end if - if ( DEBUG_LANDUSE .and. debug_flag ) & - write(*,"(a,i3,a20,2i4)")"LANDUSE: LU_SETGS", & - lu, LandDefs(lu)%name,& - LandCover(i,j)%SGS(ilu),LandCover(i,j)%EGS(ilu) - - - !/ for landuse classes with bulk-resistances, we only - ! need to specify height once. Dummy values are assigned - ! to LAI and gpot: - - if ( LandType(lu)%is_bulk ) then - LandCover(i,j)%hveg(ilu) = LandDefs(lu)%hveg_max - LandCover(i,j)%LAI(ilu) = 0.0 - LandCover(i,j)%fphen(ilu) = 0.0 - end if - - if ( LandType(lu)%is_water ) water_cover(i,j) = & - LandCover(i,j)%fraction(ilu) - if ( LandType(lu)%is_ice ) ice_landcover(i,j) = & - LandCover(i,j)%fraction(ilu) - - - end do ! ilu - if(.not. foundnwp_sea)then - if(water_cover(i,j)>water_fraction_THRESHOLD) & - nwp_sea(i,j) = .true. - endif - end do ! j - end do ! i - - water_cover_set = .true. ! just to inform other routines + !read in data from file my_first_call = .false. + + call InitLanduse() - !====================================================================== end if ! my_first_call !====================================================================== @@ -352,8 +494,8 @@ subroutine SetLandUse() end if - do i = li0, li1 - do j = lj0, lj1 + do i = 1, limax + do j = 1, ljmax effectivdaynumber=daynumber ! effectiv daynumber to shift 6 months when in southern hemisphere @@ -369,7 +511,11 @@ subroutine SetLandUse() lu = LandCover(i,j)%codes(ilu) pft = LandType(lu)%pft - if ( LandType(lu)%is_bulk ) cycle !else Growing veg present: + if ( LandType(lu)%is_bulk ) then + LandCover(i,j)%LAI(ilu) = 0.0 + LandCover(i,j)%SAI(ilu) = 0.0 + cycle + endif!else Growing veg present: LandCover(i,j)%LAI(ilu) = Polygon(effectivdaynumber, & 0.0, LandDefs(lu)%LAImin, LandDefs(lu)%LAImax,& @@ -451,6 +597,7 @@ subroutine SetLandUse() if ( DEBUG_LANDUSE.and.debug_proc ) then i=debug_li j=debug_lj + do ilu= 1, LandCover(i,j)%ncodes lu = LandCover(i,j)%codes(ilu) pft = LandType(lu)%pft @@ -462,9 +609,9 @@ subroutine SetLandUse() LandCover(i,j)%fphen(ilu), & LandCover(i,j)%SGS(ilu), LandCover(i,j)%EGS(ilu) end do - end if - end subroutine SetLandUse + end if + end subroutine SetLandUse ! ===================================================================== !======================================================================= diff --git a/LocalVariables_ml.f90 b/LocalVariables_ml.f90 index fec093f..3aa9dc4 100644 --- a/LocalVariables_ml.f90 +++ b/LocalVariables_ml.f90 @@ -57,12 +57,12 @@ module LocalVariables_ml real :: precip ! Precip at surface real :: wetarea ! Fraction of grid which is wet real :: cloud ! Cloud-cover (fraction) -!ACB integer :: snow ! 1=snow present, 0 = no snow logical :: snowice ! true is sdepth > 0 or ice>0 real :: sdepth ! snowdepth (m) real :: ice_nwp ! ice_nwp (%) real :: psurf ! Surface pressure (Pa) - real :: z_ref ! Height of grid centre (m) + real :: z_ref ! Used top of SL, = min(0.1 zi, z_mid) + real :: z_mid ! Height of grid centre (m) real :: DeltaZ ! Depth of grid centre (m) real :: qw_ref ! Specific humidity real :: rho_ref ! Air density (kg/m3) @@ -114,7 +114,7 @@ module LocalVariables_ml ,SGS = INOT_SET & ! Start, growing seasons (day num) ,EGS = INOT_SET ! End, growing seasons (day num) logical :: & - is_forest, is_water , is_veg, is_ice + is_forest, is_water , is_veg, is_ice, is_crop real :: & t2C = NOT_SET & ! Surface (2m) temperature in degrees C ,t2 = NOT_SET & ! Surface (2m) temperature in degrees K diff --git a/MARS_ml.f90 b/MARS_ml.f90 index ccaf54b..76e3360 100644 --- a/MARS_ml.f90 +++ b/MARS_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -33,14 +33,16 @@ module MARS_ml ! Presently not in use, EQSAM is used for inorganic equilibrium stuff !------------------------------------------------------------------------ - use Io_ml, only : ios + use CheckStop_ml, only : CheckStop + use Io_ml, only : ios, datewrite use MARS_Aero_water_ml, only: Awater - use ModelConstants_ml, only : NPROC + use ModelConstants_ml, only : NPROC, DEBUG_EQUIB use Par_ml, only : me implicit none private - real, parameter :: FLOOR = 1.0E-30 ! minimum concentration + real, parameter :: FLOOR = 1.0E-30 ! minimum concentration + ! -30 from RPM !/- subroutines: @@ -48,13 +50,23 @@ module MARS_ml cubic, & actcof + integer, private, save :: MAXNNN1 = 0 + integer, private, save :: MAXNNN2 = 0 + real, private, parameter :: & + MWNO3 = 62.0049 &! molecular weight for NO3 + ,MWHNO3 = 63.01287 &! .. HNO3 + ,MWSO4 = 96.0576 &! .. SO4 + ,MWHSO4 = MWSO4 + 1.0080 &! HSO4 + ,MH2SO4 = 98.07354 &! H2SO4 + ,MWNH3 = 17.03061 &! NH3 + ,MWNH4 = 18.03858 ! NH4 contains !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & ASO4, ANO3, AH2O, ANH4, GNH3, GNO3, & - ERRMARK,deb) + ERRMARK,debug_flag) !----------------------------------------------------------------------- !C @@ -202,7 +214,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & ,GNO3 & ! Gas-phase nitric acid in micrograms / m**3 ,GNH3 ! Gas-phase ammonia in micrograms / m**3 - logical, intent(in) :: deb + logical, intent(in) :: debug_flag !C...........INCLUDES and their descriptions !! INCLUDE SUBST_CONST ! constants @@ -212,26 +224,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & real MWNACL ! molecular weight for NaCl parameter ( MWNACL = 58.44277 ) - real MWNO3 ! molecular weight for NO3 - parameter ( MWNO3 = 62.0049 ) - - real MWHNO3 ! molecular weight for HNO3 - parameter ( MWHNO3 = 63.01287 ) - - real MWSO4 ! molecular weight for SO4 - parameter ( MWSO4 = 96.0576 ) - - real MWHSO4 ! molecular weight for HSO4 - parameter ( MWHSO4 = MWSO4 + 1.0080 ) - - real MH2SO4 ! molecular weight for H2SO4 - parameter ( MH2SO4 = 98.07354 ) - - real MWNH3 ! molecular weight for NH3 - parameter ( MWNH3 = 17.03061 ) - - real MWNH4 ! molecular weight for NH4 - parameter ( MWNH4 = 18.03858 ) +!emep moved a bunch upstairs. real MWORG ! molecular weight for Organic Species parameter ( MWORG = 16.0 ) @@ -254,7 +247,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !...........SCRATCH LOCAL VARIABLES and their descriptions: - REAL irh ! Index set to percent relative humidity + REAL fRH ! Index set to percent relative humidity INTEGER NITR ! Number of iterations for activity coefficients INTEGER NNN ! Loop index for iterations INTEGER NR ! Number of roots to cubic equation for HPLUS @@ -341,8 +334,8 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & parameter( MINSO4 = 1.0E-6 / MWSO4 ) real MINNO3 parameter( MINNO3 = 1.0E-6 / MWNO3 ) !2/25/99 IJA -!st real FLOOR -!st parameter( FLOOR = 1.0E-30) ! minimum concentration +!emep real FLOOR +!emep parameter( FLOOR = 1.0E-30) ! minimum concentration !2/25/99 IJA ! FSB New variables Total ammonia and nitrate mass concentrations real TMASSNH3 ! Total ammonia (gas and particle) @@ -353,6 +346,13 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !----------------------------------------------------------------------- ! begin body of subroutine RPMARES +!ASO4=FLOOR;ANO3=FLOOR;AH2O=FLOOR;ANH4=FLOOR;GNO3=FLOOR;GNH3=FLOOR +!Initialise the output variables + + ASO4=0.0;ANO3=0.0;AH2O=0.0;ANH4=0.0;GNO3=0.0;GNH3=0.0 + + ASO4 = SO4 ! from RPM + !...convert into micromoles/m**3 !..iamodels3 merge NH3/NH4 , HNO3,NO3 here @@ -367,14 +367,14 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & TMASSNH3 = MAX(0.0, NH3 + NH4 ) TMASSHNO3 = MAX(0.0, HNO3 + NO3 ) -!...now set humidity index IRH as a percent +!...now set humidity index fRH as a percent -!st IRH = NINT( 100.0 * RH ) - irh = RH -!...Check for valid IRH +! IRH = NINT( 100.0 * RH ) + fRH = RH +!...Check for valid fRH - irh = MAX( 0.01, IRH ) - irh = MIN( 0.99, IRH ) + fRH = MAX( 0.01, fRH ) + fRH = MIN( 0.99, fRH ) !...Specify the equilibrium constants at correct !... temperature. Also change units from ATM to MICROMOLE/M**3 (for KAN, @@ -419,6 +419,19 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & GAMAAN = 1.0 GAMOLD = 1.0 +!emep from RPM, but removed FLOOR : (slighty different logic) + if( (TSO4 < MINSO4 ) .and. (TNO3 < MINNO3) ) then + ASO4 = SO4 ! MAX.. + ANO3 = NO3 ! MAX.. + WH2O = 0.0 + AH2O = 0.0 + GNH3 = NH3 ! MAX(FLOOR,NH3) + GNO3 = NO3 ! MAX(FLOOR,NO3) + RETURN + END IF +!emep end rpm + + !...set the ratio according to the amount of sulfate and nitrate IF ( TSO4 > MINSO4 ) THEN @@ -433,12 +446,13 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & ! *** If there is very little sulfate and nitrate set concentrations ! to a very small value and return. - ASO4 = MAX(FLOOR, ASO4) - ANO3 = MAX(FLOOR, ANO3 ) +! Jun 2012, Note these values are set in the initialisation + ASO4 = SO4 ! MAX(FLOOR, ASO4) + ANO3 = NO3 ! MAX(FLOOR, ANO3 ) WH2O = 0.0 AH2O = 0.0 - GNH3 = MAX(FLOOR,GNH3) - GNO3 = MAX(FLOOR,GNO3) + GNH3 = NH3 ! MAX(FLOOR,GNH3) + GNO3 = NO3 ! MAX(FLOOR,GNO3) RETURN END IF @@ -458,7 +472,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !......... High Ammonia Case ........ !.................................... - IF ( RATIO > 2.0 ) THEN + IF ( RATIO > 2.0 ) THEN ! NH4/SO4 > 2 GAMAAN = 0.1 !...Set up twice the sulfate for future use. @@ -473,12 +487,23 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !... 10**(-6) kg water/ (cubic meter of air) !... start with ammomium sulfate solution without nitrate - CALL awater(IRH,TSO4,YNH4,TNO3,AH2O ) !**** note TNO3 + CALL awater(fRH,TSO4,YNH4,TNO3,AH2O ) !**** note TNO3 WH2O = 1.0E-3 * AH2O ASO4 = TSO4 * MWSO4 ANO3 = 0.0 ANH4 = YNH4 * MWNH4 - WFRAC = AH2O / ( ASO4 + ANH4 + AH2O ) +if(debug_flag) call datewrite("MARS debug ", -1,(/ ASO4, ANH4, AH2O /) ) + +if ( DEBUG_EQUIB ) then + if( ASO4 + ANH4 + AH2O < 1.0-10 ) then + call datewrite("MARS failing? ", -1,(/ ASO4, ANH4, AH2O /) ) + print *, "MARS PROB ", ASO4, ANH4, AH2O, TSO4, YNH4 + call CheckStop("MARS") + end if +end if + WFRAC = (AH2O + FLOOR) / ( ASO4 + ANH4 + AH2O + FLOOR ) + !emep WFRAC = AH2O / ( ASO4 + ANH4 + AH2O + FLOOR ) + !CRUDE FIX? WFRAC = AH2O / ( ASO4 + ANH4 + AH2O ) !!!! IF ( WFRAC == 0.0 ) RETURN ! No water IF ( WFRAC < 0.2 ) THEN @@ -490,7 +515,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !...check for not enough to support aerosol - IF ( CC <= 0.0 ) THEN + IF ( CC < FLOOR ) THEN XNO3 = 0.0 ELSE AA = 1.0 @@ -502,6 +527,8 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !2/25/99 IJA IF ( DISC < 0.0 ) THEN + if( DEBUG_EQUIB .and. debug_flag ) print *, & + "MARS DISC NEG ", XNO3, WH2O, DISC XNO3 = 0.0 AH2O = 1000.0 * WH2O YNH4 = TWOSO4 @@ -510,6 +537,10 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & ANO3 = NO3 ANH4 = YNH4 * MWNH4 GNH3 = TMASSNH3 - ANH4 + if( GNH3 < 0.0 ) then + print *, " NEG GNH3", TWOSO4, ANH4, TMASSNH3 + call CheckStop("NEG GNH3") + end if RETURN END IF @@ -527,10 +558,16 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & AH2O = 1000.0 * WH2O YNH4 = TWOSO4 + XNO3 ASO4 = TSO4 * MWSO4 - ANO3 = XNO3 * MWNO3 - ANH4 = YNH4 * MWNH4 + !dsSAFE ANO3 = XNO3 * MWNO3 + ANO3 = min(XNO3 * MWNO3, TMASSHNO3 ) + !dsSAFE ANH4 = YNH4 * MWNH4 ! ds should be safe as NH4/SO4 >2, but anyway: + ANH4 = min(YNH4 * MWNH4, TMASSNH3 ) ! ds should be safe as NH4/SO4 >2, but anyway: GNH3 = TMASSNH3 - ANH4 GNO3 = TMASSHNO3 - ANO3 + ! if( GNH3 < 0.0 .or. GNO3 < 0.0 ) then + ! print *, " NEG GNH3 GNO3", TWOSO4, ANH4, TMASSNH3, ANO3, TMASSHNO3 + ! call CheckStop("NEG GNH3 GNO3") + ! end if RETURN END IF @@ -562,41 +599,66 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & DISC = BB * BB - 4.0 * AA * CC + if( DEBUG_EQUIB ) then + MAXNNN1 = NNN + !if( MAXNNN1 > 140) print "(a,i4,9es12.3)", "NNN1 ", NNN, DISC, TNO3, TNH4, TWOSO4 + end if !...Check for complex roots, retain inital values and RETURN !2/25/99 IJA IF ( DISC < 0.0 ) THEN +if( DEBUG_EQUIB .and. debug_flag ) print *, "MARS DISC NEG2 ", XNO3, WH2O, DISC XNO3 = 0.0 AH2O = 1000.0 * WH2O YNH4 = TWOSO4 GNO3 = HNO3 ASO4 = TSO4 * MWSO4 ANO3 = NO3 - ANH4 = YNH4 * MWNH4 + !ANH4 = YNH4 * MWNH4 + ANH4 = min( YNH4 * MWNH4, TMASSNH3) ! ds added "min" GNH3 = TMASSNH3 - ANH4 -!!! WRITE( 10, * ) ' COMPLEX ROOTS ' + !WRITE( 10, * ) ' COMPLEX ROOTS ' RETURN END IF ! 2/25/99 IJA ! Deal with degenerate case (yoj) - IF ( AA /= 0.0 ) THEN - DD = SQRT( DISC ) - XXQ = -0.5 * ( BB + SIGN ( 1.0, BB ) * DD ) - RR1 = XXQ / AA - RR2 = CC / XXQ - -!...choose minimum positve root - - IF ( ( RR1 * RR2 ) < 0.0 ) THEN - XNO3 = MAX( RR1, RR2 ) - ELSE - XNO3 = MIN( RR1, RR2 ) - END IF + !emep IF ( AA /= 0.0 ) THEN + IF ( abs(AA) > FLOOR ) THEN + if( DEBUG_EQUIB .and. debug_flag ) print "(a,9es11.3)", "MARS DEGEN ", XNO3, WH2O, DISC, AA, BB, CC + DD = SQRT( DISC ) + XXQ = -0.5 * ( BB + SIGN ( 1.0, BB ) * DD ) + RR1 = XXQ / AA + RR2 = CC / XXQ + + !...choose minimum positve root + + IF ( ( RR1 * RR2 ) < 0.0 ) THEN + if( DEBUG_EQUIB .and. debug_flag ) print "(a,10es10.3)", "MARS RR1*RR2 ", XNO3, WH2O, DISC, RR1, RR2 + XNO3 = MAX( RR1, RR2 ) + ELSE if(MIN( RR1, RR2 )>0.0)then + XNO3 = MIN( RR1, RR2 ) + ELSE!two negative roots !emep added 4th July 2012 + + !--------------------- return copied from above + XNO3 = 0.0 + AH2O = 1000.0 * WH2O + YNH4 = TWOSO4 + GNO3 = HNO3 + ASO4 = TSO4 * MWSO4 + ANO3 = NO3 + !emep ANH4 = YNH4 * MWNH4 + ANH4 = min( YNH4 * MWNH4, TMASSNH3) ! emep added "min" + GNH3 = TMASSNH3 - ANH4 + if( DEBUG_EQUIB .and. debug_flag ) WRITE( *, * ) ' TWO NEG ROOTS ' + RETURN + + END IF ELSE - XNO3 = - CC / BB + XNO3 = - CC / BB ! AA equals zero here +if( DEBUG_EQUIB .and. debug_flag ) print "(a,4es10.3)", "MARS NONDEGEN ", AA, BB, CC, XNO3 END IF XNO3 = MIN( XNO3, TNO3 ) @@ -604,7 +666,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !...This version assumes no solid sulfate forms (supersaturated ) !... Now update water - CALL AWATER ( IRH, TSO4, YNH4, XNO3, AH2O) + CALL AWATER ( fRH, TSO4, YNH4, XNO3, AH2O) !...ZSR relationship is used to set water levels. Units are !... 10**(-6) kg water/ (cubic meter of air) @@ -635,7 +697,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & AN ( 1 ) = MAS AN ( 2 ) = MAN AN ( 3 ) = 0.0 - CALL ACTCOF ( CAT, AN, GAMS, MOLNU, PHIBAR , ERRMARK,1,deb) + CALL ACTCOF ( CAT, AN, GAMS, MOLNU, PHIBAR , ERRMARK,1,debug_flag) GAMAAN = GAMS( 2, 2 ) !...Use GAMAAN for convergence control @@ -650,8 +712,10 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !!! & GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR ! 2/25/99 IJA ASO4 = TSO4 * MWSO4 - ANO3 = XNO3 * MWNO3 - ANH4 = YNH4 * MWNH4 +! ANO3 = XNO3 * MWNO3 + ANO3 = min(XNO3 * MWNO3,TMASSHNO3) !pw added min + !ANH4 = YNH4 * MWNH4 + ANH4 = min( YNH4 * MWNH4, TMASSNH3 ) ! ds pw added "min" GNO3 = TMASSHNO3 - ANO3 GNH3 = TMASSNH3 - ANH4 AH2O = 1000.0 * WH2O @@ -667,8 +731,9 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & ANO3 = NO3 XNO3 = NO3 / MWNO3 YNH4 = TWOSO4 - ANH4 = YNH4 * MWNH4 - CALL AWATER ( IRH, TSO4, YNH4, XNO3, AH2O) +! ANH4 = YNH4 * MWNH4 + ANH4 = min( YNH4 * MWNH4, TMASSNH3 ) ! ds pw added "min" + CALL AWATER ( fRH, TSO4, YNH4, XNO3, AH2O) GNO3 = HNO3 GNH3 = TMASSNH3 - ANH4 RETURN @@ -685,7 +750,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !...All cases covered by this logic WH2O = 0.0 - CALL AWATER ( IRH, TSO4, TNH4, TNO3, AH2O ) + CALL AWATER ( fRH, TSO4, TNH4, TNO3, AH2O ) WH2O = 1.0E-3 * AH2O ZH2O = AH2O @@ -694,13 +759,15 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & ! 2/25/99 IJA ASO4 = TSO4 * MWSO4 ANH4 = TNH4 * MWNH4 - ANO3 = NO3 + !dsSAFE ANO3 = NO3 + ANO3 = min( NO3, TMASSHNO3 ) GNO3 = TMASSHNO3 - ANO3 GNH3 = FLOOR !...Check for zero water. - IF ( WH2O == 0.0 ) RETURN + !emep IF ( WH2O == 0.0 ) RETURN + IF ( abs(WH2O) < FLOOR ) RETURN ZSO4 = TSO4 / WH2O !...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4 @@ -735,6 +802,10 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !...loop for iteration DO 1601 NNN = 1, 150 + if( DEBUG_EQUIB ) then + if(NNN > MAXNNN2 ) MAXNNN2 = NNN + !if( MAXNNN2 > 140) print *, "NNN2 ", NNN, TNO3, TNH4, TWOSO4 + end if NITR = NNN !...set up equilibrium constants including activities @@ -766,9 +837,13 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & MNA = MAX( 0.0, MNA ) MNA = MIN( MNA, TNO3 / WH2O ) XNO3 = MNA * WH2O - ANO3 = MNA * WH2O * MWNO3 + !ds ANO3 = MNA * WH2O * MWNO3 + ANO3 = min( TMASSHNO3, MNA * WH2O * MWNO3) ! 2/25/99 IJA GNO3 = TMASSHNO3 - ANO3 + if( DEBUG_EQUIB ) then + if (GNO3 < 0.0 ) call CheckStop("NNN2 GNO3 NEG") + end if !...Calculate ionic strength @@ -776,7 +851,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & !...Update water - CALL AWATER ( IRH, TSO4, YNH4, XNO3, AH2O ) + CALL AWATER ( fRH, TSO4, YNH4, XNO3, AH2O ) !...Convert 10**(-6) kg water/(cubic meter of air) to micrograms of water !... per cubic meter of air (1000 g = 1 kg) @@ -788,7 +863,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & AN ( 2 ) = MNA AN ( 3 ) = MHSO4 - CALL ACTCOF ( CAT, AN, GAMS, MOLNU, PHIBAR, ERRMARK,2,deb) + CALL ACTCOF ( CAT, AN, GAMS, MOLNU, PHIBAR, ERRMARK,2,debug_flag) GAMANA = GAMS( 1, 2 ) GAMAS1 = GAMS( 1, 1 ) @@ -820,7 +895,7 @@ subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & GNH3 = FLOOR GNO3 = HNO3 ANO3 = NO3 - CALL AWATER ( IRH, TSO4, TNH4, TNO3, AH2O ) + CALL AWATER ( fRH, TSO4, TNH4, TNO3, AH2O ) RETURN END IF ! ratio .gt. 2.0 @@ -848,7 +923,11 @@ subroutine cubic(a2,a1,a0,nr,crutes) real :: dum1,dum2,part1,part2,part3,rrsq,phi,yy1,yy2,yy3 real :: costh, sinth - data sqrt3/1.732050808/, one3rd/0.333333333/ +!emep: 7 digits not enough! data sqrt3/1.732050808/, one3rd/0.333333333/ + + sqrt3=sqrt(3.0) + one3rd=1.0/3.0 + !======= a2sq=a2*a2 @@ -902,8 +981,8 @@ subroutine cubic(a2,a1,a0,nr,crutes) !IA ACTIONIA if(crutes(1) <= 0.0) THEN crutes(1) = 1.0e9 - !! if(deb ) write(6,*) 'WARNING: NEGATIVE ROOTS IN CUBIC', crutes(1) - !!st stop + !! if(debug_flag ) write(6,*) 'WARNING: NEGATIVE ROOTS IN CUBIC', crutes(1) + !! stop end if nr=1 end if @@ -913,7 +992,7 @@ end subroutine cubic !>-------------------------------------------------------------------------------< !<-------------------------------------------------------------------------------> - subroutine actcof ( CAT, AN, GAMA, MOLNU, PHIMULT , ERRMARK, IA2, deb) + subroutine actcof ( CAT, AN, GAMA, MOLNU, PHIMULT , ERRMARK, IA2, debug_flag) !C----------------------------------------------------------------------- !C @@ -988,7 +1067,7 @@ subroutine actcof ( CAT, AN, GAMA, MOLNU, PHIMULT , ERRMARK, IA2, deb) ,molnu & ! tot # moles of all ions ,phimult ! multicomponent paractical osmotic coef real, intent(out) :: gama(2,3) ! mean molal ionic activity coefs - logical, intent(in) :: deb + logical, intent(in) :: debug_flag !.................................................................... @@ -1002,7 +1081,7 @@ subroutine actcof ( CAT, AN, GAMA, MOLNU, PHIMULT , ERRMARK, IA2, deb) PARAMETER (XSTAT3 = 3) INTEGER ERRMARK INTEGER IA2 - CHARACTER*120 XMSG + CHARACTER(len=120) :: XMSG !...........PARAMETERS and their descriptions: @@ -1015,8 +1094,7 @@ subroutine actcof ( CAT, AN, GAMA, MOLNU, PHIMULT , ERRMARK, IA2, deb) !...........SCRATCH LOCAL VARIABLES and their descriptions: - CHARACTER*16 PNAME ! driver program name - SAVE PNAME + CHARACTER(len=16), save :: PNAME ! driver program name INTEGER IAN ! anion indX INTEGER ICAT ! cation indX @@ -1117,12 +1195,12 @@ subroutine actcof ( CAT, AN, GAMA, MOLNU, PHIMULT , ERRMARK, IA2, deb) END DO XMSG = 'Ionic strength is zero...returning zero activities' - if(deb ) WRITE(6,*) XMSG + if(debug_flag ) WRITE(6,*) XMSG RETURN ELSE IF ( I .LT. 0.0 ) THEN XMSG = 'Ionic strength below zero...negative concentrations' - if(deb ) then + if(debug_flag ) then WRITE(6,*) XMSG WRITE(6,*) 'called over ', IA2 WRITE(6,*) ' I =', I @@ -1220,7 +1298,7 @@ subroutine actcof ( CAT, AN, GAMA, MOLNU, PHIMULT , ERRMARK, IA2, deb) IF ( TRM > 30.0 ) THEN GAMA( ICAT, IAN ) = 1.0E+30 XMSG = 'Multicomponent activity coefficient is >>' - !! if(deb ) WRITE(6,*) XMSG, gama(icat,ian) + !! if(debug_flag ) WRITE(6,*) XMSG, gama(icat,ian) ERRMARK=2 ELSE diff --git a/Makefile b/Makefile old mode 100755 new mode 100644 index a962f56..8d6f3bf --- a/Makefile +++ b/Makefile @@ -7,9 +7,9 @@ include Makefile.SRCS ################################################### -LIBS = -lnetcdf -INCL = -I/global/apps/netcdf/3.6.2/include -LLIB = -L/global/apps/netcdf/3.6.2/lib +LIBS = -lnetcdf -lnetcdff +INCL = -I/global/apps/netcdf/4.1.3/include +LLIB = -L/global/apps/netcdf/4.1.3/lib F90 = mpif90 diff --git a/Makefile.SRCS b/Makefile.SRCS index 3d01cbf..1bba097 100644 --- a/Makefile.SRCS +++ b/Makefile.SRCS @@ -11,36 +11,13 @@ SRCS = Aero_Vds_ml.f90 Ammonium_ml.f90 AOD_PM_ml.f90 Advection_ml.f90 AirEmis_ml LandPFT_ml.f90 LocalVariables_ml.f90 MARS_ml.f90 MARS_Aero_water_ml.f90 \ MassBudget_ml.f90 Met_ml.f90 MetFields_ml.f90 EQSAM_ml.f90 MicroMet_ml.f90 \ ModelConstants_ml.f90 MosaicOutputs_ml.f90 My_Aerosols_ml.f90 My_Derived_ml.f90 \ - My_Emis_ml.f90 My_SOA_ml.f90 My_Outputs_ml.f90 NetCDF_ml.f90 \ + My_ExternalBICs_ml.f90 My_SOA_ml.f90 My_Outputs_ml.f90 NetCDF_ml.f90 \ Nest_ml.f90 Output_hourly.f90 OutputChem_ml.f90 OwnDataTypes_ml.f90 Par_ml.f90 \ PhysicalConstants_ml.f90 Radiation_ml.f90 Rb_ml.f90 \ ReadField_ml.f90 Rsurface_ml.f90 Runchem_ml.f90 Setup_1d_ml.f90 \ Setup_1dfields_ml.f90 Sites_ml.f90 SmallUtils_ml.f90 SoilWater_ml.f90 Solver.f90 \ SeaSalt_ml.f90 StoFlux_ml.f90 \ SubMet_ml.f90 Tabulations_ml.f90 TimeDate_ml.f90 TimeDate_ExtraUtil_ml.f90 Timefactors_ml.f90 Timing_ml.f90 \ - Trajectory_ml.f90 Unimod.f90 Volcanos_ml.f90 Wesely_ml.f90 \ + Trajectory_ml.f90 Units_ml.f90 Unimod.f90 Volcanos_ml.f90 Wesely_ml.f90 \ global2local.f90 local2global.f90 PhyChem_ml.f90 -#============================================================================= -FOBJ = Aero_Vds_ml.o Ammonium_ml.o AOD_PM_ml.o Advection_ml.o AirEmis_ml.o \ - AOTnPOD_ml.o Aqueous_n_WetDep_ml.o BLPhysics_ml.o Biogenics_ml.o \ - BoundaryConditions_ml.o CellMet_ml.o CheckStop_ml.o Chem_ml.o CoDep_ml.o Country_ml.o \ - ChemFunctions_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemRates_ml.o Convection_ml.o \ - DefPhotolysis_ml.o Derived_ml.o DerivedFields_ml.o DO3SE_ml.o DryDep_ml.o DustProd_ml.o \ - EcoSystem_ml.o EmisDef_ml.o EmisGet_ml.o Emissions_ml.o ForestFire_ml.o Functions_ml.o \ - GlobalBCs_ml.o GridAllocate_ml.o GridValues_ml.o \ - InterpolationRoutines_ml.o \ - Io_ml.o Io_Nums_ml.o Io_Progs_ml.o KeyValue_ml.o LandDefs_ml.o Landuse_ml.o \ - LandPFT_ml.o LocalVariables_ml.o MARS_ml.o MARS_Aero_water_ml.o \ - MassBudget_ml.o Met_ml.o MetFields_ml.o EQSAM_ml.o MicroMet_ml.o \ - ModelConstants_ml.o MosaicOutputs_ml.o My_Aerosols_ml.o My_Derived_ml.o \ - My_Emis_ml.o My_SOA_ml.o My_Outputs_ml.o NetCDF_ml.o \ - Nest_ml.o Output_hourly.o OutputChem_ml.o OwnDataTypes_ml.o Par_ml.o \ - PhysicalConstants_ml.o Radiation_ml.o Rb_ml.o \ - ReadField_ml.o Rsurface_ml.o Runchem_ml.o Setup_1d_ml.o \ - Setup_1dfields_ml.o Sites_ml.o SmallUtils_ml.o SoilWater_ml.o Solver.o \ - SeaSalt_ml.o StoFlux_ml.o \ - SubMet_ml.o Tabulations_ml.o TimeDate_ml.o TimeDate_ExtraUtil_ml.o Timefactors_ml.o Timing_ml.o \ - Trajectory_ml.o Unimod.o Volcanos_ml.o Wesely_ml.o \ - global2local.o local2global.o PhyChem_ml.o - diff --git a/MassBudget_ml.f90 b/MassBudget_ml.f90 index 6cc944d..7ed6823 100644 --- a/MassBudget_ml.f90 +++ b/MassBudget_ml.f90 @@ -1,9 +1,9 @@ ! -!*****************************************************************************! -!* +!*****************************************************************************! +!* !* Copyright (C) 2007-2011 met.no -!* +!* !* Contact information: !* Norwegian Meteorological Institute !* Box 43 Blindern @@ -11,434 +11,348 @@ !* NORWAY !* email: emep.mscw@met.no !* http://www.emep.int -!* +!* !* 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 MassBudget_ml - -! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -! DESCRIPTION +! ---------------------------------------------------------------------------- +module MassBudget_ml +! ---------------------------------------------------------------------------- +! DESCRIPTION ! Routine to cross check the mass balance of the model -! 29/10/02 - output formatting and descriptions improved, ds. -! 1/10/01 - code for derived fields removed. MY_MASS_PRINT ADDED, ds -! Oct, 2001 - ** new ** mass budget method by jej -! Nov.2001, ds, "use" statements moved to top, much code moved to REMOVED -! section at end !_____________________________________________________________________________ +use CheckStop_ml, only: CheckStop +use ChemChemicals_ml, only: species_adv ! species identifier (advected only) +use ChemSpecs_adv_ml, only: NSPEC_ADV ! No. species (long-lived) +use ChemSpecs_shl_ml, only: NSPEC_SHL ! No. species (shorshort-lived) +use Chemfields_ml, only: xn_adv ! advected species +use GridValues_ml, only: carea,xmd, & ! cell area, 1/xm2 where xm2 is + ! the area factor in the middle of the cell + gridwidth_m,dA,dB,debug_proc,debug_li,debug_lj +use Io_ml, only: IO_RES, PrintLog, datewrite +use MetFields_ml, only: ps ! surface pressure +use ModelConstants_ml, only: KMAX_MID,KCHEMTOP,& ! Start and upper k for 1d fields + MasterProc, & ! Master processor + dt_advec, & ! time-step + PT, & ! Pressure at top + ATWAIR, & ! Mol. weight of air(Jones,1992) + DEBUG_MASS,EXTENDEDMASSBUDGET +use Par_ml, only: & + li0,li1,& ! First/Last local index in longitude when outer boundary is excluded + lj0,lj1 ! First/Last local index in latitude when outer boundary is excluded +use PhysicalConstants_ml,only: GRAV +use Setup_1dfields_ml, only: amk, rcemis ! Air concentrations , emissions -!! use DryDep_ml, only : NDRYDEP_ADV, DDepMap , DryDep_Budget - - use ChemChemicals_ml, only : species ! species identifier - use ChemSpecs_tot_ml, only : NSPEC_TOT ! No. species (long-lived) - use ChemSpecs_adv_ml, only : NSPEC_ADV ! No. species (long-lived) - use ChemSpecs_shl_ml, only : NSPEC_SHL ! No. species (shorshort-lived) - use Chemfields_ml , only : xn_adv ! advective flag - use GridValues_ml , only : carea,xmd ! cell area, 1/xm2 where xm2 is - ! the area factor in the middle - ! of the cell - use Io_ml , only : IO_RES ! =25 - use MetFields_ml , only : ps ! surface pressure - use ModelConstants_ml, & - only : KMAX_MID & ! Number of levels in vertical - ,MasterProc & ! Master processor - ,NPROC & ! No. processors - ,PT & ! Pressure at top - ,ATWAIR & ! Mol. weight of air(Jones,1992) - ,TXTLEN_NAME& - ,EXTENDEDMASSBUDGET - use Par_ml, only : MAXLIMAX & - ,MAXLJMAX & - ,li0,li1 & - ,lj0,lj1 & - ,limax,ljmax& - ,gi0, gj0 & - ,GIMAX,GJMAX - use Setup_1dfields_ml, only : amk ! Air concentrations - -!Variable listing -!MAXLIMAX ==> Maximum number of local points in longitude -!MAXLJMAX ==> Maximum number of local points in latitude -!li0 ==> First local index in longitude when -! outer boundary is excluded -!li1 ==> Last local index in longitude when -! outer boundary is excluded -!lj0 ==> First local index in latitude when -! outer boundary is excluded -!lj1 ==> Last local index in latitude when -! outer boundary is excluded -!NPROC ==> Total no. of processors for parallel computation -!limax ==> Actual number of local points in longitude -!ljmax ==> Actual number of local points in latitude -!me ==> Address of processer, host=0 (numbering starts at 0 -! in south-west corner of ground level -!gi0 ==> Global address of longitude start point -!gj0 ==> Global address of latitute start point -!GIMAX = 132 ==> Number of global points in longitude -!GJMAX = 111 ==> Number of global points in latitude - - implicit none private - INCLUDE 'mpif.h' - INTEGER STATUS(MPI_STATUS_SIZE),INFO - real MPIbuff(NSPEC_ADV*KMAX_MID) +INCLUDE 'mpif.h' +INTEGER STATUS(MPI_STATUS_SIZE),INFO +real MPIbuff(NSPEC_ADV*KMAX_MID) -! Some work arrays used in Aqueous_ml and (in future) DryDry -! Use tot index for convenience - real, public, save, dimension(NSPEC_TOT) :: & - wdeploss, & - ddeploss +! Some work arrays used in Aqueous_ml and (in future) DryDry: +! Use ADV index, as Dry/WetDep makes no seance for SHL. +real, public, save, dimension(NSPEC_ADV) :: & +wdeploss=0.0, ddeploss=0.0 ! The following parameters are used to check the global mass budget: ! Initialise here also. - - real, public, save, dimension(NSPEC_ADV) :: & - sumint = 0.0 & ! initial mass - ,fluxin = 0.0 & ! mass in across lateral boundaries - ,fluxout = 0.0 & ! mass out across lateral boundaries - ,totddep = 0.0 & ! total dry dep - ,totwdep = 0.0 & ! total wet dep - ,totem = 0.0 & ! total emissions - ,totox = 0.0 & ! total oxidation - ,totldep = 0.0 ! local deposition (not in use - Lagrangian) - - real, public, save, dimension(NSPEC_ADV) :: & - amax = -2.0 & ! maximum concentration in field -2 - ,amin = 2.0 ! minimum concentration in field 2 - - public :: Init_massbudget - public :: massbudget -! public :: DryDep_Budget +real, public, save, dimension(NSPEC_ADV) :: & + sumint = 0.0, & ! initial mass + fluxin = 0.0, & ! mass in across lateral boundaries + fluxout = 0.0, & ! mass out across lateral boundaries + totddep = 0.0, & ! total dry dep + totwdep = 0.0, & ! total wet dep + totem = 0.0, & ! total emissions + totox = 0.0, & ! total oxidation + totldep = 0.0 ! local deposition (not in use - Lagrangian) + +real, public, save, dimension(NSPEC_ADV) :: & + amax = -2.0, & ! maximum concentration in field -2 + amin = 2.0 ! minimum concentration in field 2 + +public :: Init_massbudget +public :: massbudget +public :: emis_massbudget_1d +!public :: DryDep_Budget contains -!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - - subroutine Init_massbudget() - ! Initialise mass-budget - calculate mass of concentrations fields - ! within 3-D grid, after boundary conditions - ! - !---------------------------------------------------------------------- - - integer i, j, k, n, info ! lon,lat,lev indexes - ! n - No. of species - ! info - printing info - real rwork - - do k=2,KMAX_MID - do j=lj0,lj1 - do i=li0,li1 - rwork = carea(k)* xmd(i,j)*(ps(i,j,1) - PT) - sumint(:) = sumint(:) + xn_adv(:,i,j,k)*rwork ! sumint in kg - enddo +!---------------------------------------------------------------------------- +subroutine Init_massbudget() +! Initialise mass-budget - calculate mass of concentrations fields +! within 3-D grid, after boundary conditions +! +!---------------------------------------------------------------------- + integer i, j, k, n, info ! lon,lat,lev indexes + ! n - No. of species + ! info - printing info + real rwork + + do k=2,KMAX_MID + do j=lj0,lj1 + do i=li0,li1 + rwork = carea(k)* xmd(i,j)*(ps(i,j,1) - PT) + sumint(:) = sumint(:) + xn_adv(:,i,j,k)*rwork ! sumint in kg enddo enddo + enddo - MPIbuff(1:NSPEC_ADV)= sumint (1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, sumint , NSPEC_ADV, & - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) - - if(MasterProc.and.EXTENDEDMASSBUDGET)then - do n = 1,NSPEC_ADV - if(sumint(n) > 0. ) then - write(IO_RES,"(a15,i4,4x,e10.3)") "Initial mass",n,sumint(n) - write(6,"(a15,i4,4x,e10.3)") "Initial mass",n,sumint(n) - end if - enddo - end if - - end subroutine Init_massbudget - - -!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - subroutine massbudget() - - ! Converted from old masbud.f by ds, March 2001 - ! sums over all sulphur and nitrogen, so is model independant. - - - integer :: i, j, k, n, nn, info ! lon,lat,lev indexes - ! n - No. of species - ! nn - Total no. of short - ! lived and advected species - ! info - printing info - integer :: ifam ! family index - real, dimension(NSPEC_ADV,KMAX_MID) :: sumk ! total mass in each layer - integer, parameter :: NFAMILIES = 3 ! No. of families - character(len=8), dimension(NFAMILIES), save :: family_name = & - (/ "Sulphur ", "Nitrogen", "Carbon " /) - - real, dimension(NFAMILIES) ::family_init & ! initial total mass of - ! species family - ,family_mass & ! total family mass at the - ! end of the model run - ,family_inflow &! total family mass flowing in - ,family_outflow&! total family mass flowing out - ,family_ddep& ! total family mass dry dep. - ,family_wdep& ! total family mass wet dep. - ,family_em & ! total family mass emitted - ,family_input & ! total family mass input - ,family_fracmass ! mass fraction (should be 1.0) - - real, dimension(NSPEC_ADV) :: & - xmax, xmin, & ! min and max value for the individual species - sum_mass, & ! total mass of species - frac_mass, & ! mass budget fraction (should=1) for groups of species - gfluxin, gfluxout, & ! flux in and out - gtotem, & ! total emission - gtotddep, gtotwdep, & ! total dry and wet deposition - gtotldep, & ! local dry deposition - gtotox ! oxidation of SO2 - - real :: totdiv,helsum, natoms - - sum_mass(:) = 0. - frac_mass(:) = 0. - xmax(:) = -2. - xmin (:) = 2. - gfluxin(:) = fluxin(:) - gfluxout(:) = fluxout(:) - gtotem(:) = totem(:) - gtotddep(:) = totddep(:) - gtotwdep(:) = totwdep(:) - gtotldep(:) = totldep(:) - gtotox(:) = totox(:) + MPIbuff(1:NSPEC_ADV)= sumint (1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, sumint , NSPEC_ADV, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + if(MasterProc.and.EXTENDEDMASSBUDGET)then + do n = 1,NSPEC_ADV + if(sumint(n)<=0.) cycle + write(IO_RES,"(a15,i4,4x,e10.3)") "Initial mass",n,sumint(n) + write(*,"(a15,i4,4x,e10.3)") "Initial mass",n,sumint(n) + enddo + endif - sumk(:,:) = 0. + endsubroutine Init_massbudget +!---------------------------------------------------------------------------- +!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx +subroutine emis_massbudget_1d(i,j) + integer, intent(in) :: i,j ! coordinates of column + integer :: k, iadv, itot ! loop variables + real :: scaling, scaling_k - do k = 1,KMAX_MID - do j = lj0,lj1 - do i = li0,li1 + !Mass Budget calculations + ! Adding up the emissions in each timestep - helsum = carea(k)*xmd(i,j) * (ps(i,j,1) - PT) + !Do not include values on outer frame + if(ili1.or.jlj1)return - xmax(:) = amax1(xmax(:),xn_adv(:,i,j,k)) - xmin(:) = amin1(xmin(:),xn_adv(:,i,j,k)) + scaling = dt_advec * xmd(i,j)* gridwidth_m*gridwidth_m / GRAV - sumk(:,k) = sumk(:,k) + xn_adv(:,i,j,k)*helsum + do k = KCHEMTOP,KMAX_MID + scaling_k = scaling * (dA(k) + dB(k)*ps(i,j,1))/amk(k) + if(all((/DEBUG_MASS,debug_proc,i==debug_li,j==debug_lj/)))& + call datewrite("MASSRC ",k,(/dB(k)*ps(i,j,1),xmd(i,j),ps(i,j,1),scaling_k/)) - enddo - enddo + do iadv = 1, NSPEC_ADV + itot = iadv + NSPEC_SHL + totem(iadv) = totem(iadv) + rcemis( itot, k ) * scaling_k enddo + enddo ! k loop + +endsubroutine emis_massbudget_1d +!---------------------------------------------------------------------------- +subroutine massbudget() +! sums over all sulphur and nitrogen, so is model independant. + + integer :: i, j, k, n, nn, info ! lon,lat,lev indexes + ! n - No. of species + ! nn - Total no. of short lived and advected species + ! info - printing info + integer :: ifam ! family index + real, dimension(NSPEC_ADV,KMAX_MID) :: sumk ! total mass in each layer + integer, parameter :: NFAMILIES = 3 ! No. of families + character(len=*), dimension(NFAMILIES), parameter :: & + family_name = (/ "Sulphur ", "Nitrogen", "Carbon " /) + character(len=200) :: logtxt + + real, dimension(NFAMILIES) ::& + family_init, & ! initial total mass of species family + family_mass, & ! total family mass at the end of the model run + family_inflow, & ! total family mass flowing in + family_outflow, & ! total family mass flowing out + family_ddep, & ! total family mass dry dep. + family_wdep, & ! total family mass wet dep. + family_em, & ! total family mass emitted + family_input, & ! total family mass input + family_fracmass ! mass fraction (should be 1.0) - - - MPIbuff(1:NSPEC_ADV)= xmax(1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, xmax, NSPEC_ADV,& - MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, INFO) - MPIbuff(1:NSPEC_ADV)= xmin (1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, xmin , NSPEC_ADV, & - MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, INFO) - MPIbuff(1:NSPEC_ADV)= gfluxin (1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, gfluxin , NSPEC_ADV, & - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) - MPIbuff(1:NSPEC_ADV)= gfluxout (1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, gfluxout , NSPEC_ADV, & - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) - MPIbuff(1:NSPEC_ADV)= gtotem (1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, gtotem , NSPEC_ADV, & - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) - MPIbuff(1:NSPEC_ADV)= gtotddep (1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, gtotddep , NSPEC_ADV, & - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) - MPIbuff(1:NSPEC_ADV)= gtotwdep (1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, gtotwdep , NSPEC_ADV, & - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) - MPIbuff(1:NSPEC_ADV)= gtotldep (1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, gtotldep , NSPEC_ADV, & - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) - MPIbuff(1:NSPEC_ADV)= gtotox (1:NSPEC_ADV) - CALL MPI_ALLREDUCE(MPIbuff, gtotox , NSPEC_ADV, & - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) - j=0 - do k=1,KMAX_MID - do i=1,NSPEC_ADV - j=j+1 - MPIbuff(j)= sumk (i,k) - enddo + real, dimension(NSPEC_ADV) :: & + xmax, xmin, & ! min and max value for the individual species + sum_mass, & ! total mass of species + frac_mass, & ! mass budget fraction (should=1) for groups of species + gfluxin,gfluxout, & ! flux in and out + gtotem, & ! total emission + gtotddep, gtotwdep, & ! total dry and wet deposition + gtotldep, & ! local dry deposition + gtotox, & ! oxidation of SO2 + natoms ! number of S, N or C atoms + + real :: totdiv,helsum + + sum_mass(:) = 0.0 + frac_mass(:) = 0.0 + xmax(:) =-2.0 + xmin (:) = 2.0 + gfluxin(:) = fluxin(:) + gfluxout(:) = fluxout(:) + gtotem(:) = totem(:) + gtotddep(:) = totddep(:) + gtotwdep(:) = totwdep(:) + gtotldep(:) = totldep(:) + gtotox(:) = totox(:) + sumk(:,:) = 0.0 + + do k = 1,KMAX_MID + do j = lj0,lj1 + do i = li0,li1 + helsum = carea(k)*xmd(i,j) * (ps(i,j,1) - PT) + xmax(:) = amax1(xmax(:),xn_adv(:,i,j,k)) + xmin(:) = amin1(xmin(:),xn_adv(:,i,j,k)) + sumk(:,k) = sumk(:,k) + xn_adv(:,i,j,k)*helsum + + if(all((/DEBUG_MASS,debug_proc,i==debug_li,j==debug_lj/)))& + call datewrite("MASSBUD",k,(/carea(k),ps(i,j,1),PT,xmd(i,j)/)) enddo - CALL MPI_ALLREDUCE(MPIbuff, sumk , NSPEC_ADV*KMAX_MID, & - MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + enddo + enddo + + MPIbuff(1:NSPEC_ADV)= xmax(1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, xmax, NSPEC_ADV,& + MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, INFO) + MPIbuff(1:NSPEC_ADV)= xmin (1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, xmin , NSPEC_ADV, & + MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, INFO) + MPIbuff(1:NSPEC_ADV)= gfluxin (1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, gfluxin , NSPEC_ADV, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + MPIbuff(1:NSPEC_ADV)= gfluxout (1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, gfluxout , NSPEC_ADV, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + MPIbuff(1:NSPEC_ADV)= gtotem (1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, gtotem , NSPEC_ADV, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + MPIbuff(1:NSPEC_ADV)= gtotddep (1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, gtotddep , NSPEC_ADV, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + MPIbuff(1:NSPEC_ADV)= gtotwdep (1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, gtotwdep , NSPEC_ADV, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + MPIbuff(1:NSPEC_ADV)= gtotldep (1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, gtotldep , NSPEC_ADV, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + MPIbuff(1:NSPEC_ADV)= gtotox (1:NSPEC_ADV) + CALL MPI_ALLREDUCE(MPIbuff, gtotox , NSPEC_ADV, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + j=0 + do k=1,KMAX_MID + do i=1,NSPEC_ADV + j=j+1 + MPIbuff(j)= sumk(i,k) + enddo + enddo + CALL MPI_ALLREDUCE(MPIbuff, sumk , NSPEC_ADV*KMAX_MID, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) -! make some temporary variables used to hold the sum over all +! make some temporary variables used to hold the sum over all ! domains. Remember that sumint already holds the sum over all ! domains, see inass ! - amax(:) = max( amax(:), xmax(:) ) - amin(:) = min( amin(:), xmin(:) ) - do k = 2,KMAX_MID - sum_mass(:) = sum_mass(:)+sumk(:,k) + amax(:) = max( amax(:), xmax(:) ) + amin(:) = min( amin(:), xmin(:) ) + do k = 2,KMAX_MID + sum_mass(:) = sum_mass(:)+sumk(:,k) + enddo + + do n = 1,NSPEC_ADV + totdiv = sumint(n) + gtotem(n) + gfluxin(n) + frac_mass(n) = sum_mass(n) + (gtotddep(n)+gtotwdep(n))*ATWAIR + gfluxout(n) + if(totdiv>0.0) frac_mass(n) = frac_mass(n)/totdiv + enddo + + + if(MasterProc) then ! printout from node 0 + if(EXTENDEDMASSBUDGET)then + do n=1,NSPEC_ADV + if(gtotem(n)>0.0) write(*,*)'tot. emission of species ',n,gtotem(n) + enddo + endif + + call PrintLog('++++++++++++++++++++++++++++++++++++++++++++++++') + do ifam = 1, 3 + write(logtxt,"(a,i3,a12)") 'Mass balance ', ifam, family_name(ifam) + call PrintLog(logtxt) + select case(ifam) + case(1);natoms = real(species_adv(:)%sulphurs) + case(2);natoms = real(species_adv(:)%nitrogens) + case(3);natoms = real(species_adv(:)%carbons) + endselect + + family_init(ifam) = dot_product(sumint(:) ,natoms(:)) + family_mass(ifam) = dot_product(sum_mass(:),natoms(:)) + family_inflow(ifam) = dot_product(gfluxin(:) ,natoms(:)) + family_outflow(ifam)= dot_product(gfluxout(:),natoms(:)) + family_ddep(ifam) = dot_product(gtotddep(:),natoms(:)) + family_wdep(ifam) = dot_product(gtotwdep(:),natoms(:)) + family_em(ifam) = dot_product(gtotem(:) ,natoms(:)) + + family_input(ifam) = family_init(ifam) & + + family_inflow(ifam) & + + family_em(ifam) + + if(family_input(ifam)>0.0) & + family_fracmass(ifam) = (family_mass(ifam) & + + family_outflow(ifam) & + + family_ddep(ifam)*ATWAIR & + + family_wdep(ifam)*ATWAIR) & + / family_input(ifam) + + + call PrintLog('++++++++++++++++++++++++++++++++++++++++++++++++') + write(logtxt,"(a9,5a12)")" ","sumint","summas","fluxout","fluxin","fracmass" + call PrintLog(logtxt) + + write(logtxt,"(a9,5es12.4)") family_name(ifam), & + family_init(ifam), family_mass(ifam), family_outflow(ifam), & + family_inflow(ifam), family_fracmass(ifam) + call PrintLog(logtxt) + + write(logtxt,"(a9,3a14)")"ifam","totddep","totwdep","totem" + call PrintLog(logtxt) + write(logtxt,"(i9,3es14.3)") ifam, & + family_ddep(ifam)*ATWAIR, family_wdep(ifam)*ATWAIR, family_em(ifam) + call PrintLog(logtxt) + call PrintLog('++++++++++++++++++++++++++++++++++++++++++++++++') + enddo ! ifam = 1,3 + endif + + if(MasterProc.and.EXTENDEDMASSBUDGET) then ! printout from node 0 + !/.. now use species array which is set in My_MassBudget_ml + do n=1,NSPEC_ADV + write(IO_RES,*) + write(*,*) + do k=1,KMAX_MID + write(IO_RES,"(' Spec ',i3,2x,a12,5x,'k= ',i2,5x,es12.5)")& + n,species_adv(n)%name, k,sumk(n,k) + write(* ,"(' Spec ',i3,2x,a12,5x,'k= ',i2,5x,es12.5)")& + n,species_adv(n)%name, k,sumk(n,k) + enddo enddo - - - - do n = 1,NSPEC_ADV - - totdiv = sumint(n) + gtotem(n) + gfluxin(n) - frac_mass(n) = sum_mass(n) + (gtotddep(n)+gtotwdep(n))*ATWAIR & - + gfluxout(n) - - if(totdiv > 0.0 ) frac_mass(n) = frac_mass(n)/totdiv - - - end do - - - if ( MasterProc ) then ! printout from node 0 - - do n = 1,NSPEC_ADV - if (gtotem(n) > 0.0 .and. EXTENDEDMASSBUDGET) write(6,*) & - 'tot. emission of species ',n,gtotem(n) - end do - - family_init(:) = 0. - family_mass(:) = 0. - family_inflow(:) = 0. - family_outflow(:) = 0. - family_input(:) = 0. - family_fracmass(:) = 0. - family_ddep(:) = 0. - family_wdep(:) = 0. - family_em(:) = 0. - natoms = 0.0 - - write(6,*)'++++++++++++++++++++++++++++++++++++++++++++++++' - - do ifam = 1, 3 - - write(6,"(a8,i3,a12)") 'family ', ifam, family_name(ifam) - do n = 1, NSPEC_ADV - - nn = NSPEC_SHL + n - - - if ( ifam == 1 ) natoms = real(species(nn)%sulphurs) - - if ( ifam == 2 ) natoms = real(species(nn)%nitrogens) - - if ( ifam == 3 ) natoms = real(species(nn)%carbons) - - if (natoms > 0) then - family_init(ifam) = family_init(ifam) + sumint(n)*natoms - family_mass(ifam) = family_mass(ifam) + sum_mass(n)*natoms - family_inflow(ifam) = family_inflow(ifam) + gfluxin(n)*natoms - family_outflow(ifam) = family_outflow(ifam) + gfluxout(n)*natoms - family_ddep(ifam) = family_ddep(ifam) + gtotddep(n)*natoms - family_wdep(ifam) = family_wdep(ifam) + gtotwdep(n)*natoms - family_em(ifam) = family_em(ifam) + gtotem(n)*natoms - end if - end do ! NSPEC_ADV - - family_input(ifam) = family_init(ifam) & - + family_inflow(ifam) & - + family_em(ifam) - - if (family_input(ifam) > 0.0 ) & - family_fracmass(ifam) = (family_mass(ifam) & - + family_outflow(ifam) & - + family_ddep(ifam)*ATWAIR & - + family_wdep(ifam)*ATWAIR) & - / family_input(ifam) - - - write(6,*)'++++++++++++++++++++++++++++++++++++++++++++++++' - write(6,*) - - write(6,"(a9,5a12)") "family", "sumint", "summas", & - "fluxout","fluxin", "fracmass" - write(6,"(a9,5es12.4)") family_name(ifam), & - family_init(ifam), family_mass(ifam),family_outflow(ifam), & - family_inflow(ifam), family_fracmass(ifam) - - write(6,*) - write(6,"(a9,3a14)") "ifam", "totddep","totwdep","totem" - write(6,"(i9,3es14.3)") ifam, family_ddep(ifam)*ATWAIR & - , family_wdep(ifam)*ATWAIR & - , family_em(ifam) - write(6,*) - write(6,*)'++++++++++++++++++++++++++++++++++++++++++++++++' - - end do ! ifam = 1,3 - - - end if - - if ( MasterProc .and. EXTENDEDMASSBUDGET) then ! printout from node 0 - - !/.. now use species array which is set in My_MassBudget_ml - do n = 1,NSPEC_ADV - write(6,*) - write(IO_RES,*) - do k = 1,KMAX_MID - write(6,950) n,species(n+NSPEC_SHL)%name, k,sumk(n,k) - write(IO_RES,950) n,species(n+NSPEC_SHL)%name, k,sumk(n,k) - end do - enddo -950 format(' Spec ',i3,2x,a12,5x,'k= ',i2,5x,es12.5) - - do n = 1,NSPEC_ADV - - write(6,*) - write(6,*)'++++++++++++++++++++++++++++++++++++++++++++++++' - write(6,*) - - write(6,"(a3,6a12)") " n ", "Spec", "sumint", "summas", & - "fluxout","fluxin", "fracmass" - write(6,"(i3,1x,a11,5es12.4)") n,species(n+NSPEC_SHL)%name, & - sumint(n),sum_mass(n), gfluxout(n),gfluxin(n), frac_mass(n) - - write(6,*) - write(6,"(a3,6a12)") " n ", "species", & - "totox", "totddep", "totwdep", "totem", "totldep" - write(6,"(i3,1x,a11,5es12.4)") n, species(n+NSPEC_SHL)%name, & - gtotox(n), gtotddep(n), gtotwdep(n), gtotem(n), gtotldep(n) - write(6,*) - write(6,*)'++++++++++++++++++++++++++++++++++++++++++++++++' - + do n=1,NSPEC_ADV + write(*,*) + write(*,*)'++++++++++++++++++++++++++++++++++++++++++++++++' + write(*,*) + write(*,"(a3,6a12)")" n ", "Spec", & + "sumint", "summas", "fluxout", "fluxin", "fracmass" + write(*,"(i3,1x,a11,5es12.4)") n,species_adv(n)%name, & + sumint(n), sum_mass(n), gfluxout(n), gfluxin(n), frac_mass(n) + write(*,*) + write(*,"(a3,6a12)") " n ", "species", & + "totox", "totddep", "totwdep", "totem", "totldep" + write(*,"(i3,1x,a11,5es12.4)") n, species_adv(n)%name, & + gtotox(n), gtotddep(n), gtotwdep(n), gtotem(n), gtotldep(n) + write(*,*) + write(*,*)'++++++++++++++++++++++++++++++++++++++++++++++++' enddo -! - - end if ! MasterProc - - end subroutine massbudget - - - -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> -! -! subroutine DryDep_Budget(i,j,Loss,convfac) -! !use ChemSpecs_adv_ml -! -! real, dimension(NSPEC_ADV), intent(in) :: Loss -! real, dimension(NSPEC_ADV) :: DryLoss -! -! real, intent(in) :: convfac -! integer :: n,nadv,i,j ! index in IXADV_ arrays -! -! DryLoss(:)=Loss(:)* convfac /amk(KMAX_MID) !molec/cm3->mix ratio -! -! do n = 1, NDRYDEP_ADV -! nadv = DDepMap(n)%ind -! totddep( nadv ) = totddep (nadv) + DryLoss(nadv) -! -! enddo -! end subroutine DryDep_Budget -! -!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + endif ! MasterProc +endsubroutine massbudget +!-------------------------------------------------------------------------- end module MassBudget_ml !-------------------------------------------------------------------------- diff --git a/MetFields_ml.f90 b/MetFields_ml.f90 index 31e1610..a76ab77 100644 --- a/MetFields_ml.f90 +++ b/MetFields_ml.f90 @@ -1,8 +1,5 @@ module MetFields_ml - use ModelConstants_ml, only : KMAX_BND,KMAX_MID,NMET & - ,IIFULLDOM, JJFULLDOM - use Par_ml, only : MAXLIMAX,MAXLJMAX,GIMAX,GJMAX, me & - ,limax,ljmax,li0,li1,lj0,lj1 + implicit none private @@ -87,33 +84,33 @@ module MetFields_ml ! Vertical level geopotential heights: - real,public, save, & - dimension(MAXLIMAX,MAXLJMAX,KMAX_BND) :: z_bnd ! height of full layers - real,public, save, & - dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: z_mid ! height of half layers + real,public, save, allocatable,& + dimension(:,:,:) :: z_bnd ! height of full layers + real,public, save,allocatable, & + dimension(:,:,:) :: z_mid ! height of half layers ! Two sets of Met. fields are read in, and a linear interpolation is made ! between these two points in time. NMET == 2 (two points in time) ! note u_xmj, v_xmi are not "real" m/s wind speeds ! - they are actually divided by the mapping factor in the perpendicular direction). ! - real,public, save, dimension(0:MAXLIMAX,MAXLJMAX,KMAX_MID,NMET) :: u_xmj - real,public, save, dimension(MAXLIMAX,0:MAXLJMAX,KMAX_MID,NMET) :: v_xmi + real,public, save,allocatable, dimension(:,:,:,:) :: u_xmj + real,public, save,allocatable, dimension(:,:,:,:) :: v_xmi - real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID,NMET) :: & + real,public, save,allocatable, dimension(:,:,:,:) :: & th & ! Potential teperature ( deg. k ) ,q & ! Specific humidity ,roa & ! kg/m3 ,cw ! cloudwater - real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_BND,NMET) :: & + real,public, save,allocatable, dimension(:,:,:,:) :: & SigmaKz &! vertical diffusivity in sigma coords ,sdot &! vertical velocity, sigma coords, 1/s ,Kz_met ! vertical diffusivity in sigma coordinates from meteorology ! since pr,cc3d,cc3dmax,cnvuf,cnvdf used only for 1 time layer - define without NMET - real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: & + real,public, save,allocatable, dimension(:,:,:) :: & pr & ! Precipitation ,cc3d & ! 3-d cloud cover (cc3d), ,cc3dmax & ! and maximum for layers above a given layer @@ -121,7 +118,7 @@ module MetFields_ml ! QUERY - should xksig be MID, not BND? Is it needed at all? ,Kz_m2s ! estimated Kz, in intermediate sigma levels, m2/s - real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_BND) :: & + real,public, save,allocatable, dimension(:,:,:) :: & cnvuf & ! convective_updraft_flux (kg/s/m2) ,cnvdf ! convective_downdraft_flux (kg/s/m2) @@ -129,14 +126,14 @@ module MetFields_ml ! We don't need to calculate u,v for RiB, Kz for all layer in future maybe ! Still, for safety we let this extent to K=1 for now - real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: & + real,public, save,allocatable, dimension(:,:,:) :: & u_mid & ! wind u-compnent, m/s (real, not projected) ,v_mid ! wind v-compnent, m/s ! Surface fields, interpolated: - real,public, save, dimension(MAXLIMAX,MAXLJMAX,NMET) :: & + real,public, save,allocatable, dimension(:,:,:) :: & ps &! Surface pressure Pa ,t2_nwp & ! Temp 2 m deg. K ,fh & ! surf.flux.sens.heat W/m^2 @@ -144,7 +141,7 @@ module MetFields_ml ,tau & ! surf. stress N/m^2 ! These fields only available for EMEP/PARLAM from 2002 on ,rh2m & ! RH at 2m - ,SoilWater & ! Shallow (Upper 7.2cm in PARLAM) + ,SoilWater_uppr & ! Shallow (Upper 7.2cm in PARLAM) ,SoilWater_deep & ! Deep (Next 6x7cm in PARLAM), converted to relative value ,sdepth & ! Snowdepth, m ,ice_nwp & ! QUERY why real? @@ -152,29 +149,30 @@ module MetFields_ml ,ws_10m ! wind speed 10m - real,public, save, dimension(MAXLIMAX,MAXLJMAX) :: & + real,public, save,allocatable, dimension(:,:) :: & u_ref & ! wind speed m/s at 45m (real, not projected) ,rho_surf & ! Surface density ,surface_precip & ! Surface precip mm/hr ,Tpot2m & ! Potential temp at 2m ,ustar_nwp & ! friction velocity m/s ustar^2 = tau/roa ,invL_nwp & ! friction velocity m/s ustar^2 = tau/roa - ,pzpbl ! stores H(ABL) for averaging and plotting purposes, m - + ,pzpbl & ! stores H(ABL) for averaging and plotting purposes, m + ,pwp & ! Permanent Wilting Point + ,fc ! Field Capacity ! temporary placement of solar radiation variations QUERY? - real, public, dimension(MAXLIMAX, MAXLJMAX), save:: & + real, public,allocatable, dimension(:,:), save:: & zen & ! Zenith angle (degrees) - ,coszen=0.0 & ! cos of zenith angle + ,coszen & ! cos of zenith angle ,Idiffuse & ! diffuse solar radiation (W/m^2) ,Idirect ! total direct solar radiation (W/m^2) - logical,public, save, dimension(MAXLIMAX,MAXLJMAX) :: & + logical,public, save,allocatable, dimension(:,:) :: & nwp_sea ! Sea in NWP mode, determined in HIRLAM from roughness class - real,public, save, dimension(MAXLIMAX,MAXLJMAX) :: & !st-dust + real,public, save,allocatable, dimension(:,:) :: & !st-dust clay_frac & ! clay fraction (%) in the soil ,sand_frac ! sand fraction (%) in the soil @@ -182,6 +180,16 @@ module MetFields_ml ! cope with two: character(len=10), public, save :: SoilWaterSource ! IFS or PARLAM + real,public, save, allocatable,dimension(:,:) :: & + fSW ! fSW= f(relative extractable water) = (sw-swmin)/(swFC-swmin) + + real, public, dimension(:,:), save,allocatable ::& + xwf ! extension of water fraction, save after 1st call + + integer, parameter, public :: NEXTEND = 2 ! no. box to side of (i,j) + + integer, public, save :: Nhh & ! number of field stored per 24 hours + ,nhour_first ! time of the first meteo stored ! Logical flags, used to determine if some met fields are present in the ! input or not: logical, public, save :: & @@ -189,7 +197,7 @@ module MetFields_ml ,foundsdot & ! If not found: compute using divergence=0 ,sdot_at_mid & ! set false if sdot is defined ,foundSST & ! false if no SeaSurfaceT in metdata - ,foundSoilWater & ! false if no SW-shallow + ,foundSoilWater_uppr & ! false if no SW-shallow ,foundSoilWater_deep & ! false if no SW-deep ,foundsdepth & ! false if no snow_flag depth in metdata ,foundice & ! false if no ice_nwp coverage (%) in metdata @@ -203,6 +211,73 @@ module MetFields_ml ,foundu10_met & ! false if no u10 from meteorology ,foundv10_met & ! false if no v10 from meteorology ,foundprecip & ! false if no precipitationfrom meteorology - ,foundcloudwater !false if no cloudwater found + ,foundcloudwater& !false if no cloudwater found + ,foundSMI1& ! false if no Soil Moisture Index level 1 (shallow) + ,foundSMI3 ! false if no Soil Moisture Index level 3 (deep) + + + public :: Alloc_MetFields !allocate arrays + +contains + +subroutine Alloc_MetFields(MAXLIMAX,MAXLJMAX,KMAX_MID,KMAX_BND,NMET) +!allocate MetFields arrays arrays + implicit none + + integer, intent(in) ::MAXLIMAX,MAXLJMAX,KMAX_MID,KMAX_BND,NMET + + allocate(u_xmj(0:MAXLIMAX,MAXLJMAX,KMAX_MID,NMET)) + allocate(v_xmi(MAXLIMAX,0:MAXLJMAX,KMAX_MID,NMET)) + allocate(th(MAXLIMAX,MAXLJMAX,KMAX_MID,NMET)) + allocate(q(MAXLIMAX,MAXLJMAX,KMAX_MID,NMET)) + allocate(roa(MAXLIMAX,MAXLJMAX,KMAX_MID,NMET)) + allocate(cw(MAXLIMAX,MAXLJMAX,KMAX_MID,NMET)) + allocate(SigmaKz(MAXLIMAX,MAXLJMAX,KMAX_BND,NMET)) + allocate(sdot(MAXLIMAX,MAXLJMAX,KMAX_BND,NMET)) + allocate(Kz_met(MAXLIMAX,MAXLJMAX,KMAX_BND,NMET)) + allocate(pr(MAXLIMAX,MAXLJMAX,KMAX_MID)) + allocate(cc3d(MAXLIMAX,MAXLJMAX,KMAX_MID)) + allocate(cc3dmax(MAXLIMAX,MAXLJMAX,KMAX_MID)) + allocate(lwc(MAXLIMAX,MAXLJMAX,KMAX_MID)) + allocate(Kz_m2s(MAXLIMAX,MAXLJMAX,KMAX_MID)) + allocate(cnvuf(MAXLIMAX,MAXLJMAX,KMAX_BND)) + allocate(cnvdf(MAXLIMAX,MAXLJMAX,KMAX_BND)) + allocate(u_mid(MAXLIMAX,MAXLJMAX,KMAX_MID)) + allocate(v_mid(MAXLIMAX,MAXLJMAX,KMAX_MID)) + allocate(ps(MAXLIMAX,MAXLJMAX,NMET)) + allocate(t2_nwp(MAXLIMAX,MAXLJMAX,NMET)) + allocate(fh(MAXLIMAX,MAXLJMAX,NMET)) + allocate(fl(MAXLIMAX,MAXLJMAX,NMET)) + allocate(tau(MAXLIMAX,MAXLJMAX,NMET)) + allocate(rh2m(MAXLIMAX,MAXLJMAX,NMET)) + allocate(SoilWater_uppr(MAXLIMAX,MAXLJMAX,NMET)) + allocate(SoilWater_deep(MAXLIMAX,MAXLJMAX,NMET)) + allocate(sdepth(MAXLIMAX,MAXLJMAX,NMET)) + allocate(ice_nwp(MAXLIMAX,MAXLJMAX,NMET)) + allocate(sst(MAXLIMAX,MAXLJMAX,NMET)) + allocate(ws_10m(MAXLIMAX,MAXLJMAX,NMET)) + allocate(u_ref(MAXLIMAX,MAXLJMAX)) + allocate(rho_surf(MAXLIMAX,MAXLJMAX)) + allocate(surface_precip(MAXLIMAX,MAXLJMAX)) + allocate(Tpot2m(MAXLIMAX,MAXLJMAX)) + allocate(ustar_nwp(MAXLIMAX,MAXLJMAX)) + allocate(invL_nwp(MAXLIMAX,MAXLJMAX)) + allocate(pzpbl(MAXLIMAX,MAXLJMAX)) + allocate(pwp(MAXLIMAX,MAXLJMAX)) + allocate(fc(MAXLIMAX,MAXLJMAX)) + allocate(xwf(MAXLIMAX+2*NEXTEND,MAXLJMAX+2*NEXTEND)) + allocate(fSW(MAXLIMAX,MAXLJMAX)) + fSW = 1.0 + allocate(zen(MAXLIMAX, MAXLJMAX)) + allocate(coszen(MAXLIMAX, MAXLJMAX)) + coszen=0.0 + allocate(Idiffuse(MAXLIMAX, MAXLJMAX)) + allocate(Idirect(MAXLIMAX, MAXLJMAX)) + allocate(nwp_sea(MAXLIMAX, MAXLJMAX)) + allocate(clay_frac(MAXLIMAX, MAXLJMAX)) + allocate(sand_frac(MAXLIMAX, MAXLJMAX)) + + + end subroutine Alloc_MetFields end module MetFields_ml diff --git a/Met_ml.f90 b/Met_ml.f90 index c7ae607..38d23f0 100644 --- a/Met_ml.f90 +++ b/Met_ml.f90 @@ -79,6 +79,7 @@ module Met_ml ,Test_BLM & ! Tests all Kz, Hmix routines ,PBL_ZiMAX, PBL_ZiMIN & ! max and min PBL heights ,JericevicRiB_Hmix & ! TESTING + ,JericevicRiB_Hmix0 & ! Used, now allows shallow SBL ,Venkatram_Hmix & ! TESTING ,Zilitinkevich_Hmix & ! TESTING ,SeibertRiB_Hmix_3d & ! TESTING @@ -93,42 +94,48 @@ module Met_ml use CheckStop_ml, only : CheckStop,StopAll use Functions_ml, only : Exner_tab, Exner_nd - use GridValues_ml, only : xmd, i_fdom, j_fdom, METEOfelt, projection & + use Functions_ml, only : T_2_Tpot !OS_TESTS + use GridValues_ml, only : xmd, i_fdom, j_fdom, i_local,j_local& + ,glon,glat,gl_stagg,gb_stagg,glat_fdom,glon_fdom& + ,xm_i,xm_j ,xm2,xmd,xm2ji,xmdji,GridArea_m2& + , projection & ,glon,glat, glat_fdom, glon_fdom, MIN_ADVGRIDS & - ,Poles, Pole_included, xm_i, xm_j, xm2, sigma_bnd,sigma_mid & + ,Poles, xm_i, xm_j, xm2, sigma_bnd,sigma_mid & ,xp, yp, fi, GRIDWIDTH_M,ref_latitude & ,debug_proc, debug_li, debug_lj & ,grid_north_pole_latitude,grid_north_pole_longitude & - ,GlobalPosition,DefGrid,gl_stagg,gb_stagg,A_mid,B_mid + ,GlobalPosition,DefGrid,gl_stagg,gb_stagg,A_mid,B_mid & + ,GridRead - use Landuse_ml, only : water_cover, water_cover_set + use Io_ml , only : ios, IO_ROUGH, datewrite,PrintLog, & + IO_CLAY, IO_SAND, open_file, IO_LOG + use Landuse_ml, only : water_fraction, water_frac_set, likely_coastal use MetFields_ml use MicroMet_ml, only : PsiH ! Only if USE_MIN_KZ - use ModelConstants_ml, only : PASCAL, PT, CLOUDTHRES, METSTEP & - ,KMAX_BND,KMAX_MID,NMET & - ,IIFULLDOM, JJFULLDOM, NPROC & + use ModelConstants_ml, only : PASCAL, PT, METSTEP & + ,KMAX_BND,KMAX_MID,NMET,KCHEMTOP & + ,IIFULLDOM, JJFULLDOM, RUNDOMAIN,NPROC & ,MasterProc, DEBUG_MET,DEBUG_i, DEBUG_j, identi, V_RAIN, nmax & - ,DEBUG_BLM, DEBUG_Kz, DEBUG_SOILWATER & + ,DEBUG_BLM, DEBUG_Kz, DEBUG_SOILWATER,DEBUG_LANDIFY & ,NH3_U10 & !FUTURE ,DomainName & !HIRHAM,EMEP,EECCA etc. ,USE_DUST, USE_SOILWATER & ,nstep,USE_CONVECTION & - ,CW_THRESHOLD,RH_THRESHOLD + ,LANDIFY_MET & + ,CW_THRESHOLD,RH_THRESHOLD, CW2CC use Par_ml , only : MAXLIMAX,MAXLJMAX,GIMAX,GJMAX, me & - ,limax,ljmax,li0,li1,lj0,lj1 & + ,limax,ljmax & ,neighbor,WEST,EAST,SOUTH,NORTH,NOPROC & ,MSG_NORTH2,MSG_EAST2,MSG_SOUTH2,MSG_WEST2 & - ,MFSIZEINP, IRUNBEG,JRUNBEG, tgi0, tgj0,gi0,gj0 & - ,MSG_INIT3,MSG_READ4, tlimax, tljmax, parinit + ,IRUNBEG,JRUNBEG, tgi0, tgj0,gi0,gj0 & + ,MSG_INIT3,MSG_READ4, tlimax, tljmax use PhysicalConstants_ml, only : KARMAN, KAPPA, RGAS_KG, CP, GRAV & ,ROWATER, PI use TimeDate_ml, only : current_date, date,Init_nmdays,nmdays, & add_secs,timestamp,& make_timestamp, make_current_date, nydays, startdate, enddate - use Io_ml , only : ios, IO_ROUGH, & - IO_CLAY, IO_SAND, open_file, IO_LOG use ReadField_ml, only : ReadField ! reads ascii fields - use NetCDF_ml, only : printCDF ! testoutputs + use NetCDF_ml, only : printCDF,ReadField_CDF ! testoutputs use netcdf use TimeDate_ExtraUtil_ml,only: nctime2idate,date2string @@ -145,16 +152,19 @@ module Met_ml integer, private, save :: debug_iloc, debug_jloc ! local coords - integer, save :: Nhh & ! number of field stored per 24 hours - ,nhour_first& ! time of the first meteo stored - ,nrec ! nrec=record in meteofile, for example + integer, save :: nrec ! nrec=record in meteofile, for example ! (Nhh=8): 1=00:00 2=03:00 ... 8=21:00 ! if nhour_first=3 then 1=03:00 2=06:00...8=24:00 + logical, save, private :: xwf_done = .false. ! extended water-fraction array + character (len = 100) :: field_not_found='field_not_found' + integer*2, allocatable ::var_global(:,:,:) ! faster if defined with + + ! Aid for debugging check routine + character (len = 100), private, save :: call_msg=" Not set" - public :: MeteoGridRead public :: MeteoRead public :: MetModel_LandUse public :: metvar @@ -162,6 +172,8 @@ module Met_ml public :: BLPhysics public :: GetCDF_short public :: extendarea ! returns array which includes neighbours + public :: Getmeteofield + public :: landify ! replaces met variables from mixed sea/land with land contains @@ -191,19 +203,13 @@ subroutine MeteoRead(numt) real :: nsec ! step in seconds - real :: temp(MAXLIMAX,MAXLJMAX)!temporary metfields - ! Avergaing of soil water used box from +/- NEXTEND (e.g. -1 to +1) - integer, parameter :: NEXTEND = 2 ! no. box to side of (i,j) - real, dimension(MAXLIMAX+2*NEXTEND,MAXLJMAX+2*NEXTEND), save ::& - xwf ! extension of water fraction, save after 1st call - real, dimension(MAXLIMAX+2*NEXTEND,MAXLJMAX+2*NEXTEND) ::& - xsw ! extension of soil water - real :: tmpsw, landfrac, sumland ! for soil water averaging + real :: buff(MAXLIMAX,MAXLJMAX)!temporary metfields real :: SoilMax ! Max value soil-water-deep, used to normalise SW - integer :: i, j, ii,jj,ii2,jj2 - logical :: fexist , xwf_done + integer :: i, j + logical :: fexist nr=2 !set to one only when the first time meteo is read + call_msg = "Meteoread" if(numt == 1)then !first time meteo is read @@ -213,13 +219,15 @@ subroutine MeteoRead(numt) foundustar = .false. foundsdot = .false. foundSST = .false. - foundSoilWater = .false. + foundSoilWater_uppr = .false. foundSoilWater_deep = .false. foundKz_met = .false. ! Kz from meteo foundu10_met = .false. ! from FUTURE NH3emis foundv10_met = .false. ! from FUTURE NH3emis foundprecip = .false. foundcloudwater = .false. + foundSMI1=.false. + foundSMI3=.false. next_inptime = current_date @@ -227,6 +235,11 @@ subroutine MeteoRead(numt) ! xp and yp should be shifted here, and coordinates must be shifted when ! meteofields are read (not yet implemented) + if(MasterProc)then + allocate(var_global(GIMAX,GJMAX,KMAX_MID)) + else + allocate(var_global(1,1,1)) !just to have the array defined + endif else @@ -332,11 +345,20 @@ subroutine MeteoRead(numt) namefield='3D_cloudcover' call Getmeteofield(meteoname,namefield,nrec,ndim,& unit,validity, cc3d(:,:,:)) - call CheckStop(validity==field_not_found, "meteo field not found:" // trim(namefield)) - - if(trim(validity)/='averaged')then + if(validity/=field_not_found.and.trim(validity)/='averaged')then if(MasterProc.and.numt==1)write(*,*)'WARNING: 3D cloud cover is not averaged' endif + if(validity==field_not_found)then + !if available, will use cloudwater to determine the height of release + namefield='cloudwater' + foundcloudwater = .true. + call Getmeteofield(meteoname,namefield,nrec,ndim,& + unit,validity, cc3d(:,:,:)) + call CheckStop(validity==field_not_found, "meteo field not found: 3D_cloudcover and" // trim(namefield)) + cc3d(:,:,:)=min(0.0,max(100.0,cc3d(:,:,:)*CW2CC))!from kg/kg water to % clouds + if(MasterProc.and.numt==1)write(*,*)'WARNING: 3D cloud cover not found, using CloudWater instead' + endif + namefield='precipitation' call Getmeteofield(meteoname,namefield,nrec,ndim,& @@ -351,9 +373,9 @@ subroutine MeteoRead(numt) call CheckStop(validity==field_not_found, "meteo field not found:" // trim(namefield)) namefield='convective_precipitations' call Getmeteofield(meteoname,namefield,nrec,2,& - unit,validity, temp(:,:)) + unit,validity, buff(:,:)) call CheckStop(validity==field_not_found, "meteo field not found:" // trim(namefield)) - surface_precip=surface_precip+temp + surface_precip=surface_precip+buff !if available, will use cloudwater to determine the height of release namefield='cloudwater' @@ -407,12 +429,13 @@ subroutine MeteoRead(numt) foundKz_met = .true. endif Kz_met=max(0.0,Kz_met) ! only positive Kz - end if - if( debug_proc .and. DEBUG_Kz)then + + if( debug_proc .and. DEBUG_Kz)then write(6,*) & '*** After Kz', sum(Kz_met(:,:,:,nr)), minval(Kz_met(:,:,:,nr)), & maxval(Kz_met(:,:,:,nr)),maxval(Kz_met(:,:,KMAX_BND,nr)), & DEBUG_Kz, NWP_Kz, nr, nrec, ndim, namefield + end if endif @@ -432,6 +455,8 @@ subroutine MeteoRead(numt) call Getmeteofield(meteoname,namefield,nrec,ndim,& unit,validity, t2_nwp(:,:,nr)) call CheckStop(validity==field_not_found, "meteo field not found:" // trim(namefield)) + if(LANDIFY_MET) & + call landify(t2_nwp(:,:,nr) ,"t2nwp") namefield='relative_humidity_2m' @@ -444,26 +469,36 @@ subroutine MeteoRead(numt) call CheckStop(validity==field_not_found, "meteo field not found:" // trim(namefield)) rh2m(:,:,nr) = 0.01 * rh2m(:,:,nr) ! Convert from % to fraction endif + if(LANDIFY_MET) & + call landify(rh2m(:,:,nr),"rh2m") namefield='surface_flux_sensible_heat' call Getmeteofield(meteoname,namefield,nrec,ndim,& unit,validity, fh(:,:,nr)) call CheckStop(validity==field_not_found, "meteo field not found:" // trim(namefield)) + if(LANDIFY_MET) & + call landify(fh(:,:,nr) ,"fh") if(validity=='averaged')fh(:,:,1)=fh(:,:,nr) namefield='surface_flux_latent_heat' call Getmeteofield(meteoname,namefield,nrec,ndim,& unit,validity, fl(:,:,nr)) call CheckStop(validity==field_not_found, "meteo field not found:" // trim(namefield)) + if(LANDIFY_MET) & + call landify(fl(:,:,nr),"fl") if(validity=='averaged')fl(:,:,1)=fl(:,:,nr) namefield='surface_stress' call Getmeteofield(meteoname,namefield,nrec,ndim,& unit,validity, tau(:,:,nr)) + if(LANDIFY_MET) & + call landify(tau(:,:,nr) ,"tau") if(validity==field_not_found)then namefield='ustar_nwp' call Getmeteofield(meteoname,namefield,nrec,ndim,& unit,validity, ustar_nwp(:,:)) + if(LANDIFY_MET) & + call landify(ustar_nwp(:,:),"ustar") call CheckStop(validity==field_not_found, "meteo field not found:" // trim(namefield)) foundustar=.true. else @@ -481,144 +516,110 @@ subroutine MeteoRead(numt) foundSST = .true. endif - namefield='soil_water_content' - call Getmeteofield(meteoname,namefield,nrec,ndim,& - unit,validity, SoilWater(:,:,nr)) - if(validity==field_not_found)then - if(MasterProc.and.numt==1)write(*,*)' WARNING: SoilWater not found ' - foundSoilWater = .false. - - ! The shallow soil water is intended for the experimental dust modelling - ! and only implementted with HIRLAM-type inputs so far - else if ( trim(unit) /= "m" ) then ! PARLAM/HIRLAM has metres of water in top 7.2 cm - if(MasterProc.and.numt==1)write(*,*)'WARNING: SoilWater-shallow not HIRLAM, skipping' - foundSoilWater = .false. - else - foundSoilWater = .true. - endif + ! Soil water fields. Somewhat tricky. + ! Ideal is soil moisture index, available from IFS, = (SW-PWP)/(FC-PWP) + ! Otherwise m3/m3 or m units are converted in metvar + ! + ! Start with shallow - if ( USE_SOILWATER ) then !just deep here - !======================================== - namefield='deep_soil_water_content' - if(DomainName == "HIRHAM" ) then - if(MasterProc.and.numt==1)write(*,*) " Rename soil water in HIRHAM" - namefield='soil_water_second_layer' - end if +if( USE_DUST .and. .not.USE_SOILWATER ) call StopAll("Inconsistent SM, DUST") +if( USE_SOILWATER ) then + SoilWaterSource = "IFS"! use as default? + + namefield='SMI1' call Getmeteofield(meteoname,namefield,nrec,ndim,& - unit,validity, SoilWater_deep(:,:,nr)) - if(validity==field_not_found)then - if(MasterProc.and.numt==1)write(*,*)' WARNING: ',trim(namefield),' not found ' - foundSoilWater_deep = .false. + unit,validity, SoilWater_uppr(:,:,nr)) + + if(validity/=field_not_found)then + if( .not.foundSMI1 ) call PrintLog("Met: found SMI1", MasterProc) + foundSMI1=.true. + foundSoilWater_uppr = .true. else - !<<<<<<< process SW <<<<<<<<<<<<<<<<<<<<<<< - foundSoilWater_deep = .true. - if ( trim(unit) == "m" ) then ! PARLAM has metres of water - SoilWaterSource = "PARLAM" - SoilMax = 0.02 - else if(trim(unit)=='m3/m3')then - !IFS has a fairly complex soil water system, with field capacity of - ! up to 0.766 for organic soils. More medium soils have ca. 0.43 - ! Typical values in January are even down to 0.2. We choose 0.5 - ! as our max, and SoilWater_ml will consider drying effects after - ! down to 0.25 - call StopAll("Soil Water Handling with IFS not yet implemented") + + namefield='soil_water_content' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + unit,validity, SoilWater_uppr(:,:,nr)) + if(validity==field_not_found)then + namefield='soil_wetness_surface' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + unit,validity, SoilWater_uppr(:,:,nr)) + endif + if(validity==field_not_found)then + if(MasterProc.and.numt==1)write(*,*)' WARNING: SoilWater_uppr not found ' + foundSoilWater_uppr = .false. + + else if ( trim(unit) /= "m" ) then + ! PARLAM/HIRLAM has metres of water in top 7.2 cm + + if(MasterProc.and.numt==1) & + write(*,*)'WARNING: Assuming SoilWater from IFS' + foundSoilWater_uppr = .true. SoilWaterSource = "IFS" - SoilMax = 0.5 - else ! units not defined yet - if(numt==1)write(*,*)trim(unit) - call StopAll("Need units for deep soil water") + else + foundSoilWater_uppr = .true. + SoilWaterSource = "PARLAM" endif + endif + end if ! USE_SOILWATER first one + if ( USE_SOILWATER ) then !just deep here - ! Make SoilWater relative 0 < SW < 1: - - SoilWater_deep(:,:,nr) = min( SoilWater_deep(:,:,nr)/SoilMax, 1.0 ) - - if(MasterProc.and.numt==1) write(*,*)' Met_ml Soilwater: ' // & - trim(SoilWaterSource), SoilMax - - if ( water_cover_set ) then ! smooth the SoilWater values: - - ! If NWP thinks this is a sea-square, but we anyway have land, - ! the soil moisture might be very strange. We search neighbouring - ! grids and make a land-weighted mean SW - ! Skip on 1st numt, since water fraction set a little later. No harm done... - - call extendarea( SoilWater_deep(:,:,nr), xsw, DEBUG_SOILWATER) - - if ( .not. xwf_done ) then ! only need to do this once - call extendarea( water_cover(:,:), xwf, DEBUG_SOILWATER) - xwf_done = .true. - end if - - if(DEBUG_SOILWATER .and. debug_proc)& - write(*,*)'Met_ml water xwf_done: ', me, xwf_done - - do j = 1, ljmax - do i = 1, limax - - ! Take a 5x5 average of the land-weighted values for SW. Seems - ! best not to "believe" NWP models too much for this param, and - ! the variation in a grid is so big anyway. We aim at the broad - ! effect. (Alternative might be to find max values?) - - tmpsw = 0.0 ! Relative SW - sumland = 0.0 - if( water_cover(i,j) < 0.999 ) then !some land - do jj = -NEXTEND, NEXTEND - do ii = -NEXTEND, NEXTEND - ii2=i+ii+NEXTEND ! coord in extended array - jj2=j+jj+NEXTEND - if( xsw(ii2,jj2) > 1.0e-10 ) then ! have some SW to work with - landfrac = 1.0 - xwf(ii2,jj2) - sumland = sumland + landfrac - tmpsw = tmpsw + landfrac * xsw(ii2,jj2) - if ( DEBUG_SOILWATER .and.i==debug_li.and.j==debug_lj ) then - write(*,"(a,2i4,8f10.4)") "METSWX: ", ii2, jj2,& - water_cover(i,j), xwf(ii2,jj2), & - SoilWater_deep(i,j,nr),& - xsw(ii2,jj2), tmpsw, landfrac, sumland - end if ! DEBUG - end if ! xsw - end do!ii - end do!jj - if( sumland > 0.01) then - SoilWater_deep(i,j,nr) = tmpsw/sumland - else - SoilWater_deep(i,j,nr) = 1.0 ! same as sea - end if - else - SoilWater_deep(i,j,nr) = 1.0 ! same as sea - end if ! water_cover - - !if( sumland > 0.1 ) then - ! SoilWater_deep(i,j,nr) = tmpsw/sumland - ! if(DEBUG_SOILWATER) call CheckStop( tmpsw > sumland, "METSW ERROR") - !else - ! SoilWater_deep(i,j,nr) = 1.0 ! also over water - !end if - - end do ! i - end do ! j - if ( DEBUG_SOILWATER.and.debug_proc ) then - i = debug_li - j = debug_lj - write(*,"(a,f7.4,2i4,f12.4)") "DEBUG_METSWF: ", & - water_cover(i,j), nr, current_date%day, SoilWater_deep(i,j,nr) - end if - - else ! for sea values we usually have zero or negative. Set to 1.0 - where ( SoilWater_deep(:,:,nr) < 1.0e-3 ) SoilWater_deep(:,:,nr) = 1.0 - endif ! water_cover_set test - !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - endif ! validity test + !======================================== + !In the long term, all meteofile should have Soil Moisture Index defined + + namefield='SMI3' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + unit,validity, SoilWater_deep(:,:,nr)) + + if(validity/=field_not_found)then + if( .not.foundSMI3 ) call PrintLog("Met: found SMI3", MasterProc) + foundSMI3=.true. + foundSoilWater_deep = .true. + + else + + !Search for other fields which can be used for making SMI + namefield='deep_soil_water_content' + if(DomainName == "HIRHAM" ) then + if(MasterProc.and.numt==1)write(*,*) " Rename soil water in HIRHAM" + namefield='soil_water_second_layer' + end if + call Getmeteofield(meteoname,namefield,nrec,ndim,& + unit,validity, SoilWater_deep(:,:,nr)) + if(validity==field_not_found)then + if(MasterProc.and.numt==1)write(*,*)' WARNING: ',trim(namefield),' not found ' + foundSoilWater_deep = .false. + else + !<<<<<<< process SW <<<<<<<<<<<<<<<<<<<<<<< + foundSoilWater_deep = .true. + if ( trim(unit) == "m" ) then ! PARLAM has metres of water + SoilWaterSource = "PARLAM" + SoilMax = 0.02 + else if(unit(1:5)=='m3/m3')then + !IFS has a fairly complex soil water system, with field capacity of + ! up to 0.766 for organic soils. More medium soils have ca. 0.43 + ! Typical values in January are even down to 0.2. Best to use + ! SMI.... + SoilWaterSource = "IFS" + else ! units not defined yet + if(numt==1)write(*,*)trim(unit) + call StopAll("Need units for deep soil water") + endif + + if(MasterProc.and.numt==1) write(*,*)'max Met_ml Soilwater_deep: ' // & + trim(SoilWaterSource), SoilMax, maxval( SoilWater_deep(:,:,nr) ) + + endif !found deep_soil_water_content + + endif !SMI3 found + + + if ( DEBUG_SOILWATER.and.debug_proc ) then + i = debug_li + j = debug_lj + write(*,"(a,2i4,f12.4)") "DEBUG_METSWF2: ", & + nr, current_date%day, SoilWater_deep(i,j,nr) + end if end if ! USE_SOILWATER - - if ( DEBUG_SOILWATER.and.debug_proc ) then - i = debug_li - j = debug_lj - write(*,"(a,2i4,f12.4)") "DEBUG_METSWF2: ", & - nr, current_date%day, SoilWater_deep(i,j,nr) - end if !======================================== namefield='snow_depth' @@ -644,7 +645,7 @@ subroutine MeteoRead(numt) namefield='u10'!first component of ws_10m call Getmeteofield(meteoname,namefield,nrec,ndim,& - unit,validity, temp(:,:)) + unit,validity, buff(:,:)) if(validity==field_not_found)then foundws10_met = .false. else @@ -655,7 +656,9 @@ subroutine MeteoRead(numt) foundws10_met = .false. else foundws10_met = .true. - ws_10m(:,:,nr)=sqrt(ws_10m(:,:,nr)**2+temp(:,:)**2) + ws_10m(:,:,nr)=sqrt(ws_10m(:,:,nr)**2+buff(:,:)**2) + if(LANDIFY_MET) & + call landify(ws_10m(:,:,nr),"WS10") ! call printCDF('ws_10m',ws_10m(:,:,1),unit) endif endif @@ -663,55 +666,6 @@ subroutine MeteoRead(numt) end subroutine Meteoread - !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - - subroutine MeteoGridRead(cyclicgrid) - - ! the subroutine reads the grid parameters (projection, resolution etc.) - ! defined by the meteorological fields - ! - - implicit none - - integer, intent(out) :: cyclicgrid - integer :: nyear,nmonth,nday,nhour,k - - character (len = 100),save :: meteoname !name of the meteofile - - - nyear=startdate(1) - nmonth=startdate(2) - nday=startdate(3) - nhour=0 - current_date = date(nyear, nmonth, nday, nhour, 0 ) - call Init_nmdays( current_date ) - - !*********initialize grid parameters********* -56 FORMAT(a5,i4.4,i2.2,i2.2,a3) - write(meteoname,56)'meteo',nyear,nmonth,nday,'.nc' - if(DEBUG_MET.and.MasterProc)write(*,*)'looking for ',trim(meteoname) - - - call Getgridparams(meteoname,GRIDWIDTH_M,xp,yp,fi,xm_i,xm_j,xm2,& - ref_latitude,sigma_mid,Nhh,nyear,nmonth,nday,nhour,nhour_first& - ,cyclicgrid) - - - if(MasterProc .and. DEBUG_MET)then - write(*,*)'sigma_mid:',(sigma_mid(k),k=1,20) - write(*,*)'grid resolution:',GRIDWIDTH_M - write(*,*)'xcoordinate of North Pole, xp:',xp - write(*,*)'ycoordinate of North Pole, yp:',yp - write(*,*)'longitude rotation of grid, fi:',fi - write(*,*)'true distances latitude, ref_latitude:',ref_latitude - endif - - call DefGrid()!defines: i_fdom,j_fdom,i_local, j_local,xmd,xm2ji,xmdji, - ! sigma_bnd,carea,gbacmax,gbacmin,glacmax,glacmin - - end subroutine Meteogridread - - !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> subroutine metvar(numt) @@ -738,11 +692,15 @@ subroutine metvar(numt) real prhelp_sum,divk(KMAX_MID),sumdiv real inv_METSTEP - integer :: i, j, k, kk, nr,info + integer :: i, j, k, kk, nr,info, ii,jj,ii2,jj2 integer request_s,request_n,request_e,request_w real ::Ps_extended(0:MAXLIMAX+1,0:MAXLJMAX+1),Pmid,Pu1,Pu2,Pv1,Pv2 real :: relh1,relh2,temperature,swp,wp + real :: tmpsw, landfrac, sumland ! for soil water averaging + real :: tmpmax ! debug + + nr = 2 if (numt == 1) then @@ -753,23 +711,47 @@ subroutine metvar(numt) call Exner_tab() - ! Look for processor containing debug coordinates - debug_iloc = -999 - debug_jloc = -999 + debug_iloc = debug_li + debug_jloc = debug_lj - do i = 1, limax - do j = 1, ljmax -! if (DEBUG_MET .and. & - if( i_fdom(i) == DEBUG_I .and. j_fdom(j) == DEBUG_J ) then - debug_proc = .true. - debug_iloc = i - debug_jloc = j - end if - end do - end do if( debug_proc ) write(*,*) "DEBUG EXNER me", me, Exner_nd(99500.0) !------------------------------------------------------------------- - + ! Notes on IFS: + ! Fc has max 1.0. Set to 1.0 over sea + ! pwp has max 0.335 Set to 0.0 over sea + + if( SoilWaterSource == "IFS")then + !needed for transforming IFS soil water + call ReadField_CDF('SoilTypes_IFS.nc','pwp',pwp, & + 1,interpol='conservative',needed=.true.,UnDef=-999.,debug_flag=.false.) + !call printCDF('pwp0',pwp,' ') + call ReadField_CDF('SoilTypes_IFS.nc','fc',fc, & + 1,interpol='conservative',needed=.true.,UnDef=-999.,debug_flag=.false.) + !call printCDF('fc0',fc,' ') + + ! landify(x,intxt,xmin,xmax,wfmin,xmask) + ! We use a global mask for water_fraction < 100%, but set wfmin to 1.0 + ! to allow all grids with some land to be processed + ! Fc and PWP should be above zero and below 1, let's use 0.8 + + call landify( pwp(:,:), " PWP ", & + 0.0, 0.8, 1.0, water_fraction < 1.0 ) ! mask for where there is land + call landify( fc(:,:), " FC ", & + 0.0, 0.8, 1.0, water_fraction < 1.0 ) ! mask for where there is land + + if ( DEBUG_SOILWATER.and.debug_proc ) then + i = debug_li + j = debug_lj + write(*,"(a,2i4,3f12.4)") "DEBUG_METSWF-IFS: swd pwp fc", & + nr, current_date%day, SoilWater_deep(i,j,nr), pwp(i,j), fc(i,j) + write(*,"(a,2i4,3f12.4)") "DEBUG_METSWF-IFS maxvals: ", & + nr, current_date%day, maxval ( SoilWater_deep ), & + maxval( pwp), maxval( fc) + write(*,"(a,2i4,3f12.4)") "DEBUG_METSWF-IFS minvals: ", & + nr, current_date%day, minval ( SoilWater_deep ), & + minval( pwp), minval( fc) + end if + endif end if !numt == 1 @@ -875,7 +857,7 @@ subroutine metvar(numt) if(nr==1)cw(:,:,:,2)=cw(:,:,:,nr) do j=1,ljmax do i=1,limax - pr(i,j,KMAX_MID)= surface_precip(i,j)*10800000.0!guarantees precip at surface + pr(i,j,KMAX_MID)= surface_precip(i,j)*METSTEP*3600.0*1000.0!guarantees precip at surface do k=1,KMAX_MID-1 if(cw(i,j,k,2)+cw(i,j,k,1)>CW_THRESHOLD)then !fill the column up to this level with constant precip @@ -894,7 +876,7 @@ subroutine metvar(numt) !will use RH to determine the height of release (less accurate than cloudwater) do j=1,ljmax do i=1,limax - pr(i,j,KMAX_MID)= surface_precip(i,j)*10800000.0!guarantees precip at surface + pr(i,j,KMAX_MID)= surface_precip(i,j)*METSTEP*3600.0*1000.0!guarantees precip at surface do k=1,KMAX_MID-1 !convert from potential temperature into absolute temperature temperature = th(i,j,k,nr)*exp(KAPPA*log((A_mid(k) + B_mid(k)*ps(i,j,nr)*100)*1.e-5))!Pa, Ps still in hPa here @@ -904,7 +886,9 @@ subroutine metvar(numt) wp=q(i,j,k,nr)*(A_mid(k) + B_mid(k)*ps(i,j,nr)*100)/0.622 relh2=wp/swp !convert from potential temperature into absolute temperature - temperature = th(i,j,k,1)*exp(KAPPA*log((A_mid(k) + B_mid(k)*ps(i,j,1)*100)*1.e-5))!Pa, Ps still in hPa here + !Factor 100 for Pa, Ps still in hPa here + temperature = th(i,j,k,1)* & + exp(KAPPA*log((A_mid(k) + B_mid(k)*ps(i,j,1)*100)*1.e-5)) !saturation water pressure swp=611.2*exp(17.67*(temperature-273.15)/(temperature-29.65)) !water pressure @@ -913,7 +897,7 @@ subroutine metvar(numt) if(relh1>RH_THRESHOLD.or.relh2>RH_THRESHOLD)then !fill the column up to this level with constant precip do kk=k,KMAX_MID-1 - pr(i,j,kk)= surface_precip(i,j)*10800000.0!3hours and m->mm + pr(i,j,kk)= surface_precip(i,j)*METSTEP*3600.0*1000.0!3hours and m->mm enddo exit else @@ -1213,6 +1197,136 @@ subroutine metvar(numt) + if( USE_SOILWATER ) then + if(foundSMI3.or.foundSoilWater_deep)then + + if ( water_frac_set ) then ! smooth the SoilWater values: + + ! If NWP thinks this is a sea-square, but we anyway have land, + ! the soil moisture might be very strange. We search neighbouring + ! grids and make a land-weighted mean SW + ! Skip on 1st numt, since water fraction set a little later. No harm done... + +! changed landify routine to accept water_fraction as mask. Should +! works almost the same as code below did. +! Should move later also, after other units converted to SMI +! NB Some grid squares in EECCA have water cover of 99.998 + + call landify( SoilWater_deep(:,:,nr), "SMI_DEEP", & + 0.0, 1.0, 1.0, water_fraction < 1.0 ) + ! Allow some negative SMI for upper levels + call landify( SoilWater_uppr(:,:,nr), "SMI_UPPR", & + -1.0, 1.0, 1.0, water_fraction < 1.0 ) + + if ( DEBUG_SOILWATER.and.debug_proc ) then + + i = debug_li + j = debug_lj + write(*,"(a,f7.4,2i4,f12.4)") "DEBUG_METSWF DEEP: ", & + water_fraction(i,j), nr, current_date%day, SoilWater_deep(i,j,nr) + write(*,"(a,f7.4,2i4,f12.4)") "DEBUG_METSWF UPPR: ", & + water_fraction(i,j), nr, current_date%day, SoilWater_uppr(i,j,nr) + end if + + else ! water_frac not set yet + ! for sea values we usually have zero or negative. Set to 1.0 + call CheckStop("ERROR, Met_ml: SMD not set!! here" ) + !call datewrite("SMD here" , me, (/ -3.0 /) ) + !do i = 1, limax + !do j = 1, ljmax + ! if ( SoilWater_deep(i,j,nr) < 1.0e-3 ) then + ! write(*,*) "SMD ", me, i_fdom(i), j_fdom(j), SoilWater_deep(i,j,nr) + ! SoilWater_deep(:,:,nr) = 1.0 ! ??? + ! end if + !end do + !end do + !where ( SoilWater_deep(:,:,nr) < 1.0e-3 ) SoilWater_deep(:,:,nr) = 1.0 + endif ! water_frac_set test + end if ! USE_SOILWATER + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + endif ! validity test + + + if(SoilWaterSource == "IFS".and.(.not.foundSMI1 .or. .not.foundSMI3 ))then +!has to convert from m3/m3 to Soil Moisture Index if not already in SMI units + !- will cope with other met inputs another day + call CheckStop('SW SHOULD NOT BE HERE ') + !2 ----------------------------------------------- + do j = 1, ljmax ! NEWTEST 1, MAXLJMAX + do i = 1, limax ! NEWTEST 1, MAXLIMAX + if ( DEBUG_SOILWATER ) then + !if( ( fc(i,j)-pwp(i,j) < 1.0e-10 ) ) then + ! write(*, "(a,7i5,4f12.3)") "WARNING: PWPFC Problem? ", & + ! me, i_fdom(i), j_fdom(j), i,j, limax, ljmax, & + ! fc(i,j),pwp(i,j), maxval(pwp), maxval(fc) + ! end if + ! Can get negative values. Remember pwp=0 over sea: + if( pwp(i,j) > 0.0 .and. SoilWater_uppr(i,j,nr)-pwp(i,j) < 1.0e-10 ) then + write(*, "(a,7i5,4f12.3)") "WARNING: METSWFS NEG Problem? ", & + me, i_fdom(i), j_fdom(j), i,j, limax, ljmax, & + fc(i,j),pwp(i,j), SoilWater_uppr(i,j,nr) + end if + if( SoilWater_uppr(i,j,nr) > fc(i,j) ) then + write(*, "(a,7i5,4f12.3)") "WARNING: METSWFS >1 Problem? ", & + me, i_fdom(i), j_fdom(j), i,j, limax, ljmax, & + fc(i,j),pwp(i,j), SoilWater_uppr(i,j,nr) + end if + end if + ! Soil Moisture Index + if(.not.foundSMI1)SoilWater_uppr(i,j,nr)=(SoilWater_uppr(i,j,nr)-pwp(i,j))/(fc(i,j)-pwp(i,j)) + if(.not.foundSMI3)SoilWater_deep(i,j,nr)=(SoilWater_deep(i,j,nr)-pwp(i,j))/(fc(i,j)-pwp(i,j)) + + if ( DEBUG_SOILWATER .and. ( SoilWater_uppr(i,j,nr) > 1.0 .or. & + SoilWater_deep(i,j,nr) > 1.0 ) ) then + write(*, "(a,7i5,4f12.3)") "WARNING: METSWF Problem? ", & + me, i_fdom(i), j_fdom(j), i,j, limax, ljmax, & + fc(i,j),pwp(i,j), SoilWater_uppr(i,j,nr), SoilWater_deep(i,j,nr) + end if + end do + end do + ! call printCDF('SMI',SoilWater_uppr(:,:,nr),' ') + call printCDF('pwp',pwp,' ') + call printCDF('fc',fc,' ') + + + endif + +! We should now have SMI regardless of soil water data source. We +! restrict this to be in range 0 --- 1 for deep soil water. +! For upper-soil water, we allow some negative, since evaporation can dry the soil +! bellow the PWP. +! +! SMI = (SW-PWP)/((FC-PWP), therefore min SMI value should be -PWP/(FC-PWP) +! Let's use 99% of this: + + do i = 1, limax + do j = 1, ljmax + if( fc(i,j) > pwp(i,j) ) then ! Land values + tmpmax = -0.99 * pwp(i,j)/(fc(i,j)-pwp(i,j) ) + SoilWater_uppr(i,j,nr) = max( tmpmax, SoilWater_uppr(i,j,nr) ) + else + SoilWater_uppr(i,j,nr) = -999. ! NOT NEEDED???? + end if + end do + end do +!! SoilWater_uppr(:,:,nr) = max( & +! -0.99 * pwp(:,:)/(fc(:,:)-pwp(:,:) ), & +! SoilWater_uppr(:,:,nr) ) + + SoilWater_deep(:,:,nr) = max(0.0, SoilWater_deep(:,:,nr) ) + + SoilWater_uppr(:,:,nr) = min(1.0, SoilWater_uppr(:,:,nr)) + SoilWater_deep(:,:,nr) = min(1.0, SoilWater_deep(:,:,nr) ) + + if ( DEBUG_SOILWATER.and.debug_proc ) then + i = debug_li + j = debug_lj + write(*,"(a,2i4,4f12.4)") "DEBUG_METSWFScaled: swd swu pwp fc", & + nr, current_date%day, SoilWater_uppr(i,j,nr), & + SoilWater_deep(i,j,nr), pwp(i,j), fc(i,j) + endif + + call met_derived(nr) !compute derived meteo fields call BLPhysics(numt) @@ -1257,8 +1371,8 @@ subroutine metint + (t2_nwp(:,:,2) - t2_nwp(:,:,1))*div rh2m(:,:,1) = rh2m(:,:,1) & + (rh2m(:,:,2) - rh2m(:,:,1))*div - SoilWater(:,:,1) = SoilWater(:,:,1) & - + (SoilWater(:,:,2) - SoilWater(:,:,1))*div + SoilWater_uppr(:,:,1) = SoilWater_uppr(:,:,1) & + + (SoilWater_uppr(:,:,2) - SoilWater_uppr(:,:,1))*div SoilWater_deep(:,:,1) = SoilWater_deep(:,:,1) & + (SoilWater_deep(:,:,2) - SoilWater_deep(:,:,1))*div @@ -1296,7 +1410,7 @@ subroutine metint ps(:,:,1) = ps(:,:,2) t2_nwp(:,:,1) = t2_nwp(:,:,2) rh2m(:,:,1) = rh2m(:,:,2) - SoilWater(:,:,1) = SoilWater(:,:,2) + SoilWater_uppr(:,:,1) = SoilWater_uppr(:,:,2) SoilWater_deep(:,:,1) = SoilWater_deep(:,:,2) sdepth(:,:,1) = sdepth(:,:,2) ice_nwp(:,:,1) = ice_nwp(:,:,2) @@ -1352,6 +1466,8 @@ subroutine met_derived(nt) u_ref(i,j)= sqrt( u_mid(i,j,KMAX_MID)**2 + v_mid(i,j,KMAX_MID)**2 ) enddo enddo + if(LANDIFY_MET) & + call landify(u_ref(:,:),"u_ref") ! Tmp ustar solution. May need re-consideration for MM5 etc., but @@ -1370,7 +1486,6 @@ subroutine met_derived(nt) end forall endif - !ds 25/2/2009.. following Branko's comments, ! we limit u* to a physically plausible value over land ! to prevent numerical problems, and to account for enhanced ! mixing which is usually found over real terrain @@ -1439,14 +1554,14 @@ subroutine MetModel_LandUse(callnum) write(fname,fmt='(''landsea_mask.dat'')') write(6,*) 'reading land-sea map from ',fname end if - needed_found=.false. - call ReadField(IO_ROUGH,fname,r_class,needed_found,fill_needed=.true.) + foundnwp_sea=.false. + call ReadField(IO_ROUGH,fname,r_class,foundnwp_sea,fill_needed=.true.) ! And convert from real to integer field - nwp_sea(:,:) = .false. - if(needed_found)then + if(foundnwp_sea)then + nwp_sea(:,:) = .false. do j=1,ljmax do i=1,limax if ( nint(r_class(i,j)) == 0 ) nwp_sea(i,j) = .true. @@ -1545,9 +1660,10 @@ subroutine BLPhysics(numt) real, dimension(KMAX_BND) :: p_bnd !TESTzi real, dimension(KMAX_MID) :: Kz_nwp real :: Kz_min, stab_h -! logical :: Pielke_flag ! choice in Blackadar/Pielke equations integer i,j,k,numt, nr + real :: theta2 + logical :: debug_flag call CheckStop( KZ_SBL_LIMIT < 1.01*KZ_MINIMUM, & "SBLlimit too low! in Met_ml") @@ -1577,7 +1693,6 @@ subroutine BLPhysics(numt) end do -! Are the invL and fh comparable?? if ( debug_proc .and. DEBUG_Kz) then i = debug_iloc j = debug_jloc @@ -1593,11 +1708,11 @@ subroutine BLPhysics(numt) if (NWP_Kz .and. foundKz_met ) then ! read from met data - !hb, +ds rewrote to reduce number of lines. LAter we should remove Kz_met - ! and Kz_m2s + ! LAter we should remove Kz_met and Kz_m2s forall(i=1:limax,j=1:ljmax,k=2:KMAX_MID) SigmaKz(i,j,k,nr)=Kz_met(i,j,k,nr)/(60*60*3) + end forall call SigmaKz_2_m2s( SigmaKz(:,:,:,nr), roa(:,:,:,nr),ps(:,:,nr), Kz_m2s ) @@ -1623,13 +1738,14 @@ subroutine BLPhysics(numt) do j=1,ljmax do i=1,limax + debug_flag = ( DEBUG_Kz .and. debug_proc .and. & + i == debug_iloc .and. j == debug_jloc ) + call PielkeBlackadarKz ( & u_mid(i,j,:), v_mid(i,j,:), & z_mid(i,j,:), z_bnd(i,j,:), & th(i,j,:,nr), Kz_m2s(i,j,:), & - PIELKE, & !Pielke_flag, & - .false. ) - !( debug_proc .and. i == debug_iloc .and. j == debug_jloc ) ) + PIELKE, debug_flag ) enddo enddo @@ -1677,24 +1793,40 @@ subroutine BLPhysics(numt) do i=1,limax do j=1,ljmax - call JericevicRiB_Hmix(& + theta2 = t2_nwp(i,j,nr) * T_2_Tpot(ps(i,j,nr)) + call JericevicRiB_Hmix0(& u_mid(i,j,:), v_mid(i,j,:), & - z_mid(i,j,:), th(i,j,:,nr), & - pzpbl(i,j)) + z_mid(i,j,:), th(i,j,:,nr), & ! WHY nr?? + pzpbl(i,j), theta2, likely_coastal(i,j) ) +! if( pzpbl(i,j) < z_bnd(i,j,20) ) then +! write(*,"(a8,i2,2i4,5f8.3,f7.2)") "PZPBL ", nr, i_fdom(i), j_fdom(j), t2_nwp(i,j,nr), theta2, th(i,j,20,nr), u_mid(i,j,20), v_mid(i,j,20),pzpbl(i,j) +! end if !OS_TEST debug end do end do + else call CheckStop("Need HmixMethod") end if ! end of newer methods ! Set limits on Zi - ! mid-call at k=19 is lowest we can resolve, so set as min forall(i=1:limax,j=1:ljmax) - pzpbl(i,j) = max( z_mid(i,j,KMAX_MID-1), pzpbl(i,j)) + pzpbl(i,j) = max( PBL_ZiMIN, pzpbl(i,j)) pzpbl(i,j) = min( PBL_ZiMAX, pzpbl(i,j) ) end forall + ! mid-call at k=19 is lowest we can resolve, so set as min + !ORIG forall(i=1:limax,j=1:ljmax) + !ORIG pzpbl(i,j) = max( z_mid(i,j,KMAX_MID-1), pzpbl(i,j)) + !ORIG pzpbl(i,j) = min( PBL_ZiMAX, pzpbl(i,j) ) + !ORIG end forall end if ! Hmix done + !..spatial smoothing of new zi: Need fixed minimum here. 100 or 50 m is okay + ! First, we make sure coastal areas had "land-like" values. + + if(LANDIFY_MET) & + call landify(pzpbl,"pzbpl") + call smoosp(pzpbl,PBL_ZiMIN,PBL_ZiMAX) +! and for later... !====================================================================== ! Kz choices: @@ -1703,7 +1835,12 @@ subroutine BLPhysics(numt) do k = 2, KMAX_MID do j=1,ljmax do i=1,limax - Kz_m2s(i,j,k) = JericevicKz( z_bnd(i,j,k), pzpbl(i,j), ustar_nwp(i,j) ) + Kz_m2s(i,j,k) = JericevicKz( z_bnd(i,j,k), pzpbl(i,j), ustar_nwp(i,j), Kz_m2s(i,j,k) ) + !if v.low zi, then set Kz at bottom boundary + ! to zero to stop dispersion. +! if ( k==KMAX_MID .and. pzpbl(i,j) <= z_bnd(i,j,KMAX_MID) ) then +! Kz_m2s(i,j,k) = 0.0 +! end if end do end do end do @@ -1711,16 +1848,33 @@ subroutine BLPhysics(numt) else ! Specify unstable, stable separately: if ( StableKzMethod == "JG" ) then ! Jericevic/Grisogono for both Stable/Unstable + + + do j=1,ljmax do i=1,limax - if ( invL_nwp(i,j) >= OB_invL_LIMIT ) then !neutral and unstable + if ( invL_nwp(i,j) >= OB_invL_LIMIT ) then !neutral and unstable do k = 2, KMAX_MID - Kz_m2s(i,j,k) = & - JericevicKz( z_bnd(i,j,k), pzpbl(i,j), ustar_nwp(i,j) ) + if( z_bnd(i,j,k) < pzpbl(i,j) ) then ! OCT2011: + Kz_m2s(i,j,k) = & + JericevicKz( z_bnd(i,j,k), pzpbl(i,j), ustar_nwp(i,j) , Kz_m2s(i,j,k)) + !else + ! keep Kz from Pielke/BLackadar + end if !OCT2011 end do end if end do end do + if(debug_proc ) then + i = debug_iloc + j = debug_jloc + if(DEBUG_Kz .and. invL_nwp(i,j) >= OB_invL_LIMIT ) then + do k = 15, KMAX_MID + print "(a,i3,f7.1,3es11.3)", "DEBUG SKz_m2s",k,& + pzpbl(i,j), invL_nwp(i,j), ustar_nwp(i,j), Kz_m2s(i,j,k) + end do + endif + endif else if ( StableKzMethod == "BW" ) then @@ -1730,7 +1884,7 @@ subroutine BLPhysics(numt) do i=1,limax if ( invL_nwp(i,j) > 1.0e-10 ) then !stable ! leaves gap near zero Kz_m2s(i,j,k) = BrostWyngaardKz(z_bnd(i,j,k),pzpbl(i,j),& - ustar_nwp(i,j),invL_nwp(i,j)) + ustar_nwp(i,j),invL_nwp(i,j), Kz_m2s(i,j,k)) end if end do end do @@ -1753,6 +1907,15 @@ subroutine BLPhysics(numt) end if end do end do + if(debug_proc) then + i = debug_iloc + j = debug_jloc + if(DEBUG_Kz .and. invL_nwp(i,j) < OB_invL_LIMIT ) then + do k = 15, KMAX_MID + print "(a,f7.1,3es10.3)", "DEBUG UKz_m2s", pzpbl(i,j), invL_nwp(i,j), ustar_nwp(i,j), Kz_m2s(i,j,k) + end do + endif + endif else call CheckStop("Need UnstableKzMethod") @@ -1761,10 +1924,9 @@ subroutine BLPhysics(numt) end if ! Specify unstable, stable separately: end if + !..spatial smoothing of new zi: Need fixed minimum here. 100 or 50 m is okay + ! First, we make sure coastal areas had "land-like" values. - !..spatial smoothing of new zi: Need fixed minimum here. 100 m is okay - - call smoosp(pzpbl,PBL_ZiMIN,PBL_ZiMAX) !************************************************************************! ! test some alternative options for Kz and Hmix @@ -1784,6 +1946,7 @@ subroutine BLPhysics(numt) u=u_mid(i,j,:),v=v_mid(i,j,:), zm=z_mid(i,j,:), & zb=z_bnd(i,j,:), exnm=exnm(i,j,:), Kz=Kz_m2s(i,j,:), & Kz_nwp=Kz_nwp(:), invL=invL_nwp(i,j), & + q=q(i,j,:,nr), & ! TEST Vogel ustar=ustar_nwp(i,j), th=th(i,j,:,nr), pb=p_bnd(:), zi=pzpbl(i,j)) !************************************************************************! ! if ( USE_MIN_Kz) then @@ -1945,11 +2108,10 @@ subroutine extendarea(f,h,debug_flag) !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc !c ! based upon the smoosp routine - !c adapted by David Simpson March 2011 ! - returns extended array array, reading neighbour procs as needed !c---------------------------------------------------------------------- - real, intent(inout) :: f(:,:) + real, intent(in) :: f(:,:) real, intent(inout) :: h(:,:) logical, intent(in), optional :: debug_flag logical :: mydebug = .false. @@ -1961,9 +2123,9 @@ subroutine extendarea(f,h,debug_flag) integer :: iif,jjf,i,j,ii,jj,iifl,jjfl if ( present(debug_flag) ) mydebug = debug_flag - thick = ( size(h,1) - size(f,1) ) ! Caller has to make h > f - iif=size(f,1) - jjf=size(f,2) + thick = ( size(h,1) - size(f,1) ) ! Caller has to make h > f ;NB: NOT SAFE! + iif=limax + jjf=ljmax if( modulo(thick,2) /= 0 ) then print *, "ERROR extendarea para,s ", me, iif , jjf, thick @@ -2015,18 +2177,133 @@ subroutine extendarea(f,h,debug_flag) enddo enddo -! do j=1,jjf -! jj=j+thick -! do i=1,iif -! ii=i+thick -! f(i,j)=h2(ii,jj) -! enddo -! enddo -! end subroutine extendarea ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine landify(x,intxt,xmin,xmax,wfmin,xmask) + real, dimension(MAXLIMAX,MAXLJMAX), intent(inout) :: x + character(len=*), intent(in), optional :: intxt + real, intent(in), optional :: xmin, xmax ! Limits of valid data for x + real, intent(in), optional :: wfmin ! Limits of valid data for water frac + logical, dimension(MAXLIMAX,MAXLJMAX), intent(in), optional :: xmask + + logical, dimension(MAXLIMAX,MAXLJMAX) :: mask + real, dimension(MAXLIMAX+2*NEXTEND,MAXLJMAX+2*NEXTEND) :: xx ! extended + character(len=30) :: txt, masktxt + real :: xwfmin, xxmin, xxmax + logical :: debug_flag=.false. + real :: sumland, sumx, landfrac, oldx + integer :: i,j, ii, jj, ii2, jj2 + + txt = "Landify: " + if ( present(intxt) ) txt = trim(txt) // trim(intxt) + xwfmin = 0.5 ! Default fraction of water + if ( present(wfmin) ) xwfmin = wfmin + xxmin = 1.0e-10 ! Default min value x + if ( present(xmin) ) xxmin = xmin + xxmax = 1.0e30 ! Default max value x + if ( present(xmax) ) xxmax = xmax + + if(DEBUG_LANDIFY.and.MasterProc) then + write(*,*) trim(txt) , water_frac_set + write(*,"(a,2g12.4)") 'Data Limits ', xxmin, xxmax + write(*,"(a,g12.4)") 'Water Limit ', xwfmin + end if + + if( .not. water_frac_set ) then + if(MasterProc) write(*,*) trim(txt) // " skips 1st NTERM" + write(*,*) trim(txt) // " skips 1st NTERM" + return ! on 1st time-step water_frac hasnt yet been set. + end if + + if ( present(xmask) ) then + mask = xmask + masktxt = "Input mask" + else + mask = likely_coastal + masktxt = "Coastal mask" + end if + + if ( DEBUG_LANDIFY.and. debug_proc ) then + write(*,"(a,6i4,L2,1x,a)") "DLandify start ", & + debug_li, debug_lj, 1, limax, 1, ljmax, xwf_done, trim(masktxt) + end if + + ! We need the extended water-fraction too, but just once + if ( .not. xwf_done ) then ! only need to do this once + if ( DEBUG_MET .and. debug_proc) write(*,*) "Landify xwf" + call extendarea( water_fraction(:,:), xwf, debug_flag) + xwf_done = .true. + end if + + ! Then the data we are working with: + + call extendarea( x(:,:), xx(:,:), debug_flag ) + if ( DEBUG_LANDIFY .and. debug_proc) write(*,*) "Landify now ", & + xwf_done , likely_coastal(debug_li,debug_lj), mask(debug_li,debug_lj) + + oldx = 0.0 + if( debug_proc ) oldx = x(debug_li, debug_lj) + + do j = 1, ljmax + do i = 1, limax + + ! Take a 5x5 average of the land-weighted values for SW. Seems + ! best not to "believe" NWP models too much for this param, and + ! the variation in a grid is so big anyway. We aim at the broad + ! effect. + + sumland = 0.0 + sumx = 0.0 + debug_flag = ( DEBUG_LANDIFY .and. debug_proc .and. & + i==debug_li .and. j==debug_lj ) + + ! if( likely_coastal(i,j) ) then !some land + if( mask(i,j) ) then ! likely coastal or water_frac <0.0 for SW + do jj = -NEXTEND, NEXTEND + do ii = -NEXTEND, NEXTEND + ii2=i+ii+NEXTEND ! coord in extended array !CHECK! + jj2=j+jj+NEXTEND + + +!Had 0.5, 1.0e-10 in original for met-data + if( xwf(ii2,jj2)<= wfmin .and. &! was 0.5 likely not NWP sea + xx(ii2,jj2) <= xxmax .and. &! Valid x range + xx(ii2,jj2) >= xxmin ) then ! + landfrac = 1.0 - xwf(ii2,jj2) + sumland = sumland + landfrac + sumx = sumx + landfrac * xx(ii2,jj2) + if ( debug_flag ) then + write(*,"(a,4i4,2f7.4,3g11.3,2f7.4)") "DBG"//trim(intxt), i,j, & + ii2, jj2,& + water_fraction(i,j), xwf(ii2,jj2), x(i,j), & + xx(ii2,jj2), sumx, landfrac, sumland + end if ! DEBUG + end if ! xsw + end do!ii + end do!jj + + if ( sumland > 0.001 ) then ! replace x with land-weighted values + + x(i,j) = sumx/sumland + if ( debug_flag ) then + write(*,"(a,2i4,8g12.3)") "DBGDONE", i,j, & + water_fraction(i,j), sumx, sumland, x(i,j) + end if + + end if ! water_fraction + + end if ! likely_coastal + end do ! i + end do ! j + + !if ( DEBUG_MET .and. debug_proc ) write(*,*) "Landify done" + if ( debug_proc ) then + call datewrite("LandifyDONE: "//trim(intxt), (/ oldx, x(debug_li,debug_lj) /) ) + end if + + end subroutine landify subroutine readneighbors(data,data_south,data_north,data_west,data_east,thick) @@ -2571,34 +2848,38 @@ subroutine Getmeteofield(meteoname,namefield,nrec,& integer,intent(in) :: nrec,ndim integer*2 :: var_local(MAXLIMAX,MAXLJMAX,KMAX_MID) - integer*2, allocatable ::var_global(:,:,:) ! faster if defined with +! integer*2, allocatable ::var_global(:,:,:) ! faster if defined with ! fixed dimensions for all ! nodes? real :: scalefactors(2) integer :: KMAX,ijk,i,k,j,nfetch validity='' + call_msg = "GetMeteofield" // trim(namefield) if(ndim==3)KMAX=KMAX_MID if(ndim==2)KMAX=1 if(MasterProc)then - allocate(var_global(GIMAX,GJMAX,KMAX)) +! allocate(var_global(GIMAX,GJMAX,KMAX)) nfetch=1 call GetCDF_short(namefield,meteoname,var_global,GIMAX,IRUNBEG,GJMAX, & JRUNBEG,KMAX,nrec,nfetch,scalefactors,unit,validity) else - allocate(var_global(1,1,1)) !just to have the array defined +! allocate(var_global(1,1,1)) !just to have the array defined endif !note: var_global is defined only for me=0 call global2local_short(var_global,var_local,MSG_READ4,GIMAX,GJMAX,& KMAX,1,1) + CALL MPI_BCAST(scalefactors,8*2,MPI_BYTE,0,MPI_COMM_WORLD,INFO) CALL MPI_BCAST(validity,50,MPI_BYTE,0,MPI_COMM_WORLD,INFO) CALL MPI_BCAST(unit,50,MPI_BYTE,0,MPI_COMM_WORLD,INFO) +!scalefactors=1.0 +!validity=' ' +!unit=' ' - - deallocate(var_global) +! deallocate(var_global) ijk=0 @@ -2638,23 +2919,35 @@ subroutine GetCDF_short(varname,fileName,var,GIMAX,IRUNBEG,GJMAX,JRUNBEG & integer :: ncFileID,status real :: scale,offset character *100 :: period_read - + character *200,save :: filename_save='notsaved' + integer,save :: ncFileID_save=-99 + validity=' ' !initialisation period_read=' ' !initialisation scalefactors(1) = 1.0 !default scalefactors(2) = 0. !default + call_msg = "GetCDF_short:"//trim(fileName) ndims=3 if(KMAX==1)ndims=2 !open an existing netcdf dataset + if(trim(filename_save)==trim(filename))then + ncFileID=ncFileID_save + else + if(ncFileID_save/=-99)then + call check(nf90_close(ncFileID_save)) + filename_save='notsaved' + endif call check(nf90_open(path=trim(fileName),mode=nf90_nowrite,ncid=ncFileID)) - + ncFileID_save=ncFileID +filename_save=trim(filename) + endif !get varID: status = nf90_inq_varid(ncid=ncFileID,name=trim(varname),varID=VarID) if(status /= nf90_noerr)then validity=field_not_found - var=0 - call check(nf90_close(ncFileID)) + var=0.0 + ! call check(nf90_close(ncFileID)) return endif @@ -2696,473 +2989,19 @@ subroutine GetCDF_short(varname,fileName,var,GIMAX,IRUNBEG,GJMAX,JRUNBEG & call check(nf90_get_var(ncFileID, VarID, var,& start=(/IRUNBEG,JRUNBEG,1,nstart/),count=(/GIMAX,GJMAX,KMAX,nfetch /))) endif - - call check(nf90_close(ncFileID)) +!var=0.0 +! call check(nf90_close(ncFileID)) end subroutine GetCDF_short - - subroutine Getgridparams(meteoname,GRIDWIDTH_M,xp,yp,fi,xm_i,xm_j,xm2,& - ref_latitude,sigma_mid,Nhh,nyear,nmonth,nday,nhour,nhour_first& - ,cyclicgrid) - ! - ! Get grid and time parameters as defined in the meteo file - ! Do some checks on sizes and dates - ! - ! This routine is called only once (and is therefore not optimized for speed) - ! - - implicit none - - character (len = *), intent(in) ::meteoname - integer, intent(in):: nyear,nmonth,nday,nhour - real, intent(out) :: GRIDWIDTH_M,xp,yp,fi, ref_latitude,& - xm2(0:MAXLIMAX+1,0:MAXLJMAX+1)& - ,xm_i(0:MAXLIMAX+1,0:MAXLJMAX+1)& - ,xm_j(0:MAXLIMAX+1,0:MAXLJMAX+1),sigma_mid(KMAX_MID) - integer, intent(out):: Nhh,nhour_first,cyclicgrid - - integer :: nseconds(1),n1,i,j,im,jm,i0,j0 - integer :: ncFileID,idimID,jdimID, kdimID,timeDimID,varid,timeVarID - integer :: GIMAX_file,GJMAX_file,KMAX_file,ihh,ndate(4) - real,dimension(-1:GIMAX+2,-1:GJMAX+2) ::xm_global,xm_global_j,xm_global_i - integer :: status,iglobal,jglobal,info,South_pole,North_pole,Ibuff(2) - real :: ndays(1),x1,x2,x3,x4 - character (len = 50) :: timeunit - - if(MasterProc)then - print *,'Defining grid properties from ',trim(meteoname) - !open an existing netcdf dataset - status = nf90_open(path=trim(meteoname),mode=nf90_nowrite,ncid=ncFileID) - - if(status /= nf90_noerr) then - print *,'not found',trim(meteoname) - METEOfelt=1 - else -! print *,' reading ',trim(meteoname) - projection='' - call check(nf90_get_att(ncFileID,nf90_global,"projection",projection)) - if(trim(projection)=='Rotated_Spherical'.or.trim(projection)=='rotated_spherical'& - .or.trim(projection)=='rotated_pole'.or.trim(projection)=='rotated_latitude_longitude')then - projection='Rotated_Spherical' - endif - write(*,*)'projection: ',trim(projection) - - !get dimensions id - if(trim(projection)=='Stereographic') then - call check(nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID)) - call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) - elseif(trim(projection)==trim('lon lat')) then - call check(nf90_inq_dimid(ncid = ncFileID, name = "lon", dimID = idimID)) - call check(nf90_inq_dimid(ncid = ncFileID, name = "lat", dimID = jdimID)) - else - ! write(*,*)'GENERAL PROJECTION ',trim(projection) - call check(nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID)) - call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) - endif - - call check(nf90_inq_dimid(ncid = ncFileID, name = "k", dimID = kdimID)) - call check(nf90_inq_dimid(ncid = ncFileID, name = "time", dimID = timeDimID)) - call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = timeVarID)) - - !get dimensions length - call check(nf90_inquire_dimension(ncid=ncFileID,dimID=idimID,len=GIMAX_file)) - call check(nf90_inquire_dimension(ncid=ncFileID,dimID=jdimID,len=GJMAX_file)) - call check(nf90_inquire_dimension(ncid=ncFileID,dimID=kdimID,len=KMAX_file)) - call check(nf90_inquire_dimension(ncid=ncFileID,dimID=timedimID,len=Nhh)) - - write(*,*)'dimensions meteo grid:',GIMAX_file,GJMAX_file,KMAX_file,Nhh - - if(GIMAX_file/=IIFULLDOM.or.GJMAX_file/=JJFULLDOM)then - write(*,*)'IIFULLDOM,JJFULLDOM ',IIFULLDOM,JJFULLDOM - write(*,*)'WARNING: large domain and meteorology file have different sizes' - write(*,*)'WARNING: THIS CASE IS NOT TESTED. Please change large domain' - endif - - call CheckStop(GIMAX+IRUNBEG-1 > GIMAX_file, "NetCDF_ml: I outside domain" ) - call CheckStop(GJMAX+JRUNBEG-1 > GJMAX_file, "NetCDF_ml: J outside domain" ) - call CheckStop(KMAX_MID > KMAX_file, "NetCDF_ml: wrong vertical dimension") - call CheckStop(24/Nhh, METSTEP, "NetCDF_ml: METSTEP != meteostep" ) - - call CheckStop(nhour/=0 .and. nhour /=3,& - "Met_ml/GetCDF: must start at nhour=0 or 3") - - call check(nf90_get_att(ncFileID,timeVarID,"units",timeunit)) - - ihh=1 - n1=1 - if(trim(timeunit)==trim("days since 1900-1-1 0:0:0"))then - write(*,*)'Meteo date in days since 1900-1-1 0:0:0' - call check(nf90_get_var(ncFileID,timeVarID,ndays,& - start=(/ihh/),count=(/n1 /))) - call nctime2idate(ndate,ndays(1)) ! for printout: msg="meteo hour YYYY-MM-DD hh" - else - call check(nf90_get_var(ncFileID,timeVarID,nseconds,& - start=(/ihh/),count=(/n1 /))) - call nctime2idate(ndate,nseconds(1)) ! default - endif - nhour_first=ndate(4) - - - call CheckStop(ndate(1), nyear, "NetCDF_ml: wrong meteo year" ) - call CheckStop(ndate(2), nmonth, "NetCDF_ml: wrong meteo month" ) - call CheckStop(ndate(3), nday, "NetCDF_ml: wrong meteo day" ) - - do ihh=1,Nhh - - if(trim(timeunit)==trim("days since 1900-1-1 0:0:0"))then - call check(nf90_get_var(ncFileID, timeVarID, ndays,& - start=(/ ihh /),count=(/ n1 /))) - call nctime2idate(ndate,ndays(1)) - else - call check(nf90_get_var(ncFileID, timeVarID, nseconds,& - start=(/ ihh /),count=(/ n1 /))) - call nctime2idate(ndate,nseconds(1)) - endif - call CheckStop( mod((ihh-1)*METSTEP+nhour_first,24), ndate(4), & - date2string("NetCDF_ml: wrong meteo hour YYYY-MM-DD hh",ndate)) - - enddo - - - !get global attributes - call check(nf90_get_att(ncFileID,nf90_global,"Grid_resolution",GRIDWIDTH_M)) - if(trim(projection)=='Stereographic')then - call check(nf90_get_att(ncFileID,nf90_global,"ref_latitude",ref_latitude)) - call check(nf90_get_att(ncFileID, nf90_global, "xcoordinate_NorthPole" & - ,xp )) - call check(nf90_get_att(ncFileID, nf90_global, "ycoordinate_NorthPole" & - ,yp )) - call check(nf90_get_att(ncFileID, nf90_global, "fi",fi )) - - call GlobalPosition - elseif(trim(projection)==trim('lon lat')) then - ref_latitude=60. - xp=0.0 - yp=GJMAX - fi =0.0 - call check(nf90_inq_varid(ncid = ncFileID, name = "lon", varID = varID)) - call check(nf90_get_var(ncFileID, varID, glon_fdom(1:IIFULLDOM,1) )) - do i=1,IIFULLDOM - if(glon_fdom(i,1)>180.0)glon_fdom(i,1)=glon_fdom(i,1)-360.0 - if(glon_fdom(i,1)<-180.0)glon_fdom(i,1)=glon_fdom(i,1)+360.0 - enddo - do j=1,JJFULLDOM - glon_fdom(:,j)=glon_fdom(:,1) - enddo - call check(nf90_inq_varid(ncid = ncFileID, name = "lat", varID = varID)) - call check(nf90_get_var(ncFileID, varID, glat_fdom(1,1:JJFULLDOM) )) - do i=1,IIFULLDOM - glat_fdom(i,:)=glat_fdom(1,:) - enddo - else - ref_latitude=60. - xp=0.0 - yp=GJMAX - fi =0.0 - if(trim(projection)=='Rotated_Spherical')then - call check(nf90_get_att(ncFileID,nf90_global,"grid_north_pole_latitude",grid_north_pole_latitude)) - call check(nf90_get_att(ncFileID,nf90_global,"grid_north_pole_longitude",grid_north_pole_longitude)) - endif - call check(nf90_inq_varid(ncid = ncFileID, name = "lon", varID = varID)) - call check(nf90_get_var(ncFileID, varID, glon_fdom(1:IIFULLDOM,1:JJFULLDOM) )) - - call check(nf90_inq_varid(ncid = ncFileID, name = "lat", varID = varID)) - call check(nf90_get_var(ncFileID, varID, glat_fdom(1:IIFULLDOM,1:JJFULLDOM) )) - do j=1,JJFULLDOM - do i=1,IIFULLDOM - if(glon_fdom(i,j)>180.0)glon_fdom(i,j)=glon_fdom(i,j)-360.0 - if(glon_fdom(i,j)<-180.0)glon_fdom(i,j)=glon_fdom(i,j)+360.0 - enddo - enddo - - endif - !get variables - status=nf90_inq_varid(ncid=ncFileID, name="map_factor", varID=varID) - - if(status == nf90_noerr)then - !mapping factor at center of cells is defined - !make "staggered" map factors - call check(nf90_get_var(ncFileID, varID, xm_global(1:GIMAX,1:GJMAX) & - ,start=(/ IRUNBEG,JRUNBEG /),count=(/ GIMAX,GJMAX /))) - do j=1,GJMAX - do i=1,GIMAX-1 - xm_global_j(i,j)=0.5*(xm_global(i,j)+xm_global(i+1,j)) - enddo - enddo - i=GIMAX - do j=1,GJMAX - xm_global_j(i,j)=1.5*xm_global(i,j)-0.5*xm_global(i-1,j) - enddo - do j=1,GJMAX-1 - do i=1,GIMAX - xm_global_i(i,j)=0.5*(xm_global(i,j)+xm_global(i,j+1)) - enddo - enddo - j=GJMAX - do i=1,GIMAX - xm_global_i(i,j)=1.5*xm_global(i,j)-0.5*xm_global(i,j-1) - enddo - - else - !map factor are already staggered - status=nf90_inq_varid(ncid=ncFileID, name="map_factor_i", varID=varID) - - !BUGCHECK - moved here... (deleted if loop) - call CheckStop( status, nf90_noerr, "erro rreading map factor" ) - - call check(nf90_get_var(ncFileID, varID, xm_global_i(1:GIMAX,1:GJMAX) & - ,start=(/ IRUNBEG,JRUNBEG /),count=(/ GIMAX,GJMAX /))) - call check(nf90_inq_varid(ncid=ncFileID, name="map_factor_j", varID=varID)) - call check(nf90_get_var(ncFileID, varID, xm_global_j(1:GIMAX,1:GJMAX) & - ,start=(/ IRUNBEG,JRUNBEG /),count=(/ GIMAX,GJMAX /))) - endif - - call check(nf90_inq_varid(ncid = ncFileID, name = "k", varID = varID)) - call check(nf90_get_var(ncFileID, varID, sigma_mid )) - - - endif !found meteo - endif !me=0 - - CALL MPI_BCAST(METEOfelt ,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - if( METEOfelt==1)return !do not use NetCDF meteo input - - - CALL MPI_BCAST(Nhh,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(GRIDWIDTH_M,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(ref_latitude,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(xp,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(yp,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(fi,8*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(sigma_mid,8*KMAX_MID,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(xm_global_i(1:GIMAX,1:GJMAX),8*GIMAX*GJMAX,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(xm_global_j(1:GIMAX,1:GJMAX),8*GIMAX*GJMAX,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(glat_fdom(1:IIFULLDOM,1:JJFULLDOM),8*IIFULLDOM*JJFULLDOM,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(glon_fdom(1:IIFULLDOM,1:JJFULLDOM),8*IIFULLDOM*JJFULLDOM,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - CALL MPI_BCAST(projection,len(projection),MPI_CHARACTER,0,MPI_COMM_WORLD,INFO) - - - do j=1,MAXLJMAX - do i=1,MAXLIMAX - glon(i,j)=glon_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2) - glat(i,j)=glat_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2) - enddo - enddo - i0=0 - im=MAXLIMAX - j0=0 - jm=MAXLJMAX - if(gi0+MAXLIMAX+1+IRUNBEG-2>IIFULLDOM)im=MAXLIMAX-1!outside fulldomain - if(gi0+0+IRUNBEG-2<1)i0=1!outside fulldomain - if(gj0+MAXLJMAX+1+JRUNBEG-2>JJFULLDOM)jm=MAXLJMAX-1!outside fulldomain - if(gj0+0+JRUNBEG-2<1)j0=1!outside fulldomain - - do j=j0,jm - do i=i0,im - x1=glon_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2) - x2=glon_fdom(gi0+i+1+IRUNBEG-2,gj0+j+JRUNBEG-2) - x3=glon_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2) - x4=glon_fdom(gi0+i+1+IRUNBEG-2,gj0+j+1+JRUNBEG-2) - -!8100=90*90; could use any number much larger than zero and much smaller than 180*180 - if(x1*x2<-8100.0 .or. x1*x3<-8100.0 .or. x1*x4<-8100.0)then - !Points are on both sides of the longitude -180=180 - if(x1<0)x1=x1+360.0 - if(x2<0)x2=x2+360.0 - if(x3<0)x3=x3+360.0 - if(x4<0)x4=x4+360.0 - endif - gl_stagg(i,j)=0.25*(x1+x2+x3+x4) - - gb_stagg(i,j)=0.25*(glat_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2)+& - glat_fdom(gi0+i+1+IRUNBEG-2,gj0+j+JRUNBEG-2)+& - glat_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2)+& - glat_fdom(gi0+i+1+IRUNBEG-2,gj0+j+1+JRUNBEG-2)) - enddo - enddo - do j=0,j0 - do i=i0,im - x1=gl_stagg(i,j+1) - x2=gl_stagg(i,j+2) - if(x1*x2<-8100.0 )then - if(x1<0)x1=x1+360.0 - if(x2<0)x2=x2+360.0 - endif - gl_stagg(i,j)=2*x1-x2 - gb_stagg(i,j)=2*gb_stagg(i,j+1)-gb_stagg(i,j+2) - enddo - enddo - do j=jm,MAXLJMAX - do i=i0,im - x1=gl_stagg(i,j-1) - x2=gl_stagg(i,j-2) - if(x1*x2<-8100.0 )then - if(x1<0)x1=x1+360.0 - if(x2<0)x2=x2+360.0 - endif - gl_stagg(i,j)=2*x1-x2 - gb_stagg(i,j)=2*gb_stagg(i,j-1)-gb_stagg(i,j-2) - enddo - enddo - do j=0,MAXLJMAX - do i=0,i0 - x1=gl_stagg(i+1,j) - x2=gl_stagg(i+2,j) - if(x1*x2<-8100.0 )then - if(x1<0)x1=x1+360.0 - if(x2<0)x2=x2+360.0 - endif - gl_stagg(i,j)=2*x1-x2 - gb_stagg(i,j)=2*gb_stagg(i+1,j)-gb_stagg(i+2,j) - enddo - enddo - do j=0,MAXLJMAX - do i=im,MAXLIMAX - x1=gl_stagg(i-1,j) - x2=gl_stagg(i-2,j) - if(x1*x2<-8100.0 )then - if(x1<0)x1=x1+360.0 - if(x2<0)x2=x2+360.0 - endif - gl_stagg(i,j)=2*x1-x2 - gb_stagg(i,j)=2*gb_stagg(i-1,j)-gb_stagg(i-2,j) - enddo - enddo -!ensure that values are within [-180,+180]] - do j=0,MAXLJMAX - do i=0,MAXLIMAX - if(gl_stagg(i,j)>180.0)gl_stagg(i,j)=gl_stagg(i,j)-360.0 - if(gl_stagg(i,j)<-180.0)gl_stagg(i,j)=gl_stagg(i,j)+360.0 - enddo - enddo - - !test if the grid is cyclicgrid: - !The last cell + 1 cell = first cell - Cyclicgrid=1 !Cyclicgrid - do j=1,JJFULLDOM - if(mod(nint(glon_fdom(GIMAX,j)+360+360.0/GIMAX),360)/=& - mod(nint(glon_fdom(IRUNBEG,j)+360.0),360))then - Cyclicgrid=0 !not cyclicgrid - endif - enddo - - if(MasterProc .and. DEBUG_MET)write(*,*)'CYCLICGRID:',Cyclicgrid - - !complete (extrapolate) along the four lateral sides - do i=1,GIMAX - xm_global_j(i,0)=1.0/(2.0/(xm_global_j(i,1))-1.0/(xm_global_j(i,2))) - xm_global_j(i,-1)=1.0/(2.0/(xm_global_j(i,0))-1.0/(xm_global_j(i,1))) - xm_global_j(i,GJMAX+1)=1.0/(2.0/(xm_global_j(i,GJMAX))-1.0/(xm_global_j(i,GJMAX-1))) - xm_global_j(i,GJMAX+2)=1.0/(2.0/(xm_global_j(i,GJMAX+1))-1.0/(xm_global_j(i,GJMAX))) - xm_global_i(i,0)=1.0/(2.0/(xm_global_i(i,1))-1.0/(xm_global_i(i,2))) - xm_global_i(i,-1)=1.0/(2.0/(xm_global_i(i,0))-1.0/(xm_global_i(i,1))) - xm_global_i(i,GJMAX+1)=1.0/(2.0/(xm_global_i(i,GJMAX))-1.0/(xm_global_i(i,GJMAX-1))) - xm_global_i(i,GJMAX+2)=1.0/(2.0/(xm_global_i(i,GJMAX+1))-1.0/(xm_global_i(i,GJMAX))) - enddo - do j=-1,GJMAX+2 - xm_global_j(0,j)=1.0/(2.0/(xm_global_j(1,j))-1.0/(xm_global_j(2,j))) - xm_global_j(-1,j)=1.0/(2.0/(xm_global_j(0,j))-1.0/(xm_global_j(1,j))) - xm_global_j(GIMAX+1,j)=1.0/(2.0/(xm_global_j(GIMAX,j))-1.0/(xm_global_j(GIMAX-1,j))) - xm_global_j(GIMAX+2,j)=1.0/(2.0/(xm_global_j(GIMAX+1,j))-1.0/(xm_global_j(GIMAX,j))) - xm_global_i(0,j)=1.0/(2.0/(xm_global_i(1,j))-1.0/(xm_global_i(2,j))) - xm_global_i(-1,j)=1.0/(2.0/(xm_global_i(0,j))-1.0/(xm_global_i(1,j))) - xm_global_i(GIMAX+1,j)=1.0/(2.0/(xm_global_i(GIMAX,j))-1.0/(xm_global_i(GIMAX-1,j))) - xm_global_i(GIMAX+2,j)=1.0/(1.0/(2*xm_global_i(GIMAX+1,j))-1.0/(xm_global_i(GIMAX,j))) - enddo - - j=1 - i=1 - if(abs(1.5*glat_fdom(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2)-0.5*glat_fdom(gi0+i+IRUNBEG-2,gj0+j+1+JRUNBEG-2))>89.5)then - write(*,*)'south pole' !xm is infinity - xm_global_i(:,0)=1.0E19 - xm_global_i(:,-1)=1.0E19 - endif - - - - !keep only part of xm relevant to the local domain - !note that xm has dimensions larger than local domain - - call CheckStop( MAXLIMAX+1 > limax+2, "Error in Met_ml X size definition" ) - call CheckStop( MAXLJMAX+1 > ljmax+2, "Error in Met_ml J size definition" ) - - do j=0,MAXLJMAX+1 - do i=0,MAXLIMAX+1 - iglobal=gi0+i-1 - jglobal=gj0+j-1 - xm_i(i,j)=xm_global_i(iglobal,jglobal) - xm_j(i,j)=xm_global_j(iglobal,jglobal) - !Note that xm is inverse length: interpolate 1/xm rather than xm - xm2(i,j) = 4.0*( (xm_global_i(iglobal,jglobal-1)*& - xm_global_i(iglobal,jglobal))/ & - (xm_global_i(iglobal,jglobal-1)+& - xm_global_i(iglobal,jglobal) ) ) *(& - xm_global_j(iglobal-1,jglobal)*& - xm_global_j(iglobal,jglobal) )/(& - xm_global_j(iglobal-1,jglobal)+& - xm_global_j(iglobal,jglobal) ) - enddo - enddo - - !pw - !If some cells are to narrow (Poles in lat lon coordinates), - !this will give too small time steps in the Advection, - !because of the constraint that the Courant number should be <1. - ! - !If Poles are found and lon-lat coordinates are used the Advection scheme - !will be modified to be able to cope with the singularity - - !Look for poles - !If the northernmost or southernmost lines are poles, they are not - !considered as outer boundaries and will not be treated - !by "BoundaryConditions_ml". - !Note that "Poles" is defined in subdomains - - North_pole=1 - do i=1,limax - if(nint(glat(i,ljmax))<=88)then - North_pole=0 !not north pole - endif - enddo - - South_pole=1 - do i=1,limax - if(nint(glat(i,1))>=-88)then - South_pole=0 !not south pole - endif - enddo - - Poles=0 - if(North_pole==1)then - Poles(1)=1 - write(*,*)me,'Found North Pole' - endif - - if(South_pole==1)then - Poles(2)=1 - write(*,*)me,'Found South Pole' - endif - - CALL MPI_ALLREDUCE(Poles,Ibuff,2,MPI_INTEGER,MPI_MAX,MPI_COMM_WORLD,INFO) - Pole_included=max(Ibuff(1),Ibuff(2)) - - if(ME==0.and.Pole_included==1)write(*,*)'The grid includes a pole' - - end subroutine Getgridparams - - - - - subroutine check(status) implicit none integer, intent ( in) :: status - call CheckStop( status, nf90_noerr, "Error in Met_ml/NetCDF stuff" & + call CheckStop( status, nf90_noerr, "Error in Met_ml/NetCDF stuff:" // trim(call_msg) & // trim( nf90_strerror(status) ) ) end subroutine check diff --git a/MicroMet_ml.f90 b/MicroMet_ml.f90 index 88b2dc6..87451f7 100644 --- a/MicroMet_ml.f90 +++ b/MicroMet_ml.f90 @@ -26,6 +26,7 @@ !* along with this program. If not, see . !*****************************************************************************! module Micromet_ml + use ModelConstants_ml, only: FluxPROFILE !____________________________________________________________________ ! Miscellaneous collection of "standard" micromet functions ! Including PsiM, PsiH, AerRes @@ -52,6 +53,8 @@ module Micromet_ml public :: PsiM + public :: Launiainen1995 + public :: wind_at_h !wind for given height !/-- define PI here rather than use PhysicalCOnstants_ml, to @@ -147,6 +150,7 @@ end function AerResM function PsiH(zL) result (stab_h) ! PsiH = integral flux-gradient stability function for heat ! Ref: Garratt, 1994, pp52-54 + ! VDHH modified - use van der Hurk + Holtslag? ! In: real, intent(in) :: zL ! surface layer stability parameter, (z-d)/L @@ -156,12 +160,17 @@ function PsiH(zL) result (stab_h) ! Local real :: x + real, parameter :: a=1, b=0.667, c=5.0, d=0.35 if (zL < 0) then !unstable x = sqrt(1.0 - 16.0 * zL) stab_h = 2.0 * log( (1.0 + x)/2.0 ) else !stable - stab_h = -5.0 * zL + if ( FluxPROFILE == "Ln95" ) then + stab_h = -( (1+2*a/3.0*zL)**1.5 + b*(zL-c/d)* exp(-d*zL) + (b*c/d-1) ) + else + stab_h = -5.0 * zL + end if end if end function PsiH @@ -176,16 +185,58 @@ function PsiM(zL) result (stab_m) ! notation must be preserved real :: stab_m real :: x + real, parameter :: a=1, b=0.667, c=5.0, d=0.35 if( zL < 0) then !unstable x = sqrt(sqrt(1.0 - 16.0*zL)) stab_m = log( 0.125*(1.0+x)*(1.0+x)*(1.0+x*x) ) + PI/2.0 - 2.0*atan(x) else !stable - stab_m = -5.0 * zL + if ( FluxPROFILE == "Ln95" ) then + stab_m = -( a*zL + b*(zl-c/d)*exp(-d*zL) + b*c/d) + else + stab_m = -5.0 * zL + end if end if end function PsiM +!-------------------------------------------------------------------- +subroutine Launiainen1995 (u, z, z0m, z0mh, theta0, theta, invL) + real, intent(in) :: u ! winds + real, intent(in) :: z ! mid-cell height + real, intent(in) :: z0m ! roughness ht., momentum + real, intent(in) :: z0mh ! ration roughness ht., momentum + real, intent(in) :: theta0 !pot. temp at surface + real, intent(in) :: theta !pot. temp at ref ht. + real, intent(out) :: invL + integer :: k + real :: zeta ! z/L + real :: z0h, logzz0m, Rib + z0h = z0m/ z0mh + + ! Ignoring virtual temp (and Lau has no z0): + + !Rib = GRAV * z * (theta-theta0 ) / & + Rib = 9.81 * z * (theta-theta0 ) / & + ( theta0 * u**2 + 0.001 ) !!! EPS ) + + logzz0m = log(z/z0m) + if ( Rib <0.0 ) then + + Rib = max ( -3.0, Rib) ! Limit used by van der Hurk + Holtslag, 1996 + zeta = ( logzz0m**2/log(z/z0h) - 0.55 ) * Rib + + + else + + Rib = min ( 1.0, Rib) ! Limit used by van der Hurk + Holtslag, 1996 + zeta =( 1.89 * logzz0m + 44.2 )*Rib**2 + ( 1.18*logzz0m -1.37) * Rib + if( Rib > 0.08 ) zeta = zeta - 1.5*log(z0m/z0h)*Rib + end if + invL = zeta/z + +end subroutine Launiainen1995 + !-------------------------------------------------------------------- function Wind_at_h(u_ref, z_ref, zh, d, z0, Linv) result (u_zh) !... diff --git a/ModelConstants_ml.f90 b/ModelConstants_ml.f90 index 1b85af7..01ecd14 100644 --- a/ModelConstants_ml.f90 +++ b/ModelConstants_ml.f90 @@ -38,37 +38,73 @@ module ModelConstants_ml private !============================================================================= +! Experiment name: +! EMEPSTD Standard run & output +! EMEP2010 EMEPSTD with Iceland Volcanic Eruption input +! TFMM EMEPSTD, but with INERIS_SNAP & TFMM hourly output +! FORECAST Forecast run, MACC-ENS hourly output & BC +! EVA2010 FORECAST with MACC-EVA2010 hourly output & BC +! EMERGENCY FORECAST with ONLY Volcanic Eruption & Nuclear Accident. +CHARACTER(LEN=*), public, parameter :: EXP_NAME="EMEP2010" + +! FORECAST mode run: +! * Nested IC/BC def in Nest_ml & IFSMOZ_ExternalBICs_ml +! * Special hourly output def in My_Outputs_ml +! * Only dayly and hourly output are required, +! all other output types to false in Derived_ml. +logical, public, parameter :: FORECAST=& + (EXP_NAME=="FORECAST").or.(EXP_NAME=="EVA2010").or.(EXP_NAME=="EMERGENCY") + ! Some flags for model setup -! will be removed when code is sufficiently tested +! will be removed when code is sufficiently tested ! (for convection use foundconv in permanent code) -logical, public, parameter :: USE_CONVECTION = .false. ! false works best for Euro runs, - ! essential for global -logical, public, parameter :: USE_SOILWATER = .false. !needs more work for IFS! -logical, public, parameter :: USE_FOREST_FIRES = .false. ! Needs global files, future -logical, public, parameter :: USE_AIRCRAFT_EMIS = .false. ! Needs global file, see manual -logical, public, parameter :: USE_LIGHTNING_EMIS = .true. ! ok -logical, public, parameter :: USE_SOIL_NOX = .false. ! Future use -logical, public, parameter :: USE_SEASALT = .true. ! ok -logical, public, parameter :: USE_DUST = .false. ! Experimental -logical, public, parameter :: DO_SAHARA = .false. ! Turn on/off BG Saharan Dust -logical, public, parameter :: USE_AOD = .false. -logical, public, parameter :: USE_PFT_MAPS = .false. ! Future option -logical, public, parameter :: EXTENDEDMASSBUDGET = .false.!extended massbudget outputs +logical, public, parameter :: & + USE_CONVECTION = .false., & ! false works best for Euro runs, + INERIS_SNAP1 = (EXP_NAME=="TFMM"), & ! Switches off decadal trend + INERIS_SNAP2 = (EXP_NAME=="TFMM"), & ! Allows near-zero summer values + USE_DEGREEDAY_FACTORS = .true., & ! + USE_SOILWATER = .true., & ! for deep soilwater, under testing + USE_FOREST_FIRES = .false., & ! Needs global files, future + USE_AIRCRAFT_EMIS = .false., & ! Needs global file, see manual + USE_LIGHTNING_EMIS = .true., & ! ok + USE_SOILNOX = .true., & ! ok, but diff for global + Euro runs + NO_CROPNH3DEP = .true., & ! Stop NH3 deposition for growing crops + USE_SEASALT = .true., & ! ok +! More experimental: + USE_DUST = .true., & ! Experimental + USE_ROADDUST = .false., & ! UNDER DEVELOPMENT! Testing the TNO Road Dust routine. So far with simplified "climate-correction" factor + DO_SAHARA = .true., & ! Turn on/off BG Saharan Dust + USE_GLOBAL_SOILNOX = .false., & ! Need to design better switch + USE_SOILNH3 = .false., & ! DUMMY VALUES, DO NOT USE! + USE_AOD = FORECAST, & + USE_ZREF = .false., & ! testing + USE_PFT_MAPS = .false., & ! Future option + EXTENDEDMASSBUDGET = .false., & ! extended massbudget outputs + LANDIFY_MET = .false., & ! extended massbudget outputs + USE_POLLEN = .false., & ! EXPERIMENTAL. Only works if start Jan 1 + USE_EMERGENCY = .true. ! Emergency: Volcanic Eruption & Nuclear Accident. Under development. + +!Boundary layer profiles + character(len=4), parameter, public :: FluxPROFILE = & + "Iter" ! +! "Ln95" ! ! will use Launiainen1995 EXPERIMENTAL. Fails in some areas + ! Biogenics. Use 3 even if no terpene chemistry - simplifies -! rest of code. iso = isoprene, mtp = monoterpenes from pools, +! rest of code. iso = isoprene, mtp = monoterpenes from pools, ! mtl = monoterpenes with light dependence -integer, public, parameter :: NBVOC = 3 -character(len=4),public, save, dimension(NBVOC) :: & - BVOC_USED = (/ "Eiso","Emt ","Emtl"/) +!DSA12 integer, public, parameter :: NSOIL_EMIS = 2 ! NO + NH3 + integer, public, parameter :: NBVOC = 3 + character(len=4),public, save, dimension(NBVOC) :: & + BVOC_USED = (/ "Eiso","Emt ","Emtl"/) -!The GEA emission data, which is used for EUCAARI runs on the HIRHAM domain +!The GEA emission data, which is used for EUCAARI runs on the HIRHAM domains !have in several sea grid cells non-zero emissions in other sectors than SNAP8 -!and there are also NH3 emission over sea areas. The former problem makes -!the code crash if the sea areas are defined as sea (sea=T), so we treat -!them as land in the EUCAARI/HIRHAM runs (sea=F). This is a problem with GEA +!and there are also NH3 emission over sea areas. The former problem makes +!the code crash if the sea areas are defined as sea (sea=T), so we treat +!them as land in the EUCAARI/HIRHAM runs (sea=F). This is a problem with GEA !emission data only, not the HIRHAM domain! When e.g. interpolated EMEP emissions !are used on the HIRHAM domain, this is not a problem. - + logical, public, parameter :: SEAFIX_GEA_NEEDED = .false. ! only if problems !============================================================================= @@ -76,17 +112,22 @@ module ModelConstants_ml ! run domains character(len=*), parameter, public :: & ! DomainName = "EMEP-50kmEurope" - DomainName = "EMEP-50kmEECCA" + DomainName = "EMEP-50kmEECCA" +! DomainName = "EMEP-1degGLOBAL" ! DomainName = "EMEPCWF-0.25degEurope" ! DomainName = "EMEPCWF-0.20degEurope" ! DomainName = "HIRHAM" logical, parameter, public :: IS_GLOBAL = .false. -integer, public, parameter :: & +integer, public :: IIFULLDOM,JJFULLDOM! & SET AUTOMATICALLY BY THE CODE ! IIFULLDOM = 182, JJFULLDOM = 197 ! x,y-Dimensions of full HIRHAM domain ! IIFULLDOM = 170, JJFULLDOM = 133 ! x,y-Dimensions of full EMEP domain - IIFULLDOM = 132, JJFULLDOM = 159 ! x,y-Dimensions of full EECA domain +! IIFULLDOM = 132, JJFULLDOM = 159 ! x,y-Dimensions of full EECA domain +! IIFULLDOM = 840, JJFULLDOM = 832 ! x,y-Dimensions of full TNO07 domain +! IIFULLDOM = 420, JJFULLDOM = 416 ! x,y-Dimensions of full TNO14 domain +! IIFULLDOM = 210, JJFULLDOM = 208 ! x,y-Dimensions of full TNO28 domain +! IIFULLDOM = 105, JJFULLDOM = 104 ! x,y-Dimensions of full TNO56 domain ! IIFULLDOM = 360, JJFULLDOM = 180 ! .... full GLOBAL domain ! IIFULLDOM = 201, JJFULLDOM = 161 ! .... full GEMS 0.25 domain ! IIFULLDOM = 301, JJFULLDOM = 221 ! .... full GEMS 0.25 extended domain @@ -94,17 +135,33 @@ module ModelConstants_ml ! The difference between EMEP and EECCA is confusing... integer, public, parameter :: & -! OFFSET_i= 0, OFFSET_j= 0 ! EMEP - OFFSET_i=-35, OFFSET_j=-11 ! EECCA -integer, public, parameter, dimension(4) :: & +! OFFSET_i= 0, OFFSET_j= 0 ! EMEP or default + OFFSET_i=-35, OFFSET_j=-11 ! EECCA + +integer, public, save, dimension(4) :: & ! x0 x1 y0 y1 +RUNDOMAIN = (/ -999,-999 , -999, -999 /) ! Set values later ! RUNDOMAIN = (/ 1, 182, 1, 197 /) ! HIRHAM - RUNDOMAIN = (/ 1, 132, 1, 159 /) ! EECCA = new EMEP domain -! RUNDOMAIN = (/ 1, 100, 1, 100 /) ! Orig EMEP domain in EECCA -! RUNDOMAIN = (/ 1, 50, 1, 50 /) ! Orig EMEP domain in EECCA -! RUNDOMAIN = (/ 36, 167, 12, 122 /) ! EMEP domain -! RUNDOMAIN = (/ 56, 147, 12, 102 /) ! EGU -! RUNDOMAIN = (/ 75, 137, 32, 82 /) ! EGU +! RUNDOMAIN = (/ 1, 132, 1, 159 /) ! EECCA = new EMEP domain +! RUNDOMAIN = (/ 1, 100, 1, 100 /) ! Orig EMEP domain in EECCA (for benchmarks) +! RUNDOMAIN = (/ 40, 210, 12, 184 /) ! SR TNO28 area +! RUNDOMAIN = (/ 1, 210, 1, 208 /) ! TNO28 +! RUNDOMAIN = (/240, 720, 48, 736 /) ! TNO07 reduced (15W-45E;30N-73N) +! RUNDOMAIN = (/120, 360, 24, 368 /) ! TNO14 reduced (15W-45E;30N-73N) +! RUNDOMAIN = (/ 60, 180, 12, 184 /) ! TNO28 reduced (15W-45E;30N-73N) +! RUNDOMAIN = (/ 70, 110, 72, 110 /) ! TNO28 test +! RUNDOMAIN = (/ 30, 90, 6, 92 /) ! TNO56 reduced (15W-45E;30N-73N) +! RUNDOMAIN = (/ 60, 180, 12, 184 /) ! test TNO7 area +!-- +! Suggestions, 6th June 2012, for TFMM_RUNS scale-dep ----------------------- +! RUNDOMAIN = (/ 40, 210, 12, 184 /) ! TNO28 SR area (25W-60E;30N-73N) +! i.e. - adds 20 squares west, 30 east to TNO28 +! RUNDOMAIN = (/ 160, 840, 48, 736 /) ! TNO07 - add 80, 120 +! RUNDOMAIN = (/ 80, 420, 24, 368 /) ! TNO14 - add 40, 60 +! RUNDOMAIN = (/ 20, 105, 6, 92 /) ! TNO56 - add 10, 15 +!---------------------------------------------------------------------------- + +! RUNDOMAIN = (/ 36, 167, 12, 122 /) ! EMEP domain in PARLAM ! RUNDOMAIN = (/ 1, 360, 1, 180 /) ! FULL GLOBAL ! RUNDOMAIN = (/ 1, 132, 1, 111 /) ! EECCA, rep09 ! RUNDOMAIN = (/ 1, 132, 1, 159 /) ! EECCA, rep10 @@ -116,14 +173,14 @@ module ModelConstants_ml ! RUNDOMAIN = (/ 70+OFFSET_i, 90+OFFSET_i, 43+OFFSET_j, 63+OFFSET_j /) ! (UK) ! RUNDOMAIN = (/ 60+OFFSET_i, 86+OFFSET_i, 43+OFFSET_j, 59+OFFSET_j /) ! (UK) ! RUNDOMAIN = (/ 85+OFFSET_i,120+OFFSET_i, 55+OFFSET_j, 70+OFFSET_j /) ! (changeable) +! RUNDOMAIN = (/ 85+OFFSET_i,120+OFFSET_i, 15+OFFSET_j, 50+OFFSET_j /) ! (changeable) ! RUNDOMAIN = (/ 75+OFFSET_i,110+OFFSET_i, 45+OFFSET_j, 60+OFFSET_j /) ! (gets Esk) -! RUNDOMAIN = (/ 85+OFFSET_i,120+OFFSET_i, 70+OFFSET_j, 110+OFFSET_j /) ! (changeable) -! RUNDOMAIN = (/ 85+OFFSET_i,120+OFFSET_i, 80+OFFSET_j, 110+OFFSET_j /) ! (changeable) +! RUNDOMAIN = (/ 80+OFFSET_i, 106+OFFSET_i, 33+OFFSET_j, 55+OFFSET_j /) ! (France) +! RUNDOMAIN = (/ 80+OFFSET_i, 106+OFFSET_i, 13+OFFSET_j, 35+OFFSET_j /) ! Southern domain +! RUNDOMAIN = (/ 75+OFFSET_i,110+OFFSET_i, 25+OFFSET_j, 60+OFFSET_j /) ! (gets Esk) -integer, public, parameter :: & - NPROCX = 8 & ! Actual number of processors in longitude -, NPROCY = 4 & ! .. in latitude. NPROCY must be 2 for GLOBAL, -, NPROC = NPROCX * NPROCY +integer, public, save :: & ! Actual number of processors in longitude, latitude + NPROCX, NPROCY, NPROC ! and total. NPROCY must be 2 for GLOBAL runs. !============================================================================= !+ 2) Define debug flags. @@ -140,8 +197,11 @@ module ModelConstants_ml ! The coordinates given here only apply for the standard EMEP domain integer, private, parameter :: & +! DEBUG_ii= -99, DEBUG_jj= -99 ! none ! DEBUG_ii= 79, DEBUG_jj= 56 ! Eskdalemuir ! DEBUG_ii= 73, DEBUG_jj= 48 ! Mace Head +! DEBUG_ii= 88, DEBUG_jj= 53 ! Sibton +! DEBUG_ii= 88, DEBUG_jj= 53 ! Sibton ! DEBUG_ii= 91, DEBUG_jj= 71 ! Rorvik ! DEBUG_ii= 82, DEBUG_jj= 72 ! Voss, has some snow ! DEBUG_ii=110, DEBUG_jj= 48 ! High Vg! @@ -154,18 +214,24 @@ module ModelConstants_ml ! DEBUG_ii= 97, DEBUG_jj= 62 ! Waldhof ! DEBUG_ii=116, DEBUG_jj= 63 ! K-Puszta ! DEBUG_ii=102, DEBUG_jj= 48 ! Payerne - DEBUG_ii= 85, DEBUG_jj= 50 ! Harwell +! DEBUG_ii= 85, DEBUG_jj= 50 ! Harwell +! DEBUG_ii= 88, DEBUG_jj= 99 ! Harwell TNO TEST +! DEBUG_ii= 93, DEBUG_jj= 47 ! Grignon, France ! DEBUG_ii= 90, DEBUG_jj= 104 ! Wetland, Tundra -! DEBUG_ii= 85, DEBUG_jj= 15 ! biomass burnung, Aug 2003 +! DEBUG_ii= 72-OFFSET_i, DEBUG_jj= 37-OFFSET_j ! biomass burnung, Aug 2003 +! DEBUG_ii= 90-OFFSET_i, DEBUG_jj= 27-OFFSET_j ! biomass burnung, Jul 2009 +!DEBUG_ii= 58-OFFSET_i, DEBUG_jj= 72-OFFSET_j ! 99% water, SMI problems +!DUST DEBUG_ii= 94-OFFSET_i, DEBUG_jj= 24-OFFSET_j ! 99% water, dust problems ! DEBUG_ii= 85, DEBUG_jj= 35 ! Sea, Bay of Biscay !DEBUG_ii= 76, DEBUG_jj= 65 ! Sea, North sea -! DEBUG_ii= 66, DEBUG_jj= 50 ! Sea, west UK -! DEBUG_ii= 80, DEBUG_jj= 52 ! Irish sea + DEBUG_ii= 66, DEBUG_jj= 50 ! Sea, west UK +! DEBUG_ii= 80, DEBUG_jj= 52 ! Irish sea ! DEBUG_ii= 91, DEBUG_jj= 67 ! Tange ! DEBUG_ii=103, DEBUG_jj= 32 ! Prades, SMDge +! DEBUG_ii=128, DEBUG_jj= 13 ! Desert? integer, public, parameter :: & -! DEBUG_i= 62, DEBUG_j= 45 ! SEA +! DEBUG_i= 62, DEBUG_j= 45 ! SEA DEBUG_i= DEBUG_II+OFFSET_i, DEBUG_j= DEBUG_JJ+OFFSET_j ! EMEP/EECCA ! DEBUG_i= 9, DEBUG_j= 201 ! MACC02 ! DEBUG_i= 0, DEBUG_j= 0 ! default @@ -174,19 +240,19 @@ module ModelConstants_ml ! Some flags for model setup ! Debug flag DEBUG_XXX applied in subroutine XXX - logical, public, parameter :: & - DEBUG_AQUEOUS = .false. & - ,DEBUG_ADV = .false. & + logical, public, parameter :: & + DEBUG_ADV = .false. & ,DEBUG_AOT = .false. & + ,DEBUG_AQUEOUS = .false. & ,DEBUG_BCS = .false. & ,DEBUG_BIO = .false. & + ,DEBUG_BLM = .false. & ! Produces matrix of differnt Kz and Hmix ,DEBUG_DERIVED = .false. & ,DEBUG_COLUMN = .false. & ! Extra option in Derived ,DEBUG_DO3SE = .false. & ,DEBUG_DRYRUN = .false. & ! Skips fast chemistry to save some CPU ,DEBUG_ECOSYSTEMS = .false. & ,DEBUG_FORESTFIRE = .false. & - ,DEBUG_BLM = .false. & ! Produces matrix of differnt Kz and Hmix ,DEBUG_Kz = .false. & ,DEBUG_MY_DERIVED = .false. & ,DEBUG_DRYDEP = .false. & @@ -195,36 +261,47 @@ module ModelConstants_ml ,DEBUG_CLOVER = .false. & ,DEBUG_STOFLUX = .false. & ,DEBUG_EMISSIONS = .false. & + ,DEBUG_EMISTIMEFACS = .false. & + ,DEBUG_EQUIB = .false. & !MARS, EQSAM etc. ,DEBUG_GETEMIS = .false. & + ,DEBUG_GRIDVALUES = .false. & ,DEBUG_IOPROG = .false. & - ,DEBUG_RUNCHEM = .false. & ! DEBUG_RUNCHEM is SPECIAL - ,DEBUG_AEROSOL = .false. & ! ...needed for intended debugs are to work - ,DEBUG_MY_WETDEP = .false. & - ,DEBUG_SEASALT = .false. & - ,DEBUG_SOA = .false. & - ,DEBUG_SOLVER = .false. & - ,DEBUG_WETDEP = .false. & ,DEBUG_LANDDEFS = .false. & ,DEBUG_LANDUSE = .false. & ,DEBUG_LANDPFTS = .false. & + ,DEBUG_LANDIFY = .false. & + ,DEBUG_MASS = .false. & ,DEBUG_MET = .false. & ,DEBUG_MOSAICS = .false. & + ,DEBUG_NEST = .false. & + ,DEBUG_NEST_ICBC = .false. & ! IFS-MOZART BC ,DEBUG_NETCDF = .false. & ,DEBUG_NETCDF_RF = .false. & ! ReadField_CDF in NetCDF_ml ,DEBUG_NH3 = .false. & ! NH3Emis experimental ,DEBUG_OUTPUTCHEM = .false. & ! Output of netcdf results + ,DEBUG_OUT_HOUR = .false. & ! Debug Output_hourly.f90 + ,DEBUG_pH = .false. & ,DEBUG_PHYCHEM = .false. & + ,DEBUG_POLLEN = .false. & + ,DEBUG_RUNCHEM = .false. & ! DEBUG_RUNCHEM is SPECIAL + ,DEBUG_AEROSOL = .false. & ! ...needed for intended debugs are to work + ,DEBUG_DUST = .false. & ! Skips fast chemistry to save some CPU + ,DEBUG_ROADDUST = .false. & + ,DEBUG_MY_WETDEP = .false. & + ,DEBUG_SEASALT = .false. & + ,DEBUG_SOA = .false. & + ,DEBUG_SOLVER = .false. & + ,DEBUG_SUBMET = .false. & + ,DEBUG_WETDEP = .false. & ,DEBUG_RSUR = .false. & ,DEBUG_RB = .false. & - ,DEBUG_SOILNO = .false. & - ,DEBUG_SUBMET = .false. & ,DEBUG_SETUP_1DCHEM = .false. & ,DEBUG_SETUP_1DBIO = .false. & ,DEBUG_SITES = .false. & ,DEBUG_SOILWATER = .false. & + ,DEBUG_SOILNOX = .false. & ,DEBUG_VOLC = .false. & ! Volcanoes - ,DEBUG_NEST = .false. & - ,DEBUG_NEST_ICBC = .false. ! IFS-MOZART BC + ,DEBUG_EMERGENCY = .false. ! Emergency: Volcanic Eruption & Nuclear Accident. Under development. !============================================================================= ! 3) Source-receptor runs? @@ -233,25 +310,31 @@ module ModelConstants_ml logical, public, parameter :: SOURCE_RECEPTOR = .false. -! Forecast run? -! only dayly and hourly output is required on FORECAST mode, so in Derived_ml, -! we set all other output types to false if FORECAST=.true.. -logical, public, parameter :: FORECAST = .false. +! Compress NetCDF output? (nc4 feature) +logical, public, parameter :: NETCDF_COMPRESS_OUTPUT=& + (EXP_NAME/="FORECAST").and.(EXP_NAME/="EMERGENCY").and.(EXP_NAME/="3DPROFILES") +!logical, public, parameter :: NETCDF_COMPRESS_OUTPUT=.false. + +!Hourly output in single file or monthly/daily files: +!NB: will not work well by default on Stallo per 14th Feb 2012 because of library bugs! +!Until this is fixed, you must compile with netcdf/4.1.3 and link and run with compiler 12.1.2 +character(len=*), public, parameter :: &! ending depeding on date: +! HOURLYFILE_ending="_hour_YYYYMM.nc" ! MM -> month (01 .. 12) +! HOURLYFILE_ending="_hour_YYYYMMDD.nc" ! DD -> day of the month (00 .. 31) +! HOURLYFILE_ending="_hour_YYYYJJJ.nc" ! JJJ -> the day of the year (001 .. 366) + HOURLYFILE_ending="_hour.nc" ! keep the same for the whole run ! NH3 module as set up originally with U10 from met: kept for safety only. ! Will be replaced by sub.grid calculation of wind in future. ! Keep false until code re-implemented - logical, public, parameter :: NH3_U10 = .false. ! Nesting modes: -! produces netcdf dump of concentrations if wanted, or initialises mode runs -! from such a file. Used in Nest_ml - -integer, public, parameter ::NEST_MODE=0 !0=donothing , 1=write , 2=read , -!3=read and write, 10=write at end of run, 11=read at start, 12=read at -!start and write at end (BIC) - +! produces netcdf dump of concentrations if wanted, or initialises mode runs +! from such a file. Used in Nest_ml: +! 0=donothing; 1=write; 2=read; 3=read and write; +! 10=write at end of run; 11=read at start; 12=read atstart and write at end (BIC) +integer, public, parameter ::NEST_MODE=0 !============================================================================= !+ 4) Define main model dimensions, things that will @@ -291,15 +374,15 @@ module ModelConstants_ml integer, parameter, public :: CHEMTMIN=148,CHEMTMAX=333 real, public, parameter :: & - V_RAIN = 5. & !approximate vertical speed of rain m/ -, CLOUDTHRES = 1.0e-5 !when cloudwater is larger than - !CLOUDTHRES, there are clouds. + V_RAIN = 5. !approximate vertical speed of rain m/s real, public, parameter :: & CW_THRESHOLD = 1.0E-7&!Cloudwater (kg/kg); above threshold allow possibility ! for precipitations. Value could be adjusted. -, RH_THRESHOLD = 0.85 !Relative humidity (fraction); above threshold allow +, RH_THRESHOLD = 0.85 &!Relative humidity (fraction); above threshold allow !possibility for precipitations.Value could be adjusted. +, CW2CC = 1.0E6 !Converts Cloudwater (kg/kg) into CloudCover in % + !Value could be adjusted. ! ! additional parameters ! @@ -344,7 +427,8 @@ module ModelConstants_ml integer, public, parameter :: & IOU_INST=1, IOU_YEAR=2, IOU_MON=3, IOU_DAY=4, & ! Derived output IOU_HOUR_PREVIOUS=5, & ! Aux. field - IOU_HOUR=6, IOU_HOUR_MEAN=7 ! Hourly output + IOU_HOUR=6, IOU_HOUR_MEAN=7 & ! Hourly output + ,IOU_MAX_MAX=7 ! Max values for of IOU (for array declarations) character(len=*), public, parameter :: model="EMEP_MSC-W" diff --git a/MosaicOutputs_ml.f90 b/MosaicOutputs_ml.f90 index 62f60cf..fa7b2cd 100644 --- a/MosaicOutputs_ml.f90 +++ b/MosaicOutputs_ml.f90 @@ -47,7 +47,6 @@ module MosaicOutputs_ml use ModelConstants_ml, only : MasterProc, DEBUG => DEBUG_MOSAICS,& atwS, atwN, & NLANDUSEMAX, IOU_INST, & - IOU_MON, & !FEB2011 tmp SOX_INDEX, OXN_INDEX, RDN_INDEX ! indices for dep groups use OwnDataTypes_ml, only: Deriv, print_deriv_type, & @@ -189,6 +188,10 @@ subroutine Add_NewMosaics(Mc,nMc) itot = find_index( poll, species(:)%name ) iadv = itot - NSPEC_SHL + if( iadv < 1 ) then + if(MasterProc) write(*,*) "MOSSPEC not found ", iadv, trim(name) + cycle MC_LOOP + end if call CheckStop( iadv < 1 .or. iadv > NSPEC_ADV, & " ERR: Mc _SPECS: Mc_SPECS" ) @@ -279,10 +282,11 @@ subroutine Add_MosaicVEGO3(iotype,nVEGO3) end subroutine Add_MosaicVEGO3 !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - subroutine Add_MosaicDDEP(DDEP_ECOS,DDEP_SPECS,nDD) + subroutine Add_MosaicDDEP(DDEP_ECOS,DDEP_SPECS,DDEP_FREQ,nDD) character(len=*), dimension(:), intent(in) :: DDEP_ECOS integer, dimension(:), intent(in) :: DDEP_SPECS ! eg NH3 + integer, intent(in) :: DDEP_FREQ ! Day, Month, integer, intent(out) :: nDD integer :: i, n, ispec, iadv character(len=TXTLEN_DERIV) :: name @@ -320,6 +324,12 @@ subroutine Add_MosaicDDEP(DDEP_ECOS,DDEP_SPECS,nDD) atw = species( ispec )%nitrogens * atwN units = "mgN/m2" + else if ( species(ispec)%nitrogens == 0 .and. & + species(ispec)%sulphurs == 0 ) then + atw = species(ispec)%molwt + write(*,*) "Mosaic Molweight ", trim(species(ispec)%name), atw + units = "mg/m2" + else call StopAll("ERROR: OutDDep atw failure "// & species( ispec )%name) @@ -348,8 +358,7 @@ subroutine Add_MosaicDDEP(DDEP_ECOS,DDEP_SPECS,nDD) MosaicOutput(nMosaic) = Deriv( & name, "Mosaic", "DDEP", DDEP_ECOS(n), units, & - iadv,-99, F, 1.0e6 * atw , F, IOU_MON ) !FEB2011 -!QUERY - why no dt_scale?? + iadv,-99, F, 1.0e6 * atw , F, DDEP_FREQ ) if(DEBUG .and. MasterProc) then write(6,*) "DDEP setups" diff --git a/My_Aerosols_ml.f90 b/My_Aerosols_ml.f90 index 16480d3..a2f4e64 100644 --- a/My_Aerosols_ml.f90 +++ b/My_Aerosols_ml.f90 @@ -43,42 +43,46 @@ module My_Aerosols_ml ! 4. EQUILIB_EQSAM - run EQSAM equilibrium model !---------------------------------------------------------------------- - implicit none + use CheckStop_ml, only : StopAll, CheckStop + use ChemSpecs_tot_ml, only : SO4, NH3, HNO3, NO3_f, NH4_f + use ChemSpecs_shl_ml, only : NSPEC_SHL + use ChemChemicals_ml, only : species + use Chemfields_ml, only : PM25_water, PM25_water_rh50, & !PMwater + cfac + use EQSAM_v03d_ml, only : eqsam_v03d + use MARS_ml, only : rpmares + use ModelConstants_ml, only : KMAX_MID, KCHEMTOP, DEBUG_EQUIB + use PhysicalConstants_ml, only : AVOG + use Setup_1dfields_ml, only : xn_2d, & ! SIA concentration + temp, rh, pp + + + implicit none !/-- public !! true if wanted logical, public, parameter :: AERO_DYNAMICS = .false. & , EQUILIB_EMEP = .false. & !old Ammonium stuff - , EQUILIB_MARS = .false. & !MARS - , EQUILIB_EQSAM = .true. !EQSAM + , EQUILIB_MARS = .true. & !MARS + , EQUILIB_EQSAM = .false. !EQSAM -! logical, public, parameter :: SEASALT = .true. , AOD = .false. - !.. Number of aerosol sizes (1-fine, 2-coarse, 3-'giant' for sea salt ) - integer, public, parameter :: NSIZE = 3 - ! FINE_PM = 1, COAR_PM = 2, GIG_PM = 3 + integer, public, parameter :: NSIZE = 5 + ! FINE_PM = 1, COAR_NO3 = 2, COAR_SS = 3, COAR DUST = 4,pollen = 5 contains !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - subroutine My_MARS + subroutine My_MARS(debug_flag) !.................................................................. ! Pretty old F. Binkowski code from EPA CMAQ-Models3 ! JGR, 108, D6, 4183 !.................................................................. - use Setup_1dfields_ml, only : xn_2d ! SIA concentration - use ChemSpecs_tot_ml, only : NH3, HNO3, SO4, NO3_f, NH4_f - use Setup_1dfields_ml, only : temp, rh - use ModelConstants_ml, only : KMAX_MID, KCHEMTOP - use ChemChemicals_ml, only : species - use PhysicalConstants_ml, only : AVOG - use MARS_ml, only: rpmares - - implicit none + logical, intent(in) :: debug_flag real, parameter :: FLOOR = 1.0E-30 ! minimum concentration !.. local @@ -86,7 +90,6 @@ subroutine My_MARS aSO4out, aNO3out, aH2Oout, aNH4out, gNH3out, gNO3out, & coef integer :: k, errmark - logical, parameter :: debsub = .false. !----------------------------------- coef = 1.e12 / AVOG @@ -103,9 +106,16 @@ subroutine My_MARS !-------------------------------------------------------------------------- call rpmares (so4in, hno3in,no3in ,nh3in, nh4in , rh(k), temp(k), & aSO4out, aNO3out, aH2Oout, aNH4out, gNH3out, gNO3out, & - ERRMARK,debsub) + ERRMARK,debug_flag) !-------------------------------------------------------------------------- + if( DEBUG_EQUIB) then + call CheckStop(gNO3out< 0.0, "XMARS: gNO3out") + call CheckStop(gNH3out< 0.0, "XMARS: gNH3out") + call CheckStop(aNO3out< 0.0, "XMARS: aNO3out") + call CheckStop(aNH4out< 0.0, "XMARS: aNH4out") + end if ! DEBUG_EQUIB + xn_2d(HNO3,k) = max (FLOOR, gNO3out / (species(HNO3)%molwt *coef) ) xn_2d(NH3,k) = max (FLOOR, gNH3out / (species(NH3)%molwt *coef) ) xn_2d(NO3_f,k) = max (FLOOR, aNO3out / (species(NO3_f)%molwt *coef) ) @@ -119,7 +129,8 @@ end subroutine My_MARS !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> - subroutine My_EQSAM + subroutine My_EQSAM(debug_flag) + logical, intent(in) :: debug_flag !.................................................................. !EQSAM - Equlibrium Simplified Aerosol Model by Swen Metzger @@ -129,14 +140,6 @@ subroutine My_EQSAM ! JGR, 107(D16), 10.1029/2001JD001102, 2002. !.................................................................. - use EQSAM_v03d_ml, only : eqsam_v03d - use Setup_1dfields_ml, only : xn_2d ! SIA concentration - use ChemSpecs_tot_ml, only : NH3, HNO3, SO4, NO3_f, NH4_f,NO3 - use Setup_1dfields_ml, only : temp, rh,pp - use ModelConstants_ml, only : KMAX_MID, KCHEMTOP - use PhysicalConstants_ml, only : AVOG - - implicit none real, parameter :: FLOOR = 1.0E-30 ! minimum concentration @@ -162,11 +165,10 @@ subroutine My_EQSAM gCLout(KCHEMTOP:KMAX_MID), & gSO4out(KCHEMTOP:KMAX_MID) - logical :: debsub = .false. !----------------------------------- - if ( debsub ) then ! Selected debug cell + if ( debug_flag ) then ! Selected debug cell write(*,*)'Before EQSAM',xn_2d(SO4,20),xn_2d(HNO3,20),& xn_2d(NH3,20),xn_2d(NO3_f,20),xn_2d(NH4_f,20) endif @@ -198,7 +200,7 @@ subroutine My_EQSAM xn_2d(NH4_f,KCHEMTOP:KMAX_MID) = max(FLOOR,aNH4out(KCHEMTOP:KMAX_MID)*AVOG/1.e12 ) xn_2d(SO4,KCHEMTOP:KMAX_MID) = max(FLOOR,aSO4out(KCHEMTOP:KMAX_MID)*AVOG/1.e12 ) - if ( debsub ) then ! Selected debug cell + if ( debug_flag ) then ! Selected debug cell write(*,*)'After EQSAM',xn_2d(SO4,20),xn_2d(HNO3,20),& xn_2d(NH3,20),xn_2d(NO3_f,20),xn_2d(NH4_f,20) endif @@ -213,7 +215,7 @@ end subroutine My_EQSAM !water !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - subroutine Aero_water(i,j, ambient) + subroutine Aero_water(i,j, ambient, debug_flag) !..................................................................... ! EQSAM is called before every daily output to calculate aerosol water @@ -224,18 +226,11 @@ subroutine Aero_water(i,j, ambient) ! Atmos. Chem.. Phys., 5, 602, 1-8, 2005. !..................................................................... - use EQSAM_v03d_ml, only : eqsam_v03d - use Setup_1dfields_ml, only : xn_2d ! SIA concentration - use Chemfields_ml, only : PM25_water, PM25_water_rh50 !PMwater - use ChemSpecs_tot_ml, only : NH3, HNO3, SO4, NO3_f, NH4_f, SEASALT_F - use Setup_1dfields_ml, only : temp, rh,pp - use ModelConstants_ml, only : KMAX_MID, KCHEMTOP - use PhysicalConstants_ml, only : AVOG - implicit none integer, intent(in) :: i, j logical, intent(in) :: ambient + logical, intent(in) :: debug_flag !.. local real :: so4in(KCHEMTOP:KMAX_MID), & no3in(KCHEMTOP:KMAX_MID), & @@ -258,11 +253,10 @@ subroutine Aero_water(i,j, ambient) rlhum(KCHEMTOP:KMAX_MID),tmpr(KCHEMTOP:KMAX_MID) real, parameter :: FLOOR = 1.0E-30 ! minimum concentration - logical :: debsub = .false. !----------------------------------- - if ( debsub ) then ! Selected debug cell + if ( debug_flag ) then ! Selected debug cell write(*,*)'Before EQSAM',xn_2d(SO4,20),xn_2d(HNO3,20),& xn_2d(NH3,20),xn_2d(NO3_f,20),xn_2d(NH4_f,20) endif @@ -274,7 +268,8 @@ subroutine Aero_water(i,j, ambient) no3in(KCHEMTOP:KMAX_MID) = xn_2d(NO3_f,KCHEMTOP:KMAX_MID)*1.e12/AVOG nh4in(KCHEMTOP:KMAX_MID) = xn_2d(NH4_f,KCHEMTOP:KMAX_MID)*1.e12/AVOG - NAin(KCHEMTOP:KMAX_MID) = xn_2d(SEASALT_f,KCHEMTOP:KMAX_MID)*1.e12/AVOG +!NEEDS WORK: NAin(KCHEMTOP:KMAX_MID) = xn_2d(SEASALT_f,KCHEMTOP:KMAX_MID)*1.e12/AVOG + call StopAll("Sea-salt not implemented in eqsam in Nov 2011 plus versions") CLin(:) = NAin(:) ! NAin(KCHEMTOP:KMAX_MID) = 0. ! CLin(KCHEMTOP:KMAX_MID) = 0. @@ -302,7 +297,7 @@ subroutine Aero_water(i,j, ambient) PM25_water_rh50 (i,j) = max(0., aH2Oout(KMAX_MID) ) endif - if ( debsub ) then ! Selected debug cell + if ( debug_flag ) then ! Selected debug cell write(*,*)'After EQSAM',xn_2d(SO4,20),xn_2d(HNO3,20),& xn_2d(NH3,20),xn_2d(NO3_f,20),xn_2d(NH4_f,20) endif @@ -310,6 +305,77 @@ subroutine Aero_water(i,j, ambient) end subroutine Aero_water !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine Aero_water_MARS(i,j, debug_flag) + + !.................................................................. + ! Pretty old F. Binkowski code from EPA CMAQ-Models3 + ! JGR, 108, D6, 4183 + !.................................................................. + + integer, intent(in) :: i, j + logical, intent(in) :: debug_flag + real, parameter :: FLOOR = 1.0E-30 ! minimum concentration + + !.. local + real :: rlhum(KCHEMTOP:KMAX_MID), tmpr(KCHEMTOP:KMAX_MID) + real :: so4in, no3in, nh4in, hno3in, nh3in, & + aSO4out, aNO3out, aH2Oout, aNH4out, gNH3out, gNO3out, & + coef + integer :: k, errmark + !----------------------------------- + + coef = 1.e12 / AVOG + + !.. PM2.5 water at ambient conditions (3D) + rlhum(:) = rh(:) + tmpr(:) = temp(:) + + do k = KCHEMTOP, KMAX_MID + +!//.... molec/cm3 -> ug/m3 + so4in = xn_2d(SO4,k) * species(SO4)%molwt *coef + hno3in = xn_2d(HNO3,k)* species(HNO3)%molwt *coef + nh3in = xn_2d(NH3,k) * species(NH3)%molwt *coef + no3in = xn_2d(NO3_f,k) * species(NO3_f)%molwt *coef + nh4in = xn_2d(NH4_f,k) * species(NH4_f)%molwt *coef + + + !-------------------------------------------------------------------------- + call rpmares (so4in, hno3in,no3in ,nh3in, nh4in , rlhum(k), tmpr(k), & + aSO4out, aNO3out, aH2Oout, aNH4out, gNH3out, gNO3out, & + ERRMARK,debug_flag) + !-------------------------------------------------------------------------- + +!//....aerosol water (ug/m**3) + PM25_water(i,j,k) = max (0., aH2Oout ) + + enddo ! k-loop + +!.. PM2.5 water at equilibration conditions for gravimetric PM (Rh=50% and t=20C) + + rlhum(:) = 0.5 + tmpr(:) = 293.15 + k = KMAX_MID +!//.... molec/cm3 -> ug/m3 + so4in = xn_2d(SO4,k) * species(SO4)%molwt *coef *cfac(SO4-NSPEC_SHL,i,j) + hno3in = xn_2d(HNO3,k)* species(HNO3)%molwt *coef *cfac(HNO3-NSPEC_SHL,i,j) + nh3in = xn_2d(NH3,k) * species(NH3)%molwt *coef *cfac(NH3-NSPEC_SHL,i,j) + no3in = xn_2d(NO3_f,k) * species(NO3_f)%molwt *coef *cfac(NO3_f-NSPEC_SHL,i,j) + nh4in = xn_2d(NH4_f,k) * species(NH4_f)%molwt *coef *cfac(NH4_f-NSPEC_SHL,i,j) +!-------------------------------------------------------------------------- + call rpmares (so4in, hno3in,no3in ,nh3in, nh4in , rlhum(k), tmpr(k), & + aSO4out, aNO3out, aH2Oout, aNH4out, gNH3out, gNO3out, & + ERRMARK,debug_flag) + !-------------------------------------------------------------------------- + + PM25_water_rh50 (i,j) = max (0., aH2Oout ) + + + end subroutine Aero_water_MARS +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + end module My_Aerosols_ml diff --git a/My_Derived_ml.f90 b/My_Derived_ml.f90 index 05a40d1..2ca66c3 100644 --- a/My_Derived_ml.f90 +++ b/My_Derived_ml.f90 @@ -52,7 +52,6 @@ module My_Derived_ml ! of the bigger d_2d arrays !--------------------------------------------------------------------------- -use My_Emis_ml, only : EMIS_NAME use AOTx_ml, only : O3cl, VEGO3_OUTPUTS, VEGO3_DEFS use CheckStop_ml, only: CheckStop, StopAll use Chemfields_ml, only : xn_adv, xn_shl, cfac @@ -63,13 +62,16 @@ module My_Derived_ml !, eg. OXN_GROUP, DDEP_OXNGROUP, BVOC_GROUP use ChemChemicals_ml, only : species ! For mol. wts. use ChemSpecs_adv_ml ! Use NSPEC_ADV, IXADV_ indices +use EmisDef_ml, only : EMIS_FILE use GridValues_ml, only : debug_li, debug_lj, debug_proc +use Io_Progs_ml, only: PrintLog use LandDefs_ml, only : LandDefs, LandType, Check_LandCoverPresent ! e.g. "CF" use MetFields_ml, only : z_bnd, roa use ModelConstants_ml, only : ATWAIR & , SOX_INDEX, OXN_INDEX, RDN_INDEX & , MasterProc & , SOURCE_RECEPTOR & + , USE_SOILNOX & , DEBUG => DEBUG_MY_DERIVED & , M=>IOU_MON, D=>IOU_DAY, H=>IOU_HOUR & , KMAX_MID & ! => z dimension @@ -77,7 +79,7 @@ module My_Derived_ml , MFAC ! converts roa (kg/m3 to M, molec/cm3) use MosaicOutputs_ml, only : nMosaic, MAX_MOSAIC_OUTPUTS, MosaicOutput, & ! Init_MosaicMMC, Add_MosaicMetConcs, & - Add_NewMosaics, & + Add_NewMosaics, & Add_MosaicVEGO3, & Add_MosaicDDEP, & MMC_USTAR, MMC_INVL, MMC_RH, MMC_CANO3, MMC_VPD, MMC_FST, MMC_GSTO, MMC_EVAP @@ -131,56 +133,173 @@ module My_Derived_ml character(len=TXTLEN_SHORT), private, parameter ::& D2 = "2d", D3 = "3d", SPEC = "SPEC", GROUP ="GROUP" - !type(typ_s5i), public, parameter, dimension(37) :: & - type(typ_s5i), public, parameter, dimension(32) :: & + !REMEMBER - KEEP UPPER CASE FOR ALL GASES + type(typ_s5i), public, save, dimension(MAX_NUM_DERIV2D) :: OutputFields + integer, public, save :: nOutputFields = 0 + + type(typ_s5i), public, parameter, dimension(71) :: & OutputConcs = (/ & - typ_s5i("SO2 ", "ugS", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("SO4 ", "ugS", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("NO ", "ugN", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("NO2 ", "ugN", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("NH3 ", "ugN", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("HNO3 ", "ugN", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("HONO ", "ugN", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("PAN ", "ugN", D2,"AIR_CONCS", SPEC, D)& - ! Remember, species have upper case, so not _f ! - ,typ_s5i("NO3_F ", "ugN", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("NO3_C ", "ugN", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("NH4_F ", "ugN", D2,"AIR_CONCS", SPEC, D)& +! +! Here we use the 4th text field to give the "class" or "typ". Derived_ml +! will look for this in the select case (typ) +!CAN allow lower case ... + typ_s5i("HMIX ", "m", D2,"HMIX ","MISC", H)& !hourly tests + ,typ_s5i("USTAR_NWP ", "m/s", D2,"USTAR_NWP","MISC", H)& !hourly tests + ,typ_s5i("Kz_m2s ", "m2/s",D2,"Kz_m2s ","MISC", H)& !hourly tests + ,typ_s5i("ws_10m ", "m", D2,"ws_10m ","MISC", H)& !hourly tests + ,typ_s5i("rh2m ", "m", D2,"rh2m ","MISC", H)& !hourly tests + ,typ_s5i("T2m ", "degC",D2,"T2m ","MISC", D)& + ,typ_s5i("Snow_m ", "m", D2,"SNOW ","MISC", D)& + ,typ_s5i("SURF_ppbC_VOC ", "ppb", D2,"VOC ","MISC", D)&!?CHECK?? + ,typ_s5i("SMI_deep ", "-", D2,"SMI_deep ","MISC", D)& + ,typ_s5i("SMI_uppr ", "-", D2,"SMI_uppr ","MISC", D)& !tno10 + ,typ_s5i("CO ", "ppb", D2,"AIR_CONCS", SPEC, D)& ! ug/m3 - ,typ_s5i("SO4 ", "ug ", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("NO3_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("NO3_C ", "ug ", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("NH4_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("SEASALT_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("SO2 ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("NH3 ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("HNO3 ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("NO2 ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("NO ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("SO4 ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("NO3_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("NO3_C ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("NH4_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& !tno20 + ,typ_s5i("SEASALT_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& ,typ_s5i("SEASALT_C ", "ug ", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("SEASALT_G ", "ug ", D2,"AIR_CONCS", SPEC, D)& - !typ_s5i("DUST_NAT_F", "ug ", D2,"AIR_CONCS", SPEC, D),& - !typ_s5i("DUST_NAT_C", "ug ", D2,"AIR_CONCS", SPEC, D),& + ,typ_s5i("POLLEN_B ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("DUST_ROAD_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("DUST_ROAD_C ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("DUST_WB_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("DUST_WB_C ", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("DUST_SAH_F", "ug ", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("DUST_SAH_C", "ug ", D2,"AIR_CONCS", SPEC, D)& ! ppb - ,typ_s5i("O3 ", "ppb", D2,"AIR_CONCS", SPEC, D)& !#20 test 3d - ,typ_s5i("NO ", "ppb", D2,"AIR_CONCS", SPEC, D)& ! also have ugN - ,typ_s5i("NO2 ", "ppb", D2,"AIR_CONCS", SPEC, D)& ! also have ugN - ,typ_s5i("HCHO ", "ppb", D2,"AIR_CONCS", SPEC, D)& - ,typ_s5i("C5H8 ", "ppb", D2,"AIR_CONCS", SPEC, D)& - !typ_s5i("HCHO ", "ugC", D2,"AIR_CONCS", SPEC, D),& !#25 + ,typ_s5i("O3 ", "ppb", D2,"AIR_CONCS", SPEC, D)& ! test 3d !tno30 + ,typ_s5i("NO ", "ppb", D2,"AIR_CONCS", SPEC, D)& !20 also have ugN + ,typ_s5i("NO2 ", "ppb", D2,"AIR_CONCS", SPEC, D)& ! also have ugN + ,typ_s5i("NH3 ", "ppb", D2,"AIR_CONCS", SPEC, D)& ! also have ugN + ,typ_s5i("HNO3 ", "ppb", D2,"AIR_CONCS", SPEC, D)& ! also have ugN + ,typ_s5i("SO2 ", "ppb", D2,"AIR_CONCS", SPEC, D)& ! also have ugN + ,typ_s5i("HCHO ", "ppb", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("C5H8 ", "ppb", D2,"AIR_CONCS", SPEC, D)& ! ugC/m3 ! GenChem produces a number of groups of species. ! Here we say which ones we want for different units ! ****** UPPER CASE ONLY ************ ! Sorry, this is a limitation that GenChem converts all names to ! uppercase: - ,typ_s5i("OXN ", "ugN", D2,"AIR_CONCS", GROUP, D)& - ,typ_s5i("NOX ", "ugN", D2,"AIR_CONCS", GROUP, D)& - ,typ_s5i("RDN ", "ugN", D2,"AIR_CONCS", GROUP, D)& - ,typ_s5i("TNO3 ", "ugN", D2,"AIR_CONCS", GROUP, D)& - ,typ_s5i("SIA ", "ug ", D2,"AIR_CONCS", GROUP, D)& - ,typ_s5i("PMFINE ", "ug ", D2,"AIR_CONCS", GROUP, D)& !3D - ,typ_s5i("PM10 ", "ug ", D2,"AIR_CONCS", GROUP, D)& - ,typ_s5i("PMCO ", "ug ", D2,"AIR_CONCS", GROUP, D)& - ,typ_s5i("SS ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("OXN ", "ugN", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("NOX ", "ugN", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("RDN ", "ugN", D2,"AIR_CONCS", GROUP, D)& !tno40 + ,typ_s5i("TNO3 ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("SIA ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("PMFINE ", "ug ", D2,"AIR_CONCS", GROUP, D)& !30 + ,typ_s5i("PM10 ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("PMCO ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("PPM25 ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("PPM_C ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("SS ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("DUST_NAT_F", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("DUST_NAT_C", "ug ", D2,"AIR_CONCS", GROUP, D)& !tno50 + ,typ_s5i("DUST ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ! SOA, PCM_F etc. are special and need appropriate units. Do + ! not confuse! Only PCM has proper ug units, the others are + ! carbon-eqiuvalents (PCM is particulate carbonaceous matter + ! = sum of all EC and OM components.) + ! ,typ_s5i("AER_ASOA ", "ugC", D2,"AIR_CONCS", SPEC, D)& !! ALWAYS as ugC + ! ,typ_s5i("AER_BSOA ", "ugC", D2,"AIR_CONCS", SPEC, D)& !typ_s5i("DUST ", "ug ", D2,"AIR_CONCS", GROUP, D),& !#35 - !typ_s5i("PPM25_FIRE", "ugC", D2,"AIR_CONCS", SPEC, D) + ,typ_s5i("PPM25_FIRE", "ug", D2,"AIR_CONCS", GROUP, D) & + ! ============================================================ + ! SOA additions (26 entries) + ,typ_s5i("PART_OM_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& !! NEVER as ugC !! + ,typ_s5i("OMCOARSE ", "ug ", D2,"AIR_CONCS", GROUP, D)& !! NEVER as ugC !! + ,typ_s5i("ECFINE ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ,typ_s5i("ECCOARSE ", "ug ", D2,"AIR_CONCS", GROUP, D)& + + ,typ_s5i("PART_OC10 ", "ug ", D2,"AIR_CONCS", SPEC, M)& !! NEVER as ugC !! + ,typ_s5i("PART_OC25 ", "ug ", D2,"AIR_CONCS", SPEC, M)& !! NEVER as ugC AND note that for nonvolatile type VBS runs (NPNA etc) this lacks the FFUELOC component!! +!X ,typ_s5i("EC_F ", "ug ", D2,"AIR_CONCS", GROUP, D)& + ! SOA, PCM_F etc. are special and need appropriate units. Do + ! not confuse! Only PCM has proper ug units, the others are + ! carbon-eqiuvalents (PCM is particulate carbonaceous matter + ! = sum of all EC and OM components.) + ,typ_s5i("PART_ASOA_OC", "ugC", D2,"AIR_CONCS", SPEC, M)& !! ALWAYS as ugC + ,typ_s5i("PART_BSOA_OC", "ugC", D2,"AIR_CONCS", SPEC, M)& !tno60 +! ,typ_s5i("PART_FFUELOA25_OC", "ugC", D2,"AIR_CONCS", SPEC, M)& +! ,typ_s5i("PART_WOODOA25_OC", "ugC", D2,"AIR_CONCS", SPEC, M)& +! ,typ_s5i("PART_FFIREOA25_OC", "ugC", D2,"AIR_CONCS", SPEC, M)& +! ,typ_s5i("EC_F_FFUEL_NEW", "ug", D2,"AIR_CONCS", SPEC, D)& +! ,typ_s5i("EC_F_FFUEL_AGE", "ug", D2,"AIR_CONCS", SPEC, D)& +! ,typ_s5i("EC_C_FFUEL", "ug", D2,"AIR_CONCS", SPEC, M)& +! ,typ_s5i("NONVOL_BGNDOC", "ug", D2,"AIR_CONCS", SPEC, D)& +! ,typ_s5i("NONV_FFUELOC_COARSE", "ug", D2,"AIR_CONCS", SPEC, D)& + ,typ_s5i("PART_ASOA_OM", "ug", D2,"AIR_CONCS", SPEC, D)& !NEVER as ugC! + ,typ_s5i("PART_BSOA_OM", "ug", D2,"AIR_CONCS", SPEC, D)& !NEVER as ugC! !tno70 + !zero for NONVOL: +! ,typ_s5i("PART_FFUELOA25_OM", "ug", D2,"AIR_CONCS", SPEC, D)& !NEVER as ugC! +! ,typ_s5i("PART_WOODOA25_OM", "ug", D2,"AIR_CONCS", SPEC, D)& !NEVER as ugC! +! ,typ_s5i("PART_FFIREOA25_OM", "ug", D2,"AIR_CONCS", SPEC, M)& !NEVER as ugC! + !Sep16 tests + ,typ_s5i("FFIRE_BC" , "ug", D2,"AIR_CONCS", SPEC, D)& !NEVER as ugC! + ,typ_s5i("FFIRE_REMPPM25", "ug", D2,"AIR_CONCS", SPEC, D)& !NEVER as ugC! + ,typ_s5i("FFIRE_OM" , "ug", D2,"AIR_CONCS", SPEC, D)& !NEVER as ugC! +!SPECIAL PM25 will be sum of fine + fraction coarse +! PUT AT END OF THIS LIST ! +!--------------------------------------------- + ,typ_s5i("SURF_ug_PM25", "ug" , D2,"PM25 ","MISC", D)& + ,typ_s5i("SURF_ug_PM25X", "ug" , D2,"PM25X ","MISC", D)& + ,typ_s5i("SURF_ug_PM25X_rh50", "ug" , D2,"PM25X_rh50","MISC", D)& + ,typ_s5i("SURF_ug_PM25_rh50" , "ug" , D2,"PM25_rh50 ","MISC", D)& + ,typ_s5i("SURF_ug_PM10_rh50" , "ug" , D2,"PM10_rh50 ","MISC", D)& !tno78 + +!--------------------------------------------- + ,typ_s5i("RN222 ", "ppb", D2,"AIR_CONCS", SPEC, D)& + ! ============================================================ /) +!TFMM typ_s5i("SO2 ", "ugS", D2,"AIR_CONCS", SPEC, D)& +!TFMM ,typ_s5i("SO4 ", "ugS", D2,"AIR_CONCS", SPEC, D)& +! Could also add from earlier D2_EXTRA array: + !,"u_ref " & +!.... down to here +! ,typ_s5i("RNWATER ", "ppb", D2,"AIR_CONCS", SPEC, D)& +! Omit for CityZen +!TFMM just keep ppb version below +!TFMM ,typ_s5i("NO ", "ugN", D2,"AIR_CONCS", SPEC, D)& +!TFMM ,typ_s5i("NO2 ", "ugN", D2,"AIR_CONCS", SPEC, D)& +!TFMM ,typ_s5i("NH3 ", "ugN", D2,"AIR_CONCS", SPEC, D)& +!TFMM ,typ_s5i("HNO3 ", "ugN", D2,"AIR_CONCS", SPEC, D)& +!TFMM ,typ_s5i("HONO ", "ugN", D2,"AIR_CONCS", SPEC, D)& +!TFMM ,typ_s5i("PAN ", "ugN", D2,"AIR_CONCS", SPEC, D)& + ! Remember, species have upper case, so not _f ! +!TFMM just keep ug version below +!TFMM ,typ_s5i("NO3_F ", "ugN", D2,"AIR_CONCS", SPEC, D)& +!TFMM ,typ_s5i("NO3_C ", "ugN", D2,"AIR_CONCS", SPEC, D)& ! 10 to here +!TFMM ,typ_s5i("NH4_F ", "ugN", D2,"AIR_CONCS", SPEC, D)& +! ,typ_s5i("PART_SOA_OC", "ugC", D2,"AIR_CONCS", SPEC, M)& + ! ,typ_s5i("PART_OFFUELOA25_OC", "ugC", D2,"AIR_CONCS", SPEC, M)& + ! ,typ_s5i("PART_OWOODOA25_OC", "ugC", D2,"AIR_CONCS", SPEC, M)& + ! ,typ_s5i("PART_OFFIREOA25_OC", "ugC", D2,"AIR_CONCS", SPEC, M)& +!none yet ,typ_s5i("EC_F_WOOD_NEW ", "ug", D2,"AIR_CONCS", SPEC, D)& +!none yet ,typ_s5i("EC_F_WOOD_AGE ", "ug", D2,"AIR_CONCS", SPEC, D)& + !DS ,typ_s5i("EC_C_WOOD ", "ug", D2,"AIR_CONCS", SPEC, M)& +!Needed for forest-fire checks +! ,typ_s5i("NONVOL_FFUELOC25", "ug", D2,"AIR_CONCS", SPEC, D)& + !DS ,typ_s5i("NONVOL_WOODOC25", "ug", D2,"AIR_CONCS", SPEC, D)& +! ,typ_s5i("NONVOL_FFIREOC25", "ug", D2,"AIR_CONCS", SPEC, D)& +! ,typ_s5i("PART_SOA_OM", "ug", D2,"AIR_CONCS", SPEC, D)& !NEVER as ugC! +! + !CityZen Outputs + ! ,typ_s5i("O3 ", "ug ", D2,"AIR_CONCS", SPEC, D)& ! test 3d + ! ,typ_s5i("NO2 ", "ug ", D2,"AIR_CONCS", SPEC, D)& ! also have ugN + ! ,typ_s5i("DUST_NAT_F", "ug ", D2,"AIR_CONCS", SPEC, D)& + ! ,typ_s5i("DUST_NAT_C", "ug ", D2,"AIR_CONCS", SPEC, D)& + ! ,typ_s5i("AER_OM_F ", "ug ", D2,"AIR_CONCS", SPEC, D)& !! NEVER as ugC !! + ! ,typ_s5i("AER_OC ", "ug ", D2,"AIR_CONCS", SPEC, D)& !! NEVER as ugC !! + ! ,typ_s5i("EC_F ", "ug ", D2,"AIR_CONCS", GROUP, D)& + !,typ_s5i("PART_XO_OFFLOA25_O", "ug", D2,"AIR_CONCS", SPEC, M)& !NEVER as ugC! + !,typ_s5i("PART_XO_OWDOA25_O", "ug", D2,"AIR_CONCS", SPEC, M)& !NEVER as ugC! + !,typ_s5i("PART_XO_OFFIOA25_O", "ug", D2,"AIR_CONCS", SPEC, M)& !NEVER as ugC! ! Tropospheric columns integer, public, parameter, dimension(1) :: COLUMN_MOLEC_CM2 = & @@ -191,8 +310,8 @@ module My_Derived_ml character(len=TXTLEN_DERIV), public, parameter, dimension(4) :: & D2_SR = (/ & "SURF_MAXO3 " & - ,"SURF_PM25water" & - ,"SOMO35 " & + ,"SURF_PM25water" & + ,"SOMO35 " & ,"PSURF " & ! Surface pressure (for cross section): /) @@ -203,21 +322,16 @@ module My_Derived_ml !============ Extra parameters for model evaluation: ===================! !character(len=TXTLEN_DERIV), public, parameter, dimension(13) :: & - character(len=TXTLEN_DERIV), public, parameter, dimension(8) :: & + character(len=TXTLEN_DERIV), public, parameter, dimension(5) :: & D2_EXTRA = (/ & - "SURF_ppbC_VOC " & - ,"T2m " & - ,"Area_Grid_km2 " & + "Area_Grid_km2 " & ,"Area_Conif_Frac " & ,"Area_Decid_Frac " & ,"Area_Seminat_Frac " & ,"Area_Crops_Frac " & - ,"HMIX " & !alt HMIX00 ,HMIX12 ... - !,"Snow_m " & - !,"SoilWater_deep " & - !,"USTAR_NWP " & - !,"ws_10m " & - !,"u_ref " & +! ,"SoilWater_deep " & ! See SMI_deep above +! ,"SoilWater_uppr " & ! See SMI_uppr above +! ,"AreaPOLL " & ! Future usage. Should change name too /) @@ -227,23 +341,29 @@ module My_Derived_ml integer, private, save :: nOutDDep, nOutVEGO3 - integer, private, save :: nOutMET ! + integer, private, save :: nOutMET ! ! Specify some species and land-covers we want to output ! depositions for in netcdf files. DDEP_ECOS must match one of ! the DEP_RECEIVERS from EcoSystem_ml. ! - integer, public, parameter :: NNDRYDEP = 3 ! 7 + 1 !JUST HNO3: size(DDEP_OXNGROUP) - !integer, public, parameter, dimension(7+size(DDEP_OXNGROUP)) :: & - integer, public, parameter, dimension(NNDRYDEP) :: & - DDEP_SPECS = (/ SOX_INDEX, OXN_INDEX, RDN_INDEX /) ! , & - ! SO2, SO4, NH3, NH4_f, HNO3 /) ! DDEP_OXNGROUP /) + ! integer, public, parameter :: NNDRYDEP = 3 ! 7 + 1 !JUST HNO3: size(DDEP_OXNGROUP) + !TFMM integer, public, parameter, dimension(7+size(DDEP_OXNGROUP)) :: & + integer, public, parameter, dimension(3) :: & + !integer, public, parameter, dimension(NNDRYDEP) :: & + DDEP_SPECS = (/ SOX_INDEX, OXN_INDEX, RDN_INDEX /) !TFMM , & ! /) ! , & + !SO2, SO4, NH3, NH4_f, DDEP_OXNGROUP /) + !SO2, SO4, NH3, NH4_f, HNO3 /) ! DDEP_OXNGROUP /) character(len=TXTLEN_DERIV), public, parameter, dimension(3) :: & DDEP_ECOS = (/ "Grid " , "Conif ", "Seminat" /) !&! "Water_D" & ! , "Decid ", "Crops " /) + ! Frequency of dry-dep outputs + integer, public, parameter :: DDEP_FREQ = D ! (D)ay or (M)onth + + ! Have many combinations: species x ecosystems ! type(Deriv), public, & ! dimension( size(DDEP_SPECS)*size(DDEP_ECOS) ), save :: OutDDep @@ -251,19 +371,26 @@ module My_Derived_ml !- specify some species and land-covers we want to output ! dep. velocities for in netcdf files. Set in My_DryDep_ml. +!TFMM type(typ_s5i), public, parameter, dimension(17) :: & type(typ_s5i), public, parameter, dimension(1) :: & NewMosaic = (/ & typ_s5i( "Mosaic", "VG", "O3 ", "Grid","cms",D ) & - !,typ_s5i( "Mosaic", "VG", "O3 ", "CF ","cms",D ) & - !,typ_s5i( "Mosaic", "VG", "O3 ", "SNL ","cms",D ) & - !,typ_s5i( "Mosaic", "VG", "HNO3 ", "Grid","cms",D ) & - !,typ_s5i( "Mosaic", "VG", "HNO3 ", "W ","cms",D ) & - !,typ_s5i( "Mosaic", "VG", "SEASALT_F", "W ","cms",D ) & - !,typ_s5i( "Mosaic", "VG", "SEASALT_C", "W ","cms",D ) & - !,typ_s5i( "Mosaic", "VG", "SEASALT_F", "Grid","cms",D ) & - !,typ_s5i( "Mosaic", "VG", "SEASALT_C", "Grid","cms",D ) & - !,typ_s5i( "Mosaic", "Rs", "SO2 ", "Grid","sm",D ) & - !,typ_s5i( "Mosaic", "Rs", "NH3 ", "Grid","sm",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "O3 ", "CF ","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "O3 ", "SNL ","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "HNO3 ", "Grid","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "HNO3 ", "W ","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "HNO3 ", "CF ","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "HNO3 ", "SNL ","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "NO3_F ", "SNL ","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "NO3_C ", "SNL ","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "NO3_F ", "Grid","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "NO3_C ", "Grid","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "SEASALT_F", "W ","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "SEASALT_C", "W ","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "SEASALT_F", "Grid","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "VG", "SEASALT_C", "Grid","cms",D ) & +!TFMM ,typ_s5i( "Mosaic", "Rs", "SO2 ", "Grid","sm",D ) & +!TFMM ,typ_s5i( "Mosaic", "Rs", "NH3 ", "Grid","sm",D ) & /) ! VEGO3 outputs for PODY and AOTX - see AOTnPOD_ml for definitions, @@ -289,7 +416,7 @@ module My_Derived_ml "MMAOT40_IAM_MF ",& "MMAOT40_IAM_CR ",& "EUAOT40_Crops ", & - "EUAOT40_Forests", & + "EUAOT40_Forests", & "MMAOT40_IAM_WH " & /) !NB -last not found. Could just be skipped, but kept !to show behaviour @@ -297,16 +424,18 @@ module My_Derived_ml ! For met-data and canopy concs/fluxes ... +!TFMM character(len=TXTLEN_DERIV), public, parameter, dimension(3) :: & character(len=TXTLEN_DERIV), public, parameter, dimension(1) :: & - MOSAIC_METCONCS = (/ "VPD " /) ! & - ! ,"CanopyO3" & !SKIP + MOSAIC_METCONCS = (/ "USTAR" /) ! TFMM "VPD " & + ! ,"CanopyO3" & !SKIP !,"VPD ", "FstO3 " "EVAP ", "Gsto " & - !SKIP ,"USTAR ", "INVL " & - !/) + !SKIP + !TFMM ,"USTAR ", "INVL " & + !TFMM /) ! "g_sto" needs more work - only set as L%g_sto - character(len=TXTLEN_DERIV), public, save, dimension(1) :: & - MET_LCS = (/ "DF " /) !, "CF ", "BF ", "NF " /) !, + character(len=TXTLEN_DERIV), public, save, dimension(2) :: & + MET_LCS = (/ "DF ", "GR " /) !, "CF ", "BF ", "NF " /) !, !"IAM_DF", "IAM_MF"/) !MET_LCS = (/ "GR " , "IAM_CR", "IAM_DF", "IAM_MF"/) @@ -321,22 +450,22 @@ module My_Derived_ml !---------------------- - type(typ_s3), dimension(7), public, parameter :: WDEP_WANTED = (/ & + type(typ_s3), dimension(7-3+2), public, parameter :: WDEP_WANTED = (/ & typ_s3( "PREC ", "PREC ", "mm " ) & ,typ_s3( "SOX ", "GROUP", "mgS " ) & ! Will get WDEP_SOX group ,typ_s3( "OXN ", "GROUP", "mgN " ) & ,typ_s3( "RDN ", "GROUP", "mgN " ) & - ,typ_s3( "SS ", "GROUP", "mgSS" ) & - ! - ! ,typ_s3( "SO2 ", "SPEC ", "mgS ") & ! Makes WPEP_SO2 +!TFMM ,typ_s3( "SS ", "GROUP", "mg " ) & + ! + ,typ_s3( "SO2 ", "SPEC ", "mgS ") & ! Makes WPEP_SO2 ! ,typ_s3( "SO4 ", "SPEC ", "mgS ") & - ! ,typ_s3( "HNO3 ", "SPEC ", "mgN ") & + ,typ_s3( "HNO3 ", "SPEC ", "mgN ") & ! ,typ_s3( "NO3_F ", "SPEC ", "mgN ") & ! ,typ_s3( "NO3_C ", "SPEC ", "mgN ") & - ,typ_s3( "NH4_F ", "SPEC ", "mgN ") & - ,typ_s3( "NH3 ", "SPEC ", "mgN ") & - ! ,typ_s3( "SEASALT_F", "SPEC ", "mgSS") & - ! ,typ_s3( "SEASALT_C", "SPEC ", "mgSS") & +!TFMM ,typ_s3( "NH4_F ", "SPEC ", "mgN ") & +!TFMM ,typ_s3( "NH3 ", "SPEC ", "mgN ") & + ! ,typ_s3( "SEASALT_F", "SPEC ", "mg ") & + ! ,typ_s3( "SEASALT_C", "SPEC ", "mg ") & /) @@ -366,7 +495,9 @@ subroutine Init_My_Deriv() dimension(size( OutputConcs(:)%txt1 ) ) ::& tag_name ! Needed to concatanate some text in AddArray calls ! - older (gcc 4.1?) gfortran's had bug - character(len=TXTLEN_SHORT) :: outname, outunit, outdim, outtyp + character(len=TXTLEN_SHORT) :: outname, outunit, outdim, outtyp, outclass + +if(MasterProc ) print *, "TESTHH INSIDE Init_My_Deriv" call Init_MosaicMMC(MOSAIC_METCONCS) ! sets MMC_USTAR etc. @@ -375,23 +506,32 @@ subroutine Init_My_Deriv() call AddArray( "WDEP_" // WDEP_WANTED(:)%txt1, wanted_deriv2d, NOT_SET_STRING,errmsg) call CheckStop( errmsg, errmsg // "WDEP_WANTED too long" ) - call AddArray( D2_SR, wanted_deriv2d, NOT_SET_STRING, errmsg) - call CheckStop( errmsg, errmsg // "D2_SR too long" ) +!TEST call AddArray( D2_SR, wanted_deriv2d, NOT_SET_STRING, errmsg) +!TEST call CheckStop( errmsg, errmsg // "D2_SR too long" ) call AddArray( COL_ADD, wanted_deriv2d, NOT_SET_STRING, errmsg) call CheckStop( errmsg, errmsg // "COL_ADD too long" ) ! Emission sums - we always add these (good policy!) - do i = 1, size(EMIS_NAME) - tag_name(1) = "Emis_mgm2_" // trim(EMIS_NAME(i)) + do i = 1, size(EMIS_FILE) + tag_name(1) = "Emis_mgm2_" // trim(EMIS_FILE(i)) call AddArray( tag_name(1:1), wanted_deriv2d, NOT_SET_STRING, errmsg) end do do i = 1, size(BVOC_GROUP) itot = BVOC_GROUP(i) - tag_name(1) = "Emis_mgm2_" // trim(species(itot)%name) + tag_name(1) = "Emis_mgm2_BioNat" // trim(species(itot)%name) call AddArray( tag_name(1:1), wanted_deriv2d, NOT_SET_STRING, errmsg) end do + if ( USE_SOILNOX ) then + tag_name(1) = "Emis_mgm2_BioNatNO" + call AddArray( tag_name(1:1), wanted_deriv2d, NOT_SET_STRING, errmsg) + end if + +! Do SR last, so we get PM25 after groups have been done + call AddArray( D2_SR, wanted_deriv2d, NOT_SET_STRING, errmsg) + call CheckStop( errmsg, errmsg // "D2_SR too long" ) + if ( .not. SOURCE_RECEPTOR ) then !may want extra? call AddArray( D2_EXTRA, wanted_deriv2d, NOT_SET_STRING, errmsg) call CheckStop( errmsg, errmsg // "D2_EXTRA too long" ) @@ -417,7 +557,7 @@ subroutine Init_My_Deriv() !------------- Depositions to ecosystems -------------------------------- - call Add_MosaicDDEP(DDEP_ECOS,DDEP_SPECS,nDD) + call Add_MosaicDDEP(DDEP_ECOS,DDEP_SPECS,DDEP_FREQ,nDD) nOutDDep = nDD !------------- VEGO3 stuff ---------------------------------------------- @@ -434,7 +574,7 @@ subroutine Init_My_Deriv() call CheckStop( n1>size(VEGO3_DEFS(:)%name) .or. n1<1 , & "VEGO3 not found"//trim(VEGO3_WANTED(n)) ) VEGO3_OUTPUTS(n) = VEGO3_DEFS(n1) - if(DEBUG .and. MasterProc) print *, "VEGO3 NUMS ", n, n1,& + if(DEBUG .and. MasterProc) write(*,*) "VEGO3 NUMS ", n, n1,& trim( VEGO3_WANTED(n) ) end do if(MasterProc)call WriteArray(VEGO3_OUTPUTS(:)%name,size(VEGO3_WANTED)," VEGO3 OUTPUTS:") @@ -473,10 +613,13 @@ subroutine Init_My_Deriv() mynum_deriv2d = LenArray( wanted_deriv2d, NOT_SET_STRING ) + ! Add the pollutants wanted from OutputConcs: + ! to both OutputFields and wanted_deriv arrays (TOO MESSY) + ! Requested species which are not present will trigger warnings !type(typ_s5i), public, parameter, dimension(27) :: & ! OutputConcs = (/ typ_s5i("SO2", "ugS", D2,"AIR_CONCS", SPEC, M),& - ! typ_s5i("SO4", "ugS", D2,"AIR_CONCS", SPEC, M),& + ! typ_s5i("SO4", "ugS", D2,"AIR_CONCS", SPEC, M),& do n = 1, size( OutputConcs(:)%txt1 ) @@ -484,15 +627,43 @@ subroutine Init_My_Deriv() outunit= trim(OutputConcs(n)%txt2) outdim = trim(OutputConcs(n)%txt3) outtyp = trim(OutputConcs(n)%txt4) + outclass = trim(OutputConcs(n)%txt5) ! MISC or SPEC or GROUP if( outdim == "3d" ) txt = "D3" ! Will simplify later if( outdim == "2d" ) txt = "SURF" ! Will simplify later - if( outtyp == "AIR_CONCS" ) then + if( outclass == "MISC" ) then + + tag_name(1)= trim(outname) ! Just use raw name here + + call AddArray( tag_name(1:1) , wanted_deriv2d, & + NOT_SET_STRING, errmsg) + nOutputFields = nOutputFields + 1 + OutputFields(nOutputFields) = OutputConcs(n) + + else if( outtyp == "AIR_CONCS" ) then + + if( outclass == SPEC ) then ! check if available + n1 = find_index(outname,species(:)%name) + else if ( outclass == GROUP ) then ! check if available + n1 = find_index(outname,GROUP_ARRAY(:)%name) + end if + + if ( n1 < 1 ) then + if(DEBUG.and.MasterProc) write(*,*) "Xd-2d-SKIP ", n, trim(outname) + call PrintLog("WARNING: Requested My_Derived OutputField not found: "& + // " " //trim(outclass) // ":" //trim(outname), MasterProc) + cycle + end if + +! end if + tag_name(1) = "SURF_" // trim(outunit) // "_" // trim(outname) call AddArray( tag_name(1:1) , wanted_deriv2d, & NOT_SET_STRING, errmsg) call CheckStop( errmsg, errmsg // trim(outname) // " too long" ) + nOutputFields = nOutputFields + 1 + OutputFields(nOutputFields) = OutputConcs(n) if(DEBUG.and.MasterProc) write(*,*) "Xd-2d-DONE ", n, trim(outname) if( outdim == "3d" ) then @@ -500,10 +671,15 @@ subroutine Init_My_Deriv() call AddArray( tag_name(1:1) , wanted_deriv3d, & NOT_SET_STRING, errmsg) call CheckStop( errmsg, errmsg // trim(outname) // " too long" ) + nOutputFields = nOutputFields + 1 + OutputFields(nOutputFields) = OutputConcs(n) if(DEBUG.and.MasterProc) write(*,*) "Xd-3d-DONE ", n, trim(tag_name(1)) end if + + else - call StopAll("Not coded yet") + call StopAll("My_Deriv: Not coded yet" // & + trim(outname) //":"//trim(outtyp) ) end if end do @@ -517,6 +693,8 @@ subroutine Init_My_Deriv() call CheckStop( errmsg, errmsg // "Wanted D3 too long" ) end if end if +! TEST HERE + mynum_deriv2d = LenArray( wanted_deriv2d, NOT_SET_STRING ) mynum_deriv3d = LenArray( wanted_deriv3d, NOT_SET_STRING ) @@ -538,7 +716,7 @@ end subroutine Init_My_Deriv subroutine My_DerivFunc( e_2d, class )! , density ) ! We define here here any functions which cannot easily be defined - ! in the more general Derived_ml. + ! in the more general Derived_ml. real, dimension(:,:), intent(inout) :: e_2d ! (i,j) 2-d extract of d_2d character(len=*), intent(in) :: class ! Class of data @@ -564,7 +742,7 @@ subroutine My_DerivFunc( e_2d, class )! , density ) case default if ( MasterProc .and. num_warnings < 100 ) then - write(*,*) "WARNING - REQUEST FOR UNDEFINED OUTPUT:", n, class + write(*,*) "My_Deriv:WARNING - REQUEST FOR UNDEFINED OUTPUT:", n, class num_warnings = num_warnings + 1 end if end select diff --git a/My_Emis_ml.f90 b/My_Emis_ml.f90 deleted file mode 100644 index 7f44cad..0000000 --- a/My_Emis_ml.f90 +++ /dev/null @@ -1,41 +0,0 @@ -! -!*****************************************************************************! -!* -!* Copyright (C) 2007-2011 met.no -!* -!* Contact information: -!* Norwegian Meteorological Institute -!* Box 43 Blindern -!* 0313 OSLO -!* NORWAY -!* email: emep.mscw@met.no -!* http://www.emep.int -!* -!* 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 My_Emis_ml - implicit none - private - - integer, public, parameter :: NEMIS_FILES = 7 - character(len=12), public, save, dimension(NEMIS_FILES):: & - EMIS_NAME = (/ & - "nox " , "sox " , "co ", "voc " , "nh3 " & - , "pm25 " , "pmco " & - ! Could change here to ocfine, ecfine, etc.... - /) - -end module My_Emis_ml diff --git a/My_ExternalBICs_ml.f90 b/My_ExternalBICs_ml.f90 new file mode 100644 index 0000000..4ae4d6b --- /dev/null +++ b/My_ExternalBICs_ml.f90 @@ -0,0 +1,72 @@ +module My_ExternalBICs_ml +! External Boundary and Initial Conditions +! are set from the value depending on Experimnt Name (EXP_NAME) +use ModelConstants_ml, only: MasterProc, DEBUG=>DEBUG_NEST_ICBC +use CheckStop_ml, only: CheckStop +use Io_ml, only: PrintLog +use TimeDate_ExtraUtil_ml, only: date2string +implicit none + +private +public :: set_extbic + +logical, public, parameter :: & + EXTERNAL_BIC_SET = .false.,& + TOP_BC = .false. + +character(len=30),public, parameter :: & + EXTERNAL_BIC_NAME = "DUMMY" + +! i West/East bnd; j North/South bnd; k Top +integer,save, public :: iw=-1, ie=-1, js=-1, jn=-1, kt=-1 ! i West/East bnd; j North/South bnd; k Top + +! YYYY, YY, MM, DD, hh will be replaced by numbers by the program. +! Search for date2string in set_extbic and uncomment lines, if necessary. +! For details, see detail2str in TimeDate_ExtraUtil_ml.f90 +character(len=*),private, parameter :: & + template_read_3D = 'EMEP_IN_IC.nc' , & + template_read_BC = 'EMEP_IN_BC_YYYYMMDD.nc', & + template_write = 'EMEP_OUT.nc' +! template_write = 'EMEP_OUT_YYYYMMDD.nc' +character(len=len(template_read_3D)),public, save :: & + filename_read_3D = template_read_3D +character(len=len(template_read_BC)),public, save :: & + filename_read_BC = template_read_BC +character(len=len(template_write)),public, save :: & + filename_write = template_write + +character(len=*),public, parameter :: & + filename_eta = 'EMEP_IN_BC_eta.zaxis' + +type, public :: icbc ! Inital (IC) & Boundary Conditions (BC) + integer :: ixadv=-1 + character(len=24) :: varname="none" + logical :: wanted=.false.,found=.false. +endtype icbc + +type(icbc), dimension(:), public, pointer :: & + EXTERNAL_BC=>null() + +contains +subroutine set_extbic(idate) + implicit none + integer,intent(in) :: idate(4) + + character(len=*), parameter :: & + DEBUG_FMT="('set_extbic DEBUG: ',A,' ''',A,'''.')" + logical, save :: first_call=.true. + integer :: ydmh=0 + +!--- Set filename from idate: on every call + if(MasterProc.and.DEBUG) write(*,DEBUG_FMT) & + "External BICs filenames for",EXTERNAL_BIC_NAME +! filename_read_3D=date2string(template_read_3D,idate,debug=MasterProc.and.DEBUG) + filename_read_BC=date2string(template_read_BC,idate,debug=MasterProc.and.DEBUG) +! filename_write =date2string(template_write ,idate,debug=MasterProc.and.DEBUG) + + if(first_call) return + call PrintLog("No external BICs set",MasterProc) + first_call = .false. +endsubroutine set_extbic + +endmodule My_ExternalBICs_ml diff --git a/My_Outputs_ml.f90 b/My_Outputs_ml.f90 index 32611bd..ecbc2c9 100644 --- a/My_Outputs_ml.f90 +++ b/My_Outputs_ml.f90 @@ -35,18 +35,23 @@ module My_Outputs_ml ! Hourly - ascii output of selected species, selcted domain ! ----------------------------------------------------------------------- -use CheckStop_ml, only: CheckStop +use CheckStop_ml, only: CheckStop +use ChemSpecs_tot_ml use ChemSpecs_adv_ml use ChemSpecs_shl_ml -use ChemChemicals_ml, only: species +use ChemChemicals_ml, only: species,species_adv + use ChemGroups_ml, only: chemgroups use DerivedFields_ml, only: f_2d ! D2D houtly output type use ModelConstants_ml, only: PPBINV, PPTINV, ATWAIR, atwS, atwN, MasterProc, & - FORECAST, to_molec_cm3=>MFAC + EXP_NAME, FORECAST, USE_EMERGENCY,DEBUG_EMERGENCY use OwnDataTypes_ml, only: Asc2D -use Par_ml, only: GIMAX,GJMAX,IRUNBEG,JRUNBEG +use Par_ml, only: GIMAX,GJMAX,IRUNBEG,JRUNBEG,me use SmallUtils_ml, only: find_index use TimeDate_ml, only: date +use Units_ml, only: Init_Units,& + to_molec_cm3,to_molec_cm2,to_mgSIA,to_ugSIA,& + to_ug_ADV,to_ug_C,to_ug_N,to_ug_S implicit none @@ -66,7 +71,7 @@ module My_Outputs_ml ,NADV_SITE = NSPEC_ADV & ! No. advected species (1 up to NSPEC_ADV) ,NSHL_SITE = NSPEC_SHL & ! No. short-lived species ,NXTRA_SITE_MISC = 2 & ! No. Misc. met. params ( e.g. T2, d_2d) - ,NXTRA_SITE_D2D = 3 ! No. Misc. met. params ( e.g. T2, d_2d) + ,NXTRA_SITE_D2D = 9 ! No. Misc. met. params ( e.g. T2, d_2d) integer, public, parameter, dimension(NADV_SITE) :: & SITE_ADV = (/ (isite, isite=1,NADV_SITE) /) ! Everything @@ -87,15 +92,22 @@ module My_Outputs_ml SITE_XTRA_MISC=(/"th ","T2 "/) !These variables must have been set in My_Derived for them to be used. -character(len=18), public, parameter, dimension(NXTRA_SITE_D2D) :: & +character(len=24), public, parameter, dimension(NXTRA_SITE_D2D) :: & SITE_XTRA_D2D= (/ & - "HMIX ","PSURF ", & + "HMIX ",& + "PSURF ", & + "ws_10m ", & + "rh2m ", & + "Emis_mgm2_BioNatC5H8 ", & + "Emis_mgm2_BioNatAPINENE", & + "Emis_mgm2_BioNatNO ",& + "Emis_mgm2_nox ",& ! "SoilWater_deep ","EVAP_CF ","EVAP_DF ", & ! "EVAP_BF ","EVAP_NF ","WDEP_PREC ", & ! "RH_GR ","CanopyO3_GR ","VPD_GR ","FstO3_GR ", & ! "RH_IAM_DF ","CanopyO3_IAM_DF","VPD_IAM_DF ","FstO3_IAM_DF ", & ! "COLUMN_CO_k20 ","COLUMN_C2H6_k20","COLUMN_HCHO_k20","COLUMN_CH4_k20 ", - "COLUMN_NO2_k20 " /) + "COLUMN_NO2_k20 " /) !/*** Aircraft outputs (used in Polinat_ml) !============================================================== @@ -156,23 +168,24 @@ module My_Outputs_ml ! Or BCVppbv to get grid-centre concentrations (relevant for all layers) !---------------------------------------------------------------- -logical, public, parameter :: Hourly_ASCII = .false. -! Hourly_ASCII = .True. gives also Hourly files in ASCII format. - -integer, public :: NHOURLY_OUT = 6 ! No. outputs -integer, public, parameter :: NLEVELS_HOURLY = 4 ! No. outputs +!TESTHH integer, public :: NHOURLY_OUT = 9 ! No. outputs +!TESTHH integer, public, parameter :: NLEVELS_HOURLY = 4 ! No. outputs +integer, public, save :: nhourly_out=0 ! No. outputs +integer, public, save :: nlevels_hourly=0 ! No. outputs integer, public, parameter :: FREQ_HOURLY = 1 ! 1 hours between outputs ! Output selected model levels -logical, public, parameter :: SELECT_LEVELS_HOURLY = .false..or.FORECAST +logical, public, parameter :: & + SELECT_LEVELS_HOURLY = .false..or.FORECAST.or.(EXP_NAME=="3DPROFILES") ! Decide which levels to print out ! 20<==>uppermost model level (m01) ! 01<==>lowermost model level (m20) ! 00<==>surface approx. from lowermost model level ! 00 and 01 can be both printed out, ! but it might create loads of missing values... -integer, public, parameter, dimension(NLEVELS_HOURLY) :: & - LEVELS_HOURLY = (/0,4,6,10/) +!TESTHH integer, public, parameter, dimension(NLEVELS_HOURLY) :: & +!TESTHH LEVELS_HOURLY = (/0,4,6,10/) +integer, public, dimension(:), allocatable :: levels_hourly ! Set below type(Asc2D), public, dimension(:), allocatable :: hr_out ! Set below @@ -181,18 +194,6 @@ module My_Outputs_ml integer, public, parameter :: NBDATES = 3 type(date), public, save, dimension(NBDATES) :: wanted_dates_inst -! Conversion to ug/m3 -! xn_adv(ixadv,ix,iy,k)*roa(ix,iy,k,1)*to_ug_ADV(ixadv) -! Conversion to ugX/m3 -! xn_adv(ixadv,ix,iy,k)*roa(ix,iy,k,1)*to_ug_X(ixadv) -! Use "ADVugXX" for ug output (ug/m3, ugC/m3, ugN/m3, ugS/m3) -! For ug/m3 output use in combination with to_ug_ADV(ixadv). -! For ugX/m3 output use in combination with to_ug_X(ixadv). -real, public, save, dimension(NSPEC_ADV) :: & - to_ug_ADV, & ! conversion to ug - to_ug_C, & ! conversion to ug of C - to_ug_N, & ! conversion to ug of N - to_ug_S ! conversion to ug of S !================================================================ public :: set_output_defs @@ -202,13 +203,11 @@ module My_Outputs_ml subroutine set_output_defs implicit none - character(len=44) :: errmsg ! Local error message - integer :: i ! Loop index + character(len=144) :: errmsg ! Local error message + integer :: i,j,ash,rn222,pm25,pm10,ivent ! Loop & ash group indexes + character(len=9) :: vent ! Volcano (vent) name real, parameter :: atwC=12.0 - real, parameter :: to_mgSIA=PPBINV/ATWAIR*1000.0 & ! conversion to mg - ,to_ugSIA=PPBINV/ATWAIR & ! conversion to ug - ,to_molec_cm2=to_molec_cm3*100.0 real, parameter :: m_s = 100.0 ! From cm/s to m/s ! introduce some integers to make specification of domain simpler @@ -216,8 +215,7 @@ subroutine set_output_defs !integer, save :: ix1 = 36, ix2 = 167, iy1=12, iy2 = 122 ! EMEP ! integer, save :: ix1 = 65, ix2 = 167, iy1=12, iy2 = 122 ! restricted EMEP - integer, save :: ix1=IRUNBEG, ix2=IRUNBEG+GIMAX-1, & - iy1=JRUNBEG, iy2=JRUNBEG+GJMAX-1 ! all + integer, save :: ix1, ix2, iy1, iy2 ! WARNING: If the specification of the subdomain is different for ! different components (ix1=125 for ozone and ix1=98 for @@ -225,13 +223,17 @@ subroutine set_output_defs ! latitude and longitude in NetCDF output will be ! wrong. - ! Use "ADVugXX" for ug output (ug/m3, ugC/m3, ugN/m3, ugS/m3) - ! For ug/m3 output use in combination with to_ug_ADV(ixadv). - ! For ugX/m3 output use in combination with to_ug_X(ixadv). - to_ug_ADV=species(NSPEC_SHL+1:NSPEC_SHL+NSPEC_ADV)%molwt *PPBINV/ATWAIR - to_ug_C = species(NSPEC_SHL+1:NSPEC_SHL+NSPEC_ADV)%carbons *atwC*PPBINV/ATWAIR - to_ug_N = species(NSPEC_SHL+1:NSPEC_SHL+NSPEC_ADV)%nitrogens*atwN*PPBINV/ATWAIR - to_ug_S = species(NSPEC_SHL+1:NSPEC_SHL+NSPEC_ADV)%sulphurs *atwS*PPBINV/ATWAIR + + !============================================================== + ! Conversion to ug/m3 + ! xn_adv(ixadv,ix,iy,k)*roa(ix,iy,k,1)*to_ug_ADV(ixadv) + ! Conversion to ugX/m3 + ! xn_adv(ixadv,ix,iy,k)*roa(ix,iy,k,1)*to_ug_X(ixadv) + ! Use "ADVugXX" for ug output (ug/m3, ugC/m3, ugN/m3, ugS/m3) + ! For ug/m3 output use in combination with to_ug_ADV(ixadv). + ! For ugX/m3 output use in combination with to_ug_X(ixadv). + !============================================================== + call Init_Units() !/** Hourly outputs ! Note that the hourly output uses **lots** of disc space, so specify @@ -241,90 +243,244 @@ subroutine set_output_defs ! ** REMEMBER : SHL species are in molecules/cm3, not mixing ratio !! ! ** REMEMBER : No spaces in name, except at end !! - if(FORECAST)then - ix1=IRUNBEG;ix2=IRUNBEG+GIMAX-1 - iy1=JRUNBEG;iy2=JRUNBEG+GJMAX-1 - NHOURLY_OUT=10 - if(.not.allocated(hr_out))allocate(hr_out(NHOURLY_OUT)) +!default + ix1=IRUNBEG + ix2=IRUNBEG+GIMAX-1 + iy1=JRUNBEG + iy2=JRUNBEG+GJMAX-1 + + if(MasterProc) write(*,*) "TESTHH INSIDE set_output_defs",EXP_NAME + + select case(EXP_NAME) + case("EMERGENCY") + nlevels_hourly = 1+18 + nhourly_out=4+1 !PM*,AOD (&Z) + ash=find_index("ASH",chemgroups(:)%name) + call CheckStop(ash<1,"set_output_defs: Unknown group 'ASH'") + vent="none" + do i=1,size(chemgroups(ash)%ptr) + if(species(chemgroups(ash)%ptr(i))%name(1:9)==vent)cycle + vent=species(chemgroups(ash)%ptr(i))%name(1:9) + nhourly_out=nhourly_out+2 + if(MasterProc.and.DEBUG_EMERGENCY)& + write(*,*)'EMERGENCY: Volcanic Ash, Vent=',vent + enddo + case("FORECAST") + nhourly_out=11 + nlevels_hourly = 4 + case("EVA2010") + nhourly_out=4 + nlevels_hourly = 1 + case("3DPROFILES") + nhourly_out=2 + nlevels_hourly = 10 ! nb zero is one of levels in this system + case("TFMM") + nhourly_out=28 + nlevels_hourly = 1 ! nb zero is *not* one of levels + case default + nhourly_out=1 + nlevels_hourly = 1 ! nb zero is *not* one of levels + endselect + + if(allocated(hr_out)) deallocate(hr_out) + if(allocated(levels_hourly))deallocate(levels_hourly) + allocate(hr_out(nhourly_out),levels_hourly(nlevels_hourly)) + hr_out(:)=Asc2D("none","none",-99,-99,-99,-99,-99,-99,"none",-99.9,-99.9) + + select case(EXP_NAME) + case("EMERGENCY") +! ix1=IRUNBEG;ix2=IRUNBEG+GIMAX-1 +! iy1=JRUNBEG;iy2=JRUNBEG+GJMAX-1 + levels_hourly = (/(i-1,i=1,nlevels_hourly)/) + + pm25 =find_index("PMFINE",chemgroups(:)%name) !NB There is no "PM25" group + pm10 =find_index("PM10" ,chemgroups(:)%name) !** name type ofmt !** ispec ix1 ix2 iy1 iy2 nk sellev? unit conv max - hr_out(01)=Asc2D("o3_3km" ,"BCVugXX","(f9.4)",& - IXADV_O3 ,ix1,ix2,iy1,iy2,4,"ug",to_ug_ADV(IXADV_O3) ,600.0*2.0) - hr_out(02)=Asc2D("no_3km" ,"BCVugXX","(f9.4)",& - IXADV_NO ,ix1,ix2,iy1,iy2,4,"ug",to_ug_ADV(IXADV_NO) ,-999.9)!60000.0*1.21) - hr_out(03)=Asc2D("no2_3km" ,"BCVugXX","(f9.4)",& - IXADV_NO2 ,ix1,ix2,iy1,iy2,4,"ug",to_ug_ADV(IXADV_NO2) ,600.0*1.91) - hr_out(04)=Asc2D("so2_3km" ,"BCVugXX","(f9.4)",& - IXADV_SO2 ,ix1,ix2,iy1,iy2,4,"ug",to_ug_ADV(IXADV_SO2) ,-999.9) - hr_out(05)=Asc2D("co_3km" ,"BCVugXX","(f9.4)",& - IXADV_CO ,ix1,ix2,iy1,iy2,4,"ug",to_ug_ADV(IXADV_CO) ,-999.9) - hr_out(06)=Asc2D("Rn222_3km" ,"BCVugXX","(f9.4)",& - IXADV_Rn222,ix1,ix2,iy1,iy2,4,"ug",to_ug_ADV(IXADV_Rn222),-999.9) - hr_out(07)=Asc2D("pm25_3km" ,"BCVugXXgroup","(f9.4)",& - find_index("PM25",chemgroups(:)%name),ix1,ix2,iy1,iy2,4,"ug",1.0,-999.9) - hr_out(08)=Asc2D("pm10_3km" ,"BCVugXXgroup","(f9.4)",& - find_index("PM10",chemgroups(:)%name),ix1,ix2,iy1,iy2,4,"ug",1.0,-999.9) - hr_out(09)=Asc2D("pm_h2o_3km","PMwater","(f9.4)",& - 00 ,ix1,ix2,iy1,iy2,4,"ug",1.0,-999.9) -! Partial/Full COLUMN/COLUMgroup calculations: -! hr_out%nk indecate the number of levels in the column, -! 1<%nk Partial column: %nk lowermost levels -! oterwise ==> Full column: all model levels - hr_out(10)=Asc2D("no2_col" ,"COLUMN","(f9.4)",& - IXADV_NO2 ,ix1,ix2,iy1,iy2,1,"ug",to_ug_ADV(IXADV_NO2),-999.9) -! hr_out(10)=Asc2D("no2_col" ,"COLUMN","(f9.4)",& -! IXADV_NO2 ,ix1,ix2,iy1,iy2,1,"1e15molec/cm2",to_molec_cm2*1e-15,-999.9) - else - if(.not.allocated(hr_out))allocate(hr_out(NHOURLY_OUT)) + j=5;hr_out(:j) = (/& + Asc2D("pm25_3km" ,"BCVugXXgroup",pm25,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",1.0,-999.9),& + Asc2D("pm10_3km" ,"BCVugXXgroup",pm10,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",1.0,-999.9),& + Asc2D("pm_h2o_3km","PMwater",00 ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",1.0,-999.9),& + Asc2D("AOD_550nm" ,"AOD" ,00 ,& + ix1,ix2,iy1,iy2,1," ",1.0 ,-9999.9),& + Asc2D("z" ,"Z_MID" ,00 ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"km",1e-3,-9999.9)/) + vent="none" + do i=1,size(chemgroups(ash)%ptr) + if(species(chemgroups(ash)%ptr(i))%name(1:9)==vent)cycle + vent=species(chemgroups(ash)%ptr(i))%name(1:9) + ivent=find_index(vent,chemgroups(:)%name) + call CheckStop(ivent<1,"set_output_defs: Unknown group '"//vent//"'") + j=j+2;hr_out(j-1:j)=(/& + Asc2D(vent ,"BCVugXXgroup",ivent,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",1.0,-999.9),& + Asc2D(vent//"_col","COLUMNgroup" ,ivent,& + ix1,ix2,iy1,iy2,1,"ug",1.0,-999.9)/) + enddo + case("FORECAST") +! ix1=IRUNBEG;ix2=IRUNBEG+GIMAX-1 +! iy1=JRUNBEG;iy2=JRUNBEG+GJMAX-1 + levels_hourly = (/0,4,6,10/) + rn222=find_index("RN222",species_adv(:)%name) + pm25 =find_index("PMFINE",chemgroups(:)%name) !NB There is no "PM25" group + pm10 =find_index("PM10" ,chemgroups(:)%name) !** name type ofmt !** ispec ix1 ix2 iy1 iy2 nk sellev? unit conv max - - hr_out(1)= Asc2D("o3_3m", "ADVppbv", "(f9.4)",& - IXADV_o3, ix1,ix2,iy1,iy2,1, "ppbv",PPBINV,600.0) - -! Use "ADVugXX" for ug output (ug/m3, ugS/m3, ugC/m3) -! For ug/m3 output use in combination with to_ug_ADV(IXADV_XX). -! For ugX/m3 output use in combination with to_ug_X. - hr_out(2)= Asc2D("NH4_f-air","ADVugXX","(f8.4)",& - IXADV_NH4_f, ix1,ix2,iy1,iy2,1, "ugN",to_ug_N(IXADV_NH4_f),600.0) - hr_out(3)= Asc2D("NO3_f-air", "ADVugXX","(f8.4)",& - IXADV_NO3_f,ix1,ix2,iy1,iy2,1, "ugN",to_ug_N(IXADV_NO3_f),600.0) - hr_out(4)= Asc2D("SO4-air", "ADVugXX","(f8.4)",& - IXADV_SO4, ix1,ix2,iy1,iy2,1, "ugS",to_ug_S(IXADV_SO4),400.0) - hr_out(5)= Asc2D("cNO3-air","ADVugXX","(f8.4)",& - IXADV_NO3_c,ix1,ix2,iy1,iy2,1, "ugN",to_ug_N(IXADV_NO3_c),400.0) -!Hourly accumulated deposition. NB if(hr_out%unit=="")f_2d%unit is used - hr_out(6)=Asc2D("sox_wdep" ,"D2D","(f9.4)",& - find_index("WDEP_SOX",f_2d(:)%name),ix1,ix2,iy1,iy2,1,"",1.0,-999.9) - - ! Extra parameters - need to be coded in Sites_ml also. - ! So far we can choose from T2, or th (pot. temp.) or from d_2d arrays. + hr_out(:) = (/& + Asc2D("o3_3km" ,"BCVugXX",IXADV_O3 ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",to_ug_ADV(IXADV_O3) ,600.0*2.0),& + Asc2D("no_3km" ,"BCVugXX",IXADV_NO ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",to_ug_ADV(IXADV_NO) ,-999.9),& + Asc2D("no2_3km" ,"BCVugXX",IXADV_NO2 ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",to_ug_ADV(IXADV_NO2),600.0*1.91),& + Asc2D("so2_3km" ,"BCVugXX",IXADV_SO2 ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",to_ug_ADV(IXADV_SO2),-999.9),& + Asc2D("co_3km" ,"BCVugXX",IXADV_CO ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",to_ug_ADV(IXADV_CO) ,-999.9),& + Asc2D("Rn222_3km" ,"BCVugXX",rn222,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",to_ug_ADV(rn222) ,-999.9),& + Asc2D("pm25_3km" ,"BCVugXXgroup",pm25,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",1.0 ,-999.9),& + Asc2D("pm10_3km" ,"BCVugXXgroup",pm10,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",1.0 ,-999.9),& + Asc2D("pm_h2o_3km","PMwater",00 ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",1.0 ,-999.9),& +!! Partial/Full COLUMN/COLUMgroup calculations:kk$ +!! hr_out%nk indecate the number of levels in the column, +!! 1<%nk Partial column: %nk lowermost levels +!! otherwise ==> Full column: all model levels + Asc2D("no2_col" ,"COLUMN",IXADV_NO2 ,& + ix1,ix2,iy1,iy2,1,"ug",to_ug_ADV(IXADV_NO2) ,-999.9),& +!! ix1,ix2,iy1,iy2,1,"1e15molec/cm2",to_molec_cm2*1e-15 ,-999.9), + Asc2D("AOD_550nm" ,"AOD" ,00 ,& + ix1,ix2,iy1,iy2,1," ",1.0 ,-999.9)/) + case("EVA2010") +! ix1=IRUNBEG;ix2=IRUNBEG+GIMAX-1 +! iy1=JRUNBEG;iy2=JRUNBEG+GJMAX-1 + levels_hourly = (/0/) + pm25 =find_index("SURF_ug_PM25X_rh50",f_2d(:)%name) + pm10 =find_index("SURF_ug_PM10_rh50" ,f_2d(:)%name) +!** name type ofmt ispec +!** ix1 ix2 iy1 iy2 nk sellev? unit conv max + hr_out = (/& + Asc2D("o3" ,"BCVugXX",IXADV_O3 ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",to_ug_ADV(IXADV_O3) ,600.0*2.0),& + Asc2D("no2" ,"BCVugXX",IXADV_NO2 ,& + ix1,ix2,iy1,iy2,NLEVELS_HOURLY,"ug",to_ug_ADV(IXADV_NO2),600.0*1.91),& + Asc2D("pm25","D2D",pm25,& + ix1,ix2,iy1,iy2,1 ,"ug",1.0 ,-999.9),& + Asc2D("pm10","D2D" ,pm10,& + ix1,ix2,iy1,iy2,1 ,"ug",1.0 ,-999.9)/) +! if(MasterProc)then +! write(*,*)(i,hr_out(i),i=1,nhourly_out) +! call CheckStop("AMVB") +! endif + case("3DPROFILES") + ! nb Out3D uses totals, e.g. O3, not IXADV_O3 + ! Number of definitions must match nhourly_out set above + levels_hourly = (/ (i, i= 0,nlevels_hourly-1) /) ! -1 will give surfac + hr_out= (/ & + Asc2D("o3_3dppb" ,"Out3D",O3 ,& + ix1,ix2,iy1,iy2,nlevels_hourly,"ppbv", PPBINV,600.0*2.0) & + ,Asc2D("no2_3dppb" ,"Out3D",& + NO2 ,ix1,ix2,iy1,iy2,nlevels_hourly,"ppbv",PPBINV ,600.0*1.91) & +! ,Asc2D("o3_3dug" ,"Out3D",& +! O3, ix1,ix2,iy1,iy2,nlevels_hourly,"ug",to_ug_ADV(IXADV_O3) ,600.0*2.0) & + /) + + if(MasterProc ) write(*,*) "TESTHH 3D O3 SET", nlevels_hourly + case("TFMM") !** name type ofmt !** ispec ix1 ix2 iy1 iy2 nk sellev? unit conv max -! hr_out(3)= Asc2D("D2_HMIX","D2D", "(f6.1)", & -! find_index("D2_HMIX",f_2d(:)%name), ix1,ix2,iy1,iy2,1, "m",1.0,10000.0) - -!/** theta is in deg.K -! hr_out(1)= Asc2D("T2_C", "T2_C ", "(f5.1)", & -! -99, ix1,ix2,iy1,iy2, "degC",1.0 ,100.0) -! hr_out(2)= Asc2D("Precip", "PRECIP ", "(f11.7)", & -! -99, ix1,ix2,iy1,iy2, "mm/hr",1.0, 200.0) -! hr_out(3)= Asc2D("Idir", "Idirect", "(f5.1)", & -! -99, ix1,ix2,iy1,iy2, "umole/m2/s",1.0, 1000.0) -! hr_out(4)= Asc2D("Idif", "Idiffus", "(f5.1)", & -! -99, ix1,ix2,iy1,iy2, "umole/m2/s",1.0, 1000.0) - endif - - !/** Consistency checks - do i = 1, NHOURLY_OUT - ! We use ix1 to see if the array has been set. - if ( hr_out(i)%ix1 < 1 .or. hr_out(i)%ix1 > 999 ) then - write(errmsg,*) "Failed consistency check in & - &set_output_defs: Hourly is ",i, "Nhourly is ",NHOURLY_OUT - call CheckStop(errmsg) - endif - enddo + +!!!! It seems easiest to just use many variables as given in the d_2d arrays. Thus +!!!! we search for the name as given there using "find_index" below. +!!!! (As a test I tried both pmfine two ways, one as D2D and the other +!!!! as ADVugXXXgroup. The results were identical.) + + hr_out = (/ & + Asc2D("o3_3m", "ADVppbv", IXADV_o3, & + ix1,ix2,iy1,iy2,1, "ppbv",PPBINV,600.0) & + ,Asc2D("no3_f" ,"ADVugXX",IXADV_NO3_F ,& + ix1,ix2,iy1,iy2,1,"ug/m3",to_ug_ADV(IXADV_NO3_F) ,-999.9) & + ,Asc2D("no3_c" ,"ADVugXX",IXADV_NO3_C ,& + ix1,ix2,iy1,iy2,1,"ug/m3",to_ug_ADV(IXADV_NO3_C) ,-999.9) & + ,Asc2D("nh4_f" ,"ADVugXX",IXADV_NH4_F ,& + ix1,ix2,iy1,iy2,1,"ug/m3",to_ug_ADV(IXADV_NH4_F) ,-999.9) & + ,Asc2D("so4_f" ,"ADVugXX",IXADV_SO4 ,& + ix1,ix2,iy1,iy2,1,"ug/m3",to_ug_ADV(IXADV_SO4) ,-999.9) & + ! Organics + ,Asc2D("OM25_3m" ,"D2D", find_index("SURF_ug_PART_OM_F",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("EC25_3m" ,"D2D", find_index("SURF_ug_ECFINE",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("OM_c_3m" ,"D2D", find_index("SURF_ug_OMCOARSE",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("EC_c_3m" ,"D2D", find_index("SURF_ug_ECCOARSE",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("NatDust_f","D2D",find_index("SURF_ug_DUST_NAT_F",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("NatDust_c","D2D",find_index("SURF_ug_DUST_NAT_C",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("RoadDust_f","D2D",find_index("SURF_ug_DUST_ROAD_F",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("RoadDust_c","D2D",find_index("SURF_ug_DUST_ROAD_C",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("SeaSalt_f","D2D",find_index("SURF_ug_SEASALT_F",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("SeaSalt_c","D2D",find_index("SURF_ug_SEASALT_C",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ! Sums + ,Asc2D("PM25_3m" ,"D2D", find_index("SURF_ug_PM25_rh50",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("PMFINE" ,"D2D", find_index("SURF_ug_PMFINE",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("pm_h2o_3m","D2D",find_index("SURF_PM25water",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1,"ug",1.0,-999.9) & + ,Asc2D("PM25dry_3m","D2D",find_index("SURF_ug_PM25",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("PM10_3m" ,"D2D", find_index("SURF_ug_PM10_rh50",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("PM10dry_3m","D2D",find_index("SURF_ug_PM10",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "ug/m3",1.0,-999.9) & + ,Asc2D("no_3m" ,"ADVppbv", IXADV_NO,& + ix1,ix2,iy1,iy2,1,"ppbv",PPBINV ,600.0*1.91) & + ,Asc2D("no2_3m","ADVppbv", IXADV_NO2,& + ix1,ix2,iy1,iy2,1,"ppbv",PPBINV ,600.0*1.91) & + ,Asc2D("T2_C", "T2_C" , 00, & + ix1,ix2,iy1,iy2,1, "degC",1.0 ,100.0) & + ,Asc2D("ws_10m", "ws_10m", 00, & + ix1,ix2,iy1,iy2,1, "m/s",1.0 ,100.0) & + ,Asc2D("HMIX","D2D", find_index("HMIX",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "m",1.0,10000.0) & + ,Asc2D("USTAR_NWP","D2D", find_index("USTAR_NWP",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "m/s",1.0,-999.9) & + ,Asc2D("Kz_m2s","D2D",find_index("Kz_m2s",f_2d(:)%name), & + ix1,ix2,iy1,iy2,1, "m2/s",1.0,-999.9) & + /) + case default + hr_out = (/ & + Asc2D("o3_3m", "ADVppbv", IXADV_o3, & + ix1,ix2,iy1,iy2,1, "ppbv",PPBINV,600.0) & + /) + endselect + + !/** Consistency check: + ! Was the array set? R: %name/=none + ! Was the D2D/Group found? R: %spec>0 + do i=1,nhourly_out + if(MasterProc) write(*,*) "TESTHH O3 ATEND", i, nlevels_hourly + if(hr_out(i)%name/="none".and.hr_out(i)%spec>=0) cycle + write(errmsg,"(A,2(1X,A,'=',I0),2(1X,A,':',A))")& + "set_output_defs: Failed consistency check",& + "Hourly",i, "Nhourly",NHOURLY_OUT,& + "Name",trim(hr_out(i)%name),"Type",trim(hr_out(i)%type) + call CheckStop(errmsg) + enddo !/** Wanted dates for instantaneous values output: ! specify months,days,hours for which full output is wanted. diff --git a/My_RunSettings.inc b/My_RunSettings.inc new file mode 100644 index 0000000..3957275 --- /dev/null +++ b/My_RunSettings.inc @@ -0,0 +1 @@ + logical, save, public :: SOURCE_RECEPTOR = .false. diff --git a/My_SOA_ml.f90 b/My_SOA_ml.f90 index 80bf535..a3c55f7 100644 --- a/My_SOA_ml.f90 +++ b/My_SOA_ml.f90 @@ -1,66 +1,481 @@ -! -!*****************************************************************************! -!* -!* Copyright (C) 2007-2011 met.no -!* -!* Contact information: -!* Norwegian Meteorological Institute -!* Box 43 Blindern -!* 0313 OSLO -!* NORWAY -!* email: emep.mscw@met.no -!* http://www.emep.int -!* -!* 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 OrganicAerosol_ml - !-------------------------------------------------------------------------- - ! This module is fake - for initial 2011 public-domain ozone model only, pending - ! decision as to which SOA scheme to release as default. - ! Contact David.Simpson@met.no for more information if interested in SOA - ! schemes - !-------------------------------------------------------------------------- + ! Calculates the amount of condensible species in the gas and aerosol phases. + ! + ! References: + ! S2007: Simpson, D. et al., JGR, 2007, + ! B2012: Bergström, R. et al., ACP (in press Sept.), 2012, + ! S2012: Simpson, D. et al., ACP, 2012, + ! + ! + ! Usage: call OrganicAerosol from Runchem, after setup of column data + ! (for meteorology, etc.). The subroutine initialises itself on the + ! first call and thereafter modifies two external variables: + ! xn(k,SOA) : the concentrations of SOA (For a 1-d column array(in EMEP)) + ! Fgas(k,X) : The fraction of X which is gas and not aeorosol + ! + ! ---------------------------------------------------------------------------- + ! + ! From Gas/Particle theory, A/G = K.COA, + ! therefore, Fgas = G/(G+A) = 1/(1+K.COA) + ! + !----------------------------------------------------------------------------- + ! NB- we exclude use of gamma for now, but leave commented out code + !----------------------------------------------------------------------------- + ! + ! Dave Simpson, August 2001 -- 2012 + ! Robert Bergström 2010 -- 2012 + ! + !-------------------------------------------------------------------------- + + ! Functions + GridValues + PT only for BGNDOC + use Functions_ml, only: StandardAtmos_kPa_2_km !ds for use in Hz scaling + use ChemFields_ml, only : Fgas3d ! stores 3-d between time-steps + use ChemChemicals_ml, only : species ! for molwts + use ChemSpecs_tot_ml, S1 => FIRST_SEMIVOL , S2 => LAST_SEMIVOL + + use ChemGroups_ml, only : & + NONVOLPCM_GROUP & + ,NVABSOM_GROUP & ! nonvolatile absorbing species for OA partitioning + ,ASOA => ASOA_GROUP & + ,BSOA => BSOA_GROUP & + ,ECFINE => ECFINE_GROUP & + ,SVFFUELOA25 => SVFFUELOA25_GROUP & ! semi-volatile FFUELOA25 + ,SVWOODOA25 => SVWOODOA25_GROUP & ! for VBS semivolatile WOOD BURNING OA (primary + aged!) + ,SVFFIREOA25 => SVFFIREOA25_GROUP & ! for VBS semivolatile Wildfire OA (primary + aged!) + ,FFUELEC => FFUELEC_GROUP & + ,NVFFUELOC25 => NVFFUELOC25_GROUP & ! non-vol. FFUELOC emis. (in PM2.5) + ,NVFFUELOCCO => NVFFUELOC_COARSE_GROUP & ! non-vol. " " , (PM2.5-10 frac.) + ,NVWOODOC25 => NVWOODOC25_GROUP & ! non-vol. WOODOC emissions + ! (zero in VBS-PAX type runs) + ,NVFFIREOC25 => NVFFIREOC25_GROUP ! only non-vol. FFIREOC emissions + ! (zero in VBS-PAX type runs) + + use GridValues_ml, only: sigma_mid + use ModelConstants_ml, only : PT + use ModelConstants_ml, only : CHEMTMIN, CHEMTMAX, & + MasterProc, DEBUG => DEBUG_SOA, & K2 => KMAX_MID, K1 => KCHEMTOP - use PhysicalConstants_ml, only : AVOG - use Setup_1dfields_ml, only : itemp, xn => xn_2d - use ChemChemicals_ml, only : species ! for molwts - use ChemSpecs_tot_ml, A1 => FIRST_SEMIVOL , A2 => LAST_SEMIVOL + use Par_ml, only : LIDIM => MAXLIMAX, LJDIM => MAXLJMAX + use PhysicalConstants_ml, only : AVOG, RGAS_J + use Setup_1dfields_ml, only : itemp, xn => xn_2d, Fgas, Fpart + use TimeDate_ml, only: current_date implicit none + private + !/-- subroutines - public :: OrganicAerosol + + public :: Init_OrganicAerosol + public :: OrganicAerosol !/-- public - logical, public, parameter :: ORGANIC_AEROSOLS = .false. - real, public, dimension(A1:A2,K1:K2), save :: Fgas ! Fraction in gas-phase + logical, public, parameter :: ORGANIC_AEROSOLS = .true. + + ! We store some values in 3-D fields, to allow the next G/P partitioning + ! calculation to start off with values of COA, mw and Fgas which + ! are about right. Ensures that very few iterations are needed. + +! real,public, save, dimension(S1:S2,LIDIM,LJDIM,K1:K2) :: & +! Grid_SOA_Fgas !EXC Grid_SOA_gamma + + real,public, save, allocatable, dimension(:,:,:) :: Grid_COA + + real, private, dimension(K1:K2), save :: & + COA & ! Org. aerosol, ug/m3 + ! (this version does not include EC as absorber) + ,BGND_OC & ! FAKE FOR NOW, 0.50 ugC/m3 at surface + ,BGND_OA ! Assumed OA/OC=2, -> 1 ug/m3 + + + !VBS real, private, dimension(S1:S2,K1:K2), save :: & + ! TMP - we assign Fpart for all species for now, since + ! it makes it easier to code for nonvol and vol +! From Setup_1dfields now +! real, private, dimension(1:NSPEC_TOT,K1:K2), save :: & +! Fgas & ! Fraction in gas-phase +! ,Fpart! & ! Fraction in gas-phase + !VBS ,tabRTpL ! = 1.0e-6 * R.T(i)/pL(Ti) for all temps i: + !EXC ,gamma & ! activity coefficient + + real, parameter, public :: SMALLFN = 1.0e-20 ! Minimum value of ug allowed + + !/-- private + + ! ug = array for aerosol masses (ug/m3). Includes non-volatile compounds: + ! TMP??? Excluding NVOL for now? + + real, private, dimension(S1:S2,K1:K2), save :: ug_semivol +! - use new NONVOLOC grpup to define: + integer, private, parameter :: NUM_NONVOLPCM = size(NONVOLPCM_GROUP) + integer, private, parameter :: NUM_NVABSOM = size(NVABSOM_GROUP) +! integer, private, parameter, dimension(NUM_NONVOL) :: & +! NONVOL = (/ NONVOLOC_GROUP, NONVOLEC_GROUP /) ! OC+EC in partitioning OM + real, private, dimension(NUM_NVABSOM,K1:K2), save :: ug_nonvol + !real, private, dimension(K1:K2), save :: ug_ecf ! CityZen added + + real, private, save, dimension(S1:S2,CHEMTMIN:CHEMTMAX) :: tabCiStar + + integer, private, save :: NITER = 2 ! No. iterations for Ksoa + real, private, save :: xn2molem3 ! Conversion from molec/cm3 to mole/m3 + real, private, save :: xn2ugC, ugC2xn + + + !/-- DEBUG variables + ! Usually, DEBUG_SOA gives extra outputs. debug_flag is used to allow + ! some extra outputs for a gven i,j - set in CTM model. + + character(len=20), public, save :: soa_errmsg = "ok" + character(len=*), public, parameter :: SOA_MODULE_FLAG="VBS" contains !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< - !+ Driver routine for Secondary Organic Aerosol module + subroutine Init_OrganicAerosol(i,j,debug_flag) + integer, intent(in) :: i,j + logical, intent(in) :: debug_flag + integer :: is, it, k + real, parameter :: kJ = 1000.0 + real, dimension(K2), save :: p_kPa, h_km ! for standard atmosphere + logical, save :: my_first_call = .true. + + + if ( my_first_call ) then + + allocate(Grid_COA(LIDIM,LJDIM,K1:K2)) + + !========================================================================= + ! Set up background OM + ! Need to convert aeros to ug/m3 or ugC/m3. Since xn is in molecules/cm3 + ! we divide by AVOG to get mole/cm3, multiply by 1e6 to get mole/m3, + ! by mol. weight to get g/m3 and by 1e6 to get ug/m3 + + xn2molem3 = 1.0/AVOG * 1.0e6 + xn2ugC = xn2molem3 * 12.0 * 1.0e6 + ugC2xn = 1/xn2ugC + + ! Use Standard Atmosphere to get average heights of layers + + p_kPa(:) = 0.001*( PT + sigma_mid(:)*(101325.0-PT) ) ! Pressure in kPa + h_km = StandardAtmos_kPa_2_km(p_kPa) + BGND_OC(:)= 0.5 * 1.005 ! ng/m3 !!! will give 0.5 ugC/m3 at z=0 m + + do k = K1, K2 + BGND_OC(k) = BGND_OC(k) * exp( -h_km(k)/9.1 ) + if(DEBUG .and. MasterProc ) write(*,"(a,i4,2f8.3)") & + "BGND_OC ", k, h_km(k), BGND_OC(k) + end do + BGND_OA(:) = 2*BGND_OC(:) ! Assume OA/OC = 2 for bgnd + + do k = K1, K2 + Grid_COA(:,:,k) = BGND_OA(k) ! Use OA, not OC here + end do + + !========================================================================= + ! Set up Tables for Fcond + ! Ci = 1.0e6*P0/RT + ! Now, pi(T) = Ai exp(-Hi/RT) + ! And pi(T) = Pi(Tref) * exp( H/RT * (1/Tref - 1/T) ) + ! -> Ci(T) = Ci(Tref) * Tref/T * exp(...) + + do is=S1,S2 + do it=CHEMTMIN,CHEMTMAX + + ! C*-values are given for 298K according to most(?) publications. + tabCiStar(is,it) = species(is)%CiStar * 298./it * & + exp( species(is)%DeltaH * kJ/RGAS_J * (1.0/298. - 1.0/it) ) + end do + end do + + + if ( MasterProc ) then + do is = S1, S2 + write(6,"(a,i4,a16,f7.1,i3,8es12.3)") & + " Tab SOA: MW, Carbons, C*:", is, trim(species(is)%name), & + species(is)%molwt, species(is)%carbons, & + tabCiStar(is,273), tabCiStar(is,303) + end do + end if + + + ! print *, "FEB2012 ALLOCATE ", S1,S2, K1, K2 + allocate( Fgas3d(S1:S2,LIDIM,LJDIM,K1:K2) ) + + !+ initial guess (1st time-step only) + ! Fgas3D is only defined for the semivol stuff, so no need for nonvol here + ! We need to assume something on 1st time-step though: + Fgas3d = 1.0 + + ! Initial values. Should not change except for semi-volatiles + + Fpart(:,:) = 0.0 + Fpart(NONVOLPCM_GROUP,:) = 1.0 + Fgas(:,:) = max(0.0, 1.0 - Fpart(:,:) ) + + !VBS Grid_avg_mw = 250.0 ! Da + !EXC Grid_SOA_gamma = 1.0 + !========================================================================= + my_first_call = .false. + end if ! my_first_call + + ! We need to set Fgas at start of each Runchem i,j loop, as it is + ! used for rcemis: + + Fgas(S1:S2,:) = Fgas3d(S1:S2,i,j,:) ! Semivolatiles only in 3D Fgas + Fpart(S1:S2,:) = 1-Fgas(S1:S2,:) + +! Fgas(NONVOLPCM_GROUP,:) = 0.0 ! not needed, shouldn't change + + end subroutine Init_OrganicAerosol + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine OrganicAerosol(i_pos,j_pos,debug_flag) + + integer, intent(in) :: i_pos, j_pos + logical, intent(in) :: debug_flag + + integer :: i, k, iter, ispec ! loop variables +! real, save :: molcc2ngm3 = 1.0e9*1.0e6/AVOG !molecules/cc-> ng/m3 + real, save :: molcc2ugm3 = 1.0e12/AVOG !molecules/cc-> ng/m3 +! real, save :: ngm32molcc = AVOG/1.0e15 !molecules/cc <- ng/m3 +! real, save :: ugm32molcc = AVOG/1.0e12 !molecules/cc <- ng/m3 + real :: Ksoa + integer :: nmonth, nday, nhour, seconds + + ! Outputs: +! real :: surfOC25, surfASOA, surfBSOA, surfFFUELOC25, surfWOODOC25, surfBGNDOC, surfOFFUELOA25_OC, surfFFUELOA25_OC, surfOWOODOA25, surfWOODOA25, surfOFFIREOA25, surfFFIREOA25 + real :: surfOC25, surfASOA, surfBSOA, surfBGNDOC, surfFFUELOA25_OC, surfWOODOA25_OC, surfFFIREOA25_OC + + + nmonth = current_date%month + nday = current_date%day + nhour = current_date%hour + seconds = current_date%seconds + + if( DEBUG .and. debug_flag) write(unit=*,fmt=*) "Into SOA" + +! Note that xn(SOA) is not strictly needed with the method we have, but it +! is a good first guess of the sum of the condensed phases, enables easy output +! and saves the need for iteration. +! +! Remember also that Fgas is saved, so will initially have been set by the +! preceding call to OrganicAerosol for a different set of i,j. + + ! 1st guesses: + + COA(:) = Grid_COA(i_pos,j_pos,:) + + + ! ============ Non-volatile species first ============================ + ! NVABSOM - Only include fine OM! That is no EC and no coarse OM! + + do i = 1, NUM_NVABSOM ! OA/OC for POC about 1.333 + ispec = NVABSOM_GROUP(i) + + ug_nonvol(i,:) = molcc2ugm3 * xn(ispec,:)*species(ispec)%molwt + + end do + + ! ============ SOA species now, iteration needed =================== + + do iter = 1, NITER + + + ! Fgas = G/(G+A) = 1/(1+K.COA) + ! K = tabRTpL/(mw*gamma) + + do ispec = S1, S2 + + !VBS Fgas(ispec,:) = 1.0/(1.0+tabRTpL(ispec,:)*COA(:)/avg_mw(:) ) + !EXC *gamma(:,ispec)) ) + + Fpart(ispec,:) = COA(:)/( COA(:)+tabCiStar(ispec,itemp(:)) ) + + ug_semivol(ispec,:) = molcc2ugm3 * xn(ispec,:)*species(ispec)%molwt & + * Fpart(ispec,:) + + end do ! ispec + + !ng(:,:) = max(SMALLFN, ng(:,:)) + + ! New estimate of COA (in ug/m3) and avg_mw (g/mole): + ! (nb. xn in molecules/cm3) + + do k = K1,K2 + + COA(k) = sum( ug_semivol(:,k) ) + sum( ug_nonvol(:,k) ) + BGND_OA(k) + + !VBS Nmoles = ( sum( Fpart(VOL,k) * xn(VOL,k) ) + sum( xn(NONVOLOC,k) ) & + !VBS + BGND_OC_ng(k)*ngm32molcc/250.0 ) & ! Assumed MW + !VBS * xn2molem3 + !VBS avg_mw(k) = 1.0e-6 * COA(k)/Nmoles + + end do !k + ! ==================================================================== + + if( DEBUG .and. debug_flag ) then + + if( iter == NITER .and. seconds == 0 ) then + write(unit=6,fmt="(a,i2,a,3i3,f7.2)") "Iteration ", Niter, & + " ======== ",nmonth, nday, nhour, itemp(K2) + write(unit=6,fmt="(a3,a15,3a10,a4,4a10)") "SOA","Species", "xn", & + "Ci* ", "Ki"," ", "Fpart", "ng" + + do i = 1, NUM_NONVOLPCM + ispec = NONVOLPCM_GROUP(i) +! write(unit=6,fmt="(a4,i3,a15,es10.2,2f10.3,a4,es10.3,f13.4)")& +! "NVOL", ispec,& +! species(ispec)%name, xn(ispec,K2),-999.999, & +! -999.999, " => ", Fpart(ispec,K2), 1000.0*ug_nonvol(i, K2) + write(unit=6,fmt="(a4,i3,a15,es10.2,2f10.3)")& + "NVOL", ispec,& + species(ispec)%name, xn(ispec,K2),-999.999, & + -999.999 + end do + + do ispec = S1,S2 + ! K = tabRTpL*COA/(mw*gamma) QUERY COA===!!!! + !Ksoa = tabRTpL(ispec,K2)*COA(K2)/(avg_mw(K2)) + Ksoa = 1.0/tabCiStar(ispec,itemp(K2)) !just for printout + write(unit=6,fmt="(a4,i3,a15,3es10.2,a4,es10.3,f13.4)") "SOA ",ispec,& + species(ispec)%name, xn(ispec,K2), & + tabCiStar(ispec,itemp(K2)),& !VBStabVpsoa(ispec,298), + Ksoa, " => ", Fpart(ispec,K2), 1000.0*ug_semivol(ispec, K2) + end do ! ispec + end if + + write(unit=6,fmt="(a,i2,f12.6)") "COA: ", iter, COA(K2) + + end if ! DEBUG + + end do ! ITER + + ! The above iteration has now given new values to: + ! + ! 1) COA(1:nz) + ! 3) Fgas(FIRST_SEMIVOL:LAST_SEMIVOL,1:nz) + ! 4) Fpart(FIRST_SEMIVOL:LAST_SEMIVOL,1:nz) + ! 5) ng(FIRST_SEMIVOL:LAST_SEMIVOL,1:nz) + ! + ! Note: ng(FIRST_NONVOLOC:LAST_NONVOLOC,1:nz) + ! and xn(1:LAST_SEMIVOL,1:nz) are unaffected by the + ! iteration. + !========================================================================= + + ! Set Fgas for later chemistry, and eset 3-D fields + + Fgas(S1:S2,:) = 1.0 - Fpart(S1:S2,:) + Grid_COA(i_pos,j_pos,:) = COA(:) + Fgas3d(S1:S2,i_pos,j_pos,:) = Fgas(S1:S2,:) !FEB2012 + +! PCM_F is for output only. Has MW 1 to avoid confusion with OC +! do not use ugC outputs, just ug + + xn(PART_OM_F,:) = COA(:) * ugC2xn * 12.0 + + !Grid_SOA_Fgas(S1:S2, i_pos,j_pos,:) = Fgas(S1:S2,:) + !VBS Grid_avg_mw(i_pos,j_pos,:) = avg_mw(:) + !SOA_gamma(i_pos,j_pos,:,:) = gamma(:,:) + + ! Outputs, ugC/m3 + + ! Would like to be able to store also total OM (not only OC) + ! at least for some components. And for a "total" OM and/or OM2.5 and OM10. + ! Total TC and EC (and TC2.5, TC10, EC2.5 and EC10) would also be useful. + ! Also perhaps the names of these species should reflect + ! that they are in units of C? + do k = K1, K2 + xn(PART_ASOA_OC,k) = sum ( Fpart(ASOA,k) *xn(ASOA,k) *species(ASOA)%carbons ) + xn(GAS_ASOA_OC,k) = sum ( Fgas(ASOA,k) * xn(ASOA,k) *species(ASOA)%carbons ) + xn(PART_BSOA_OC,k) = sum ( Fpart(BSOA,k) *xn(BSOA,k) *species(BSOA)%carbons ) + xn(GAS_BSOA_OC,k) = sum ( Fgas( BSOA,k) *xn(BSOA,k) *species(BSOA)%carbons ) + xn(NONVOL_FFUELOC25,k) = sum ( xn(NVFFUELOC25,k) *species(NVFFUELOC25)%carbons) + xn(NONV_FFUELOC_COARSE,k) = sum ( xn(NVFFUELOCCO,k) *species(NVFFUELOCCO)%carbons) + xn(NONVOL_WOODOC25,k) = sum ( xn(NVWOODOC25,k) *species(NVWOODOC25)%carbons ) + xn(NONVOL_FFIREOC25,k) = sum ( xn(NVFFIREOC25,k) *species(NVFFIREOC25)%carbons ) +! want to have PART_FFUELOA25/FFIREOA/WOODOA_OC working also with nonvolatile POA emissions, test this hard coded version first + xn(PART_FFUELOA25_OC,k) = sum ( Fpart(SVFFUELOA25,k) *xn(SVFFUELOA25,k) *species(SVFFUELOA25)%carbons ) + & + xn(NONVOL_FFUELOC25,k) + xn(PART_WOODOA25_OC,k) = sum ( Fpart(SVWOODOA25,k) *xn(SVWOODOA25,k) *species(SVWOODOA25)%carbons ) + & + xn(NONVOL_WOODOC25,k) + xn(PART_FFIREOA25_OC,k) = sum ( Fpart(SVFFIREOA25,k) *xn(SVFFIREOA25,k) *species(SVFFIREOA25)%carbons ) + & + xn(NONVOL_FFIREOC25,k) +!Test for storing in ug/m3, Use with caution! + xn(PART_ASOA_OM,k) = sum ( ug_semivol(ASOA,k) ) * ugC2xn * 12.0 + xn(PART_BSOA_OM,k) = sum ( ug_semivol(BSOA,k) ) * ugC2xn * 12.0 +! want to have PART_FFUELOA25/FFIREOA/WOODOA_OM working also with nonvolatile POA emissions, test this hard coded version first + xn(PART_FFUELOA25_OM,k) = sum ( ug_semivol(SVFFUELOA25,k) ) * ugC2xn * 12.0 + xn(NONVOL_FFUELOC25,k) * 1.25 * 12.0 ! factor 12.0 from M(OC25-components)=12 and M(OM-components)=1, OM/OC=1.25 assumed for Primary FFUELOC emissions + xn(PART_WOODOA25_OM,k) = sum ( ug_semivol(SVWOODOA25,k) ) * ugC2xn * 12.0 + xn(NONVOL_WOODOC25,k) * 1.7 * 12.0 ! OM/OC=1.7 assumed for Primary WOODOC and FFIRE emissions + xn(PART_FFIREOA25_OM,k) = sum ( ug_semivol(SVFFIREOA25,k) ) * ugC2xn * 12.0 + xn(NONVOL_FFIREOC25,k) * 1.7 * 12.0 + +!HARDCODE +! xn(AER_TBSOA,k) = xn(AER_BSOA,k) ! Just in case TBSOA is wanted for kam +!............................................................................... +!Research xn(PART_TBSOA_OC,k) = & +!Research Fpart( TERP_ng100,k) *xn(TERP_ng100,k) *species(TERP_ng100)%carbons + & +!Research Fpart( TERP_ug1,k) *xn(TERP_ug1,k) *species(TERP_ug1)%carbons + & +!Research Fpart( TERP_ug10,k) *xn(TERP_ug10,k) *species(TERP_ug10)%carbons + & +!Research Fpart( TERP_ug1e2,k) *xn(TERP_ug1e2,k) *species(TERP_ug1e2)%carbons + & +!Research Fpart( TERP_ug1e3,k) *xn(TERP_ug1e3,k) *species(TERP_ug1e3)%carbons +!Research xn(PART_IBSOA_OC,k) = & +!Research Fpart( ISOP_ng100,k) *xn(ISOP_ng100,k) *species(ISOP_ng100)%carbons + & +!Research Fpart( ISOP_ug1,k) *xn(ISOP_ug1,k) *species(ISOP_ug1)%carbons + & +!Research Fpart( ISOP_ug10,k) *xn(ISOP_ug10,k) *species(ISOP_ug10)%carbons + & +!Research Fpart( ISOP_ug1e2,k) *xn(ISOP_ug1e2,k) *species(ISOP_ug1e2)%carbons + & +!Research Fpart( ISOP_ug1e3,k) *xn(ISOP_ug1e3,k) *species(ISOP_ug1e3)%carbons +! xn(PART_SBSOA,k) = & +! Fpart( SESQ_ug1,k) *xn(SESQ_ug1,k) *species(SESQ_ug1)%carbons + & +! Fpart( SESQ_ug10,k) *xn(SESQ_ug10,k) *species(SESQ_ug10)%carbons + & +! Fpart( SESQ_ug1e2,k) *xn(SESQ_ug1e2,k) *species(SESQ_ug1e2)%carbons + & +! Fpart( SESQ_ug1e3,k) *xn(SESQ_ug1e3,k) *species(SESQ_ug1e3)%carbons +!............................................................................... + end do + xn(NONVOL_BGNDOC,:) = ugC2xn * BGND_OC(:) ! FAKE FOR NOW, 0.5 ug/m3 at surface + + ! for convencience: +! WARNING! Test changing to WOODOC25, FFIREOC25 and NONVOLOC25 may cause problems here, especially if coarse components are inlcuded later! But this is rather hard coded anyway... + xn(PART_OC10,:) = xn(PART_ASOA_OC,:)+xn(PART_BSOA_OC,:)+xn(NONV_FFUELOC_COARSE,:) + & + xn(NONVOL_BGNDOC,:)+ & + xn(PART_FFUELOA25_OC,:)+xn(PART_WOODOA25_OC,:)+ & + xn(PART_FFIREOA25_OC,:) +!WARNING! The below will NOT work for NPNA (nonvolatile) type runs. These include fine and coarse OC in NONVOL_FFUELOC. So for these runs the FFUELOC-contribution has to be added separately!!! +!Test shifting to NONVOL_FFUELOC25! + xn(PART_OC25,:) = xn(PART_ASOA_OC,:)+ xn(PART_BSOA_OC,:)+ & + xn(NONVOL_BGNDOC,:)+ & + xn(PART_FFUELOA25_OC,:)+xn(PART_WOODOA25_OC,:)+ & + xn(PART_FFIREOA25_OC,:) + + surfASOA = xn2ugC* xn(PART_ASOA_OC,K2) ! sum ( Fpart(ASOA,K2) * xn(ASOA,K2)*species(ASOA)%carbons ) + surfBSOA = xn2ugC* xn(PART_BSOA_OC,K2) ! sum ( Fpart(BSOA,K2) * xn(BSOA,K2)*species(BSOA)%carbons ) +! + surfFFUELOA25_OC = xn2ugC* xn(PART_FFUELOA25_OC,K2) ! + surfWOODOA25_OC = xn2ugC* xn(PART_WOODOA25_OC,K2) ! + surfFFIREOA25_OC = xn2ugC* xn(PART_FFIREOA25_OC,K2) ! + + surfBGNDOC = BGND_OC(K2) + surfOC25 = surfASOA+surfBSOA+surfFFUELOA25_OC+surfWOODOA25_OC+surfBGNDOC+surfFFIREOA25_OC ! + + !/ Sum of Biogenics ----------------------- + + if ( debug_flag .and. seconds == 0 ) then - subroutine OrganicAerosol(i,j,debug_flag) - integer, intent(in) :: i,j - logical, intent(in) :: debug_flag ! for debugging purposes only + k=20 + write(unit=6,fmt="(a,3i3,2f7.2,f5.2,11es9.2)")"xns ug ", & + nmonth, nday, nhour, & + xn(PART_OM_F,20)*xn2ugC, & + COA(20), surfOC25,surfBGNDOC, surfASOA, surfBSOA, surfFFUELOA25_OC, & + surfWOODOA25_OC, & + surfFFIREOA25_OC!, & +! COA(20), surfOC25,surfBGNDOC, surfASOA, surfBSOA,surfFFUELOA25_OC, & +! surfOFFUELOA25_OC,surfFFUELOC25, surfWOODOA25, surfOWOODOA25, surfWOODOC25, & +! surfFFIREOA25, surfOFFIREOA25!, & +!vbs xn2ugC*xn(PART_IBSOA,k), xn2ugC*xn(PART_TBSOA,k), xn2ugC*xn(PART_SBSOA,k) - ! empty + endif - end subroutine OrganicAerosol + end subroutine OrganicAerosol end module OrganicAerosol_ml !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx diff --git a/Nest_ml.f90 b/Nest_ml.f90 index d7e4550..775e651 100644 --- a/Nest_ml.f90 +++ b/Nest_ml.f90 @@ -50,58 +50,67 @@ module Nest_ml ! It should be possible to save only xn_adv_bnd if the inner grid is known for the outer grid. ! The routines should be thought together with GlobalBC_ml (can it replace it?) -use OwnDataTypes_ml, only: Deriv -use TimeDate_ml, only: date -use GridValues_ml, only: glon,glat +!----------------------------------------------------------------------------! +! EXTERNAL BICs: +! The code in My_ExternalBICs is different for different external sources. So +! far coded for FORECAST and EnsClimRCA work. +! These set the following arrays, and filenames + +use My_ExternalBICs_ml, only: set_extbic, icbc, & + EXTERNAL_BIC_SET, EXTERNAL_BC, EXTERNAL_BIC_NAME, TOP_BC, & + iw, ie, js, jn, kt, & ! i West/East bnd; j North/South bnd; k Top + filename_read_3D,filename_read_BC,fileName_write,filename_eta +!----------------------------------------------------------------------------! use CheckStop_ml, only : CheckStop,StopAll -use ChemChemicals_ml, only: species -use ChemSpecs_shl_ml, only: NSPEC_SHL -use ChemSpecs_adv_ml -use ChemSpecs_tot_ml, only: NSPEC_TOT -use GridValues_ml, only: A_mid,B_mid -use Io_ml, only: open_file, IO_TMP -use netcdf -use netcdf_ml, only: GetCDF,Out_netCDF,Init_new_netCDF& - ,Int1,Int2,Int4,Real4,Real8,ReadTimeCDF +use ChemChemicals_ml, only: species_adv +use Chemfields_ml, only: xn_adv ! emep model concs. +use ChemSpecs_adv_ml, only: NSPEC_ADV use Functions_ml, only: great_circle_distance +use GridValues_ml, only: A_mid,B_mid, glon,glat +use Io_ml, only: open_file, IO_TMP use ModelConstants_ml, only: Pref,PPB,PT,KMAX_MID, MasterProc, NPROC & - , IOU_INST,IOU_HOUR, IOU_YEAR,IOU_MON, IOU_DAY,RUNDOMAIN & + , IOU_INST,IOU_HOUR,IOU_YEAR,IOU_MON,IOU_DAY, RUNDOMAIN & , MODE=>NEST_MODE, FORECAST, DEBUG_NEST, DEBUG_ICBC=>DEBUG_NEST_ICBC -use Par_ml, only: MAXLIMAX, MAXLJMAX, GIMAX,GJMAX,IRUNBEG,JRUNBEG & - , me, li0,li1,lj0,lj1,limax,ljmax, tgi0, tgj0, tlimax, tljmax -use Chemfields_ml, only: xn_adv, xn_shl ! emep model concs. +use MetFields_ml, only: roa +use netcdf +use netcdf_ml, only: GetCDF,Out_netCDF,Init_new_netCDF,& + Int1,Int2,Int4,Real4,Real8,ReadTimeCDF +use OwnDataTypes_ml, only: Deriv +use Par_ml, only: MAXLIMAX,MAXLJMAX,GIMAX,GJMAX,IRUNBEG,JRUNBEG, & + me, li0,li1,lj0,lj1,limax,ljmax +use TimeDate_ml, only: date use TimeDate_ExtraUtil_ml, only: idate2nctime,nctime2idate,date2string - +use Units_ml, only: Units_Scale implicit none INCLUDE 'mpif.h' INTEGER INFO ! Nested input/output on FORECAST mode -integer, public, parameter :: FORECAST_NDUMP = 2 ! Number of nested output +integer, public, parameter :: FORECAST_NDUMP = 1 ! Number of nested output ! on FORECAST mode (1: starnt next forecast; 2: NMC statistics) type(date), public :: outdate(FORECAST_NDUMP)=date(-1,-1,-1,-1,-1) -logical , public,parameter :: TRANSPHORM = .false. ! Use limited set of BC components -logical , public,parameter :: RCA = .false. ! Use limited set of IC and BC components -!RCA: remember to manually set some BC to fixed values! + !coordinates of subdomain to write !coordinates relative to LARGE domain (only used in write mode) integer ::istart=60,jstart=11,iend=107,jend=58 !ENEA NB: version has changed, these numbers where for small domain!!! +!integer ::istart=RUNDOMAIN(1),jstart=RUNDOMAIN(3),iend=RUNDOMAIN(2),jend=RUNDOMAIN(4) !entire domain !/-- subroutines public :: readxn public :: wrtxn +logical, private, save :: mydebug = .false. integer, public, parameter :: NHOURSAVE=3 !time between two saves. should be a fraction of 24 integer, public, parameter :: NHOURREAD=1 !time between two reads. should be a fraction of 24 !if(NHOURREADnull() ! Time dependent BC, varname, wanted, found contains +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! subroutine readxn(indate) - implicit none type(date), intent(in) :: indate ! Gives year..seconds integer,save :: first_data=-1 - integer :: n,i,j,k,KMAX_BC !nseconds(1),n1,II,JJ + integer :: n,i,j,k,KMAX_BC,bc !nseconds(1),n1,II,JJ integer :: ndate(4) !nstart,nfetch,nseconds_indate real(kind=8):: ndays_indate @@ -215,9 +166,11 @@ subroutine readxn(indate) real :: W1,W2 logical, save :: first_call=.true. logical :: fexist=.false. + integer ::oldmonth=0 - if(DEBUG_NEST.and.MasterProc)write(*,*)'Read BC, MODE=',MODE - if(MODE /= 2.and.MODE /= 3.and. MODE /= 11.and. MODE /= 12.and. .not.FORECAST)return + mydebug = DEBUG_NEST .and. MasterProc + if( mydebug )write(*,*)'Nest:Read BC, MODE=',MODE + if(MODE /= 2.and.MODE /= 3.and. MODE /= 11.and. MODE /= 12.and. MODE /= 100.and. .not.FORECAST)return KMAX_BC=KMAX_MID @@ -229,30 +182,35 @@ subroutine readxn(indate) if(first_call)date_nextfile=ndate if(FORECAST)then ! FORECAST mode superseeds nest MODE - filename_read_3D='EMEP_IN_IC.nc' !IC file: dump/re-start - filename_read_BC_template='EMEP_IN_BC_YYYYMMDD.nc' - filename_read_BC=date2string(trim(filename_read_BC_template),date_nextfile) -! filename_read_BC=date2string('EMEP_IN_BC_YYYYMMDD.nc',indate) !BC file: 01,...,24 UTC rec for 1 day + call set_extbic(date_nextfile) +!filename_read_BC=date2string('EMEP_IN_BC_YYYYMMDD.nc',indate) !BC file: 01,...,24 UTC rec for 1 day if(first_call)then first_call=.false. inquire(file=filename_read_3D,exist=fexist) if(.not.fexist)then - if(MasterProc) print *,'No nest IC file found: ',trim(filename_read_3D) + if(MasterProc) write(*,*)'No Nest IC file found: ',trim(filename_read_3D) else - if(MasterProc) print *,'RESET ALL XN 3D' + if(MasterProc) write(*,*)'Nest RESET ALL XN 3D' call reset_3D(ndays_indate) endif endif if(mod(indate%hour,NHOURREAD)/=0.or.indate%seconds/=0) return inquire(file=filename_read_BC,exist=fexist) if(.not.fexist)then - if(MasterProc) print *,'No nest BC file found: ',trim(filename_read_BC) + if(MasterProc) write(*,*)'No Nest BC file found: ',trim(filename_read_BC) return endif + elseif(MODE == 100)then +!monthly input file + if(indate%month==oldmonth)return + if(MasterProc.and.oldmonth==0) print *,'Nest: Initialzing IC' + oldmonth=indate%month + if(MasterProc) write(*,*)'Nest: New month, reset BC' + elseif(MODE == 11.or.MODE == 12)then if(.not. first_call)return first_call=.false. - if(MasterProc) print *,'RESET ALL XN 3D' + if(MasterProc) write(*,*)'Nest RESET ALL XN 3D' call reset_3D(ndays_indate) return else @@ -262,153 +220,102 @@ subroutine readxn(indate) !never comes to this point if MODE=11 or 12 - if(MasterProc) print *,'NESTING' + if(MasterProc) write(*,*) 'Nest: kt', kt, first_data if(first_data==-1)then - - filename_read_BC=date2string(trim(filename_read_BC_template),date_nextfile) - filename_read_3D=date2string(trim(filename_read_3D),date_nextfile) !used only once - !filename_read_BC file must be defined before reset_3D, because it is used by init_icbc + + call set_extbic(date_nextfile) if(.not.FORECAST) call reset_3D(ndays_indate) - if(MasterProc) print *,'NEST: READING BC DATA from ',trim(filename_read_BC) - call read_newdata_LATERAL(ndays_indate) + if(mydebug) write(*,*)'Nest: READING FIRST BC DATA 3D: ',& + trim(filename_read_3D), ndays_indate + + call read_newdata_LATERAL(ndays_indate) + if(mydebug) write(*,"(a,5i4)")'Nest: iw, ie, js, jn, kt ',iw,ie,js,jn,kt + !the first hour only these values are used, no real interpolation between two records endif - - if(ndays_indate-rtime_saved(2)>halfsecond)then - !look for a new data set - filename_read_BC=date2string(trim(filename_read_BC_template),date_nextfile) ! - if(MasterProc) print *,'NEST: READING NEW BC DATA from ',trim(filename_read_BC) + + if(ndays_indate-rtime_saved(2)>halfsecond.or.MODE==100)then + !look for a new data set + call set_extbic(date_nextfile) + + if(MasterProc) write(*,*)'Nest: READING NEW BC DATA from ',& + trim(filename_read_BC) + call read_newdata_LATERAL(ndays_indate) endif ! make weights for time interpolation - W1=1.0; W2=0.0 ! default - if(ndays_indate-rtime_saved(1)>halfsecond)then - !interpolate - W2=(ndays_indate-rtime_saved(1))/(rtime_saved(2)-rtime_saved(1)) - W1=1.0-W2 -! if(me==1)then -! call nctime2idate(ndate,ndays_indate,'YYYY-MM-DD hh:mm:ss') -! call nctime2idate(ndate,rtime_saved(1),'interpolating between YYYY-MM-DD hh:mm:ss') -! call nctime2idate(ndate,rtime_saved(2),'and YYYY-MM-DD hh:mm:ss') -! print *,'with weights : ',W1,W2 -! endif + if(MODE==100)then + !don't interpolate for now + W1=0.0; W2=1.0 ! use last read value + else + W1=1.0; W2=0.0 ! default + if(ndays_indate-rtime_saved(1)>halfsecond)then + !interpolate + W2=(ndays_indate-rtime_saved(1))/(rtime_saved(2)-rtime_saved(1)) + W1=1.0-W2 + endif endif - if(DEBUG_NEST.and.MasterProc) print *,'nesting BC 2D: time weights : ',W1,W2 - if(DEBUG_NEST.and.MasterProc) print *,'nesting BC 2D: time stamps : ',rtime_saved(1),rtime_saved(2) - - do n=1,NSPEC_ADV - if(adv_bc(n)%wanted.and.adv_bc(n)%found)then - if(DEBUG_ICBC.and.MasterProc) print *,'nesting component ',trim(adv_bc(n)%varname) - forall (i=iw:iw, k=1:KMAX_BC, j=1:ljmax, i>=1) & - xn_adv(n,i,j,k)=W1*xn_adv_bndw(n,j,k,1)+W2*xn_adv_bndw(n,j,k,2) - forall (i=ie:ie, k=1:KMAX_BC, j=1:ljmax, i<=limax) & - xn_adv(n,i,j,k)=W1*xn_adv_bnde(n,j,k,1)+W2*xn_adv_bnde(n,j,k,2) - forall (j=js:js, k=1:KMAX_BC, i=1:limax, j>=1) & - xn_adv(n,i,j,k)=W1*xn_adv_bnds(n,i,k,1)+W2*xn_adv_bnds(n,i,k,2) - forall (j=jn:jn, k=1:KMAX_BC, i=1:limax, j<=ljmax) & - xn_adv(n,i,j,k)=W1*xn_adv_bndn(n,i,k,1)+W2*xn_adv_bndn(n,i,k,2) - forall (k=kt:kt, i=1:limax, j=1:ljmax, k>=1) & - xn_adv(n,i,j,k)=W1*xn_adv_bndt(n,i,j,1)+W2*xn_adv_bndt(n,i,j,2) - endif + if(DEBUG_NEST.and.MasterProc) then + write(*,*) 'Nesting BC 2D: time weights : ',W1,W2 + write(*,*) 'Nesting BC 2D: time stamps : ',rtime_saved(1),rtime_saved(2) + endif + + do bc=1,size(adv_bc) + if(.not.(adv_bc(bc)%wanted.and.adv_bc(bc)%found))cycle + n=adv_bc(bc)%ixadv + if(DEBUG_ICBC.and.MasterProc) write(*,"(2(A,1X),I0,'-->',I0)") & + 'NestICBC: Nesting component',trim(adv_bc(bc)%varname),bc,n + forall (i=iw:iw, k=1:KMAX_BC, j=1:ljmax, i>=1) & + xn_adv(n,i,j,k)=W1*xn_adv_bndw(n,j,k,1)+W2*xn_adv_bndw(n,j,k,2) + forall (i=ie:ie, k=1:KMAX_BC, j=1:ljmax, i<=limax) & + xn_adv(n,i,j,k)=W1*xn_adv_bnde(n,j,k,1)+W2*xn_adv_bnde(n,j,k,2) + forall (j=js:js, k=1:KMAX_BC, i=1:limax, j>=1) & + xn_adv(n,i,j,k)=W1*xn_adv_bnds(n,i,k,1)+W2*xn_adv_bnds(n,i,k,2) + forall (j=jn:jn, k=1:KMAX_BC, i=1:limax, j<=ljmax) & + xn_adv(n,i,j,k)=W1*xn_adv_bndn(n,i,k,1)+W2*xn_adv_bndn(n,i,k,2) + forall (k=kt:kt, i=1:limax, j=1:ljmax, k>=1) & + xn_adv(n,i,j,k)=W1*xn_adv_bndt(n,i,j,1)+W2*xn_adv_bndt(n,i,j,2) enddo -if(RCA)then -!some components put to a fixed value - if(kt==1)then - !top - xn_adv(IXADV_H2,:,:,kt)= 5e-7 - xn_adv(IXADV_C2H4,:,:,kt)= 2e-10 - xn_adv(IXADV_C3H6,:,:,kt)= 5e-11 - xn_adv(IXADV_C2H5OH,:,:,kt)= 4e-10 - xn_adv(IXADV_MEK,:,:,kt)= 2.5e-11 - xn_adv(IXADV_CH3O2H,:,:,kt)= 7.5e-11 - xn_adv(IXADV_MGLYOX,:,:,kt)= 0 - xn_adv(IXADV_GLYOX,:,:,kt)= 0 - xn_adv(IXADV_C2H5OOH,:,:,kt)= 1e-12 - endif - if(iw>=1)then -!west - xn_adv(IXADV_H2,iw,:,:)= 5e-7 - xn_adv(IXADV_C2H4,iw,:,:)= 2e-10 - xn_adv(IXADV_C3H6,iw,:,:)= 5e-11 - xn_adv(IXADV_C2H5OH,iw,:,:)= 4e-10 - xn_adv(IXADV_MEK,iw,:,:)= 2.5e-11 - xn_adv(IXADV_CH3O2H,iw,:,:)= 1e-10 - xn_adv(IXADV_MGLYOX,iw,:,:)= 2e-12 - xn_adv(IXADV_GLYOX,iw,:,:)= 6e-12 - xn_adv(IXADV_C2H5OOH,iw,:,:)= 1e-12 - endif - if(ie<=limax)then -!east - xn_adv(IXADV_H2,ie,:,:)= 5e-7 - xn_adv(IXADV_C2H4,ie,:,:)= 2e-10 - xn_adv(IXADV_C3H6,ie,:,:)= 2e-10 - xn_adv(IXADV_C2H5OH,ie,:,:)= 6e-10 - xn_adv(IXADV_MEK,ie,:,:)= 5e-11 - xn_adv(IXADV_CH3O2H,ie,:,:)= 1e-10 - xn_adv(IXADV_MGLYOX,ie,:,:)= 1.5e-12 - xn_adv(IXADV_GLYOX,ie,:,:)= 1.3e-11 - xn_adv(IXADV_C2H5OOH,ie,:,:)= 1e-12 - endif - if(js>=1)then -!south - xn_adv(IXADV_H2,:,js,:)= 5e-7 - xn_adv(IXADV_C2H4,:,js,:)= 5e-11 - xn_adv(IXADV_C3H6,:,js,:)= 1.6e-11 - xn_adv(IXADV_C2H5OH,:,js,:)= 7e-11 - xn_adv(IXADV_MEK,:,js,:)= 2.5e-11 - xn_adv(IXADV_CH3O2H,:,js,:)= 1e-10 - xn_adv(IXADV_MGLYOX,:,js,:)= 2e-12 - xn_adv(IXADV_GLYOX,:,js,:)= 4e-12 - xn_adv(IXADV_C2H5OOH,:,js,:)= 1e-12 - endif - if(jn<=ljmax)then -!north - xn_adv(IXADV_H2,:,jn,:)= 5e-7 - xn_adv(IXADV_C2H4,:,jn,:)= 2e-10 - xn_adv(IXADV_C3H6,:,jn,:)= 2e-10 - xn_adv(IXADV_C2H5OH,:,jn,:)= 4e-10 - xn_adv(IXADV_MEK,:,jn,:)= 2.5e-11 - xn_adv(IXADV_CH3O2H,:,jn,:)= 1e-12 - xn_adv(IXADV_MGLYOX,:,jn,:)= 2e-12 - xn_adv(IXADV_GLYOX,:,jn,:)= 4e-12 - xn_adv(IXADV_C2H5OOH,:,jn,:)= 1e-12 - endif +if(EXTERNAL_BIC_NAME == "RCA")then + call CheckStop("WORK NEEDED: RCA BICs commented out in Nest_ml - not consistent with all chem schemes") endif first_data=0 first_call=.false. return -end subroutine readxn +endsubroutine readxn +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! subroutine wrtxn(indate,WriteNow) - implicit none type(date), intent(in) :: indate logical, intent(in) :: WriteNow !Do not check indate value - real, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: dat ! Data arrays + real,allocatable, dimension(:,:,:) :: dat ! Data arrays type(Deriv) :: def1 ! definition of fields integer :: n,iotyp,ndim,kmax real :: scale logical, save ::first_call=.true. + logical :: fexist, lsend, lrecv if(MODE /= 1.and.MODE /= 3.and.MODE /= 10.and.MODE /= 12.and. .not.FORECAST)return if(FORECAST)then ! FORECAST mode superseeds nest MODE outdate(:)%seconds=0 ! output only at full hours - if(.not.any(indate%year ==outdate%year .and. & - indate%month ==outdate%month .and. & - indate%day ==outdate%day .and. & - indate%hour ==outdate%hour .and. & - indate%seconds==outdate%seconds))return - if(MasterProc) print *,& + if(.not.any((indate%year ==outdate%year .or.outdate%year ==-1).and.& + (indate%month ==outdate%month .or.outdate%month ==-1).and.& + (indate%day ==outdate%day .or.outdate%day ==-1).and.& + (indate%hour ==outdate%hour .or.outdate%hour ==-1).and.& + (indate%seconds==outdate%seconds.or.outdate%seconds==-1)))return + if(MasterProc) write(*,*)& date2string(" Forecast nest/dump at YYYY-MM-DD hh:mm:ss",indate) + istart=RUNDOMAIN(1) jstart=RUNDOMAIN(3) iend=RUNDOMAIN(2) @@ -425,18 +332,10 @@ subroutine wrtxn(indate,WriteNow) ! fileName_write=date2string("EMEP_BC_MMYYYY.nc",indate)!for different names each month !NB: readxn should have same name - if(MasterProc)print *,'write Nest data ',trim(fileName_write) + if(MasterProc)write(*,*)'Nest:write data ',trim(fileName_write) - iotyp=IOU_INST - if(first_call)then - if(MasterProc)then - print *,'Writing BC on ',trim(fileName_write) - !write(command,*)'rm ',trim(fileName_write) - !call system(command) - endif - first_call=.false. - endif + iotyp=IOU_INST ndim=3 !3-dimensional kmax=KMAX_MID scale=1.0 @@ -448,66 +347,111 @@ subroutine wrtxn(indate,WriteNow) def1%name='' ! written def1%unit='mix_ratio' ! written + if(first_call) allocate(dat(MAXLIMAX,MAXLJMAX,KMAX_MID)) + + inquire(file=fileName_write,exist=fexist) + !do first one loop to define the fields, without writing them (for performance purposes) + if(.not.fexist)then + call init_icbc(cdate=indate) + do n= 1, NSPEC_ADV + def1%name= species_adv(n)%name !written + if(.not.adv_ic(n)%wanted)then + if((DEBUG_NEST.or.DEBUG_ICBC).and.MasterProc)& + write(*,"(A,':',/2(2X,A,1X,'''',A,'''',A,'.'))")& + "Nest(wrtxn) DEBUG_ICBC", & + "Variable",trim(def1%name), "is not wanted as IC", & + "Will not be written to IC file:",trim(filename_write),"" + cycle + endif + dat=xn_adv(n,:,:,:) + if(FORECAST.and..false.)then + lsend=any(dat/=0.0) + CALL MPI_ALLREDUCE(lsend,lrecv,1,MPI_LOGICAL,MPI_LOR,MPI_COMM_WORLD,INFO) + adv_ic(n)%wanted=lrecv + if(.not.adv_ic(n)%wanted)then + if((DEBUG_NEST.or.DEBUG_ICBC).and.MasterProc)& + write(*,"(A,':',/2(2X,A,1X,'''',A,'''',A,'.'))")"Nest(wrtxn) DEBUG_ICBC",& + "Variable",trim(def1%name),"was found constant=0.0",& + "Will not be written to IC file:",trim(filename_write),"" + cycle + endif + endif + call Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype=Real4,& + ist=istart,jst=jstart,ien=iend,jen=jend,& + fileName_given=fileName_write,create_var_only=.true.) + enddo + endif + do n= 1, NSPEC_ADV - !do n= 1, NSPEC_ADV-4 !ENEA - def1%name= species(NSPEC_SHL+n)%name !written + if(.not.adv_ic(n)%wanted)cycle + def1%name= species_adv(n)%name !written dat=xn_adv(n,:,:,:) call Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype=Real4,& - ist=istart,jst=jstart,ien=iend,jen=jend,fileName_given=fileName_write) + ist=istart,jst=jstart,ien=iend,jen=jend,& + fileName_given=fileName_write,create_var_only=.false.) enddo + first_call=.false. return -end subroutine wrtxn - - -subroutine check(status) - use netcdf - implicit none - integer, intent ( in) :: status - - if(status /= nf90_noerr) then - print *, trim(nf90_strerror(status)) - WRITE(*,*) 'MPI_ABORT: ', "errorin NetCDF_ml" - call MPI_ABORT(MPI_COMM_WORLD,9,INFO) - end if -end subroutine check - -subroutine init_icbc() - implicit none +endsubroutine wrtxn + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! +subroutine check(status,msg) + integer, intent(in) :: status + character(len=*),intent(in),optional::msg + if(present(msg))write(*,*)msg + call CheckStop(status,nf90_noerr,"Error in Nest_ml. "//trim(nf90_strerror(status))) +endsubroutine check + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! +subroutine init_icbc(idate,cdate,ndays,nsecs) + integer, intent(in), optional :: idate(4) + type(date),intent(in), optional :: cdate + real(kind=8),intent(in),optional:: ndays + integer, intent(in),optional:: nsecs logical, save :: first_call=.true. - integer :: n + integer :: n,dat(4) if(.not.first_call)return first_call=.false. - if(all(adv_ic%varname==""))then - adv_ic(:)%varname=species(NSPEC_SHL+1:NSPEC_SHL+NSPEC_ADV)%name - adv_ic(:)%wanted=.true. - adv_ic(:)%found=find_icbc(filename_read_3D,adv_ic%varname(:)) +! One of the date fromats needs to be provided + call CheckStop(count((/present(idate),present(cdate),present(ndays),& + present(nsecs)/)),1,"init_icbc: wrong date option") + if(present(idate)) dat=idate + if(present(cdate)) dat=(/cdate%year,cdate%month,cdate%day,cdate%hour/) + if(present(ndays)) call nctime2idate(dat,ndays) + if(present(nsecs)) call nctime2idate(dat,nsecs) + call set_extbic(dat) ! set mapping, EXTERNAL_BC, TOP_BC + + adv_ic(:)%ixadv=(/(n,n=1,NSPEC_ADV)/) + adv_ic(:)%varname=species_adv(:)%name + adv_ic(:)%wanted=.true. + adv_ic(:)%found=find_icbc(filename_read_3D,adv_ic%varname(:)) + if(mydebug) then + do n = 1,size(adv_ic%varname) + if(adv_ic(n)%found) write(*,*) & + "init_icbc filled adv_ic "//trim(adv_ic(n)%varname) + enddo endif - if(all(adv_bc%varname==""))then - if(FORECAST)then ! IFS-MOZART BC - adv_bc(:)%wanted=.false. - adv_bc(FORECAST_BC%ixadv)=FORECAST_BC%icbc - adv_bc(:)%found=find_icbc(filename_read_bc,adv_bc%varname(:)) - elseif(TRANSPHORM)then ! TRANSPHORM BC - adv_bc(:)%wanted=.false. - adv_bc(TRANSPHORM_BC%ixadv)=TRANSPHORM_BC%icbc - adv_bc(:)%found=find_icbc(filename_read_bc,adv_bc%varname(:)) - elseif(RCA)then ! RCA BC - adv_bc(:)%wanted=.false. - adv_bc(RCA_BC%ixadv)=RCA_BC%icbc - adv_bc(:)%found=find_icbc(filename_read_bc,adv_bc%varname(:)) - adv_ic(:)=adv_bc(:) - else - adv_bc(:)=adv_ic(:) - endif + if(EXTERNAL_BIC_SET) then + adv_bc=>EXTERNAL_BC + adv_bc(:)%found=find_icbc(filename_read_bc,adv_bc%varname(:)) + else + adv_bc=>adv_ic + endif + if(mydebug) then + do n = 1,size(adv_bc%varname) + if(adv_bc(n)%found) write(*,*) & + "init_icbc filled adv_bc "//trim(adv_bc(n)%varname) + enddo endif if((DEBUG_NEST.or.DEBUG_ICBC).and.MasterProc)then - print "(A)","DEBUG_ICBC Variables:" - print "(2(1X,A,I3,'=',A24,2L2))",& - ('ADV_IC',n,adv_ic(n),'ADV_BC',n,adv_bc(n),n=1,NSPEC_ADV) + write(*,"(a)") "Nest: DEBUG_ICBC Variables:" + write(*,"((1X,A,I3,'->',I3,'=',A24,2L2))") & + ('Nest: ADV_IC',n,adv_ic(n),n=1,size(adv_ic)),& + ('Nest: ADV_BC',n,adv_bc(n),n=1,size(adv_bc)) endif contains function find_icbc(filename_read,varname) result(found) @@ -515,30 +459,32 @@ function find_icbc(filename_read,varname) result(found) character(len=*), intent(in) :: filename_read character(len=*), dimension(:), intent(in) :: varname logical, dimension(size(varname)) :: found - integer :: status,ncFileID,varID,n + integer :: ncFileID,varID,status,n found(:)=.false. if(MasterProc)then - status = nf90_open(path=trim(filename_read),mode=nf90_nowrite,ncid=ncFileID) - if(status /= nf90_noerr) then + status=nf90_open(path=trim(filename_read),mode=nf90_nowrite,ncid=ncFileID) + if(status/=nf90_noerr) then print *,'icbc: not found ',trim(filename_read) else print *,'icbc: reading ',trim(filename_read) do n=1,size(varname) - if(varname(n)/="") & - found(n)=(nf90_inq_varid(ncid=ncFileID,name=trim(varname(n)),varID=varID)==nf90_noerr) + if(varname(n)=="") cycle + status=nf90_inq_varid(ncid=ncFileID,name=trim(varname(n)),varID=varID) + found(n)=(status==nf90_noerr) enddo + call check(nf90_close(ncFileID)) endif endif CALL MPI_BCAST(found,size(found),MPI_LOGICAL,0,MPI_COMM_WORLD,INFO) - end function find_icbc -end subroutine init_icbc + endfunction find_icbc +endsubroutine init_icbc +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! subroutine init_nest(ndays_indate,filename_read,IIij,JJij,Weight,& - k1_ext,k2_ext,weight_k1,weight_k2,& - N_ext,KMAX_ext,GIMAX_ext,GJMAX_ext) + k1_ext,k2_ext,weight_k1,weight_k2,& + N_ext,KMAX_ext,GIMAX_ext,GJMAX_ext) - implicit none character(len=*),intent(in) :: filename_read real ,intent(out):: Weight(MAXLIMAX,MAXLJMAX,4) integer ,intent(out)::IIij(MAXLIMAX,MAXLJMAX,4),JJij(MAXLIMAX,MAXLJMAX,4) @@ -548,115 +494,107 @@ subroutine init_nest(ndays_indate,filename_read,IIij,JJij,Weight,& real(kind=8) :: ndays_indate integer :: ncFileID,idimID,jdimID, kdimID,timeDimID,varid,status !,timeVarID integer :: ndate(4) !nseconds_indate, - real :: dist(0:4),P_emep + real :: DD,dist(4),P_emep integer :: i,j,k,n,k_ext,II,JJ !nseconds(1),n,n1,k real, allocatable, dimension(:,:) ::lon_ext,lat_ext - real, allocatable, dimension(:) ::hyam,hybm,P_ext + real, allocatable, dimension(:) ::hyam,hybm,P_ext,temp_ll character(len=80) ::projection,word - logical :: reversed_k_BC,time_exists + logical :: reversed_k_BC,time_exists,fexist rtime_saved = -99999.9 !initialization -!Read dimensions (global) + !Read dimensions (global) if(MasterProc)then status = nf90_open(path=trim(filename_read),mode=nf90_nowrite,ncid=ncFileID) if(status /= nf90_noerr) then - print *,'init_nest: not found',trim(filename_read) + print *,'init_Nest: not found',trim(filename_read) return else - print *,'init_nest: reading ',trim(filename_read) + print *,'init_Nest: reading ',trim(filename_read) endif - projection='' + projection='Unknown' status = nf90_get_att(ncFileID,nf90_global,"projection",projection) if(status == nf90_noerr) then - write(*,*)'projection: ' + write(*,*)'Nest: projection: '//trim(projection) else - write(*,*)'projection not found for ',trim(filename_read)//', assuming lon lat' - projection='lon lat' + projection='lon lat' + write(*,*)'Nest: projection not found for ',& + trim(filename_read)//', assuming '//trim(projection) endif !get dimensions id if(trim(projection)=='Stereographic') then call check(nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID)) call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) elseif(trim(projection)==trim('lon lat').or. & - trim(projection)==trim('lon_lat')) then + trim(projection)==trim('lon_lat')) then projection='lon lat' call check(nf90_inq_dimid(ncid = ncFileID, name = "lon", dimID = idimID)) call check(nf90_inq_dimid(ncid = ncFileID, name = "lat", dimID = jdimID)) else - !write(*,*)'GENERAL PROJECTION ',trim(projection) + !write(*,*)'GENERAL PROJECTION ',trim(projection) call check(nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID)) call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) - !WRITE(*,*) 'MPI_ABORT: ', "PROJECTION NOT RECOGNIZED" - !call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + !WRITE(*,*) 'MPI_ABORT: ', "PROJECTION NOT RECOGNIZED" + !call MPI_ABORT(MPI_COMM_WORLD,9,INFO) endif - status = nf90_inq_dimid(ncid = ncFileID, name = "k", dimID = kdimID) - if(status /= nf90_noerr) then - status = nf90_inq_dimid(ncid = ncFileID, name = "mlev", dimID = kdimID) - if(status /= nf90_noerr) then - status = nf90_inq_dimid(ncid = ncFileID, name = "lev", dimID = kdimID) - if(status /= nf90_noerr) then - !include more possible names here - write(*,*)'vertical levels name not found: ',trim(filename_read) - call StopAll('Include new name in init_nest') - endif - endif + status = nf90_inq_dimid(ncid=ncFileID,dimID=kdimID,name="k") + if(status/=nf90_noerr) & + status=nf90_inq_dimid(ncid=ncFileID,dimID=kdimID,name="mlev") + if(status/=nf90_noerr) & + status=nf90_inq_dimid(ncid=ncFileID,dimID=kdimID,name="lev") + if(status/=nf90_noerr) then + !include more possible names here + write(*,*)'Nest: vertical levels name not found: ',trim(filename_read) + call StopAll('Include new name in init_nest') endif - N_ext=0 - status = nf90_inq_dimid(ncid = ncFileID, name = "time", dimID = timeDimID) - if(status == nf90_noerr) then - time_exists=.true. - call check(nf90_inquire_dimension(ncid=ncFileID,dimID=timedimID,len=N_ext)) + status = nf90_inq_dimid(ncid=ncFileID,name="time",dimID=timeDimID) + time_exists=(status==nf90_noerr) + if(time_exists) then + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=timedimID,len=N_ext)) else - write(*,*)'time dimension not found. Assuming only one record ' - time_exists=.false. - N_ext=1 + write(*,*)'Nest: time dimension not found. Assuming only one record ' + N_ext=1 endif call check(nf90_inquire_dimension(ncid=ncFileID,dimID=idimID,len=GIMAX_ext)) call check(nf90_inquire_dimension(ncid=ncFileID,dimID=jdimID,len=GJMAX_ext)) call check(nf90_inquire_dimension(ncid=ncFileID,dimID=kdimID,len=KMAX_ext)) - write(*,*)'dimensions external grid',GIMAX_ext,GJMAX_ext,KMAX_ext,N_ext - if(allocated(ndays_ext))then - if(size(ndays_ext)halfsecond)then + elseif(ndays_ext(1)-ndays_indate>halfsecond)then call nctime2idate(ndate,ndays_indate,& - 'WARNING: did not find BIC for date YYYY-MM-DD hh:mm:ss') + 'WARNING: Nest did not find BIC for date YYYY-MM-DD hh:mm:ss') call nctime2idate(ndate,ndays_ext(1),& - 'first date found YYYY-MM-DD hh:mm:ss') + 'Nest first date found YYYY-MM-DD hh:mm:ss') endif - + if(N_ext>1)then - NHOURS_Stride_BC = nint((ndays_ext(2)-ndays_ext(1))*24) + NHOURS_Stride_BC = nint((ndays_ext(2)-ndays_ext(1))*24) else - !use manually set stride: - NHOURS_Stride_BC = NHOURS_Stride_BC_default + !use manually set stride: + NHOURS_Stride_BC = NHOURS_Stride_BC_default endif - write(*,*)'new BC record every ',NHOURS_Stride_BC,' hours' + write(*,*)'Nest: new BC record every ',NHOURS_Stride_BC,' hours' - !enddo + !enddo !Read pressure for vertical levels - write(*,*)'reading vertical level' - - status = nf90_inq_varid(ncid = ncFileID, name = "hyam", varID = varID) - if(status == nf90_noerr) then - call check(nf90_get_var(ncFileID, varID, hyam,count=(/ KMAX_ext /) )) - call check(nf90_inq_varid(ncid = ncFileID, name = "hybm", varID = varID)) - call check(nf90_get_var(ncFileID, varID, hybm,count=(/ KMAX_ext /) )) - else + write(*,*)'Nest: reading vertical levels' + status = nf90_inq_varid(ncid = ncFileID, name = "hyam", varID = varID) + if(status == nf90_noerr) then + call check(nf90_get_var(ncFileID, varID, hyam,count=(/ KMAX_ext /) )) + call check(nf90_inq_varid(ncid = ncFileID, name = "hybm", varID = varID)) + call check(nf90_get_var(ncFileID, varID, hybm,count=(/ KMAX_ext /) )) + else + inquire(file=filename_eta,exist=fexist) status = nf90_inq_varid(ncid = ncFileID, name = "k", varID = varID) if(status == nf90_noerr) then - write(*,*)'assuming sigma level and PT=',PT,KMAX_ext - call check(nf90_get_var(ncFileID, varID, hybm,count=(/ KMAX_ext /) ))!NB: here assume = sigma - do k=1,KMAX_ext - hyam(k)=PT*(1.0-hybm(k)) - enddo + write(*,*)'Nest: assuming sigma level and PT=',PT,KMAX_ext + call check(nf90_get_var(ncFileID, varID, hybm,count=(/ KMAX_ext /) ))!NB: here assume = sigma + do k=1,KMAX_ext + hyam(k)=PT*(1.0-hybm(k)) + enddo + elseif(fexist) then + !read eta levels from ad-hoc text file + write(*,*)'Nest: Reading vertical level from ',trim(filename_eta) + call open_file(IO_TMP,"r",trim(filename_eta),needed=.true.) + do n=1,10000 + read(IO_TMP,*)word + if(trim(word)=='vct')exit + enddo + read(IO_TMP,*)(hyam(k),k=1,KMAX_ext+1)!NB: here = A_bnd, not mid + read(IO_TMP,*)(hybm(k),k=1,KMAX_ext+1)!NB: here = B_bnd, not mid + close(IO_TMP) + !convert to mid levels coefficients + do k=1,KMAX_ext + hyam(k)=0.5*(hyam(k)+hyam(k+1)) + hybm(k)=0.5*(hybm(k)+hybm(k+1)) + enddo else - - !read eta levels from ad-hoc text file - call open_file(IO_TMP,"r",trim(filename_eta),needed=.true.) - do n=1,10000 - read(IO_TMP,*)word - if(trim(word)=='vct')exit - enddo - read(IO_TMP,*)(hyam(k),k=1,KMAX_ext+1)!NB: here = A_bnd, not mid - read(IO_TMP,*)(hybm(k),k=1,KMAX_ext+1)!NB: here = B_bnd, not mid - close(IO_TMP) - !convert to mid levels coefficients - do k=1,KMAX_ext - hyam(k)=0.5*(hyam(k)+hyam(k+1)) - hybm(k)=0.5*(hybm(k)+hybm(k+1)) - enddo - !assumes lev=1000*(A+B) (IFS-MOZART?) - !call check(nf90_inq_varid(ncid = ncFileID, name = "lev", varID = varID)) - !call check(nf90_get_var(ncFileID, varID, hybm )) - !hybm=hybm/1000.0 - !hyam=0.0 - endif + status = nf90_inq_varid(ncid = ncFileID, name = "lev", varID = varID) + if(status == nf90_noerr) then + call StopAll('Pressure levels not yet implemented') + write(*,*)'Nest: assuming pressure levels and hPa' + call check(nf90_get_var(ncFileID, varID, hyam,count=(/ KMAX_ext /) )) + hyam=100.0*hyam ! hPa ->Pa + hybm=0.0 + else + call StopAll('Vertical coordinate Unknown/Not yet implemented') + !assumes lev=1000*(A+B) (IFS-MOZART?) + !call check(nf90_inq_varid(ncid = ncFileID, name = "lev", varID = varID)) + !call check(nf90_get_var(ncFileID, varID, hybm )) + !hybm=hybm/1000.0 + !hyam=0.0 + endif endif + endif call check(nf90_close(ncFileID)) endif !end MasterProc @@ -740,60 +691,39 @@ subroutine init_nest(ndays_indate,filename_read,IIij,JJij,Weight,& CALL MPI_BCAST(hyam,8*KMAX_ext,MPI_BYTE,0,MPI_COMM_WORLD,INFO) CALL MPI_BCAST(hybm,8*KMAX_ext,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - !find horizontal interpolation constants - !note that i,j are local - !find the four closest points + !find horizontal interpolation constants + !note that i,j are local + !find the four closest points do j=1,ljmax do i=1,limax - dist=1.0E40 + dist(:)=1.0E40 do JJ=1,GJMAX_ext do II=1,GIMAX_ext - !distance between (i,j) and (II,JJ) - dist(0)=great_circle_distance(lon_ext(II,JJ),lat_ext(II,JJ),glon(i,j),glat(i,j)) - if(dist(0)P_ext(2))then - ! assumes that k_ext=KMAX_EXT is top and k_ext=1 is surface - reversed_k_BC=.true. - else - ! assumes that k_ext=1 is top and k_ext=KMAX_EXT is surface - reversed_k_BC=.false. - endif - -if(reversed_k_BC)then - do k=1,KMAX_MID - P_emep=A_mid(k)+B_mid(k)*Pref !Pa - if(DEBUG_NEST.and.MasterProc) write(*,fmt="(A,I3,F10.2)")'P_emep',k,P_emep - !largest available P smaller than P_emep (if possible) - k1_ext(k)=1 !start at surface, and go up until P_emep - do k_ext=1,KMAX_EXT + reversed_k_BC=(P_ext(1)>P_ext(2)) + ! .true. --> assumes k_ext=KMAX_EXT is top and k_ext=1 is surface + ! .false. --> assumes k_ext=1 is top and k_ext=KMAX_EXT is surface + + if(reversed_k_BC)then + do k=1,KMAX_MID + P_emep=A_mid(k)+B_mid(k)*Pref !Pa + if(mydebug) write(*,fmt="(A,I3,F10.2)")'Nest: P_emep',k,P_emep + !largest available P smaller than P_emep (if possible) + k1_ext(k)=1 !start at surface, and go up until P_emep + do k_ext=1,KMAX_EXT if(P_ext(k_ext)P_emep)exit if(k_ext/=k1_ext(k))k2_ext(k)=k_ext - enddo - weight_k1(k)=(P_emep-P_ext(k2_ext(k)))/(P_ext(k1_ext(k))-P_ext(k2_ext(k))) - weight_k2(k)=1.0-weight_k1(k) - if(DEBUG_NEST.and.MasterProc)then - write(*,fmt="(A,I3,A,I2,A,f4.2,A,I2,A,F4.2)")'level',k,' is the sum of level ',& - k1_ext(k),' weight ',weight_k1(k),' and level ',k2_ext(k),' weight ',weight_k2(k) - endif - enddo + enddo + weight_k1(k)=(P_emep-P_ext(k2_ext(k)))/(P_ext(k1_ext(k))-P_ext(k2_ext(k))) + weight_k2(k)=1.0-weight_k1(k) + if(mydebug)& + write(*,fmt="(A,I3,2(A,I2,A,F5.2))")'Nest: level',k,& + ' is the sum of level ',k1_ext(k),' weight ',weight_k1(k),& + ' and level ',k2_ext(k),' weight ',weight_k2(k) + enddo -else - do k=1,KMAX_MID - P_emep=A_mid(k)+B_mid(k)*Pref !Pa - if(DEBUG_NEST.and.MasterProc) write(*,fmt="(A,I3,F10.2)")'P_emep',k,P_emep - !largest available P smaller than P_emep (if possible) - k1_ext(k)=KMAX_EXT !start at surface, and go up until P_emep - do k_ext=KMAX_EXT,1,-1 + else + do k=1,KMAX_MID + P_emep=A_mid(k)+B_mid(k)*Pref !Pa + if(mydebug) write(*,fmt="(A,I3,F10.2)")'Nest: P_emep',k,P_emep + !largest available P smaller than P_emep (if possible) + k1_ext(k)=KMAX_EXT !start at surface, and go up until P_emep + do k_ext=KMAX_EXT,1,-1 if(P_ext(k_ext)P_emep)exit if(k_ext/=k1_ext(k))k2_ext(k)=k_ext - enddo - weight_k1(k)=(P_emep-P_ext(k2_ext(k)))/(P_ext(k1_ext(k))-P_ext(k2_ext(k))) - weight_k2(k)=1.0-weight_k1(k) - if(DEBUG_NEST.and.MasterProc)then - write(*,fmt="(A,I3,A,I2,A,f4.2,A,I2,A,F4.2)")'level',k,' is the sum of level ',& - k1_ext(k),' weight ',weight_k1(k),' and level ',k2_ext(k),' weight ',weight_k2(k) - endif - enddo -endif + enddo + weight_k1(k)=(P_emep-P_ext(k2_ext(k)))/(P_ext(k1_ext(k))-P_ext(k2_ext(k))) + weight_k2(k)=1.0-weight_k1(k) + if(mydebug) & + write(*,fmt="(A,I3,2(A,I2,A,F5.2))")'Nest: level',k,& + ' is the sum of level ', k1_ext(k),' weight ',weight_k1(k),& + ' and level ', k2_ext(k),' weight ',weight_k2(k) + enddo + endif deallocate(P_ext,hyam,hybm) - if(DEBUG_NEST.and.MasterProc)write(*,*)'Nesting: finished determination of interpolation parameters' - -end subroutine init_nest + if(mydebug) & + write(*,*)'Nest: finished determination of interpolation parameters' +endsubroutine init_nest +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! subroutine read_newdata_LATERAL(ndays_indate) - implicit none real(kind=8), intent(in)::ndays_indate real, allocatable, dimension(:,:,:) ::data integer :: ncFileID,varid,status - integer :: ndate(4),n,i,j,k + integer :: ndate(4),n,i,j,k,bc real(kind=8) :: ndays(1),ndays_old logical, save :: first_call=.true. !4 nearest points from external grid (horizontal) - integer, save ::IIij(MAXLIMAX,MAXLJMAX,4),JJij(MAXLIMAX,MAXLJMAX,4) + integer, save,allocatable :: IIij(:,:,:),JJij(:,:,:) !weights of the 4 nearest points (horizontal) - real, save :: Weight(MAXLIMAX,MAXLJMAX,4) + real, save,allocatable :: Weight(:,:,:) !2 adjacent levels from external grid (vertical) integer, save, dimension(KMAX_MID) :: k1_ext,k2_ext @@ -900,27 +826,34 @@ subroutine read_newdata_LATERAL(ndays_indate) integer, save ::GIMAX_ext,GJMAX_ext character (len=80) ::units real :: scale_factor,add_offset - logical :: time_exists + logical :: time_exists,divbyroa KMAX_BC=KMAX_MID + if(mydebug)write(*,*)'Nest: read_newdata_LATERAL, first?', first_call if(first_call)then - if(DEBUG_NEST.and.MasterProc)write(*,*)'Nesting: initializations 2D' - call init_icbc() + if(mydebug)write(*,*)'Nest: initializations 2D' + allocate(IIij(MAXLIMAX,MAXLJMAX,4),JJij(MAXLIMAX,MAXLJMAX,4)) + allocate(Weight(MAXLIMAX,MAXLJMAX,4)) + call init_icbc(ndays=ndays_indate) + if(mydebug)write(*,*)'calling init_nest for '//trim(filename_read_BC) call init_nest(ndays_indate,filename_read_BC,IIij,JJij,Weight,& k1_ext,k2_ext,weight_k1,weight_k2,& N_ext_BC,KMAX_ext_BC,GIMAX_ext,GJMAX_ext) - + if(MODE==100.and.N_ext_BC/=12.and.MasterProc)then + write(*,*)'Nest: WARNING: Expected 12 monthes in BC file, found ',N_ext_BC + call StopAll('Nest BC: wrong number of monthes') + endif !Define & allocate West/East/South/Nort Boundaries iw=li0-1;ie=li1+1 ! i West/East boundaries js=lj0-1;jn=lj1+1 ! j South/North boundaries kt=0;if(TOP_BC)kt=1 ! k Top boundary - if(DEBUG_NEST.and.MasterProc)then - if(kt==1)then - write(*,*)'Also including the top layer in BC' - else - write(*,*)'Not resetting the top layer' - endif + if(mydebug)then + if(kt==1)then + write(*,*)'Nest-kt test: Also including the top layer in BC' + else + write(*,*)'Nest-kt test: Not resetting the top layer' + endif endif if(iw>=1 .and..not.allocated(xn_adv_bndw)) & @@ -935,8 +868,8 @@ subroutine read_newdata_LATERAL(ndays_indate) allocate(xn_adv_bndt(NSPEC_ADV,MAXLIMAX,MAXLJMAX,2)) ! Top if(DEBUG_ICBC)then CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) - if(MasterProc) print "(A)","DEBUG_ICBC Boundaries:" - print "(1X,'me=',i3,5(1X,A,I0,'=',L1))",& + if(MasterProc) write(*, "(A)") "Nest: DEBUG_ICBC Boundaries:" + write(*,"(1X,'me=',i3,5(1X,A,I0,'=',L1))")& me,'W:i',iw,allocated(xn_adv_bndw),'E:i',ie,allocated(xn_adv_bnde),& 'S:j',js,allocated(xn_adv_bnds),'N:j',jn,allocated(xn_adv_bndn),& 'T:k',kt,allocated(xn_adv_bndt) @@ -944,7 +877,8 @@ subroutine read_newdata_LATERAL(ndays_indate) CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) endif rtime_saved(2)=-99.0!just to put a value - if(DEBUG_NEST.and.MasterProc)write(*,*)'Nesting: end initializations 2D' + if(mydebug)write(*,*)'Nest: end initializations 2D' + endif rtime_saved(1)=rtime_saved(2)!put old values in 1 @@ -952,187 +886,176 @@ subroutine read_newdata_LATERAL(ndays_indate) if(MasterProc)then call check(nf90_open(path = trim(fileName_read_BC), mode = nf90_nowrite, ncid = ncFileID)) status = nf90_inq_dimid(ncid = ncFileID, name = "time", dimID = timeDimID) - if(status == nf90_noerr) then - time_exists=.true. - call check(nf90_inquire_dimension(ncid=ncFileID,dimID=timedimID,len=N_ext_BC)) + time_exists=(status==nf90_noerr) + if(time_exists) then + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=timedimID,len=N_ext_BC)) else - time_exists=.false. - N_ext_BC=1 + N_ext_BC=1 endif - if(size(ndays_ext)=1) forall (k=1:KMAX_BC, j=1:ljmax) & - xn_adv_bndw(n,j,k,1)=xn_adv_bndw(n,j,k,2) - if(ie<=limax) forall (k=1:KMAX_BC, j=1:ljmax) & - xn_adv_bnde(n,j,k,1)=xn_adv_bnde(n,j,k,2) - if(js>=1) forall (k=1:KMAX_BC, i=1:limax) & - xn_adv_bnds(n,i,k,1)=xn_adv_bnds(n,i,k,2) - if(jn<=ljmax) forall (k=1:KMAX_BC, i=1:limax) & - xn_adv_bndn(n,i,k,1)=xn_adv_bndn(n,i,k,2) - if(kt>=1) forall (i=1:limax, j=1:ljmax) & - xn_adv_bndt(n,i,j,1)=xn_adv_bndt(n,i,j,2) - endif - if(iw>=1) forall (k=1:KMAX_BC, j=1:ljmax) & - xn_adv_bndw(n,j,k,2)=0.0 - if(ie<=limax) forall (k=1:KMAX_BC, j=1:ljmax) & - xn_adv_bnde(n,j,k,2)=0.0 - if(js>=1) forall (k=1:KMAX_BC, i=1:limax) & - xn_adv_bnds(n,i,k,2)=0.0 - if(jn<=ljmax) forall (k=1:KMAX_BC, i=1:limax) & - xn_adv_bndn(n,i,k,2)=0.0 - if(kt>=1) forall (i=1:limax, j=1:ljmax) & - xn_adv_bndt(n,i,j,2)=0.0 - - enddo DO_SPEC_init - - DO_SPEC: do n= 1, NSPEC_ADV - if(.not.(adv_bc(n)%wanted.and.adv_bc(n)%found)) cycle DO_SPEC + if(.not.first_call) call store_old_bc() !store the old values in 1 + if(allocated(xn_adv_bndw)) xn_adv_bndw(:,:,:,2)=0.0 + if(allocated(xn_adv_bnde)) xn_adv_bnde(:,:,:,2)=0.0 + if(allocated(xn_adv_bnds)) xn_adv_bnds(:,:,:,2)=0.0 + if(allocated(xn_adv_bndn)) xn_adv_bndn(:,:,:,2)=0.0 + if(allocated(xn_adv_bndt)) xn_adv_bndt(:,:,:,2)=0.0 + DO_BC: do bc=1,size(adv_bc) + if(.not.(adv_bc(bc)%wanted.and.adv_bc(bc)%found))cycle DO_BC + n=adv_bc(bc)%ixadv if(MasterProc)then + if(DEBUG_NEST.or.DEBUG_ICBC) write(*,"(2(A,1X),I0,'-->',I0)")& + 'Nest: DO_BC',trim(adv_bc(bc)%varname),bc,n !Could fetch one level at a time if sizes becomes too big - call check(nf90_inq_varid(ncid=ncFileID, name=trim(adv_bc(n)%varname), varID=varID)) + call check(nf90_inq_varid(ncid=ncFileID, name=trim(adv_bc(bc)%varname), varID=varID)) call check(nf90_get_var(ncFileID, varID, data & ,start=(/ 1,1,1,itime /),count=(/ GIMAX_ext,GJMAX_ext,KMAX_ext_BC,1 /) )) status = nf90_get_att(ncFileID,VarID,"scale_factor",scale_factor) - if(status == nf90_noerr) then - data=data*scale_factor - endif + if(status==nf90_noerr) data=data*scale_factor status = nf90_get_att(ncFileID,VarID,"add_offset",add_offset) - if(status == nf90_noerr) then - data=data+add_offset - endif + if(status==nf90_noerr) data=data+add_offset status = nf90_get_att(ncFileID,VarID,"units",units) - if(status == nf90_noerr) then - if(DEBUG_NEST)write(*,*)'variable '//trim(adv_bc(n)%varname)//' has unit '//trim(units) - if(units(1:3) == 'ppb') then - if(DEBUG_NEST)write(*,*)'which is ppb unit. Scaling by ',PPB - data=data*PPB - else - if(DEBUG_NEST)write(*,*)'which is not recognized as ppb unit. Assuming mixing ratio' - endif + if(status==nf90_noerr) then + if(DEBUG_NEST.or.DEBUG_ICBC) write(*,*)& + 'Nest: variable '//trim(adv_bc(bc)%varname)//' has unit '//trim(units) + data=data/Units_Scale(units,n,needroa=divbyroa,debug_msg="read_newdata_LATERAL") else - if(DEBUG_NEST)write(*,*)'units attribute not found for variable '//trim(adv_bc(n)%varname) + if(DEBUG_NEST.or.DEBUG_ICBC) write(*,*)& + 'units attribute not found for variable '//trim(adv_bc(bc)%varname) endif endif + CALL MPI_BCAST(data,8*GIMAX_ext*GJMAX_ext*KMAX_ext_BC,MPI_BYTE,0,MPI_COMM_WORLD,INFO) !overwrite Global Boundaries (lateral faces) - if(iw>=1) forall (k=1:KMAX_BC, j=1:ljmax) & - xn_adv_bndw(n,j,k,2)=xn_adv_bndw(n,j,k,2)+(Weight(iw,j,1)*data(IIij(iw,j,1),JJij(iw,j,1),k1_ext(k)) & - +Weight(iw,j,2)*data(IIij(iw,j,2),JJij(iw,j,2),k1_ext(k)) & - +Weight(iw,j,3)*data(IIij(iw,j,3),JJij(iw,j,3),k1_ext(k)) & - +Weight(iw,j,4)*data(IIij(iw,j,4),JJij(iw,j,4),k1_ext(k)))*weight_k1(k)& - +(Weight(iw,j,1)*data(IIij(iw,j,1),JJij(iw,j,1),k2_ext(k)) & - +Weight(iw,j,2)*data(IIij(iw,j,2),JJij(iw,j,2),k2_ext(k)) & - +Weight(iw,j,3)*data(IIij(iw,j,3),JJij(iw,j,3),k2_ext(k)) & - +Weight(iw,j,4)*data(IIij(iw,j,4),JJij(iw,j,4),k2_ext(k)))*weight_k2(k) - if(ie<=limax) forall (k=1:KMAX_BC, j=1:ljmax) & - xn_adv_bnde(n,j,k,2)=xn_adv_bnde(n,j,k,2)+(Weight(ie,j,1)*data(IIij(ie,j,1),JJij(ie,j,1),k1_ext(k)) & - +Weight(ie,j,2)*data(IIij(ie,j,2),JJij(ie,j,2),k1_ext(k)) & - +Weight(ie,j,3)*data(IIij(ie,j,3),JJij(ie,j,3),k1_ext(k)) & - +Weight(ie,j,4)*data(IIij(ie,j,4),JJij(ie,j,4),k1_ext(k)))*weight_k1(k)& - +(Weight(ie,j,1)*data(IIij(ie,j,1),JJij(ie,j,1),k2_ext(k)) & - +Weight(ie,j,2)*data(IIij(ie,j,2),JJij(ie,j,2),k2_ext(k)) & - +Weight(ie,j,3)*data(IIij(ie,j,3),JJij(ie,j,3),k2_ext(k)) & - +Weight(ie,j,4)*data(IIij(ie,j,4),JJij(ie,j,4),k2_ext(k)))*weight_k2(k) - if(js>=1) forall (k=1:KMAX_BC, i=1:limax) & - xn_adv_bnds(n,i,k,2)=xn_adv_bnds(n,i,k,2)+(Weight(i,js,1)*data(IIij(i,js,1),JJij(i,js,1),k1_ext(k)) & - +Weight(i,js,2)*data(IIij(i,js,2),JJij(i,js,2),k1_ext(k)) & - +Weight(i,js,3)*data(IIij(i,js,3),JJij(i,js,3),k1_ext(k)) & - +Weight(i,js,4)*data(IIij(i,js,4),JJij(i,js,4),k1_ext(k)))*weight_k1(k)& - +(Weight(i,js,1)*data(IIij(i,js,1),JJij(i,js,1),k2_ext(k)) & - +Weight(i,js,2)*data(IIij(i,js,2),JJij(i,js,2),k2_ext(k)) & - +Weight(i,js,3)*data(IIij(i,js,3),JJij(i,js,3),k2_ext(k)) & - +Weight(i,js,4)*data(IIij(i,js,4),JJij(i,js,4),k2_ext(k)))*weight_k2(k) - if(jn<=ljmax) forall (k=1:KMAX_BC, i=1:limax) & - xn_adv_bndn(n,i,k,2)=xn_adv_bndn(n,i,k,2)+(Weight(i,jn,1)*data(IIij(i,jn,1),JJij(i,jn,1),k1_ext(k)) & - +Weight(i,jn,2)*data(IIij(i,jn,2),JJij(i,jn,2),k1_ext(k)) & - +Weight(i,jn,3)*data(IIij(i,jn,3),JJij(i,jn,3),k1_ext(k)) & - +Weight(i,jn,4)*data(IIij(i,jn,4),JJij(i,jn,4),k1_ext(k)))*weight_k1(k)& - +(Weight(i,jn,1)*data(IIij(i,jn,1),JJij(i,jn,1),k2_ext(k)) & - +Weight(i,jn,2)*data(IIij(i,jn,2),JJij(i,jn,2),k2_ext(k)) & - +Weight(i,jn,3)*data(IIij(i,jn,3),JJij(i,jn,3),k2_ext(k)) & - +Weight(i,jn,4)*data(IIij(i,jn,4),JJij(i,jn,4),k2_ext(k)))*weight_k2(k) - if(kt>=1) forall (i=1:limax, j=1:ljmax) & - xn_adv_bndt(n,i,j,2)=xn_adv_bndt(n,i,j,2)+(Weight(i,j,1)*data(IIij(i,j,1),JJij(i,j,1),k1_ext(kt)) & - +Weight(i,j,2)*data(IIij(i,j,2),JJij(i,j,2),k1_ext(kt)) & - +Weight(i,j,3)*data(IIij(i,j,3),JJij(i,j,3),k1_ext(kt)) & - +Weight(i,j,4)*data(IIij(i,j,4),JJij(i,j,4),k1_ext(kt)))*weight_k1(kt)& - +(Weight(i,j,1)*data(IIij(i,j,1),JJij(i,j,1),k2_ext(kt)) & - +Weight(i,j,2)*data(IIij(i,j,2),JJij(i,j,2),k2_ext(kt)) & - +Weight(i,j,3)*data(IIij(i,j,3),JJij(i,j,3),k2_ext(kt)) & - +Weight(i,j,4)*data(IIij(i,j,4),JJij(i,j,4),k2_ext(kt)))*weight_k2(kt) - enddo DO_SPEC + if(divbyroa)then + if(allocated(xn_adv_bndw)) forall(k=1:KMAX_BC, j=1:ljmax) & + xn_adv_bndw(n,j,k,2)=xn_adv_bndw(n,j,k,2) & + +(WeightData(iw,j,k1_ext(k))*weight_k1(k) & + +WeightData(iw,j,k2_ext(k))*weight_k2(k))& + /roa(iw,j,k,1) + if(allocated(xn_adv_bnde)) forall(k=1:KMAX_BC, j=1:ljmax) & + xn_adv_bnde(n,j,k,2)=xn_adv_bnde(n,j,k,2) & + +(WeightData(ie,j,k1_ext(k))*weight_k1(k) & + +WeightData(ie,j,k2_ext(k))*weight_k2(k))& + /roa(ie,j,k,1) + if(allocated(xn_adv_bnds)) forall(k=1:KMAX_BC, i=1:limax) & + xn_adv_bnds(n,i,k,2)=xn_adv_bnds(n,i,k,2) & + +(WeightData(i,js,k1_ext(k))*weight_k1(k) & + +WeightData(i,js,k2_ext(k))*weight_k2(k))& + /roa(i,js,k,1) + if(allocated(xn_adv_bndn)) forall(k=1:KMAX_BC, i=1:limax) & + xn_adv_bndn(n,i,k,2)=xn_adv_bndn(n,i,k,2) & + +(WeightData(i,jn,k1_ext(k))*weight_k1(k) & + +WeightData(i,jn,k2_ext(k))*weight_k2(k))& + /roa(i,jn,k,1) + if(allocated(xn_adv_bndt)) forall(i=1:limax, j=1:ljmax) & + xn_adv_bndt(n,i,j,2)=xn_adv_bndt(n,i,j,2) & + +(WeightData(i,j,k1_ext(kt))*weight_k1(kt) & + +WeightData(i,j,k2_ext(kt))*weight_k2(kt))& + /roa(i,j,kt,1) + else + if(allocated(xn_adv_bndw)) forall(k=1:KMAX_BC, j=1:ljmax) & + xn_adv_bndw(n,j,k,2)=xn_adv_bndw(n,j,k,2) & + +WeightData(iw,j,k1_ext(k))*weight_k1(k)& + +WeightData(iw,j,k2_ext(k))*weight_k2(k) + if(allocated(xn_adv_bnde)) forall(k=1:KMAX_BC, j=1:ljmax) & + xn_adv_bnde(n,j,k,2)=xn_adv_bnde(n,j,k,2) & + +WeightData(ie,j,k1_ext(k))*weight_k1(k)& + +WeightData(ie,j,k2_ext(k))*weight_k2(k) + if(allocated(xn_adv_bnds)) forall(k=1:KMAX_BC, i=1:limax) & + xn_adv_bnds(n,i,k,2)=xn_adv_bnds(n,i,k,2) & + +WeightData(i,js,k1_ext(k))*weight_k1(k)& + +WeightData(i,js,k2_ext(k))*weight_k2(k) + if(allocated(xn_adv_bndn)) forall(k=1:KMAX_BC, i=1:limax) & + xn_adv_bndn(n,i,k,2)=xn_adv_bndn(n,i,k,2) & + +WeightData(i,jn,k1_ext(k))*weight_k1(k)& + +WeightData(i,jn,k2_ext(k))*weight_k2(k) + if(allocated(xn_adv_bndt)) forall(i=1:limax, j=1:ljmax) & + xn_adv_bndt(n,i,j,2)=xn_adv_bndt(n,i,j,2) & + +WeightData(i,j,k1_ext(kt))*weight_k1(kt)& + +WeightData(i,j,k2_ext(kt))*weight_k2(kt) + endif + enddo DO_BC if(first_call)then - !copy 2 into 1 so that both are well defined - rtime_saved(1)=rtime_saved(2)!put time in 1 - DO_SPEC_init1: do n= 1, NSPEC_ADV !copy BC used to nr=1 - if(.not.(adv_bc(n)%wanted.and.adv_bc(n)%found)) cycle DO_SPEC_init1 - !store the old values in 1 - if(iw>=1) forall (k=1:KMAX_BC, j=1:ljmax) & - xn_adv_bndw(n,j,k,1)=xn_adv_bndw(n,j,k,2) - if(ie<=limax) forall (k=1:KMAX_BC, j=1:ljmax) & - xn_adv_bnde(n,j,k,1)=xn_adv_bnde(n,j,k,2) - if(js>=1) forall (k=1:KMAX_BC, i=1:limax) & - xn_adv_bnds(n,i,k,1)=xn_adv_bnds(n,i,k,2) - if(jn<=ljmax) forall (k=1:KMAX_BC, i=1:limax) & - xn_adv_bndn(n,i,k,1)=xn_adv_bndn(n,i,k,2) - if(kt>=1) forall (i=1:limax, j=1:ljmax) & - xn_adv_bndt(n,i,j,1)=xn_adv_bndt(n,i,j,2) - enddo DO_SPEC_init1 + !copy 2 into 1 so that both are well defined + rtime_saved(1)=rtime_saved(2)!put time in 1 + call store_old_bc() !store the old values in 1 endif deallocate(data) if(MasterProc) call check(nf90_close(ncFileID)) first_call=.false. return -end subroutine read_newdata_LATERAL - + contains + PURE function WeightData(i,j,k) result(wsum) + integer, intent(in)::i,j,k + real:: wsum + wsum=dot_product(Weight(i,j,:),& + (/data(IIij(i,j,1),JJij(i,j,1),k),data(IIij(i,j,2),JJij(i,j,2),k),& + data(IIij(i,j,3),JJij(i,j,3),k),data(IIij(i,j,4),JJij(i,j,4),k)/)) + endfunction WeightData + subroutine store_old_bc !store the old values in 1 + if(allocated(xn_adv_bndw)) xn_adv_bndw(:,:,:,1)=xn_adv_bndw(:,:,:,2) + if(allocated(xn_adv_bnde)) xn_adv_bnde(:,:,:,1)=xn_adv_bnde(:,:,:,2) + if(allocated(xn_adv_bnds)) xn_adv_bnds(:,:,:,1)=xn_adv_bnds(:,:,:,2) + if(allocated(xn_adv_bndn)) xn_adv_bndn(:,:,:,1)=xn_adv_bndn(:,:,:,2) + if(allocated(xn_adv_bndt)) xn_adv_bndt(:,:,:,1)=xn_adv_bndt(:,:,:,2) + endsubroutine store_old_bc +endsubroutine read_newdata_LATERAL + +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! subroutine reset_3D(ndays_indate) implicit none real(kind=8), intent(in)::ndays_indate @@ -1143,10 +1066,10 @@ subroutine reset_3D(ndays_indate) logical, save :: first_call=.true. !4 nearest points from external grid - integer, save ::IIij(MAXLIMAX,MAXLJMAX,4),JJij(MAXLIMAX,MAXLJMAX,4) + integer, save,allocatable :: IIij(:,:,:),JJij(:,:,:) !weights of the 4 nearest points - real, save :: Weight(MAXLIMAX,MAXLJMAX,4) + real, save,allocatable :: Weight(:,:,:) !dimensions of external grid for 3D integer, save ::N_ext,KMAX_ext,GIMAX_ext,GJMAX_ext @@ -1155,86 +1078,102 @@ subroutine reset_3D(ndays_indate) integer, save, dimension(KMAX_MID) :: k1_ext,k2_ext !weights of the 2 adjacent levels (vertical) real, save, dimension(KMAX_MID) :: weight_k1,weight_k2 - character (len=80) ::units + character (len=80) :: units real :: scale_factor,add_offset + logical :: divbyroa + if(mydebug) write(*,*) 'Nest: initializations 3D', first_call + if(first_call)then - if(DEBUG_NEST.and.MasterProc)write(*,*)'Nesting: initializations 3D' - first_call=.false. - call init_icbc() - call init_nest(ndays_indate,filename_read_3D,IIij,JJij,Weight,& - k1_ext,k2_ext,weight_k1,weight_k2,& - N_ext,KMAX_ext,GIMAX_ext,GJMAX_ext) - if(DEBUG_NEST.and.MasterProc)write(*,*)'Nesting: end initializations 3D' + if(mydebug) write(*,*)'Nest: initializations 3D' + allocate(IIij(MAXLIMAX,MAXLJMAX,4),JJij(MAXLIMAX,MAXLJMAX,4)) + allocate(Weight(MAXLIMAX,MAXLJMAX,4)) + first_call=.false. + if(mydebug) write(*,*) 'Nest: init-icbc' + call init_icbc(ndays=ndays_indate) + if(mydebug) write(*,*)'calling init_nest for 3D '//trim(filename_read_3D) + call init_nest(ndays_indate,filename_read_3D,IIij,JJij,Weight,& + k1_ext,k2_ext,weight_k1,weight_k2,& + N_ext,KMAX_ext,GIMAX_ext,GJMAX_ext) + if(MODE==100.and.(N_ext/=12.and.N_ext/=1.and.MasterProc))then + write(*,*)'Nest: WARNING: Expected 12 or 1 monthes in IC file, found ',N_ext + call StopAll('Nest: IC: wrong number of months') + endif + if(mydebug) write(*,*)'Nest: end initializations 3D' endif allocate(data(GIMAX_ext,GJMAX_ext,KMAX_ext), stat=status) if(MasterProc)then call check(nf90_open(path = trim(fileName_read_3D), mode = nf90_nowrite, ncid = ncFileID)) - -! call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = varID)) - do n=1,N_ext - !call check(nf90_get_var(ncFileID, varID, ndays,start=(/ n /),count=(/ 1 /) )) - if(ndays_ext(n)>=ndays_indate) goto 876 - enddo - n=N_ext - write(*,*)'WARNING: did not find correct date' -876 continue - call nctime2idate(ndate,ndays_ext(n),'Using date YYYY-MM-DD hh:mm:ss') + if(MODE==100)then + if(N_ext==1)then + n=1 + else + call nctime2idate(ndate,ndays_indate,'Using record MM') + n=ndate(2) + endif + else + ! call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = varID)) + do n=1,N_ext + !call check(nf90_get_var(ncFileID, varID, ndays,start=(/ n /),count=(/ 1 /) )) + if(ndays_ext(n)>=ndays_indate) goto 876 + enddo + n=N_ext + write(*,*)'Nest: WARNING: did not find correct date' +876 continue + call nctime2idate(ndate,ndays_ext(n),'Using date YYYY-MM-DD hh:mm:ss') + endif itime=n endif - if(DEBUG_NEST.and.MasterProc)write(*,*)'Nesting: overwrite 3D' + if(mydebug)write(*,*)'Nest: overwrite 3D' + DO_SPEC: do n= 1, NSPEC_ADV - if(.not.(adv_ic(n)%wanted.and.adv_ic(n)%found)) cycle DO_SPEC - if(MasterProc)then - !Could fetch one level at a time if sizes becomes too big - call check(nf90_inq_varid(ncid=ncFileID, name=trim(adv_ic(n)%varname), varID=varID)) - - call check(nf90_get_var(ncFileID, varID, data & - ,start=(/ 1,1,1,itime /),count=(/ GIMAX_ext,GJMAX_ext,KMAX_ext,1 /) )) - status = nf90_get_att(ncFileID,VarID,"scale_factor",scale_factor) - if(status == nf90_noerr) then - data=data*scale_factor - endif - status = nf90_get_att(ncFileID,VarID,"add_offset",add_offset) - if(status == nf90_noerr) then - data=data+add_offset - endif - if(DEBUG_NEST) print *,'nesting 3D component ',trim(adv_ic(n)%varname) - status = nf90_get_att(ncFileID,VarID,"units",units) - if(status == nf90_noerr) then - if(DEBUG_NEST)write(*,*)'variable '//trim(adv_ic(n)%varname)//' has unit '//trim(units) - if(units(1:3) == 'ppb') then - if(DEBUG_NEST)write(*,*)'which is ppb unit. Scaling by ',PPB - data=data*PPB - else - if(DEBUG_NEST)write(*,*)'which is not recognized as ppb unit. Assuming mixing ratio' - endif - else - if(DEBUG_NEST)write(*,*)'units attribute not found for variable '//trim(adv_bc(n)%varname) - endif - endif - CALL MPI_BCAST(data,8*GIMAX_ext*GJMAX_ext*KMAX_ext,MPI_BYTE,0,MPI_COMM_WORLD,INFO) - + if(.not.(adv_ic(n)%wanted.and.adv_ic(n)%found)) cycle DO_SPEC + if(MasterProc)then + if(DEBUG_NEST) print *,'Nest: 3D component ',trim(adv_ic(n)%varname) + !Could fetch one level at a time if sizes becomes too big + call check(nf90_inq_varid(ncid=ncFileID, name=trim(adv_ic(n)%varname), varID=varID)) + call check(nf90_get_var(ncFileID, varID, data & + ,start=(/ 1,1,1,itime /),count=(/ GIMAX_ext,GJMAX_ext,KMAX_ext,1 /) )) + status = nf90_get_att(ncFileID,VarID,"scale_factor",scale_factor) + if(status==nf90_noerr) data=data*scale_factor + status = nf90_get_att(ncFileID,VarID,"add_offset",add_offset) + if(status==nf90_noerr) data=data+add_offset + status = nf90_get_att(ncFileID,VarID,"units",units) + if(status==nf90_noerr) then + if(DEBUG_NEST)write(*,*)'Nest: variable '//trim(adv_ic(n)%varname)//' has unit '//trim(units) + data=data/Units_Scale(units,n,needroa=divbyroa,debug_msg="reset_3D") + else + if(DEBUG_NEST)write(*,*)'units attribute not found for variable '//trim(adv_ic(n)%varname) + endif + endif + CALL MPI_BCAST(data,8*GIMAX_ext*GJMAX_ext*KMAX_ext,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + !overwrite everything 3D (init) - forall (k=1:KMAX_ext, j=1:ljmax, i=1:limax) & - xn_adv(n,i,j,k)=(Weight(i,j,1)*data(IIij(i,j,1),JJij(i,j,1),k1_ext(k)) & - +Weight(i,j,2)*data(IIij(i,j,2),JJij(i,j,2),k1_ext(k)) & - +Weight(i,j,3)*data(IIij(i,j,3),JJij(i,j,3),k1_ext(k)) & - +Weight(i,j,4)*data(IIij(i,j,4),JJij(i,j,4),k1_ext(k)))*weight_k1(k)& - +(Weight(i,j,1)*data(IIij(i,j,1),JJij(i,j,1),k2_ext(k)) & - +Weight(i,j,2)*data(IIij(i,j,2),JJij(i,j,2),k2_ext(k)) & - +Weight(i,j,3)*data(IIij(i,j,3),JJij(i,j,3),k2_ext(k)) & - +Weight(i,j,4)*data(IIij(i,j,4),JJij(i,j,4),k2_ext(k)))*weight_k2(k) + if(divbyroa)then + forall (k=1:KMAX_MID, j=1:ljmax, i=1:limax) & + xn_adv(n,i,j,k)=(WeightData(i,j,k1_ext(k))*weight_k1(k) & + +WeightData(i,j,k2_ext(k))*weight_k2(k))& + /roa(i,j,k,1) + else + forall (k=1:KMAX_MID, j=1:ljmax, i=1:limax) & + xn_adv(n,i,j,k)=WeightData(i,j,k1_ext(k))*weight_k1(k)& + +WeightData(i,j,k2_ext(k))*weight_k2(k) + endif enddo DO_SPEC deallocate(data) if(MasterProc) call check(nf90_close(ncFileID)) -end subroutine reset_3D - - - - -end module Nest_ml - + contains + PURE function WeightData(i,j,k) result(wsum) + integer, intent(in)::i,j,k + real:: wsum + wsum=dot_product(Weight(i,j,:),& + (/data(IIij(i,j,1),JJij(i,j,1),k),data(IIij(i,j,2),JJij(i,j,2),k),& + data(IIij(i,j,3),JJij(i,j,3),k),data(IIij(i,j,4),JJij(i,j,4),k)/)) + endfunction WeightData +endsubroutine reset_3D + +endmodule Nest_ml +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++! diff --git a/NetCDF_ml.f90 b/NetCDF_ml.f90 index ce6fe52..097b3dc 100644 --- a/NetCDF_ml.f90 +++ b/NetCDF_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -36,15 +36,15 @@ module NetCDF_ml !http://www.unidata.ucar.edu/software/netcdf/ ! ! -!To improve: When output is onto the same file, but with different positions -!for the lower left corner, the coordinates i_EMEP j_EMEP and long lat will +!To improve: When output is onto the same file, but with different positions +!for the lower left corner, the coordinates i_EMEP j_EMEP and long lat will !be wrong ! use My_Outputs_ml, only : FREQ_HOURLY, & NHOURLY_OUT, & ! No. outputs Asc2D, hr_out, & ! Required outputs SELECT_LEVELS_HOURLY, LEVELS_HOURLY, & - NLEVELS_HOURLY + NLEVELS_HOURLY use Chemfields_ml, only : xn_shl,xn_adv use CheckStop_ml, only : CheckStop,StopAll use ChemSpecs_shl_ml, only : NSPEC_SHL @@ -59,10 +59,13 @@ module NetCDF_ml ,glat_fdom,glon_fdom,ref_latitude& ,projection, sigma_mid,gb_stagg,gl_stagg,glon& ,sigma_bnd& - ,glat,lb2ij,A_bnd,B_bnd + ,glat,lb2ij,A_bnd,B_bnd& + ,lb2ij,lb2ijm,ij2lb& + ,ref_latitude_EMEP,xp_EMEP_old,yp_EMEP_old& + ,i_local,j_local use InterpolationRoutines_ml, only : grid2grid_coeff use ModelConstants_ml, only : KMAX_MID,KMAX_BND, runlabel1, runlabel2 & - ,MasterProc & + ,MasterProc, FORECAST, NETCDF_COMPRESS_OUTPUT & ,DEBUG_NETCDF, DEBUG_NETCDF_RF & ,NPROC, IIFULLDOM,JJFULLDOM & ,IOU_INST,IOU_HOUR,IOU_HOUR_MEAN, IOU_YEAR & @@ -88,11 +91,11 @@ module NetCDF_ml character (len=125), save :: fileName_day = 'out_day.nc' character (len=125), save :: fileName_month = 'out_month.nc' character (len=125), save :: fileName_year = 'out_year.nc' - character (len=125) :: fileName ,period_type + character (len=125) :: fileName = 'NotSet' ,period_type !TESTHH integer,parameter ::closedID=-999 !flag for showing that a file is closed - integer :: ncFileID_new=closedID !don't save because should always be - !redefined (in case several routines are using ncFileID_new + integer :: ncFileID_new=closedID !don't save because should always be + !redefined (in case several routines are using ncFileID_new !with different filename_given) integer,save :: ncFileID_inst=closedID integer,save :: ncFileID_hour=closedID @@ -101,7 +104,7 @@ module NetCDF_ml integer,save :: ncFileID_year=closedID integer,save :: outCDFtag=0 !CDF types for output: - integer, public, parameter :: Int1=1,Int2=2,Int4=3,Real4=4,Real8=5 + integer, public, parameter :: Int1=1,Int2=2,Int4=3,Real4=4,Real8=5 character (len=18),parameter::Default_projection_name = 'General_Projection' public :: Out_netCDF @@ -166,7 +169,7 @@ subroutine Init_new_netCDF(fileName,iotyp) enddo GIMAXcdf=min(GIMAXcdf,GIMAX) GJMAXcdf=min(GJMAXcdf,GJMAX) - KMAXcdf =min(KMAXcdf ,NLEVELS_HOURLY) + KMAXcdf =min(KMAXcdf ,NLEVELS_HOURLY) ! Output selected model levels if(SELECT_LEVELS_HOURLY)then @@ -241,8 +244,13 @@ subroutine CreatenetCDFfile(fileName,GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,& if(DEBUG_NETCDF)write(*,*)'UsedProjection ',trim(UsedProjection) if(DEBUG_NETCDF)write(*,fmt='(A,8I7)')'with sizes (IMAX,JMAX,IBEG,JBEG,KMAX) ',& GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,KMAXcdf - call check(nf90_create(path = trim(fileName), & - cmode = nf90_clobber, ncid = ncFileID),"create:"//trim(fileName)) + if(NETCDF_COMPRESS_OUTPUT)then + call check(nf90_create(path = trim(fileName), & + cmode = nf90_hdf5, ncid = ncFileID),"create:"//trim(fileName)) + else + call check(nf90_create(path = trim(fileName), & + cmode = nf90_clobber, ncid = ncFileID),"create:"//trim(fileName)) + endif ! Define the dimensions if(UsedProjection=='Stereographic')then @@ -362,7 +370,7 @@ subroutine CreatenetCDFfile(fileName,GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,& call check(nf90_def_var(ncFileID, "time", nf90_double, dimids = timeDimID, varID = VarID) ) if(trim(period_type) /= 'instant'.and.trim(period_type) /= 'unknown'.and.& - trim(period_type) /= 'hourly' .and.trim(period_type) /= 'fullrun')then + trim(period_type) /= 'hourly' .and.trim(period_type) /= 'fullrun')then call check(nf90_put_att(ncFileID, VarID, "long_name", "time at middle of period")) else call check(nf90_put_att(ncFileID, VarID, "long_name", "time at end of period")) @@ -489,26 +497,30 @@ subroutine CreatenetCDFfile(fileName,GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,& else kcoord(k)=sigma_mid(KMAX_MID-KLEVcdf(k)+1) !1-->20;2-->19;...;20-->1 endif + if(DEBUG_NETCDF) write(*,*) "TESTHH netcdf KLEVcdf ", k, KLEVCDF(k), kcoord(k) enddo elseif(KMAXcdf==KMAX_MID)then do k=1,KMAX_MID kcoord(k)=sigma_mid(k) + if(DEBUG_NETCDF) write(*,*) "TESTHH netcdf no KLEVcdf ", k, kcoord(k) enddo else do k=1,KMAXcdf kcoord(k)=sigma_mid(KMAX_MID-k+1) !REVERSE order of k ! +! write(*,*) "TESTHH netcdf KMAXcdf ", k, kcoord(k) enddo endif call check(nf90_put_var(ncFileID, kVarID, kcoord(1:KMAXcdf)) ) call check(nf90_put_var(ncFileID, PTVarID, PT )) call check(nf90_close(ncFileID)) - if(DEBUG_NETCDF)write(*,*)'NetCDF: file created, end of CreatenetCDFfile' + if(DEBUG_NETCDF)write(*,*)'NetCDF: file created, end of CreatenetCDFfile ',ncFileID end subroutine CreatenetCDFfile + !_______________________________________________________________________ -subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik,fileName_given,overwrite) +subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik,fileName_given,overwrite,create_var_only) !The use of fileName_given is probably slower than the implicit filename used by defining iotyp. @@ -518,13 +530,16 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, integer, intent(in) :: iotyp real ,intent(in) :: scale real, dimension(MAXLIMAX,MAXLJMAX,KMAX), intent(in) :: dat ! Data arrays - integer, optional, intent(in) :: ist,jst,ien,jen,ik !start and end of saved area. + integer, optional, intent(in) :: ist,jst,ien,jen,ik !start and end of saved area. !Only level ik is written if defined integer, optional, intent(in) :: CDFtype != OUTtype. (Integer*1, Integer*2,Integer*4, real*8 or real*4) character (len=*),optional, intent(in):: fileName_given!filename to which the data must be written - logical, optional, intent(in) :: overwrite !overwrite if file already exists (in case fileName_given) !NB if the file fileName_given exist (also from earlier runs) it will be appended + logical, optional, intent(in) :: overwrite !overwrite if file already exists (in case fileName_given) + logical, optional, intent(in) :: create_var_only !only create the variable, without writing the data content + logical:: create_var_only_local !only create the variable, without writing the data content + character(len=len(def1%name)) :: varname character*8 ::lastmodified_date character*10 ::lastmodified_hour,lastmodified_hour0,created_hour @@ -549,13 +564,14 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, if(present(ien))i2=min(ien-IRUNBEG+1,i2) if(present(jst))j1=max(jst-JRUNBEG+1,j1) if(present(jen))j2=min(jen-JRUNBEG+1,j2) - + create_var_only_local=.false. + if(present(create_var_only))create_var_only_local=create_var_only !Check that that the area is larger than 0 if((i2-i1)<0.or.(j2-j1)<0.or.kmax<=0)return - !make variable name + !make variable name write(varname,fmt='(A)')trim(def1%name) - if(DEBUG_NETCDF) write(*,*)'Out_NetCDF: START ' , me, trim(varname) + if(DEBUG_NETCDF.and.MasterProc) write(*,*)'Out_NetCDF: START ',trim(varname) !to shorten the output we can save only the components explicitely named here !if(varname.ne.'D2_NO2'.and.varname.ne.'D2_O3' & @@ -569,10 +585,10 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, !NB if the file already exist (also from earlier runs) it will be appended overwrite_local=.false. if(present(overwrite))overwrite_local=overwrite - if(me==0)then - if(DEBUG_NETCDF) write(*,*)'Out_NetCDF: fileName_given ' , me, trim(fileName_given) + if(MasterProc)then !try to open the file - status=nf90_open(path = trim(fileName_given), mode = nf90_write, ncid = ncFileID) + status=nf90_open(path = trim(fileName_given), mode = nf90_share+nf90_write, ncid = ncFileID) + if(DEBUG_NETCDF) write(*,*)'Out_NetCDF: fileName_given ' , trim(fileName_given),overwrite_local,status == nf90_noerr, ncfileID,trim(nf90_strerror(status)) ISMBEGcdf=IRUNBEG+i1-1 JSMBEGcdf=JRUNBEG+j1-1 GIMAXcdf=i2-i1+1 @@ -613,11 +629,11 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, ncFileID_new=ncFileID endif - if(DEBUG_NETCDF) then + if(DEBUG_NETCDF.and.MasterProc) then if(iotyp_new==1)then - write(*,*)' Out_NetCDF: cases new ', trim(fileName_given), iotyp + write(*,*)' Out_NetCDF: cases new file', trim(fileName_given), iotyp else - write(*,*)' Out_NetCDF: cases old ', trim(fileName), iotyp + write(*,*)' Out_NetCDF: cases old file', trim(fileName), iotyp end if endif @@ -642,13 +658,63 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, else return endif - if(DEBUG_NETCDF) write(*,*)'Out_NetCDF, filename ', trim(fileName), iotyp + if(DEBUG_NETCDF.and.MasterProc) write(*,*)'Out_NetCDF, filename ', trim(fileName), iotyp,ncFileID call CheckStop(ndim /= 2 .and. ndim /= 3, "NetCDF_ml: ndim must be 2 or 3") + OUTtype=Real4 !default value if(present(CDFtype))OUTtype=CDFtype + if(MasterProc)then + + ndate(1) = current_date%year + ndate(2) = current_date%month + ndate(3) = current_date%day + ndate(4) = current_date%hour + + !test if the file is already open + if(ncFileID==closedID)then + !open an existing netcdf dataset + call check(nf90_open(path = trim(fileName), mode = nf90_write, & + ncid = ncFileID), "nf90_open"//trim(fileName) ) + if(iotyp_new==1)then !needed in case iotyp is defined + ncFileID_new = ncFileID!not really needed + elseif(iotyp==IOU_YEAR)then + ncFileID_year = ncFileID + elseif(iotyp==IOU_MON)then + ncFileID_month = ncFileID + elseif(iotyp==IOU_DAY)then + ncFileID_day = ncFileID + elseif(iotyp==IOU_HOUR)then + ncFileID_hour = ncFileID + elseif(iotyp==IOU_INST)then + ncFileID_inst = ncFileID + endif + endif + + !test first if the variable is already defined: + status = nf90_inq_varid(ncid = ncFileID, name = varname, varID = VarID) + + if(status == nf90_noerr) then +! print *, 'variable exists: ',varname + if (DEBUG_NETCDF) write(6,*) 'Out_NetCDF: variable exists: ',varname + else + if (DEBUG_NETCDF) write(6,*) 'Out_NetCDF: creating variable: ',varname + call createnewvariable(ncFileID,varname,ndim,ndate,def1,OUTtype) + endif + endif!MasterProc + + if(create_var_only_local)then + !Don't write the data + !For performance: need to create all variables before writing data + if(DEBUG_NETCDF.and.MasterProc)write(*,*)'variable ONLY created. Finished' + if(MasterProc.and.iotyp_new==1)call check(nf90_close(ncFileID)) + return + endif!create var only + + + !buffer the wanted part of data ijk=0 do k=1,kmax @@ -755,44 +821,13 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, endif !return - if(me==0)then + if(MasterProc)then ndate(1) = current_date%year ndate(2) = current_date%month ndate(3) = current_date%day ndate(4) = current_date%hour - !test if the file is already open - if(ncFileID==closedID)then - !open an existing netcdf dataset - call check(nf90_open(path = trim(fileName), mode = nf90_write, & - ncid = ncFileID), "nf90_open"//trim(fileName) ) - if(iotyp_new==1)then !needed in case iotyp is defined - ncFileID_new = ncFileID!not really needed - elseif(iotyp==IOU_YEAR)then - ncFileID_year = ncFileID - elseif(iotyp==IOU_MON)then - ncFileID_month = ncFileID - elseif(iotyp==IOU_DAY)then - ncFileID_day = ncFileID - elseif(iotyp==IOU_HOUR)then - ncFileID_hour = ncFileID - elseif(iotyp==IOU_INST)then - ncFileID_inst = ncFileID - endif - endif - - !test first if the variable is already defined: - status = nf90_inq_varid(ncid = ncFileID, name = varname, varID = VarID) - - if(status == nf90_noerr) then -! print *, 'variable exists: ',varname - if (DEBUG_NETCDF) write(6,*) 'Out_NetCDF: variable exists: ',varname - else - if (DEBUG_NETCDF) write(6,*) 'Out_NetCDF: creating variable: ',varname - call createnewvariable(ncFileID,varname,ndim,ndate,def1,OUTtype) - endif - !get variable id call check(nf90_inq_varid(ncid = ncFileID, name = varname, varID = VarID)) @@ -826,10 +861,8 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, call check(nf90_put_var(ncFileID, VarID, & Idata3D(i1:i2, j1:j2, 1), start = (/ 1, 1, ik,nrecords /)) ) else - do k=1,kmax call check(nf90_put_var(ncFileID, VarID,& - Idata3D(i1:i2, j1:j2, k), start = (/ 1, 1, k,nrecords /)) ) - enddo + Idata3D(i1:i2, j1:j2, 1:kmax), start = (/ 1, 1, 1,nrecords /)) ) endif else call check(nf90_put_var(ncFileID, VarID,& @@ -847,10 +880,8 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, call check(nf90_put_var(ncFileID, VarID, & R4data3D(i1:i2, j1:j2, 1), start = (/ 1, 1, ik,nrecords /)) ) else - do k=1,kmax - call check(nf90_put_var(ncFileID, VarID,& - R4data3D(i1:i2, j1:j2, k), start = (/ 1, 1, k,nrecords /)) ) - enddo + call check(nf90_put_var(ncFileID, VarID,& + R4data3D(i1:i2, j1:j2, 1:kmax), start = (/ 1, 1, 1,nrecords /)) ) endif else call check(nf90_put_var(ncFileID, VarID,& @@ -868,10 +899,8 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, call check(nf90_put_var(ncFileID, VarID, & R8data3D(i1:i2, j1:j2, 1), start = (/ 1, 1, ik,nrecords /)) ) else - do k=1,kmax - call check(nf90_put_var(ncFileID, VarID,& - R8data3D(i1:i2, j1:j2, k), start = (/ 1, 1, k,nrecords /)) ) - enddo + call check(nf90_put_var(ncFileID, VarID,& + R8data3D(i1:i2, j1:j2, 1:kmax), start = (/ 1, 1, 1,nrecords /)) ) endif else call check(nf90_put_var(ncFileID, VarID,& @@ -907,7 +936,7 @@ subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik, endif endif !me=0 - if(DEBUG_NETCDF) write(*,*)'Out_NetCDF: FINISHED ' + if(DEBUG_NETCDF.and.MasterProc) write(*,*)'Out_NetCDF: FINISHED ' end subroutine Out_netCDF !_______________________________________________________________________ @@ -929,6 +958,7 @@ subroutine createnewvariable(ncFileID,varname,ndim,ndate,def1,OUTtype) real :: scale integer :: OUTtypeCDF !NetCDF code for type + if(OUTtype==Int1)then OUTtypeCDF=nf90_byte elseif(OUTtype==Int2)then @@ -967,6 +997,9 @@ subroutine createnewvariable(ncFileID,varname,ndim,ndate,def1,OUTtype) else print *, 'createnewvariable: unexpected ndim ',ndim endif +!define variable as to be compressed + if(NETCDF_COMPRESS_OUTPUT) & + call check(nf90_def_var_deflate(ncFileid ,varID,shuffle=0,deflate=1 ,deflate_level=4) ) ! FillValue=0. scale=1. !define attributes of new variable @@ -1007,61 +1040,47 @@ subroutine createnewvariable(ncFileID,varname,ndim,ndate,def1,OUTtype) call check(nf90_put_att(ncFileID, varID, "current_date_last",ndate )) call check(nf90_enddef(ncid = ncFileID)) +! call check(nf_enddef(ncFileID)) end subroutine createnewvariable !_______________________________________________________________________ - subroutine check(status,errmsg) - implicit none - integer, intent ( in) :: status - character(len=*), intent(in), optional :: errmsg +subroutine check(status,errmsg) + implicit none + integer, intent ( in) :: status + character(len=*), intent(in), optional :: errmsg - if(status /= nf90_noerr) then - print *, trim(nf90_strerror(status)) - if( present(errmsg) ) print *, "ERRMSG: ", trim(errmsg) - call CheckStop("NetCDF_ml : error in netcdf routine") - end if - end subroutine check + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + if(present(errmsg)) print *, "ERRMSG: ", trim(errmsg) + call CheckStop("NetCDF_ml : error in netcdf routine") + endif +endsubroutine check - subroutine CloseNetCDF +subroutine CloseNetCDF !close open files -!NB the data in a NetCDF file is not "safe" before the file is closed. +!NB the data in a NetCDF file is not "safe" before the file is closed. !The files are NOT automatically properly closed after end of program, ! and data may be lost if the files are not closed explicitely. -integer :: ncFileID - -outCDFtag=0 !for avoiding too large integers - -if(me==0)then - - if(ncFileID_year/=closedID)then - ncFileID = ncFileID_year - call check(nf90_close(ncFileID)) - ncFileID_year=closedID - endif - if(ncFileID_month/=closedID)then - ncFileID = ncFileID_month - call check(nf90_close(ncFileID)) - ncFileID_month=closedID - endif - if(ncFileID_day/=closedID)then - ncFileID = ncFileID_day - call check(nf90_close(ncFileID)) - ncFileID_day=closedID - endif - if(ncFileID_hour/=closedID)then - ncFileID = ncFileID_hour - call check(nf90_close(ncFileID)) - ncFileID_hour=closedID - endif - if(ncFileID_inst/=closedID)then - ncFileID = ncFileID_inst - call check(nf90_close(ncFileID)) - ncFileID_inst=closedID - endif -endif -end subroutine CloseNetCDF + if(MasterProc)then + call CloseNC(ncFileID_year) + call CloseNC(ncFileID_month) + call CloseNC(ncFileID_day) + call CloseNC(ncFileID_hour) + call CloseNC(ncFileID_inst) + endif + contains + subroutine CloseNC(ncID) + integer, intent(inout) :: ncID + integer :: ncFileID + + if(ncID==closedID)return + ncFileID = ncID + call check(nf90_close(ncFileID)) + ncID=closedID + end subroutine CloseNC +endsubroutine CloseNetCDF subroutine GetCDF(varname,fileName,Rvar,varGIMAX,varGJMAX,varKMAX,nstart,nfetch,needed) ! @@ -1090,7 +1109,7 @@ subroutine GetCDF(varname,fileName,Rvar,varGIMAX,varGJMAX,varKMAX,nstart,nfetch, real :: scale,offset,scalefactors(2) integer, allocatable:: Ivalues(:) - if(me==0.and.DEBUG_NETCDF)print *,'GetCDF reading ',trim(fileName), ' nstart ', nstart + if(MasterProc.and.DEBUG_NETCDF)print *,'GetCDF reading ',trim(fileName), ' nstart ', nstart !open an existing netcdf dataset fileneeded=.true.!default if(present(needed))then @@ -1118,7 +1137,7 @@ subroutine GetCDF(varname,fileName,Rvar,varGIMAX,varGJMAX,varKMAX,nstart,nfetch, status = nf90_inq_varid(ncid = ncFileID, name = varname, varID = VarID) if(status == nf90_noerr) then - if(DEBUG_NETCDF)print *, 'variable exists: ',trim(varname) + if(DEBUG_NETCDF)write(*,*) 'variable exists: ',trim(varname) else print *, 'variable does not exist: ',trim(varname),nf90_strerror(status) nfetch=0 @@ -1178,6 +1197,8 @@ subroutine GetCDF(varname,fileName,Rvar,varGIMAX,varGJMAX,varKMAX,nstart,nfetch, deallocate(Ivalues) elseif(xtype==NF90_FLOAT .or. xtype==NF90_DOUBLE)then call check(nf90_get_var(ncFileID, VarID, Rvar,start=startvec,count=dims)) + if(DEBUG_NETCDF) & + write(*,*)'datatype real, read', me, maxval(Rvar), minval(Rvar) else write(*,*)'datatype not yet supported'!Char Call StopAll('GetCDF datatype not yet supported') @@ -1250,7 +1271,7 @@ subroutine WriteCDF(varname,vardate,filename_given,newfile) ndim=3 !3-dimensional kmax=KMAX_MID - if(NSPEC_SHL+ NSPEC_ADV /= NSPEC_TOT.and. me==0)then + if(NSPEC_SHL+ NSPEC_ADV /= NSPEC_TOT.and. MasterProc)then write(*,*)'WARNING: NSPEC_SHL+ NSPEC_ADV /= NSPEC_TOT' write(*,*) NSPEC_SHL,NSPEC_ADV, NSPEC_TOT write(*,*)'WRITING ONLY SHL and ADV' @@ -1289,7 +1310,7 @@ subroutine WriteCDF(varname,vardate,filename_given,newfile) else - if(me==0)write(*,*)'case not implemented' + if(MasterProc)write(*,*)'case not implemented' endif @@ -1299,7 +1320,7 @@ subroutine Read_Inter_CDF(fileName,varname,Rvar,varGIMAX,varGJMAX,varKMAX,nstart ! !reads data from netcdf file and interpolates data into full-domain model grid ! -!the data in filename must have global coverage and lat-lon projection +!the data in filename must have global coverage and lat-lon projection ! !Typical use: Master node reads the data with this routine and distributes the data to all subdomains. ! @@ -1531,6 +1552,7 @@ end subroutine Read_Inter_CDF recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,interpol, & known_projection, &! can be provided by user, eg. for MEGAN. + fractions_out,CC_out,Ncc_out,&! additional output for emissions given with country-codes needed,debug_flag,UnDef) ! !reads data from netcdf file and interpolates data into model local (subdomain) grid @@ -1543,39 +1565,49 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte ! !undefined field values: !Some data can be missing/not defined for some gridpoints; - !If Undef is present, it is used as value for these undefined gridpoints; + !If general projection is used (not lon lat or polarstereo), it takes the nearest value. + !If Undef is present, it is used as value for undefined gridpoints; !If it is not present, an error occurs if data is missing. !Data can be undefined either because it is outside the domain in the netcdf file, - !or because it has the value defined in "FillValue" ("FillValue" defined from netcdf file) + !or because it has the value defined in "FillValue" ("FillValue" defined from netcdf file) ! !projections: !Lon-lat projection in the netcdf file is implemented with most functionalities. - !General projection in the netcdf file is still primitive. Limitations are: no 3D, + !General projection in the netcdf file is still primitive. Limitations are: no 3D, ! no Undef, only linear interpolation, cpu expensive. - !The netcdf file projection is defined by user in "known_projection" or read from + !The netcdf file projection is defined by user in "known_projection" or read from !netcdf file (in attribute "projection"). - !If the model grid projection is not lon-lat and not stereographic the method is not + !If the model grid projection is not lon-lat and not stereographic the method is not !very CPU efficient in th epresent version. !Vertical interpolation is not implemented, except from "Fligh Levels", but !"Flight Levels" are so specific that we will probably move them in an own routine !interpolation: - !'zero_order' gives value at closest gridcell. Probably good enough for most applications. + !'zero_order' gives value at closest gridcell. Probably good enough for most applications. !Does not smooth out values - !'conservative' and 'mass_conservative' give smoother fields and are approximatively - !integral conservative (integral over a region is conserved). The initial gridcells + !'conservative' and 'mass_conservative' give smoother fields and are approximatively + !integral conservative (integral over a region is conserved). The initial gridcells !are subdivided into smaller subcells and each subcell is assigned to a cell in the model grid - !'conservative' can be used for emissions given in kg/m2 (or kg/m2/s) or landuse or most fields. + !'conservative' can be used for emissions given in kg/m2 (or kg/m2/s) or landuse or most fields. !The value in the netcdf file and in model gridcell are of the similar. - !'mass_conservative' can be used for emissions in kg (or kg/s). If the gricell in the model are + !'mass_conservative' can be used for emissions in kg (or kg/s). If the gricell in the model are !twice as small as the gridcell in the netcdf file, the values will also be reduced by a factor 2. + !Emissions with country-codes: (July 2012, under development) + !Emissions are given in each gridcell with: + !1) Total (Rvar) + !2) Number of country-codes (Ncc_out) + !3) Country codes (CC_out) + !4) fraction assigned to each country (fractions_out) + !Presently only lat-lon projection of input file supported + !negative data not finished/tested (can give 0 totals, definition of fractions?) + !Technical, future developements: - !This routine is likely to change a lot in the future: can be divided into simpler routines; + !This routine is likely to change a lot in the future: should be divided into simpler routines; !more functionalities will be introduced. !Should also be usable as standalone. - !All MPI processes read the same file simultaneously (i.e. in parallel). + !All MPI processes read the same file simultaneously (i.e. in parallel). !They read only the chunk of data they need for themselves. use netcdf @@ -1591,11 +1623,15 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte integer, optional,intent(in) :: kend!largest k to read. Default: assume 2D field logical, optional, intent(in) :: debug_flag real, optional, intent(in) :: UnDef ! Value put into the undefined gridcells - logical, save :: debug_ij + real , optional, intent(out) ::fractions_out(MAXLIMAX*MAXLJMAX,*) !fraction assigned to each country + integer, optional, intent(out) ::Ncc_out(*), CC_out(MAXLIMAX*MAXLJMAX,*) !Number of country-codes and Country codes + logical, save :: debug_ij + logical ::fractions integer :: ncFileID,VarID,lonVarID,latVarID,status,xtype,ndims,dimids(NF90_MAX_VAR_DIMS),nAtts - integer :: dims(NF90_MAX_VAR_DIMS),totsize,i,j,k - integer :: startvec(NF90_MAX_VAR_DIMS) + integer :: VarIDCC,VarIDNCC,VarIDfrac,NdimID + integer :: dims(NF90_MAX_VAR_DIMS),NCdims(NF90_MAX_VAR_DIMS),totsize,i,j,k + integer :: startvec(NF90_MAX_VAR_DIMS),Nstartvec(NF90_MAX_VAR_DIMS) integer ::alloc_err character*100 ::name real :: scale,offset,scalefactors(2),dloni,dlati @@ -1621,7 +1657,13 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte real, dimension(4) :: Weight real :: sumWeights integer, dimension(4) :: ijkn - integer :: ii, jj + integer :: ii, jj,i_ext,j_ext + real::an_ext,xp_ext,yp_ext,fi_ext,ref_lat_ext,xp_ext_div,yp_ext_div,Grid_resolution_div,an_ext_div + real ::buffer1(MAXLIMAX, MAXLJMAX),buffer2(MAXLIMAX, MAXLJMAX) + real, allocatable ::fraction_in(:,:) + integer, allocatable ::CC(:,:),Ncc(:) + real ::total + integer ::N_out,Ng,Nmax !_______________________________________________________________________________ ! @@ -1662,7 +1704,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte interpol_used/='conservative'.and.& interpol_used/='mass_conservative',& 'interpolation method not recognized') - if ( debug ) write(*,*) 'ReadCDF interp set: ',trim(filename),':', trim(interpol) + if ( debug ) write(*,*) 'ReadCDFstereo interp set: ',trim(filename),':', trim(interpol) !test if the variable is defined and get varID: @@ -1732,7 +1774,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte if(trim(data_projection)=="lon lat")then ! here we have simple 1-D lat, lon allocate(Rlon(dims(1)), stat=alloc_err) allocate(Rlat(dims(2)), stat=alloc_err) - if ( debug ) write(*,"(a,a,i5,i5,a,i5)") 'alloc lon lat ',& + if ( debug ) write(*,"(a,a,i5,i5,a,i5)") 'alloc_err lon lat ',& trim(data_projection), alloc_err, dims(1), "x", dims(2) else allocate(Rlon(dims(1)*dims(2)), stat=alloc_err) @@ -1762,6 +1804,8 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte Flight_Levels=.false. + + if ( debug .and. filename == "DegreeDayFac.nc" ) print *, 'ABCD2 got to here' !_______________________________________________________________________________ ! !2) Coordinates conversion and interpolation @@ -1798,7 +1842,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte call ReadField_CDF('SurfacePressure.nc','surface_pressure',& Psurf_ref,current_date%month,needed=.true.,interpol='zero_order',debug_flag=debug_flag) else - call CheckStop(trim(name)/='k',"vertical coordinate k not found") + call CheckStop(trim(name)/='k'.and.trim(name)/='N',"vertical coordinate (k or N) not found") endif endif @@ -1809,6 +1853,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte dlati=1.0/(Rlat(2)-Rlat(1)) Grid_resolution = EARTH_RADIUS*360.0/dims(1)*PI/180.0 + if ( debug .and. filename == "DegreeDayFac.nc" ) print *, 'ABCD3 got to here' !the method chosen depends on the relative resolutions if(.not.present(interpol).and.Grid_resolution/GRIDWIDTH_M>4)then @@ -1819,8 +1864,8 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte !Find chunk of data required (local) maxlon=max(maxval(gl_stagg),maxval(glon)) minlon=min(minval(gl_stagg),minval(glon)) - maxlat=maxval(gb_stagg) - minlat=minval(gb_stagg) + maxlat=max(maxval(gb_stagg),maxval(glat)) + minlat=min(minval(gb_stagg),minval(glat)) if(debug) then write(*,*) "SET Grid resolution:" // trim(fileName), Grid_resolution @@ -1851,7 +1896,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte jmax=max(1,min(dims(2),ceiling((maxlat-Rlat(1))*dlati)+1)) else!if starting to count from north pole jmin=max(1,min(dims(2),floor((maxlat-Rlat(1))*dlati)))!maxlat is closest to Rlat(1) - jmax=max(1,min(dims(2),ceiling((minlat-Rlat(1))*dlati)+1)) + jmax=max(1,min(dims(2),ceiling((minlat-Rlat(1))*dlati)+1)) endif @@ -1908,6 +1953,64 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte call check(nf90_get_var(ncFileID, VarID, Rvalues,start=startvec,count=dims),& errmsg="RRvalues") +!test if this is "fractions" type data + fractions=.false. + if(present(fractions_out).or.present(CC_out).or.present(Ncc_out))then + if ( debug ) write(*,*) 'ReadField_CDF, fraction arrays ' + if(.not.(present(fractions_out).and.present(CC_out).and.present(Ncc_out)))then + write(*,*) 'Fraction interpolation missing some arrays of arrays fractions_out CC_out Ncc_out',& + present(fractions_out),present(CC_out),present(Ncc_out) + end if + fractions=.true. + end if + if(fractions)then + if ( debug ) write(*,*) 'fractions method. reading data ' + Nstartvec=startvec!set 2 first dimensions + Nstartvec(3)=1 + NCdims=dims!set 2 first dimensions + !find size of dimension for N (max number of countries per gridcell) + call check(nf90_inq_dimid(ncid = ncFileID, name = "N", dimID = NdimID)) + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=NdimID,len=Nmax)) + NCdims(3)=Nmax + + allocate(NCC(dims(1)*dims(2)), stat=alloc_err) + allocate(CC(dims(1)*dims(2),Nmax), stat=alloc_err) + allocate(fraction_in(dims(1)*dims(2),Nmax), stat=alloc_err) + + call check(nf90_inq_varid(ncid = ncFileID, name = 'NCodes', varID = VarIDNCC),& + errmsg="NCodes not found") + + call check(nf90_get_var(ncFileID, VarIDNCC,NCC ,start=startvec,count=dims),& + errmsg="Nvalues") + + call check(nf90_inq_varid(ncid = ncFileID, name = 'Codes', varID = VarIDCC),& + errmsg="Codes not found") + call check(nf90_get_var(ncFileID, VarIDCC,CC ,start=Nstartvec,count=NCdims),& + errmsg="CCvalues") + + call check(nf90_inq_varid(ncid = ncFileID, name = 'fractions_'//trim(varname), varID = VarIDfrac),& + errmsg="fractions not found") + call check(nf90_get_var(ncFileID, VarIDfrac,fraction_in ,start=Nstartvec,count=NCdims),& + errmsg="fractions") + + if( debug )then +! write(*,*)'More than 2 countries:' +! do i=1,dims(1)*dims(2) +! if(NCC(i)>2)write(*,77)me,i,NCC(i),CC(i,1),fraction_in(i,1),CC(i,NCC(i)),fraction_in(i,NCC(i)) + 77 format(3I7,2(I5,F6.3)) +! enddo + endif + + Ncc_out(1:MAXLIMAX*MAXLJMAX)=0 + CC_out(1:MAXLIMAX*MAXLJMAX,1:Nmax)=0 + fractions_out(1:MAXLIMAX*MAXLJMAX,1)=0.0 + fractions_out(1:MAXLIMAX*MAXLJMAX,2:Nmax)=0.0 + endif + + + if ( DEBUG_NETCDF_RF ) write(*,*) 'ReadCDF types ', & + xtype, NF90_INT, NF90_SHORT, NF90_BYTE + if(xtype==NF90_INT.or.xtype==NF90_SHORT.or.xtype==NF90_BYTE)then !scale data if it is packed scalefactors(1) = 1.0 !default @@ -1952,11 +2055,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte do ij=1,MAXLIMAX*MAXLJMAX*k2 Ivalues(ij)=0 NValues(ij) = 0 - if(present(UnDef))then - Rvar(ij)=UnDef!default value - else - Rvar(ij)=0.0 - endif + Rvar(ij)=0.0 enddo do jg=1,dims(2) @@ -1980,7 +2079,42 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte Nvalues(ijk)=Nvalues(ijk)+1 igjgk=igjg+(k-1)*dims(1)*dims(2) - if(OnlyDefinedValues.or.Rvalues(igjgk)/=FillValue)then + if(fractions)then + do Ng=1,Ncc(igjgk)!number of fields at igjg as read + do N_out=1,Ncc_out(ijk) !number of fields at ij already saved in the model grid + if(CC(igjgk,Ng)==CC_out(ijk,N_out))goto 731 + enddo + !the country is not yet used for this gridcell. Define it now + Ncc_out(ijk)=Ncc_out(ijk)+1 + N_out=Ncc_out(ijk) + CC_out(ijk, N_out)=CC(igjgk,Ng) + fractions_out(ijk,N_out)=0.0 +731 continue + !update fractions + total=Rvar(ijk)+Rvalues(igjgk)*fraction_in(igjgk,Ng) + if(debug.and.fraction_in(igjgk,Ng)>1.001)then + write(*,*)'fractions_in TOO LARGE ',Ng,ig,jg,k,fraction_in(igjgk,Ng) + stop + endif + if(abs(total)>1.0E-30)then + do N=1,Ncc_out(ijk) + !reduce previously defined fractions + fractions_out(ijk,N)=fractions_out(ijk,N)*Rvar(ijk)/total + enddo + !increase fraction of this country (yes, after having reduced it!) + fractions_out(ijk,N_out)=fractions_out(ijk,N_out)+Rvalues(igjgk)*fraction_in(igjgk,Ng)/total + else + !should try to keep proportions right in case cancellation of positive an negative; not finished! + do N=1,Ncc_out(ijk) + !reduce existing fractions + fractions_out(ijk,N)=fractions_out(ijk,N)/Ncc_out(ijk) + enddo + !increase fraction of this country (yes, after having reduced it!) + fractions_out(ijk,N_out)=fractions_out(ijk,N_out)+Rvalues(igjgk)*fraction_in(igjgk,Ng)/Ncc_out(ijk) + endif + Rvar(ijk)=total + enddo + elseif(OnlyDefinedValues.or.Rvalues(igjgk)/=FillValue)then Rvar(ijk)=Rvar(ijk)+Rvalues(igjgk) else !Not defined: don't include this Rvalue @@ -2025,6 +2159,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte enddo enddo enddo + k2=1 if(data3D)k2=kend-kstart+1 do k=1,k2 @@ -2035,13 +2170,18 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte debug_ij = ( DEBUG_NETCDF_RF .and. debug_proc .and. & i== debug_li .and. j== debug_lj ) - if ( debug_ij ) write(*,*) 'DEBUG -- INValues!' , Ivalues(ijk), Nvalues(ijk) + if ( debug_ij ) write(*,"(a,9i5)") 'DEBUG -- INValues!',& + Ivalues(ijk), Nvalues(ijk), me, i,j,k if(Ivalues(ijk)<=0.)then if( .not.present(UnDef))then - write(*,*)'ERROR. no values found!', trim(fileName), & + write(*,"(a,a,4i4,6g10.3,i6)") & + 'ERROR, NetCDF_ml no values found!', & + trim(fileName) // ":" // trim(varname), & i,j,k,me,maxlon,minlon,maxlat,minlat,glon(i,j),glat(i,j), & Ivalues(ijk) call CheckStop("Interpolation error") + else + Rvar(ijk)=UnDef endif else if(interpol_used=='mass_conservative')then @@ -2093,7 +2233,262 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte endif !_________________________________________________________________________________________________________ !_________________________________________________________________________________________________________ - else ! data_projection)/="lon lat" + elseif(data_projection=="Stereographic")then + !we assume that data is originally in Polar Stereographic projection + if(MasterProc.and.debug)write(*,*)'interpolating from ', trim(data_projection),' to ',trim(projection) + + !get coordinates + !check that there are dimensions called i and j + call check(nf90_inquire_dimension(ncid = ncFileID, dimID = dimids(1), name=name ),name) + call CheckStop(trim(name)/='i',"i not found") + call check(nf90_inquire_dimension(ncid = ncFileID, dimID = dimids(2), name=name ),name) + call CheckStop(trim(name)/='j',"j not found") + + call CheckStop(data3D,"3D data in Stereographic projection not yet implemented") + + status=nf90_get_att(ncFileID, nf90_global, "Grid_resolution", Grid_resolution ) + if(status /= nf90_noerr)then + Grid_resolution=GRIDWIDTH_M_EMEP + if ( debug )write(*,*)'Grid_resolution assumed =',Grid_resolution + endif + status = nf90_get_att(ncFileID, nf90_global, "xcoordinate_NorthPole", xp_ext ) + if(status /= nf90_noerr)then + xp_ext=xp_EMEP_old + if ( debug )write(*,*)'xcoordinate_NorthPole assumed =',xp_ext + endif + status=nf90_get_att(ncFileID, nf90_global, "ycoordinate_NorthPole", yp_ext ) + if(status /= nf90_noerr)then + yp_ext=yp_EMEP_old + if ( debug )write(*,*)'ycoordinate_NorthPole assumed =',yp_ext + endif + status=nf90_get_att(ncFileID, nf90_global, "fi", fi_ext ) + if(status /= nf90_noerr)then + fi_ext=fi_EMEP + if ( debug )write(*,*)'fi assumed =',fi_ext + endif + status=nf90_get_att(ncFileID, nf90_global, "ref_latitude", ref_lat_ext ) + if(status /= nf90_noerr)then + ref_lat_ext=ref_latitude_EMEP + if ( debug )write(*,*)'ref_latitude assumed =',ref_lat_ext + endif + an_ext=EARTH_RADIUS*(1.0+sin(ref_lat_ext*PI/180.0))/Grid_resolution + +!read entire grid in a first implementation + startvec=1 + totsize=1 + + do i=1,ndims + totsize=totsize*dims(i) + enddo + if ( debug )write(*,*)'totsize ',totsize,ndims + allocate(Rvalues(totsize), stat=alloc_err) + call check(nf90_get_var(ncFileID, VarID, Rvalues,start=startvec,count=dims),& + errmsg="RRvaluesStereo") + if(xtype==NF90_INT.or.xtype==NF90_SHORT.or.xtype==NF90_BYTE)then + !scale data if it is packed + scalefactors(1) = 1.0 !default + scalefactors(2) = 0. !default + status = nf90_get_att(ncFileID, VarID, "scale_factor", scale ) + if(status == nf90_noerr) scalefactors(1) = scale + status = nf90_get_att(ncFileID, VarID, "add_offset", offset ) + if(status == nf90_noerr) scalefactors(2) = offset + Rvalues=Rvalues*scalefactors(1)+scalefactors(2) + FillValue=FillValue*scalefactors(1)+scalefactors(2) + if ( debug ) then + write(*,*)' Start scaling mpixtype',xtype + write(*,*)' FillValue scaled to',FillValue + write(*,*)' Max(RValues) ',maxval(RValues) + end if + else ! Real + if ( debug ) then + write(*,*)' xtype real ',xtype + write(*,*)' FillValue still',FillValue + write(*,*)' Max(RValues) ',maxval(RValues) + write(*,*)' Min(RValues) ',minval(RValues) + end if + endif + + if(interpol_used=='conservative'.or.interpol_used=='mass_conservative')then + !conserves integral (almost, does not take into account local differences in mapping factor) + !takes weighted average over gridcells covered by model gridcell + + !divide the external grid into pieces significantly smaller than the fine grid + !Divide each global gridcell into Ndiv x Ndiv pieces + Ndiv=1!5*nint(Grid_resolution/GRIDWIDTH_M) + Ndiv=max(1,Ndiv) + Ndiv2=Ndiv*Ndiv + Grid_resolution_div=Grid_resolution/Ndiv + xp_ext_div=(xp_ext+0.5)*Ndiv-0.5 + yp_ext_div=(yp_ext+0.5)*Ndiv-0.5 + an_ext_div=an_ext*Ndiv + + if(projection/='Stereographic'.and.projection/='lon lat'.and.projection=='Rotated_Spherical')then + !the method should be revised or used only occasionally + if(me==0)write(*,*)'WARNING: interpolation method may be CPU demanding' + endif + k2=1 + if(data3D)k2=kend-kstart+1 + allocate(Ivalues(MAXLIMAX*MAXLJMAX*k2)) + allocate(Nvalues(MAXLIMAX*MAXLJMAX*k2)) + do ij=1,MAXLIMAX*MAXLJMAX*k2 + Ivalues(ij)=0 + NValues(ij) = 0 +! if(present(UnDef))then +! Rvar(ij)=UnDef!default value +! else + Rvar(ij)=0.0 +! endif + enddo + + do jg=1,dims(2) + do jdiv=1,Ndiv + j_ext=(jg-1)*Ndiv+jdiv + do ig=1,dims(1) + igjg=ig+(jg-1)*dims(1) + do idiv=1,Ndiv + i_ext=(ig-1)*Ndiv+idiv + call ij2lb(i_ext,j_ext,lon,lat,fi_ext,an_ext_div,xp_ext_div,yp_ext_div) + call lb2ij(lon,lat,ir,jr)!back to model (fulldomain) coordinates + !convert from fulldomain to local domain + !ir,jr may be any integer, therefore should not use i_local array + i=nint(ir)-gi0-IRUNBEG+2 + j=nint(jr)-gj0-JRUNBEG+2 + +83 format(2I4,33F9.2) + !if ( debug .and.me==0) write(*,83)i,j,ir,jr,lon,lat,fi_ext,an_ext_div,xp_ext_div,yp_ext_div,fi,xp,yp,Rvalues(igjg) + + if(i>=1.and.i<=limax.and.j>=1.and.j<=ljmax)then + ij=i+(j-1)*MAXLIMAX + k2=1 + if(data3D)k2=kend-kstart+1 + do k=1,k2 + ijk=k+(ij-1)*k2 + Ivalues(ijk)=Ivalues(ijk)+1 + Nvalues(ijk)=Nvalues(ijk)+1 + igjgk=igjg+(k-1)*dims(1)*dims(2) + + if(OnlyDefinedValues.or.Rvalues(igjgk)/=FillValue)then + Rvar(ijk)=Rvar(ijk)+Rvalues(igjgk) + else + !Not defined: don't include this Rvalue + Ivalues(ijk)=Ivalues(ijk)-1 + + endif + enddo + endif + enddo + enddo + enddo + enddo + k2=1 + if(data3D)k2=kend-kstart+1 + do k=1,k2 + do i=1,limax + do j=1,ljmax + ij=i+(j-1)*MAXLIMAX + ijk=k+(ij-1)*k2 + + debug_ij = ( DEBUG_NETCDF_RF .and. debug_proc .and. & + i== debug_li .and. j== debug_lj ) + if ( debug_ij ) write(*,*) 'DEBUG -- INValues!', & + Ivalues(ijk), Nvalues(ijk) + if(Ivalues(ijk)<=0.)then + if( .not.present(UnDef))then + write(*,"(a,a,4i4,6g10.3,i6)") & + 'ERROR, NetCDF_ml no values found!', & + trim(fileName) // ":" // trim(varname), & + i,j,k,me,maxlon,minlon,maxlat,minlat,glon(i,j),glat(i,j), & + Ivalues(ijk) + call CheckStop("Interpolation error") + else + Rvar(ijk)=UnDef + endif + else + if(interpol_used=='mass_conservative')then + !used for example for emissions in kg (or kg/s) + Rvar(ijk)=Rvar(ijk)/Ndiv2! Total sum of values from all cells is constant + if ( debug_ij ) write(*,"(a,a,3i5,es12.4)") 'DEBUG -- mass!' , & + trim(varname), Ivalues(ijk), Nvalues(ijk), Ndiv2, Rvar(ijk) + else + !used for example for emissions in kg/m2 (or kg/m2/s) + ! integral is approximately conserved + Rvar(ijk)=Rvar(ijk)/Ivalues(ijk) + if ( debug_ij ) write(*,"(a,a,3i5,es12.4)") & + 'DEBUG -- approx!' , trim(varname),& + Ivalues(ijk), Nvalues(ijk),Ndiv2, Rvar(ijk) + + endif + endif + enddo + enddo + enddo + + deallocate(Ivalues) + deallocate(Nvalues) + + elseif(interpol_used=='zero_order')then + !interpolation 1: + !nearest gridcell + + Ndiv=1 + Grid_resolution_div=Grid_resolution/Ndiv + xp_ext_div=(xp_ext+0.5)*Ndiv-0.5 + yp_ext_div=(yp_ext+0.5)*Ndiv-0.5 + an_ext_div=an_ext*Ndiv + if(MasterProc.and.debug)write(*,*)'zero_order interpolation ',an_ext_div,xp_ext_div,yp_ext_div,dims(1),dims(2) + + if(projection/='Stereographic'.and.projection/='lon lat')then + !the method should be revised or used only occasionally + if(me==0)write(*,*)'WARNING: interpolation method may be CPU demanding' + endif + + + call lb2ijm(maxlimax,maxljmax,glon,glat,buffer1,buffer2,fi_ext,an_ext_div,xp_ext_div,yp_ext_div) + i_ext=nint(buffer1(1,1)) + j_ext=nint(buffer2(1,1)) + call ij2lb(i_ext,j_ext,lon,lat,fi_ext,an_ext_div,xp_ext_div,yp_ext_div) + k2=1 + if(data3D)k2=kend-kstart+1 + do j=1,ljmax + do i=1,limax + ij=i+(j-1)*MAXLIMAX + i_ext=nint(buffer1(i,j)) + j_ext=nint(buffer2(i,j)) + if(i_ext>=1.and.i_ext<=dims(1).and.j_ext>=1.and.j_ext<=dims(2))then + + do k=1,k2 + ijk=k+(ij-1)*k2 + + igjgk=i_ext+(j_ext-1)*dims(1)+(k-1)*dims(1)*dims(2) + + if(OnlyDefinedValues.or.Rvalues(igjgk)/=FillValue)then + Rvar(ijk)=Rvalues(igjgk) + else + if(present(UnDef))then + Rvar(ijk)=UnDef!default value + else + Rvar(ijk)=Rvalues(igjgk) + endif + endif + enddo + else + do k=1,k2 + ijk=k+(ij-1)*k2 + if(present(UnDef))then + Rvar(ijk)=UnDef!default value + else + ! if ( debug ) write(*,*)'WARNING: gridcell out of map. Set to ',FillValue + call StopAll("ReadField_CDF: values outside grid required") + endif + enddo + endif + enddo + enddo + + + endif + + else ! data_projection /="lon lat" .and. data_projection/="Stereographic" if(MasterProc.and.debug)write(*,*)'interpolating from ', trim(data_projection),' to ',trim(projection) @@ -2160,10 +2555,10 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte do i=1,limax do j=1,ljmax - Weight(1) = Weight1(i,j) - Weight(2) = Weight2(i,j) - Weight(3) = Weight3(i,j) - Weight(4) = Weight4(i,j) + Weight(1) = Weight1(i,j) + Weight(2) = Weight2(i,j) + Weight(3) = Weight3(i,j) + Weight(4) = Weight4(i,j) ijkn(1)=IIij(i,j,1)-startvec(1)+1+(JJij(i,j,1)-startvec(2))*dims(1) ijkn(2)=IIij(i,j,2)-startvec(1)+1+(JJij(i,j,2)-startvec(2))*dims(1) @@ -2177,7 +2572,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte do k = 1, 4 ii = IIij(i,j,k) jj = JJij(i,j,k) - if ( Rvalues(ijkn(k) ) > FillValue ) then + if ( Rvalues(ijkn(k) ) /= FillValue ) then Rvar(ijk) = Rvar(ijk) + Weight(k)*Rvalues(ijkn(k)) sumWeights = sumWeights + Weight(k) end if @@ -2204,6 +2599,9 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte deallocate(Rvalues) deallocate(Rlon) deallocate(Rlat) + if(fractions)then + deallocate(NCC,CC,fraction_in) + endif call check(nf90_close(ncFileID)) @@ -2215,7 +2613,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte !code below only used for testing purposes CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) - if(debug)write(*,*)'writing results in file',trim(varname) + if(debug)write(*,*)'writing results in file. Variable: ',trim(varname) !only for tests: def1%class='Readtest' !written @@ -2260,14 +2658,16 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte CALL MPI_FINALIZE(INFO) stop else - if(trim(varname)=='NOX_EMISSION')then + if(trim(varname)=='nonHighwayRoadDustPM10_Jun-Feb')then +! if(.true.)then n=2 k2=1 + call Out_netCDF(IOU_INST,def1,n,k2, & - Rvar,1.0,CDFtype=Real4,fileName_given='ReadField2D.nc') + rvar,1.0,CDFtype=Real4,fileName_given='ReadField2D.nc',overwrite=.false.) CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) - CALL MPI_FINALIZE(INFO) - stop +! CALL MPI_FINALIZE(INFO) +! stop endif endif @@ -2276,7 +2676,7 @@ recursive subroutine ReadField_CDF(fileName,varname,Rvar,nstart,kstart,kend,inte end subroutine ReadField_CDF subroutine printCDF(name, array,unit) - ! Minimal print out to cdf, for real numbe, 2-d arrays + ! Minimal print out to cdf, for real numbers, 2-d arrays character(len=*), intent(in) :: name real, dimension(:,:), intent(in) :: array character(len=*), intent(in) :: unit @@ -2290,140 +2690,142 @@ subroutine printCDF(name, array,unit) def1%scale=1.0 !not used def1%name=trim(name) ! written def1%unit=trim(unit) - + fname = "PRINTCDF_" // trim(name) // ".nc" !Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik,fileName_given) - if(MasterProc) write(*,*) "TEST printCDF :"//trim(fname), maxval(array) + if(MasterProc) write(*,*) "OUTPUTS printCDF :"//trim(fname), maxval(array) call Out_netCDF(IOU_INST,def1,2,1, array,1.0,& CDFtype=Real4,fileName_given=fname,overwrite=.true.) end subroutine printCDF - subroutine ReadTimeCDF(filename,TimesInDays,NTime_Read) - !Read times in file under CF convention and convert into days since 1900-01-01 00:00:00 - character(len=*) ,intent(in)::filename - real,intent(out) ::TimesInDays(*) - integer, intent(in) :: NTime_Read !number of records to read +subroutine ReadTimeCDF(filename,TimesInDays,NTime_Read) + !Read times in file under CF convention and convert into days since 1900-01-01 00:00:00 + character(len=*) ,intent(in)::filename + real,intent(out) :: TimesInDays(*) + integer, intent(in) :: NTime_Read !number of records to read - real, allocatable ::times(:) - integer :: i,ntimes,status - integer :: varID,ncFileID,ndims - integer :: xtype,dimids(NF90_MAX_VAR_DIMS),nAtts - integer, parameter::wordarraysize=20 - character*50 ::varname,period,since,name,timeunit,wordarray(wordarraysize) + real, allocatable :: times(:) + integer :: i,ntimes,status + integer :: varID,ncFileID,ndims + integer :: xtype,dimids(NF90_MAX_VAR_DIMS),nAtts + integer, parameter::wordarraysize=20 + character(len=50) ::varname,period,since,name,timeunit,wordarray(wordarraysize),calendar - integer :: yyyy,mo,dd,hh,mi,ss,julian,julian_1900,diff_1900,nwords,errcode + integer :: yyyy,mo,dd,hh,mi,ss,julian,julian_1900,diff_1900,nwords,errcode + logical:: proleptic_gregorian + call check(nf90_open(path=fileName, mode=nf90_nowrite, ncid=ncFileID),& + errmsg="ReadTimeCDF, file not found: "//trim(fileName)) - status = nf90_open(path = trim(fileName), mode = nf90_nowrite, ncid = ncFileID) - call CheckStop(status /= nf90_noerr, "ReadTimeCDF, file not found: "//trim(fileName)) + varname='time' + call check(nf90_inq_varid(ncid=ncFileID, name=varname, varID=VarID),& + errmsg="ReadTimeCDF, "//trim(varname)//" not found in "//trim(fileName)) + if(DEBUG_NETCDF)write(*,*)'variable exists: ',trim(varname) - varname='time' - status = nf90_inq_varid(ncid = ncFileID, name = varname, varID = VarID) - - if(status == nf90_noerr) then - if(DEBUG_NETCDF)print *, 'variable exists: ',trim(varname) - else - print *, 'variable does not exist: ',trim(varname),'file: ',trim(fileName),nf90_strerror(status) - call StopAll("ReadTimeCDF : time not found") - return - endif - - call check(nf90_Inquire_Variable(ncFileID,VarID,name,xtype,ndims,dimids,nAtts)) - if(ndims>1)write(*,*)'WARNING: time has more than 1 dimension!? ',ndims - call check(nf90_inquire_dimension(ncid=ncFileID, dimID=dimids(1), len=ntimes)) - call CheckStop(ntimes1)write(*,*)'WARNING: time has more than 1 dimension!? ',ndims + call check(nf90_inquire_dimension(ncid=ncFileID, dimID=dimids(1), len=ntimes)) + call CheckStop(ntimes59.999)then - !later than midnight the 28th february (28th Feb is 59th day) - TimesInDays(i)=TimesInDays(i)+1.0 - endif - enddo -!if the current date in the model is 29th of february, then this date is not defined in the + do i=1,NTime_Read + TimesInDays(i)=diff_1900+times(i)-yyyy*365 + enddo + !for leap years and dates after 28th February add one day to get Julian days + if(mod(yyyy,4)==0)then + do i=1,NTime_Read + !later than midnight the 28th february (28th Feb is 59th day) + if(times(i)-yyyy*365>59.999) TimesInDays(i)=TimesInDays(i)+1.0 + enddo +!if the current date in the model is 29th of february, then this date is not defined in the !365 days calendar. We then assume that the 60th day is 29th of february in the netcdf file !and not the 1st of march. !Keep this separately as this may be defined differently in different situations. !This implementation works for the IFS-MOZART BC - if(current_date%month==2.and.current_date%day==29)then - write(*,*)'WARNING: assuming 29th of February for ',trim(filename) - do i=1,NTime_Read - if(int(times(i)-yyyy*365)==60)then - !move 1st march to 29th february - TimesInDays(i)=TimesInDays(i)-1.0 - endif - enddo - endif - - endif + if(current_date%month==2.and.current_date%day==29)then + write(*,*)'WARNING: assuming 29th of February for ',trim(filename) + do i=1,NTime_Read + !move 1st march to 29th february + if(int(times(i)-yyyy*365)==60) TimesInDays(i)=TimesInDays(i)-1.0 + enddo + endif endif + endif - deallocate(times) - end subroutine ReadTimeCDF + call check(nf90_close(ncFileID)) + deallocate(times) +endsubroutine ReadTimeCDF end module NetCDF_ml diff --git a/OutputChem_ml.f90 b/OutputChem_ml.f90 index 045d646..1aad1fc 100644 --- a/OutputChem_ml.f90 +++ b/OutputChem_ml.f90 @@ -38,7 +38,7 @@ module OutputChem_ml use Io_ml, only: IO_WRTCHEM, datewrite use ModelConstants_ml, only: nprint, END_OF_EMEPDAY, KMAX_MID, MasterProc& ,DEBUG => DEBUG_OUTPUTCHEM & - ,IOU_INST, IOU_YEAR, IOU_MON, IOU_DAY + ,IOU_INST, IOU_YEAR, IOU_MON, IOU_DAY, IOU_MAX_MAX use NetCDF_ml, only: CloseNetCDF, Out_netCDF use OwnDataTypes_ml, only: Deriv, print_deriv_type use Par_ml, only: MAXLIMAX,MAXLJMAX,GIMAX,GJMAX, & @@ -188,13 +188,25 @@ end subroutine Wrtchem subroutine Output_fields(iotyp) integer, intent(in) :: iotyp + logical, dimension(IOU_MAX_MAX),save :: myfirstcall = .true. + logical :: Init_Only + if(myfirstcall(iotyp))then + !only predefine the fields. For increased performance + Init_Only = .true. + if(num_deriv2d > 0) call Output_f2d(iotyp,num_deriv2d,nav_2d,f_2d,d_2d,Init_Only) + if(num_deriv3d > 0) call Output_f3d(iotyp,num_deriv3d,nav_3d,f_3d,d_3d,Init_Only) + myfirstcall(iotyp) = .false. + IF(DEBUG.and.MasterProc)write(*,*)'2d and 3D OUTPUT INITIALIZED',iotyp + endif + Init_Only = .false. + IF(DEBUG.and.MasterProc)write(*,*)'2d and 3D OUTPUT WRITING',iotyp !*** 2D fields, e.g. surface SO2, SO4, NO2, NO3 etc.; AOT, fluxes !-------------------- - if(num_deriv2d > 0) call Output_f2d(iotyp,num_deriv2d,nav_2d,f_2d,d_2d) + if(num_deriv2d > 0) call Output_f2d(iotyp,num_deriv2d,nav_2d,f_2d,d_2d,Init_Only) !*** 3D concentration fields, e.g. O3 !-------------------- - if(num_deriv3d > 0) call Output_f3d(iotyp,num_deriv3d,nav_3d,f_3d,d_3d) + if(num_deriv3d > 0) call Output_f3d(iotyp,num_deriv3d,nav_3d,f_3d,d_3d,Init_Only) call CloseNetCDF end subroutine Output_fields @@ -207,7 +219,7 @@ function wanted_iou(iou,iotype) result(wanted) if(present(iotype))wanted=wanted.and.(iou<=iotype) end function wanted_iou -subroutine Output_f2d (iotyp, dim, nav, def, dat) +subroutine Output_f2d (iotyp, dim, nav, def, dat, Init_Only) !--------------------------------------------------------------------- ! Sends fields to NetCDF output routines !--------------------------------------------------------------------- @@ -216,13 +228,13 @@ subroutine Output_f2d (iotyp, dim, nav, def, dat) integer, dimension(dim,LENOUT2D),intent(in) :: nav ! No. items averaged type(Deriv), dimension(dim), intent(in) :: def ! Definition of fields real, dimension(dim,MAXLIMAX,MAXLJMAX,LENOUT2D), intent(in) :: dat + logical, intent(in) :: Init_Only! only define fields integer :: icmp ! component index real :: scale ! Scaling factor !--------------------------------------------------------------------- do icmp = 1, dim - !FEB2011. QUERY on INST ?? if ( wanted_iou(iotyp,def(icmp)%iotype) ) then scale = def(icmp)%scale if (iotyp /= IOU_INST ) scale = scale / max(1,nav(icmp,iotyp)) @@ -240,13 +252,13 @@ subroutine Output_f2d (iotyp, dim, nav, def, dat) endif endif - call Out_netCDF(iotyp,def(icmp),2,1,dat(icmp,:,:,iotyp),scale) + call Out_netCDF(iotyp,def(icmp),2,1,dat(icmp,:,:,iotyp),scale,create_var_only=Init_Only) endif ! wanted enddo ! component loop end subroutine Output_f2d -subroutine Output_f3d (iotyp, dim, nav, def, dat) +subroutine Output_f3d (iotyp, dim, nav, def, dat, Init_Only) !--------------------------------------------------------------------- ! Sends fields to NetCDF output routines !--------------------------------------------------------------------- @@ -256,6 +268,7 @@ subroutine Output_f3d (iotyp, dim, nav, def, dat) integer, dimension(dim,LENOUT3D),intent(in) :: nav ! No. items averaged type(Deriv), dimension(dim), intent(in) :: def ! definition of fields real, dimension(dim,MAXLIMAX,MAXLJMAX,KMAX_MID,LENOUT3D), intent(in):: dat + logical, intent(in) :: Init_Only! only define fields integer :: icmp ! component index real :: scale ! Scaling factor @@ -267,7 +280,7 @@ subroutine Output_f3d (iotyp, dim, nav, def, dat) scale = def(icmp)%scale if (iotyp /= IOU_INST) scale = scale /max(1,nav(icmp,iotyp)) - call Out_netCDF(iotyp,def(icmp),3,KMAX_MID,dat(icmp,:,:,:,iotyp),scale) + call Out_netCDF(iotyp,def(icmp),3,KMAX_MID,dat(icmp,:,:,:,iotyp),scale,create_var_only=Init_Only) endif ! wanted enddo ! component loop diff --git a/Output_hourly.f90 b/Output_hourly.f90 index 0175baa..39c1ca3 100644 --- a/Output_hourly.f90 +++ b/Output_hourly.f90 @@ -42,33 +42,38 @@ subroutine hourly_out() !! spec,ofmt,ix1,ix2,iy1,iy2,unitfac) ! !************************************************************************* ! - use My_Outputs_ml, only: NHOURLY_OUT, & ! No. outputs - NLEVELS_HOURLY, & ! No. output levels - FREQ_HOURLY, & ! No. hours between outputs - Asc2D, hr_out, & ! Required outputs - Hourly_ASCII, & ! ASCII output or not - to_ug_ADV, to_ug_C, to_ug_S, to_ug_N, & - SELECT_LEVELS_HOURLY, LEVELS_HOURLY !Output selected model levels + use My_Outputs_ml, only: NHOURLY_OUT, & ! No. outputs + NLEVELS_HOURLY, & ! No. output levels + FREQ_HOURLY, & ! No. hours between outputs + hr_out, & ! Required outputs + SELECT_LEVELS_HOURLY, LEVELS_HOURLY ! Output selected model levels + use CheckStop_ml, only: CheckStop - use Chemfields_ml, only: xn_adv,xn_shl, cfac, PM25_water_rh50 + use Chemfields_ml, only: xn_adv,xn_shl,cfac,PM25_water,PM25_water_rh50,AOD use ChemGroups_ml, only: chemgroups use Derived_ml, only: num_deriv2d ! D2D houtly output type use DerivedFields_ml, only: f_2d,d_2d ! D2D houtly output type - use OwnDataTypes_ml, only: Deriv + use OwnDataTypes_ml, only: Asc2D, Deriv use ChemSpecs_shl_ml ,only: NSPEC_SHL ! Maps indices use ChemChemicals_ml ,only: species ! Gives names - use GridValues_ml, only: i_fdom, j_fdom ! Gives emep coordinates + use GridValues_ml, only: i_fdom, j_fdom,& ! Gives emep coordinates + debug_proc, debug_li,debug_lj use Io_ml, only: IO_HOURLY - use ModelConstants_ml,only: KMAX_MID, DEBUG_i, DEBUG_j, MasterProc, & - IOU_INST, IOU_HOUR, IOU_YEAR, IOU_HOUR_PREVIOUS - use MetFields_ml, only: t2_nwp,th, roa, surface_precip, & - Idirect, Idiffuse, z_bnd - use NetCDF_ml, only: Out_netCDF, & + use ModelConstants_ml,only: KMAX_MID, MasterProc, & + IOU_INST, IOU_HOUR, IOU_YEAR, IOU_HOUR_PREVIOUS, & + DEBUG => DEBUG_OUT_HOUR,runlabel1,HOURLYFILE_ending,& + FORECAST + use MetFields_ml, only: t2_nwp,th, roa, surface_precip, ws_10m ,rh2m,& + pzpbl, ustar_nwp, Kz_m2s, & + Idirect, Idiffuse, z_bnd, z_mid + use NetCDF_ml, only: Out_netCDF, CloseNetCDF, Init_new_netCDF, fileName_hour, & Int1, Int2, Int4, Real4, Real8 !Output data type to choose use OwnDataTypes_ml, only: TXTLEN_DERIV,TXTLEN_SHORT use Par_ml, only: MAXLIMAX, MAXLJMAX, GIMAX,GJMAX, & me, IRUNBEG, JRUNBEG, limax, ljmax use TimeDate_ml, only: current_date + use TimeDate_ExtraUtil_ml,only : date2string + use Units_ml, only: Group_Units implicit none @@ -86,8 +91,6 @@ subroutine hourly_out() !! spec,ofmt,ix1,ix2,iy1,iy2,unitfac) ! local variables logical, save :: my_first_call = .true. ! Set false after file opened - logical, save :: debug_flag = .false. - integer, save :: i_debug, j_debug ! Coords matching i,j integer msnr ! Message number for rsend real hourly(MAXLIMAX,MAXLJMAX) ! Local hourly value (e.g. ppb) real ghourly(GIMAX,GJMAX) ! Global hourly value (e.g. ppb) @@ -95,71 +98,80 @@ subroutine hourly_out() !! spec,ofmt,ix1,ix2,iy1,iy2,unitfac) real :: unit_conv ! Unit conversion (ppb ug etc.) real :: g ! tmp - saves value of ghourly(i,j) integer, dimension(2) :: maxpos ! Location of max value - integer i,j,ih,ispec,itot ! indices + integer i,j,ih,ispec,itot,iadv ! indices integer :: k,ik,iik ! Index for vertical level integer ist,ien,jst,jen ! start and end coords character(len=TXTLEN_DERIV) :: name ! For output file, species names character(len=4) :: suffix ! For date "mmyy" integer, save :: prev_month = -99 ! Initialise with non-possible month - logical, parameter :: DEBUG = .false. type(Deriv) :: def1 ! for NetCDF real :: scale ! for NetCDF integer ::CDFtype,nk,klevel ! for NetCDF - character(len=TXTLEN_SHORT) :: hr_out_type ! hr_out%type - integer :: hr_out_nk ! hr_out%nk - integer, allocatable, dimension(:) :: gspec ! group array of indexes - real, allocatable, dimension(:) :: gunit_conv ! group array of unit conv. factors + character(len=TXTLEN_SHORT) :: hr_out_type="" ! hr_out%type + integer :: hr_out_nk=0 ! hr_out%nk + integer, pointer, dimension(:) :: gspec=>null() ! group array of indexes + real, pointer, dimension(:) :: gunit_conv=>null() ! & unit conv. factors + + character(len=len(fileName_hour)) :: filename + logical, save :: debug_flag ! = ( MasterProc .and. DEBUG ) + logical :: surf_corrected ! to get 3m values + + logical :: file_exist=.false. - if ( NHOURLY_OUT <= 0 ) then - if ( MasterProc .and. DEBUG ) print *,"DEBUG Hourly_out: nothing to output!" + if(NHOURLY_OUT<= 0) then + if(my_first_call.and.MasterProc.and.DEBUG) & + write(*,*) "DEBUG Hourly_out: nothing to output!" + my_first_call = .false. return endif - if ( my_first_call ) then + if(my_first_call) then + debug_flag=(debug_proc.and.DEBUG) !/ Ensure that domain limits specified in My_Outputs lie within ! model domain. In emep coordinates we have: - do ih = 1, NHOURLY_OUT hr_out(ih)%ix1 = max(IRUNBEG,hr_out(ih)%ix1) hr_out(ih)%iy1 = max(JRUNBEG,hr_out(ih)%iy1) hr_out(ih)%ix2 = min(GIMAX+IRUNBEG-1,hr_out(ih)%ix2) hr_out(ih)%iy2 = min(GJMAX+JRUNBEG-1,hr_out(ih)%iy2) hr_out(ih)%nk = min(KMAX_MID,hr_out(ih)%nk) + if(debug_flag) write(*,*) "DEBUG Hourly nk ", ih, hr_out(ih)%nk enddo ! ih - - if ( DEBUG ) then - do j = 1, ljmax - do i = 1, limax - if ( i_fdom(i)==DEBUG_i .and. j_fdom(j)==DEBUG_j) then - debug_flag = .true. - i_debug = i - j_debug = j - !print *, "DEBUG FOUNDIJ me ", me, " IJ ", i, j - endif - enddo - enddo - endif ! DEBUG - my_first_call = .false. endif ! first_call - if( MasterProc .and. Hourly_ASCII .and. current_date%month/=prev_month ) then - if(prev_month>0) close(IO_HOURLY) ! Close last-months file - prev_month = current_date%month - - !/.. Open new file for write-out - write(suffix,"(2i2.2)")current_date%month,modulo(current_date%year,100) - name = "Hourly." // suffix - open(file=name,unit=IO_HOURLY,action="write") - - ! Write summary of outputs to top of Hourly file - write(IO_HOURLY,"(1(I0,1X,A))") & - NHOURLY_OUT, "Outputs", & - FREQ_HOURLY, "Hours betwen outputs",& - NLEVELS_HOURLY, "Max Level(s)" - write(IO_HOURLY,"(1(a21,a21,a10,i4,5i4,a21,es12.5,es10.3))")hr_out + filename=trim(runlabel1)//date2string(HOURLYFILE_ending,current_date) + inquire(file=filename,exist=file_exist) + if(my_first_call.or..not.file_exist)then + if(debug_flag) write(*,*) "DEBUG ",HOURLYFILE_ending,"-Hourlyfile ", trim(filename) + call Init_new_netCDF(trim(filename),IOU_HOUR) + + !! Create variables first, without writing them (for performance purposes) + do ih=1,NHOURLY_OUT + def1%name=hr_out(ih)%name + def1%unit=hr_out(ih)%unit + def1%class=hr_out(ih)%type + ist = hr_out(ih)%ix1 + jst = hr_out(ih)%iy1 + ien = hr_out(ih)%ix2 + jen = hr_out(ih)%iy2 + nk = hr_out(ih)%nk + CDFtype=Real4 ! can be choosen as Int1,Int2,Int4,Real4 or Real8 + scale=1. + if(any(hr_out(ih)%type==(/"ADVppbv ","ADVugXX ","ADVugXXgroup",& + "COLUMN ","COLUMNgroup ","D2D "/)))nk=1 + select case(nk) + case(1) ! write as 2D + call Out_netCDF(IOU_HOUR,def1,2,1,hourly,scale,CDFtype,ist,jst,ien,jen,& + create_var_only=.true.) + case(2:) ! write as 3D + call Out_netCDF(IOU_HOUR,def1,3,1,hourly,scale,CDFtype,ist,jst,ien,jen,1,& + create_var_only=.true.) + endselect + enddo endif + my_first_call = .false. !......... Uses concentration/met arrays from Chem_ml or Met_ml .................. ! ! real xn_adv(NSPEC_ADV,MAXLIMAX,MAXLJMAX,KMAX_MID) @@ -175,34 +187,46 @@ subroutine hourly_out() !! spec,ofmt,ix1,ix2,iy1,iy2,unitfac) HLOOP: do ih = 1, NHOURLY_OUT - hr_out_type=hr_out(ih)%type + hr_out_type=trim(hr_out(ih)%type) hr_out_nk=hr_out(ih)%nk if(any(hr_out_type==(/"ADVppbv ","ADVugXX ","ADVugXXgroup",& - "COLUMN ","COLUMNgroup "/)))hr_out_nk=1 + "COLUMN ","COLUMNgroup ","D2D "/)))hr_out_nk=1 KVLOOP: do k = 1,hr_out_nk msnr = 3475 + ih ispec = hr_out(ih)%spec name = hr_out(ih)%name - if ( DEBUG .and. debug_flag ) & - print "(A,2(1X,I0),1X,A,/A,1X,A)",& - "DEBUG OH", me, ispec, trim(name),& - "INTO HOUR TYPE", trim(hr_out(ih)%type) + if(debug_flag) & + write(*,'(a,2i4,1X,a,/a,1X,2a,i3)')"DEBUG DERIV HOURLY", ih, ispec, & + trim(name),"INTO HOUR TYPE:", & + trim(hr_out(ih)%type) // " "//trim(hr_out(ih)%name), " nk:", hr_out_nk if(any(hr_out_type==(/"COLUMN " ,"COLUMNgroup"/)))then ik=KMAX_MID-hr_out(ih)%nk+1 ! top of the column if(ik>=KMAX_MID)ik=1 ! 1-level column does not make sense else ik=KMAX_MID-k+1 ! all levels from model bottom are outputed, + if(debug_flag) write(*,*)"SELECT LEVELS? ", ik, SELECT_LEVELS_HOURLY if(SELECT_LEVELS_HOURLY)then ! or the output levels are taken ik=LEVELS_HOURLY(k) ! from LEVELS_HOURLY array (default) hr_out_type=hr_out(ih)%type + if(debug_flag) write(*,*)"DEBUG SELECT LEVELS", ik, hr_out_type + surf_corrected = (ik==0) ! Will implement cfac + if(debug_flag.and.surf_corrected) & + write(*,*)"DEBUG HOURLY Surf_correction", ik, k +!TESTHH QUERY: see below if(ik==0)then ik=KMAX_MID ! surface/lowermost level - if(any(hr_out_type==(/"BCVppbv ","BCVugXX ","BCVugXXgroup"/)))& + if(debug_flag) write(*,*)"DEBUG LOWEST LEVELS", ik, hr_out_type + if(any(hr_out_type==(/"BCVppbv ","BCVugXX ",& + "BCVugXXgroup"/)))& +! "BCVugXXgroup","Out3D "/)))& hr_out_type(1:3)="ADV" ! ensure surface output + if(any(hr_out_type==(/"PMwater"/)))& + hr_out_type=trim(hr_out_type)//"SRF" else +!TESTHH QUERY: ik=KMAX_MID-ik+1 ! model level to be outputed if(any(hr_out_type==(/"ADVppbv ","ADVugXX ","ADVugXXgroup"/)))& ik=KMAX_MID ! all ADV* types represent surface output @@ -232,198 +256,254 @@ subroutine hourly_out() !! spec,ofmt,ix1,ix2,iy1,iy2,unitfac) ! For molec/cm2 output, set hr_out%unitconv=to_molec_cm2. !---------------------------------------------------------------- - OPTIONS: select case ( trim(hr_out_type) ) - case ( "ADVppbv" ) - itot = NSPEC_SHL + ispec - name = species(itot)%name - unit_conv = hr_out(ih)%unitconv - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = xn_adv(ispec,i,j,KMAX_MID) & - * cfac(ispec,i,j) & ! 50m->3m conversion + if(debug_flag) write(*,"(5a,i4)") "DEBUG Hourly MULTI ",& + trim(hr_out(ih)%name), " case ", trim(hr_out_type), " k: ", ik + OPTIONS: select case(hr_out_type) + + case("ADVppbv") + itot = NSPEC_SHL + ispec + name = species(itot)%name + unit_conv = hr_out(ih)%unitconv + forall ( i=1:limax, j=1:ljmax) + hourly(i,j) = xn_adv(ispec,i,j,KMAX_MID) & + * cfac(ispec,i,j) & ! 50m->3m conversion + * unit_conv ! Units conv. + endforall + + case("Out3D") + itot = ispec + iadv = ispec - NSPEC_SHL + name = species(itot)%name + unit_conv = hr_out(ih)%unitconv + + if(index(hr_out(ih)%unit,"ppb")>0) then + forall(i=1:limax,j=1:ljmax) + hourly(i,j) = xn_adv(iadv ,i,j,ik) & * unit_conv ! Units conv. - end forall - - case ( "BCVppbv" ) - itot = NSPEC_SHL + ispec - name = species(itot)%name - unit_conv = hr_out(ih)%unitconv - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = xn_adv(ispec,i,j,ik) & !BCV:KMAX_MID) & - !BCV * cfac(ispec,i,j) & ! 50m->3m conversion - * unit_conv ! Units conv. - end forall - if ( DEBUG .and. debug_flag ) & - print "(2(A,'=',I0,1X))", "K-level", ik, trim(name), itot - - case ( "ADVugXX" ) !ug/m3, ugX/m3 output at the surface - itot = NSPEC_SHL + ispec - name = species(itot)%name - unit_conv = hr_out(ih)%unitconv - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = xn_adv(ispec,i,j,KMAX_MID) & - * cfac(ispec,i,j) & ! 50m->3m conversion - * unit_conv & ! Units conv. - * roa(i,j,KMAX_MID,1) ! density. - end forall - - case ( "BCVugXX" ) ! ug/m3, ugX/m3 output at model mid-levels - itot = NSPEC_SHL + ispec - name = species(itot)%name - unit_conv = hr_out(ih)%unitconv - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = xn_adv(ispec,i,j,ik) & - !BCV * cfac(ispec,i,j) & ! 50m->3m conversion - * unit_conv & ! Units conv. - * roa(i,j,ik,1) ! density. - end forall - if ( DEBUG .and. debug_flag ) & - print "(2(A,'=',I0,1X))", "K-level", ik, trim(name), itot - - case ( "ADVugXXgroup" ) ! GROUP output in ug/m3, ugX/m3 at the surface - call group_setup() - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = dot_product(xn_adv(gspec,i,j,KMAX_MID),& - cfac(gspec,i,j) & ! 50m->3m conversion - *gunit_conv(:)) & ! Units conv. - * roa(i,j,KMAX_MID,1) ! density. - end forall - if ( DEBUG .and. debug_flag ) & - print "(A,1X,A,'=',30(I0,:,'+'))", "Surface", trim(name), gspec+NSPEC_SHL - deallocate(gspec,gunit_conv) - - case ( "BCVugXXgroup" ) ! GROUP output in ug/m3, ugX/m3 at model mid-levels - call group_setup() - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = dot_product(xn_adv(gspec,i,j,ik), & - gunit_conv(:)) & ! Units conv. - * roa(i,j,ik,1) ! density. - end forall - if ( DEBUG .and. debug_flag ) & - print "(A,'=',I0,1X,A,'=',30(I0,:,'+'))", "K-level", ik, trim(name), gspec+NSPEC_SHL - deallocate(gspec,gunit_conv) - - case ( "PMwater" ) ! PM water content in ug/m3 - if(trim(hr_out(ih)%unit)/="ug/m3")hr_out(ih)%unit="ug" - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = PM25_water_rh50(i,j) - end forall - - case ( "COLUMN" ) ! Column output in ug/m2, ugX/m2, molec/cm2 - itot = NSPEC_SHL + ispec - name = species(itot)%name - unit_conv = hr_out(ih)%unitconv - if(ih>0) hourly(:,:) = 0.0 - do iik=ik,KMAX_MID - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = hourly(i,j) & - + xn_adv(ispec,i,j,iik) & - * roa(i,j,iik,1) & ! density. - * (z_bnd(i,j,iik)-z_bnd(i,j,iik+1)) ! level thickness - end forall - enddo - - case ( "COLUMNgroup" )! GROUP Column output in ug/m2, ugX/m2, molec/cm2 - call group_setup() - if(ih>1) hourly(:,:) = 0.0 - do iik=ik,KMAX_MID - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = hourly(i,j) & - + dot_product(xn_adv(gspec,i,j,iik),& - gunit_conv(:)) & ! Units conv. - * roa(i,j,iik,1) & ! density. - * (z_bnd(i,j,iik)-z_bnd(i,j,iik+1)) ! level thickness - end forall - enddo - if ( DEBUG .and. debug_flag ) & - print "(A,'=',I0,1X,A,'=',30(I0,:,'+'))", "K-level", ik, trim(name), gspec+NSPEC_SHL - deallocate(gspec,gunit_conv) - - case ( "SHLmcm3" ) ! No cfac for short-lived species - itot = ispec - name = species(itot)%name - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = xn_shl(ispec,i,j,KMAX_MID) & - * hr_out(ih)%unitconv ! Units conv. - end forall - - case ( "T2_C " ) ! No cfac for surf.variable - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = t2_nwp(i,j,1) - 273.15 ! Skip Units conv. - end forall - - case ( "theta " ) ! No cfac for met.variable - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = th(i,j,KMAX_MID,1) ! Skip Units conv. - end forall - - case ( "PRECIP " ) ! No cfac for surf.variables - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = surface_precip(i,j) ! Skip Units conv. - end forall - - case ( "Idirect" ) ! Direct radiation (W/m2) - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = Idirect(i,j) ! Skip Units conv. - end forall - - case ( "Idiffus" ) ! Diffuse radiation (W/m2) - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = Idiffuse(i,j) ! Skip Units conv. - end forall - - case ( "D2D" ) - call CheckStop(ispec<1.or.ispec>num_deriv2d,"ERROR-DEF! Hourly_out: "& - //trim(hr_out(ih)%name)//", wrong D2D id!") - if(hr_out(ih)%unit=="") hr_out(ih)%unit = f_2d(ispec)%unit - unit_conv = hr_out(ih)%unitconv*f_2d(ispec)%scale - if(f_2d(ispec)%avg)then ! non accumulated variables - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = d_2d(ispec,i,j,IOU_INST) * unit_conv - end forall - else ! hourly accumulated variables - forall ( i=1:limax, j=1:ljmax) - hourly(i,j) = (d_2d(ispec,i,j,IOU_YEAR)& - -d_2d(ispec,i,j,IOU_HOUR_PREVIOUS)) * unit_conv - d_2d(ispec,i,j,IOU_HOUR_PREVIOUS)=d_2d(ispec,i,j,IOU_YEAR) - end forall + endforall + elseif(index(hr_out(ih)%unit,"ug")>0) then + forall(i=1:limax,j=1:ljmax) + hourly(i,j) = xn_adv(iadv ,i,j,ik) & + * roa(i,j,ik,1) & ! density. + * unit_conv ! Units conv. + endforall + else + call CheckStop("ERROR: Output_hourly unit problem"//trim(name) ) + endif + + if(surf_corrected.and.ik==KMAX_MID.and.itot>NSPEC_SHL) then + forall(i=1:limax,j=1:ljmax) + hourly(i,j) = hourly(i,j)*cfac(iadv,i,j) ! 50m->3m conversion + endforall + endif + + if(debug_flag) then + i=debug_li; j=debug_lj + write(*,'(A,2I4,1X,L2,2f10.4)')"Out3D K-level"//trim(name), ik, & + itot, surf_corrected, hourly(i,j), cfac(ispec-NSPEC_SHL,i,j) + endif + + case("BCVppbv") + itot = NSPEC_SHL + ispec + name = species(itot)%name + unit_conv = hr_out(ih)%unitconv + forall(i=1:limax,j=1:ljmax) + hourly(i,j) = xn_adv(ispec,i,j,ik) & + * unit_conv ! Units conv. + endforall + if(DEBUG) & + write(*,'(A,I0,1X,L2)')"K-level", ik, trim(name), itot, surf_corrected + + case("ADVugXX") !ug/m3, ugX/m3 output at the surface + itot = NSPEC_SHL + ispec + name = species(itot)%name + unit_conv = hr_out(ih)%unitconv + forall ( i=1:limax, j=1:ljmax) + hourly(i,j) = xn_adv(ispec,i,j,KMAX_MID) & + * cfac(ispec,i,j) & ! 50m->3m conversion + * unit_conv & ! Units conv. + * roa(i,j,KMAX_MID,1) ! density. + endforall + + case("BCVugXX") ! ug/m3, ugX/m3 output at model mid-levels + itot = NSPEC_SHL + ispec + name = species(itot)%name + unit_conv = hr_out(ih)%unitconv + forall ( i=1:limax, j=1:ljmax) + hourly(i,j) = xn_adv(ispec,i,j,ik) & + !BCV * cfac(ispec,i,j) & ! 50m->3m conversion + * unit_conv & ! Units conv. + * roa(i,j,ik,1) ! density. + endforall + if(DEBUG) & + write(*,'(a,i5,a10,i5)')"K-level", ik, trim(name), itot + + case("ADVugXXgroup") ! GROUP output in ug/m3, ugX/m3 at the surface + call Group_Units(hr_out(ih),gspec,gunit_conv,debug_flag,name) + forall ( i=1:limax, j=1:ljmax) + hourly(i,j) = dot_product(xn_adv(gspec,i,j,KMAX_MID),& + cfac(gspec,i,j) & ! 50m->3m conversion + *gunit_conv(:)) & ! Units conv. + * roa(i,j,KMAX_MID,1) ! density. + endforall + if(DEBUG) & + write(*,'(2a10,99i5)')"Surface", trim(name), gspec+NSPEC_SHL + deallocate(gspec,gunit_conv) + + case("BCVugXXgroup") ! GROUP output in ug/m3, ugX/m3 at model mid-levels + call Group_Units(hr_out(ih),gspec,gunit_conv,debug_flag,name) + forall ( i=1:limax, j=1:ljmax) + hourly(i,j) = dot_product(xn_adv(gspec,i,j,ik), & + gunit_conv(:)) & ! Units conv. + * roa(i,j,ik,1) ! density. + endforall + if(DEBUG) & + write(*,'(a10,i7,a10,i7)')"K-level", ik, trim(name), gspec+NSPEC_SHL + deallocate(gspec,gunit_conv) + + case("PMwater") ! PM water content in ug/m3 at model mid-levels + if(hr_out(ih)%unit/="ug/m3")hr_out(ih)%unit="ug" + forall(i=1:limax,j=1:ljmax) hourly(i,j) = PM25_water(i,j,ik) + + case("PMwaterSRF") ! PM water content in ug/m3 at surface level + if(hr_out(ih)%unit/="ug/m3")hr_out(ih)%unit="ug" + forall(i=1:limax,j=1:ljmax) hourly(i,j) = PM25_water_rh50(i,j) + + case("Z","Z_MID") + name = "Z_MID" + unit_conv = hr_out(ih)%unitconv + if(surf_corrected)then + forall(i=1:limax,j=1:ljmax) hourly(i,j) = 0.0 + else + forall(i=1:limax,j=1:ljmax) hourly(i,j) = z_mid(i,j,ik)*unit_conv + endif + + case("AOD") + name = "AOD 550nm" + forall(i=1:limax,j=1:ljmax) hourly(i,j) = AOD(i,j) + + case("COLUMN") ! Column output in ug/m2, ugX/m2, molec/cm2 + itot = NSPEC_SHL + ispec + name = species(itot)%name + unit_conv = hr_out(ih)%unitconv + if(ih>0) hourly(:,:) = 0.0 + do iik=ik,KMAX_MID + forall(i=1:limax,j=1:ljmax) + hourly(i,j) = hourly(i,j) & + + xn_adv(ispec,i,j,iik) & + * unit_conv & ! Units conv. + * roa(i,j,iik,1) & ! density. + * (z_bnd(i,j,iik)-z_bnd(i,j,iik+1)) ! level thickness + endforall + enddo + + case("COLUMNgroup")! GROUP Column output in ug/m2, ugX/m2, molec/cm2 + call Group_Units(hr_out(ih),gspec,gunit_conv,debug_flag,name) + if(ih>1) hourly(:,:) = 0.0 + do iik=ik,KMAX_MID + forall(i=1:limax,j=1:ljmax) + hourly(i,j) = hourly(i,j) & + + dot_product(xn_adv(gspec,i,j,iik),& + gunit_conv(:)) & ! Units conv. + * roa(i,j,iik,1) & ! density. + * (z_bnd(i,j,iik)-z_bnd(i,j,iik+1)) ! level thickness + endforall + enddo + if(DEBUG) & + write(*,'(a10,i7,a10,i7)')"K-level", ik, trim(name), gspec+NSPEC_SHL + deallocate(gspec,gunit_conv) + + case("SHLmcm3") ! No cfac for short-lived species + itot = ispec + name = species(itot)%name + forall ( i=1:limax, j=1:ljmax) + hourly(i,j) = xn_shl(ispec,i,j,KMAX_MID) & + * hr_out(ih)%unitconv ! Units conv. + endforall + + case("T2_C") ! No cfac for surf.variable; Skip Units conv. + forall(i=1:limax,j=1:ljmax) hourly(i,j) = t2_nwp(i,j,1) - 273.15 + + case("rh2m") ! No cfac for surf.variable; Skip Units conv. + forall(i=1:limax,j=1:ljmax) hourly(i,j) = rh2m(i,j,1)*100 + + case("ws_10m") ! No cfac for surf.variable; Skip Units conv. + forall(i=1:limax,j=1:ljmax) hourly(i,j) = ws_10m(i,j,1) + + case("theta") ! No cfac for surf.variable; Skip Units conv. + forall(i=1:limax,j=1:ljmax) hourly(i,j) = th(i,j,KMAX_MID,1) + + case("PRECIP") ! No cfac for surf.variable; Skip Units conv. + forall(i=1:limax,j=1:ljmax) hourly(i,j) = surface_precip(i,j) + + case("Idirect") ! Direct radiation (W/m2); Skip Units conv. + forall(i=1:limax,j=1:ljmax) hourly(i,j) = Idirect(i,j) + + case("Idiffus") ! Diffuse radiation (W/m2); Skip Units conv. + forall(i=1:limax,j=1:ljmax) hourly(i,j) = Idiffuse(i,j) + + case ( "D2D" ) + ! Here ispec is the index in the f_2d arrays + call CheckStop(ispec<1.or.ispec>num_deriv2d,& + "ERROR-DEF! Hourly_out: "//trim(hr_out(ih)%name)//", wrong D2D id!") + if(hr_out(ih)%unit=="") hr_out(ih)%unit = f_2d(ispec)%unit + unit_conv = hr_out(ih)%unitconv*f_2d(ispec)%scale + if(f_2d(ispec)%avg)then ! non accumulated variables + if( debug_flag ) write(*,*) " D2Davg ",& + trim(hr_out(ih)%name), ih, ispec, trim(f_2d(ispec)%name), f_2d(ispec)%avg + forall(i=1:limax,j=1:ljmax) + hourly(i,j) = d_2d(ispec,i,j,IOU_INST) * unit_conv + endforall + else ! hourly accumulated variables + if(debug_flag) then + i=debug_li + j=debug_lj + write(*,"(2a,2i4,a,3g12.3)") "OUTHOUR D2Dpre ",& + trim(hr_out(ih)%name), ih, ispec,trim(f_2d(ispec)%name),& + d_2d(ispec,i,j,IOU_YEAR), d_2d(ispec,i,j,IOU_HOUR_PREVIOUS),& + unit_conv endif - if( DEBUG .and. debug_flag) & - print "(a,2i3,2es12.3)","HHH DEBUG D2D", ispec, ih, & - hr_out(ih)%unitconv, hourly(i_debug,j_debug) + + forall(i=1:limax,j=1:ljmax) + hourly(i,j) = (d_2d(ispec,i,j,IOU_YEAR)& + -d_2d(ispec,i,j,IOU_HOUR_PREVIOUS)) * unit_conv + d_2d(ispec,i,j,IOU_HOUR_PREVIOUS)=d_2d(ispec,i,j,IOU_YEAR) + endforall + endif + if(debug_flag) & + write(*,'(a,2i3,2es12.3)')"HHH DEBUG D2D", ispec, ih, & + hr_out(ih)%unitconv, hourly(debug_li,debug_lj) - case DEFAULT - call CheckStop( "ERROR-DEF! Hourly_out: "//trim(hr_out(ih)%type)//& - " hourly type not found!") + case DEFAULT + call CheckStop( "ERROR-DEF! Hourly_out: '"//trim(hr_out(ih)%type)//& + "' hourly type not found!") - end select OPTIONS + endselect OPTIONS - if(DEBUG .and. debug_flag ) then - i = i_debug - j = j_debug - print *,"DEBUG-HOURLY-TH ",me,ih,ispec,hourly(i,j),& - hr_out(ih)%unitconv - endif + if(debug_flag) & + write(*,"(a,3i4,2g12.3)")"DEBUG-HOURLY-OUT:"//trim(hr_out(ih)%name),& + me,ih,ispec, hourly(debug_li,debug_lj), hr_out(ih)%unitconv !/ Get maximum value of hourly array hourly(limax+1:MAXLIMAX,:) = 0.0 hourly(1:limax,ljmax+1:MAXLJMAX) = 0.0 arrmax = maxval(hourly) - if ((hr_out(ih)%max>0.0).and.(arrmax>hr_out(ih)%max)) then - write(6,*) "Hourly value too big!: ", ih, trim(hr_out(ih)%type), arrmax - write(6,*) "Species : ", trim(name)," : ", " ispec ", ispec - write(6,*) "max allowed is : ", hr_out(ih)%max - write(6,*) "unitconv was : ", hr_out(ih)%unitconv - write(6,*) " me, limax, ljmax, MAXLIMAX,MAXLJMAX : ", me, & + if((hr_out(ih)%max>0.0).and.(arrmax>hr_out(ih)%max)) then + write(*,*) "Hourly value too big!: ", ih, trim(hr_out(ih)%type), arrmax + write(*,*) "Species : ", trim(name)," : ", " ispec ", ispec + write(*,*) "max allowed is : ", hr_out(ih)%max + write(*,*) "unitconv was : ", hr_out(ih)%unitconv + write(*,*) " me, limax, ljmax, MAXLIMAX,MAXLJMAX : ", me, & limax, ljmax ,MAXLIMAX,MAXLJMAX maxpos = maxloc(hourly) - write(6,*) "Location is i=", maxpos(1), " j=", maxpos(2) - write(6,*) "EMEP coords ix=", i_fdom(maxpos(1)), " iy=", j_fdom(maxpos(2)) - write(6,*) "hourly is ", hourly(maxpos(1),maxpos(2)) - if ( hr_out(ih)%type(1:3) == "ADV" ) then - write(6,*) "xn_ADV is ", xn_adv(ispec,maxpos(1),maxpos(2),KMAX_MID) - write(6,*) "cfac is ", cfac(ispec,maxpos(1),maxpos(2)) - end if + write(*,*) "Location is i=", maxpos(1), " j=", maxpos(2) + write(*,*) "EMEP coords ix=", i_fdom(maxpos(1)), " iy=", j_fdom(maxpos(2)) + write(*,*) "hourly is ", hourly(maxpos(1),maxpos(2)) + if(hr_out(ih)%type(1:3)=="ADV") then + write(*,*) "xn_ADV is ", xn_adv(ispec,maxpos(1),maxpos(2),KMAX_MID) + write(*,*) "cfac is ", cfac(ispec,maxpos(1),maxpos(2)) + endif call CheckStop("Error, Output_hourly/hourly_out: too big!") endif @@ -435,91 +515,31 @@ subroutine hourly_out() !! spec,ofmt,ix1,ix2,iy1,iy2,unitfac) jst = max(JRUNBEG,hr_out(ih)%iy1) ien = min(GIMAX+IRUNBEG-1,hr_out(ih)%ix2) jen = min(GJMAX+JRUNBEG-1,hr_out(ih)%iy2) - nk = min(KMAX_MID,hr_out_nk) + nk = min(KMAX_MID,hr_out_nk) CDFtype=Real4 ! can be choosen as Int1,Int2,Int4,Real4 or Real8 scale=1. - if (nk == 1) then !write as 2D + select case(nk) + case(1) ! write as 2D call Out_netCDF(IOU_HOUR,def1,2,1,hourly,scale,CDFtype,ist,jst,ien,jen) - elseif( nk > 1 ) then !write as 3D + case(2:) ! write as 3D klevel=ik if(nkNPROC,'bug in NPROCX algorithm') + enddo + elseif(Pole_singular==2)then + !2 poles. divide Y into 2 for max efficiency (load balance) + NPROCY=2 + NPROCX=NPROC/NPROCY + if(NPROCX*NPROCY/=NPROC)then + NPROCY=1 + NPROCX=NPROC/NPROCY + endif + else + !1 pole. divide only in X direction for max efficiency (load balance) + NPROCY=1 + NPROCX=NPROC/NPROCY + endif + + + if(GJMAX/NPROCY !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -26,7 +26,7 @@ !* along with this program. If not, see . !*****************************************************************************! module Rsurface_ml -use LandDefs_ml, only : LandDefs +use LandDefs_ml, only : LandDefs, LandType use CheckStop_ml, only : CheckStop use CoDep_ml, only : CoDep_factors, humidity_fac, Rns_NH3, Rns_SO2 use DO3SE_ml, only : g_stomatal, do3se @@ -36,16 +36,19 @@ module Rsurface_ml ! PARsun,PARshade,LAIsunfrac, RgsO, RgsS, is_water, is_forest ! G (Grid) provides snow, sdepth so2nh3ratio, -use ModelConstants_ml, only: DEBUG_RSUR +use ModelConstants_ml, only: DEBUG_RSUR, NO_CROPNH3DEP use Radiation_ml, only : CanopyPAR use TimeDate_ml, only : current_date use Wesely_ml, only : Wesely_tab2 & ! Wesely Table 2 for 14 gases ,WES_HNO3, WES_NH3,DRx,WES_SO2 ! Indices and Ratio of diffusivities to ozone use MetFields_ml, only : foundsdepth, foundice +use Par_ml,only :me implicit none private public :: Rsurface +INCLUDE 'mpif.h' +INTEGER STATUS(MPI_STATUS_SIZE),INFO real, public, save :: Rinc, RigsO, GnsO, RgsS !hf CoDep @@ -196,6 +199,7 @@ subroutine Rsurface(i,j,DRYDEP_CALC,Gns,Rsur,errmsg,debug_arg,fsnow) !=========================================================================== !/** Adjustment for low temperatures (Wesely, 1989, p.1296, left column) + ! (ACP63) lowTcorr = exp(0.2*(-1 -L%t2C))!Zhang,2003 & Erisman 1994 lowTcorr = min(2.0,lowTcorr) !Zhang,2003 & Erisman 1994 @@ -246,9 +250,8 @@ subroutine Rsurface(i,j,DRYDEP_CALC,Gns,Rsur,errmsg,debug_arg,fsnow) current_date, iL, leafy_canopy, G%Idirect, L%g_sto end if -!Need to find a way to define vegetation outside growing season - Rns_SO2 and NH3 should be used here as well - !/** Calculate Rinc, Gext + !/** Calculate Rinc, Gext (ACPs8.6.1) if( canopy ) then @@ -281,15 +284,15 @@ subroutine Rsurface(i,j,DRYDEP_CALC,Gns,Rsur,errmsg,debug_arg,fsnow) end if ! canopy - !snow treated as in Zhang 2003 + !snow treated similar to Zhang 2003 !But Zhang wse 2*fsnow for ground surface because Sdmax(snow depth when total coverage is assumed) !for soils under vegetation is assumed to stay snow covered longer than 'the leafs' !but - we have underlying surfaces only for O3 and for simplicity we treat them equally !RECONSIDER THIS ESPECIALLY BASED ON SATELITTES !no snow corrections (or low temperature) for Rinc - !RgsO 'corrected for snow' and low temp - !as adviced by Juha-Pekka + !RgsO 'corrected for snow' and low temp (JP) + GigsO= (1.-fsnow)/do3se(iL)%RgsO + fsnow/RsnowO RigsO = lowTcorr/GigsO + Rinc @@ -299,8 +302,8 @@ subroutine Rsurface(i,j,DRYDEP_CALC,Gns,Rsur,errmsg,debug_arg,fsnow) !/ Ozone values.... - !RextO corrected for low temp - !as adviced by Juha-Pekka + !RextO corrected for low temp (JP) + GnsO = L%SAI/(RextO * lowTcorr) + 1.0/ RigsO ! (SAI=0 if no canopy) @@ -362,6 +365,22 @@ subroutine Rsurface(i,j,DRYDEP_CALC,Gns,Rsur,errmsg,debug_arg,fsnow) Rsur(icmp) = 1.0/( L%LAI*DRx(iwes) *L%g_sto + Gns(icmp) ) + ! Stop NH3 deposition for growing crops + ! Crude reflection of likely emission + + if ( NO_CROPNH3DEP .and. DRYDEP_CALC(icmp) == WES_NH3 ) then + + if ( L%is_crop .and. L%LAI > 0.1 ) then + if ( DEBUG_RSUR .and. debug_flag .and. L%is_crop ) then + write(*,"(a,i4,2i4,L2,f8.2)") "NO_CROPNH3DEP ", & + iL, DRYDEP_CALC(icmp), WES_NH3, L%is_crop, L%LAI + end if + + Rsur(icmp) = 1.0e10 ! BIG number + + end if + end if + ! write(*,"(a20,2i3,3g12.3)") "RSURFACE Gs (i): ", iL, icmp, GnsO, Gns_dry, Gns_wet elseif (L%is_veg) then !vegetation outside growing season @@ -383,7 +402,8 @@ subroutine Rsurface(i,j,DRYDEP_CALC,Gns,Rsur,errmsg,debug_arg,fsnow) end if ! end of canopy tests - ! write(*,"(a20,2i3,3g12.3)") "RSURFACE Rsur(i): ", iL, icmp, Rsur_dry(icmp), Rsur_wet(icmp) + if(DEBUG_RSUR.and.debug_flag) write(*,"(a20,2i3,L2,3g12.3)") & + "RSURFACE Rsur(i): ", iL, icmp, L%is_crop, Rsur(icmp) end do GASLOOP @@ -391,10 +411,13 @@ subroutine Rsurface(i,j,DRYDEP_CALC,Gns,Rsur,errmsg,debug_arg,fsnow) if ( DEBUG_RSUR ) then if ( debug_flag ) then - write(*,"(a,2i4)") "RSURFACE DRYDEP_CALC", size(DRYDEP_CALC), DRYDEP_CALC(1) - write(*,"(a,i3,2f7.3,5L2)") "RSURFACE iL, LAI, SAI, LOGIS ", iL, L%LAI, L%SAI, & - L%is_forest, L%is_water, L%is_veg, canopy, leafy_canopy - write(*,"(a,i3,4g12.3)") "RSURFACE xed Gs", iL, do3se(iL)%RgsO,do3se(iL)%RgsS, lowTcorr, Rinc + write(*,"(a,2i4)") "RSURFACE DRYDEP_CALC", & + size(DRYDEP_CALC), DRYDEP_CALC(1) + write(*,"(a,i3,2f7.3,5L2)") "RSURFACE iL, LAI, SAI, LOGIS ", & + iL, L%LAI, L%SAI, L%is_forest, L%is_water, L%is_veg, & + canopy, leafy_canopy + write(*,"(a,i3,4g12.3)") "RSURFACE xed Gs", iL, & + do3se(iL)%RgsO,do3se(iL)%RgsS, lowTcorr, Rinc end if end if end subroutine Rsurface diff --git a/Runchem_ml.f90 b/Runchem_ml.f90 index b3b2a6f..2626dc4 100644 --- a/Runchem_ml.f90 +++ b/Runchem_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -42,32 +42,38 @@ module RunChem_ml use My_Aerosols_ml, only: My_MARS, My_EQSAM, AERO_DYNAMICS, & EQUILIB_EMEP, EQUILIB_MARS, EQUILIB_EQSAM, & - Aero_water !DUST -> USE_DUST + Aero_water, Aero_water_MARS !DUST -> USE_DUST use My_Timing_ml, only: Code_timer, Add_2timing, & tim_before, tim_after use Ammonium_ml, only: Ammonium use AOD_PM_ml, only: AOD_calc use Aqueous_ml, only: Setup_Clouds, prclouds_present, WetDeposition - use Biogenics_ml, only: BIO_ISOP, BIO_TERP, setup_bio !rcbio for debug + use Biogenics_ml, only: setup_bio use CellMet_ml, only: Get_CellMet use CheckStop_ml, only: CheckStop use Chemfields_ml, only: xn_adv ! For DEBUG use Chemsolver_ml, only: chemistry + use ChemSpecs_tot_ml ! DEBUG ONLY + use ChemSpecs_adv_ml ! DEBUG ONLY use DefPhotolysis_ml, only: setup_phot use DryDep_ml, only: drydep use DustProd_ml, only: WindDust - use ChemSpecs_tot_ml ! DEBUG ONLY - use ChemSpecs_adv_ml ! DEBUG ONLY use GridValues_ml, only : debug_proc, debug_li, debug_lj use Io_Progs_ml, only : datewrite + use MassBudget_ml, only : emis_massbudget_1d use ModelConstants_ml, only : USE_DUST, USE_SEASALT, USE_AOD, & PPB, KMAX_MID, dt_advec, & nprint, END_OF_EMEPDAY, & + USE_POLLEN, & + DebugCell, DEBUG_AOT, & ! DEBUG only DEBUG => DEBUG_RUNCHEM, DEBUG_i, DEBUG_j,nstep, NPROC - use OrganicAerosol_ml, only: ORGANIC_AEROSOLS, OrganicAerosol + use OrganicAerosol_ml, only: ORGANIC_AEROSOLS, OrganicAerosol, & + Init_OrganicAerosol, & !FEB2012 + SOA_MODULE_FLAG ! ="VBS" or "NotUsed" + !FUTURE use Pollen_ml, only : Pollen_flux,Pollen_prod use Par_ml, only : lj0,lj1,li0,li1, limax, ljmax & ,gi0, gj0, me & !! for testing ,IRUNBEG, JRUNBEG !! for testing @@ -75,9 +81,9 @@ module RunChem_ml use Setup_1d_ml, only: setup_1d, & setup_rcemis, reset_3d !FUTURE setup_nh3 ! NH3emis (NMR-NH3 project) - use Setup_1dfields_ml, only: first_call, rcbio, & + use Setup_1dfields_ml, only: first_call, & amk, rcemis, xn_2d ! DEBUG for testing - use TimeDate_ml, only: current_date + use TimeDate_ml, only: current_date,daynumber !-------------------------------- implicit none @@ -98,9 +104,8 @@ subroutine runchem(numt) integer :: errcode integer :: nmonth, nday, nhour logical :: Jan_1st, End_of_Run - logical :: ambient +! logical :: ambient logical :: debug_flag ! => Set true for selected i,j - !TEST real, dimension(limax,ljmax) :: aotpre, aotpost ! ============================= @@ -111,17 +116,25 @@ subroutine runchem(numt) Jan_1st = ( nmonth == 1 .and. nday == 1 ) End_of_Run = ( mod(numt,nprint) == 0 ) + if ( ORGANIC_AEROSOLS .and. first_call ) then + + call CheckStop( SOA_MODULE_FLAG == "NotUsed", & ! Just safety + "Wrong My_SOA? Flag is "// trim(SOA_MODULE_FLAG) ) + + end if + ! Processes calls errcode = 0 - do j = lj0, lj1 - do i = li0, li1 + do j = 1, ljmax + do i = 1, limax +! do j = lj0, lj1 ! ljmax +! do i = li0, li1 ! 1, limax call Code_Timer(tim_before) !****** debug cell set here ******* - debug_flag = .false. debug_flag = .false. if ( DEBUG .and. debug_proc ) then @@ -133,51 +146,60 @@ subroutine runchem(numt) !write(*,"(a,4i4)") "RUNCHEM DEBUG IJTESTS", debug_li, debug_lj, i,j !write(*,*) "RUNCHEM DEBUG LLTESTS", me,debug_proc,debug_flag - ! Prepare some near-surface grid and sub-scale meteorology - ! for MicroMet - call Get_CellMet(i,j,debug_flag) + ! Prepare some near-surface grid and sub-scale meteorology + ! for MicroMet - call setup_1d(i,j) + call Get_CellMet(i,j,debug_flag) - call Add_2timing(27,tim_after,tim_before,& - "Runchem:setup_1d") + ! we need to get the gas fraction of semivols: + if ( ORGANIC_AEROSOLS ) call Init_OrganicAerosol(i,j,debug_flag) - call Setup_Clouds(i,j,debug_flag) + call setup_1d(i,j) - call setup_bio(i,j) + call setup_rcemis(i,j) ! Sets initial rcemis=0.0 + + if ( USE_SEASALT ) & + call SeaSalt_flux(i,j,debug_flag) ! sets rcemis(SEASALT_...) + + if ( USE_DUST ) & + call WindDust (i,j,debug_flag) ! sets rcemis(DUST...) + + !FUTURE if ( USE_Pollen .and. daynumber > 59) & + !FUTURE call Pollen_flux (i,j,debug_flag) + + call Setup_Clouds(i,j,debug_flag) - call Add_2timing(28,tim_after,tim_before, & + call setup_bio(i,j) ! Adds bio/nat to rcemis + + call setup_bio(i,j) ! Adds bio/nat to rcemis + + call emis_massbudget_1d(i,j) ! Adds bio/nat to rcemis + call Add_2timing(28,tim_after,tim_before, & "Runchem:setup_cl/bio") - call setup_phot(i,j,errcode) + call setup_phot(i,j,errcode) - call CheckStop(errcode,"setup_photerror in Runchem") - call Add_2timing(29,tim_after,tim_before, & + call CheckStop(errcode,"setup_photerror in Runchem") + call Add_2timing(29,tim_after,tim_before, & "Runchem:1st setups") - call setup_rcemis(i,j) -! Called every adv step, only updated every third hour + ! Called every adv step, only updated every third hour !FUTURE call setup_nh3(i,j) ! NH3emis, experimental (NMR-NH3) - if ( USE_SEASALT ) & - call SeaSalt_flux(i,j,debug_flag) - - if ( USE_DUST ) & - call WindDust (i,j,debug_flag) - if ( DEBUG .and. debug_flag ) then call datewrite("Runchem Pre-Chem", (/ rcemis(NO,20), & - rcbio(BIO_ISOP,KMAX_MID), rcemis(C5H8,KMAX_MID), & - xn_2d(NO,20),xn_2d(C5H8,20) /) ) + rcemis(C5H8,KMAX_MID), xn_2d(NO,20),xn_2d(C5H8,20) /) ) end if - if ( ORGANIC_AEROSOLS ) & + if ( ORGANIC_AEROSOLS ) & call OrganicAerosol(i,j,debug_flag) - call Add_2timing(30,tim_after,tim_before, & + call Add_2timing(30,tim_after,tim_before, & "Runchem:2nd setups") + call Add_2timing(27,tim_after,tim_before,& + "Runchem:setup_1d+rcemis") !if ( DEBUG .and. debug_flag ) then ! write(6,"(a16,9es10.2)") "RUNCHEM PRE-CHEM ", & @@ -206,8 +228,8 @@ subroutine runchem(numt) if(mod(nstep,2) /= 0 ) then if ( EQUILIB_EMEP ) call ammonium() - if ( EQUILIB_MARS ) call My_MARS() - if ( EQUILIB_EQSAM ) call My_EQSAM() + if ( EQUILIB_MARS ) call My_MARS(debug_flag) + if ( EQUILIB_EQSAM ) call My_EQSAM(debug_flag) call DryDep(i,j) @@ -215,8 +237,8 @@ subroutine runchem(numt) call DryDep(i,j) if ( EQUILIB_EMEP ) call ammonium() - if ( EQUILIB_MARS ) call My_MARS() - if ( EQUILIB_EQSAM ) call My_EQSAM() + if ( EQUILIB_MARS ) call My_MARS(debug_flag) + if ( EQUILIB_EQSAM ) call My_EQSAM(debug_flag) endif !???????????????????????????????????????????????????? @@ -241,18 +263,22 @@ subroutine runchem(numt) if ( USE_AOD ) & call AOD_calc (i,j,debug_flag) - ! Modelling PM water at filter equlibration conditions: + ! Calculates PM water: 1. for ambient condition (3D) + ! and for filter equlibration conditions (2D at surface) ! T=20C and Rh=50% for comparability with gravimetric PM - if ( nhour == END_OF_EMEPDAY .or. End_of_Run ) then - ambient = .false. - call Aero_water(i,j, ambient) ! - else - ambient = .true. - call Aero_water(i,j, ambient) - endif - - call reset_3d(i,j) + call Aero_water_MARS(i,j, debug_flag) + +!.. Water from EQSAM ....... +! ambient = .false. ! For Rh=50% +! call Aero_water(i,j, ambient, debug_flag) +! ambient = .true. ! For real conditions (3D) +! call Aero_water(i,j, ambient, debug_flag) + + if(i>=li0.and.i<=li1.and.j>=lj0.and.j<=lj1)then + call reset_3d(i,j) + !(DO NOT UPDATE BC. BC are frozen) + endif call Add_2timing(33,tim_after,tim_before,& "Runchem:post stuff") diff --git a/SeaSalt_ml.f90 b/SeaSalt_ml.f90 index 480404a..0153af0 100644 --- a/SeaSalt_ml.f90 +++ b/SeaSalt_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -44,21 +44,23 @@ module SeaSalt_ml ! Programmed by Svetlana Tsyro !----------------------------------------------------------------------------- - use ChemSpecs_tot_ml, only : SeaSalt_f, SeaSalt_c, SeaSalt_g + use Biogenics_ml, only : EMIS_BioNat, EmisNat use ChemChemicals_ml, only : species - use EmisDef_ml, only : NSS, QSSFI, QSSCO, QSSGI - use GridValues_ml, only : glat, glon - use Landuse_ml, only : LandCover, water_cover + use GridValues_ml, only : glat, glon, i_fdom, j_fdom + use Io_Progs_ml, only : PrintLog + use Landuse_ml, only : LandCover, water_fraction use LocalVariables_ml, only : Sub, Grid - use MetFields_ml, only : u_ref - use MetFields_ml, only : z_bnd, z_mid, sst, & + use MetFields_ml, only : u_ref, z_bnd, z_mid, sst, & nwp_sea, u_ref, foundSST, & foundws10_met,ws_10m use MicroMet_ml, only : Wind_at_h use ModelConstants_ml, only : KMAX_MID, KMAX_BND, & + MasterProc, & DEBUG_SEASALT, DEBUG_i,DEBUG_j use Par_ml, only : MAXLIMAX,MAXLJMAX ! => x, y dimensions use PhysicalConstants_ml, only : CHARNOCK, AVOG ,PI + use Setup_1dfields_ml, only : rcemis + use SmallUtils_ml, only : find_index use TimeDate_ml, only : current_date !------------------------------------- @@ -69,17 +71,27 @@ module SeaSalt_ml public :: SeaSalt_flux ! subroutine integer, parameter :: SS_MAAR= 7, SS_MONA= 3, & !Number size ranges for - !Maartinsson's and Monahan's - NFIN= 7, NCOA= 2, NGIG=1, & !Number fine&coarse&giant bins + !Maartinsson's and Monahan's + NFIN= 7, NCOA= 3 , & !Number fine&coarse bins SSdens = 2200.0 ! sea salt density [kg/m3] +!TEST NFIN= 7, NCOA= 2, NGIG= 1, & real, save, dimension(SS_MAAR) :: dp3, a, b real, save, dimension(SS_MAAR+1) :: log_dbin real, save, dimension(SS_MONA) :: temp_Monah, radSS, dSS3 real, save :: n_to_mSS - real, public, dimension(NSS,MAXLIMAX,MAXLJMAX) :: SS_prod !Sea salt flux + real, public, allocatable,dimension(:,:,:) :: SS_prod !Sea salt flux logical, private, save :: my_first_call = .true. + logical, private, save :: seasalt_found + integer, private, save :: iseasalt ! index of SEASALT_F + + ! Indices for the species defined in this routine. Only set if found + ! Hard-coded for 2 specs just now. Could extend and allocate. + integer, private, parameter :: NSS = 2 + integer, private, parameter :: iSSFI=1, iSSCO=2 + integer, private, save :: inat_SSFI, inat_SSCO + integer, private, save :: itot_SSFI, itot_SSCO contains @@ -93,33 +105,63 @@ subroutine SeaSalt_flux (i,j, debug_flag) ! Output: SS_prod - fluxes of fine and coarse sea salt aerosols [molec/cm3/s] !----------------------------------------------------------------------- - implicit none - integer, intent(in) :: i,j ! coordinates of column logical, intent(in) :: debug_flag real, parameter :: Z10 = 10.0 ! 10m height integer :: ii, jj, nlu, ilu, lu real :: invdz, n2m, u10, u10_341, Tw, flux_help, total_flux + real, save :: moleccm3s_2_kgm2h real :: ss_flux(SS_MAAR+SS_MONA), d3(SS_MAAR+SS_MONA) + real :: rcss(NSS) !//--------------------------------------------------- if ( my_first_call ) then - call init_seasalt + ! We might have USE_SEASALT=.true. in ModelConstants, but the + ! chemical scheme might not have seasalt species. We check. + + inat_SSFI = find_index( "SEASALT_F", Emis_BioNat(:) ) + inat_SSCO = find_index( "SEASALT_C", Emis_BioNat(:) ) + itot_SSFI = find_index( "SEASALT_F", species(:)%name ) + itot_SSCO = find_index( "SEASALT_C", species(:)%name ) + + if(DEBUG_SEASALT ) write(*,*)"SSALT INIT", inat_SSFI, itot_SSFI, debug_flag + + if ( inat_SSFI < 1 ) then + seasalt_found = .false. + call PrintLog("WARNING: SeaSalt asked for but not found",MasterProc) + else + seasalt_found = .true. + call init_seasalt() + end if + ! For EmisNat, need kg/m2/h from molec/cm3/s + moleccm3s_2_kgm2h = Grid%DeltaZ * 1.0e6 * 3600.0 &! /cm3/s > /m2/hr + /AVOG * 1.0e-6 ! kg after *MW my_first_call = .false. end if ! my_first_call !.................................... - SS_prod(:,i,j) = 0.0 + if ( .not. seasalt_found ) return + + !.................................... + - if ( .not. Grid%is_NWPsea .or. Grid%snowice ) return ! quick check + + if ( .not. Grid%is_NWPsea .or. Grid%snowice ) then ! quick check + EmisNat( inat_SSFI,i,j) = 0.0 + EmisNat( inat_SSCO,i,j) = 0.0 + rcemis( itot_SSFI,KMAX_MID) = 0.0 + rcemis( itot_SSCO,KMAX_MID) = 0.0 + return + end if !// Loop over the land-use types present in the grid + rcss(:) = 0.0 nlu = LandCover(i,j)%ncodes do ilu= 1, nlu lu = LandCover(i,j)%codes(ilu) @@ -131,9 +173,9 @@ subroutine SeaSalt_flux (i,j, debug_flag) if ( Sub(lu)%is_water ) then if(DEBUG_SEASALT .and. debug_flag) then - write(6,'(a40)') ' Sea-Salt Check ' - write(6,*) - write(6,'(a30,4f12.4,f8.2)') '** CHAR, ustar_nwp, d, Z0, SST ** ',& + write(6,'(a,2i4,f8.4,f12.4,3f8.3)') & + 'SSALT ** Charnock, ustar_nwp, d, Z0, SST ** ',& + i_fdom(i), j_fdom(j), & CHARNOCK,Grid%ustar,Sub(lu)%d,Sub(lu)%z0, sst(i,j,1) end if @@ -146,12 +188,14 @@ subroutine SeaSalt_flux (i,j, debug_flag) Sub(lu)%z0, Sub(lu)%invL) end if - if (u10 <= 0.0) u10 = 1.0e-5 ! make sure u10!=0 because of LOG(u10) + !if (u10 <= 0.0) u10 = 1.0e-5 ! make sure u10!=0 because of LOG(u10) + !u10 = max(1.0e-5, u10) ! make sure u10!=0 because of LOG(u10) + u10 = max(0.1, u10) ! DS - use more physical limit here u10_341=exp(log(u10) * (3.41)) if(DEBUG_SEASALT .and. debug_flag) & - write(6,'(a,L2,4f12.4,es14.4)')'** U*, Uref, U10, Uh, invL ** ',& + write(6,'(a,L2,4f12.4,es14.4)')'SSALT ** U*, Uref, U10, Uh, invL ** ',& foundws10_met, Sub(lu)%ustar, Grid%u_ref, u10, & Wind_at_h (Grid%u_ref, Grid%z_ref, Z10, Sub(lu)%d, & Sub(lu)%z0, Sub(lu)%invL), & @@ -167,6 +211,8 @@ subroutine SeaSalt_flux (i,j, debug_flag) else Tw = Grid%t2 endif + Tw = max(Tw, 270.0)! prevents unrealistic sub.zero values + Tw = min(Tw, 300.0)! prevents unrealistic high values ! ==== Calculate sea salt fluxes in size bins [part/m2/s] ======== total_flux = 0.0 @@ -182,7 +228,7 @@ subroutine SeaSalt_flux (i,j, debug_flag) total_flux = total_flux + ss_flux(ii) if(DEBUG_SEASALT .and. debug_flag) write(6,'(a20,i5,es13.4)') & - 'Flux Maarten -> ',ii, ss_flux(ii) + 'SSALT Flux Maarten -> ',ii, ss_flux(ii) enddo !... Fluxes of larger aerosols for each size bin (Monahan etal,1986) @@ -196,39 +242,43 @@ subroutine SeaSalt_flux (i,j, debug_flag) total_flux = total_flux + ss_flux(ii) if(DEBUG_SEASALT .and. debug_flag) & - write(6,'(a20,i5,es13.4)') 'Flux Monah -> ',ii, ss_flux(jj) + write(6,'(a20,i5,es13.4)') 'SSALT Flux Monah -> ',ii, ss_flux(jj) enddo - if(DEBUG_SEASALT .and. debug_flag) write(6,'(a20,es13.3)') 'Total SS flux -> ', total_flux + if(DEBUG_SEASALT .and. debug_flag) write(6,'(a20,es13.3)') 'SSALT Total SS flux -> ', total_flux + -!.. conversion factor from [part/m2/s] to [molec/cm3/s] + !ESX n2m = n_to_mSS * invdz *AVOG / species(iseasalt)%molwt *1.0e-15 + ! convert [part/m2/s] to [molec/cm3/s] required for differential equations. + !1). n_to_mSS =PI*SSdens/6.0 - partfrom number to mass conversion + ! (as M = PI/6 * diam^3 * density * N) + !2). 1.0e-15 = e-18 * e3 (where e-18 is to convert [um3] to [m3] in diam^3;i + ! and e3 is [kg] to [g] in density). + !3) (then mass is converted to [molec] with AVOG/MotW) invdz = 1.0e-6 / Grid%DeltaZ ! 1/dZ [1/cm3] - n2m = n_to_mSS * invdz *AVOG / species(SeaSalt_f)%molwt *1.0e-15 -!.. Fine particles emission [molec/cm3/s] + n2m = n_to_mSS * invdz *AVOG / species(itot_SSFI)%molwt *1.0e-15 + +!.. Fine particles emission [molec/cm3/s] need to be scaled to get units kg/m2/s consistent with +! Emissions_ml (snapemis). Scaling factor is do ii = 1, NFIN - SS_prod(QSSFI,i,j) = SS_prod(QSSFI,i,j) & + rcss( iSSFI) = rcss( iSSFI) + & + !! ESX SS_prod(QSSFI,i,j) = SS_prod(QSSFI,i,j) & + ss_flux(ii) * d3(ii) * n2m & - * water_cover(i,j) + * water_fraction(i,j) if(DEBUG_SEASALT .and. debug_flag) & - write(6,'(a20,i5,2es13.4)') 'Flux fine -> ',ii,d3(ii),SS_prod(QSSFI,i,j) + write(6,'(a20,i5,2es13.4)') 'SSALT Flux fine -> ',ii,d3(ii), rcss( iSSFI ) !ESX SS_prod(QSSFI,i,j) enddo !..Coarse particles emission [molec/cm3/s] do ii = NFIN+1, NFIN+NCOA - SS_prod(QSSCO,i,j) = SS_prod(QSSCO,i,j) & + rcss( iSSCO ) = rcss( iSSCO ) + & + !!ESX SS_prod(QSSCO,i,j) = SS_prod(QSSCO,i,j) & + ss_flux(ii) * d3(ii) * n2m & - * water_cover(i,j) + * water_fraction(i,j) if(DEBUG_SEASALT .and. debug_flag) & - write(6,'(a20,i5,2es13.4)') 'Flux coarse -> ',ii,d3(ii),SS_prod(QSSCO,i,j) - enddo - -!..'Giant' particles emission [molec/cm3/s] - do ii = NFIN+NCOA+1, NFIN+NCOA+NGIG - SS_prod(QSSGI,i,j) = SS_prod(QSSGI,i,j) & - + ss_flux(ii) * d3(ii) * n2m & - * water_cover(i,j) + write(6,'(a20,i5,2es13.4)') 'SSALT Flux coarse -> ',ii,d3(ii), rcss( iSSCO ) !ESX SS_prod(QSSCO,i,j) enddo !... Crude fix for the effect of lower salinity in the Baltic Sea @@ -236,16 +286,22 @@ subroutine SeaSalt_flux (i,j, debug_flag) if ( (glat(i,j) > 52.0 .and. glat(i,j) < 67.0) .and. & (glon(i,j) > 13.0 .and. glon(i,j) < 30.0) ) then - SS_prod(:,i,j) = 0.5 * SS_prod(:,i,j) + rcss( iSSFI ) = 0.2 * rcss( iSSFI ) + rcss( iSSCO ) = 0.2 * rcss( iSSCO ) endif if(DEBUG_SEASALT .and. debug_flag) write(6,'(a35,2es15.4)') & - '>> SS production fine/coarse >>', & - SS_prod(QSSFI,i,j), SS_prod(QSSCO,i,j) + '>> SSALT production fine/coarse >>', & + rcss( iSSFI ), rcss( iSSCO ) endif ! water enddo ! LU classes + EmisNat( inat_SSFI, i,j ) = rcss( iSSFI ) * moleccm3s_2_kgm2h * species( itot_SSFI )%molwt + EmisNat( inat_SSCO, i,j ) = rcss( iSSCO ) * moleccm3s_2_kgm2h * species( itot_SSCO )%molwt + rcemis ( itot_SSFI, KMAX_MID ) = rcss( iSSFI ) + rcemis ( itot_SSCO, KMAX_MID ) = rcss( iSSCO ) + end subroutine SeaSalt_flux diff --git a/Setup_1d_ml.f90 b/Setup_1d_ml.f90 index 0da5e77..c51b53d 100644 --- a/Setup_1d_ml.f90 +++ b/Setup_1d_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -36,15 +36,15 @@ module Setup_1d_ml !-----------------------------------------------------------------------! !FUTURE use NH3variables_ml, only : NNH3 ! hb NH3emis use AirEmis_ml, only : airn, airlig ! airborne NOx emissions + use Biogenics_ml, only : SoilNOx + use Biogenics_ml, only : EMIS_BioNat, EmisNat use Chemfields_ml, only : xn_adv,xn_bgn,xn_shl, & NSPEC_COL, NSPEC_BGN, xn_2d_bgn use CheckStop_ml, only : CheckStop use DerivedFields_ml, only : d_2d - use DustProd_ml, only : DU_prod ! Dust - use EmisDef_ml, only : NSS, NDU !SeaS, Dust !FUTURE ,NH3EMIS_VAR ! FUTURE NH3Emis use EmisGet_ml, only : nrcemis, iqrc2itot !DSRC added nrcemis - use Emissions_ml, only : gridrcemis, KEMISTOP, SoilNOx + use Emissions_ml, only : gridrcemis, gridrcroadd, KEMISTOP use ForestFire_ml, only : Fire_rcemis, burning use Functions_ml, only : Tpot_2_T use ChemChemicals_ml, only : species @@ -53,11 +53,11 @@ module Setup_1d_ml IXADV_SO4, IXADV_NO3_f, IXADV_NH4_F use ChemSpecs_shl_ml, only : NSPEC_SHL use ChemRates_rct_ml, only : set_rct_rates, rct - use ChemRates_rcmisc_ml, only : rcmisc, set_rcmisc_rates use GridValues_ml, only : sigma_mid, xmd, GridArea_m2, & debug_proc, debug_li, debug_lj,& A_mid,B_mid,gridwidth_m,dA,dB,& i_fdom, j_fdom + use Io_Progs_ml, only : datewrite !MASS use LocalVariables_ml, only : Grid use MassBudget_ml, only : totem ! sum of emissions use MetFields_ml, only : ps @@ -67,16 +67,19 @@ module Setup_1d_ml ATWAIR & ,DEBUG_SETUP_1DCHEM & ,DEBUG_SETUP_1DBIO & + ,DEBUG_MASS & ,dt_advec & ! time-step ,PT & ! Pressure at top ,MFAC & ! converts roa (kg/m3 to M, molec/cm3) ,USE_FOREST_FIRES & ! +!FUTURE ,USE_POLLEN & ! Pollen ,USE_SEASALT & - ,USE_LIGHTNING_EMIS & ! - ,USE_SOIL_NOX, USE_DUST & ! + ,USE_LIGHTNING_EMIS, USE_AIRCRAFT_EMIS & ! + ,USE_SOILNOX, USE_GLOBAL_SOILNOX, USE_DUST, USE_ROADDUST & ! + ,USE_EMERGENCY,DEBUG_EMERGENCY & ! Emergency: Volcanic Eruption ,KMAX_MID ,KMAX_BND, KCHEMTOP & ! Start and upper k for 1d fields ,DEBUG_i, DEBUG_j !FUTURE , DEBUG_NH3 !NH3emis - use Landuse_ml, only : water_cover, ice_landcover + use Landuse_ml, only : water_fraction, ice_landcover use Par_ml, only : me,MAXLIMAX,MAXLJMAX & ,gi0,gi1,gj0,gj1,IRUNBEG,JRUNBEG use PhysicalConstants_ml, only : AVOG, PI, GRAV @@ -84,13 +87,10 @@ module Setup_1d_ml use Setup_1dfields_ml, only : & xn_2d & ! concentration terms ,rcemis & ! emission terms - ,rc_Rn222 & ! for Pb210 - ,rcss, rcwbd & !Sea salt, Dust ,rh, temp, tinv, itemp,pp & ! - ,amk, o2, n2, h2o & ! Air concentrations - ,rcbio ! BVOC + ,amk, o2, n2, h2o ! & ! Air concentrations !FUTURE ,rcnh3 ! NH3emis - use SeaSalt_ml, only : SS_prod + use SmallUtils_ml, only : find_index use Tabulations_ml, only : tab_esat_Pa use TimeDate_ml, only : current_date, date use Volcanos_ml @@ -103,6 +103,15 @@ module Setup_1d_ml !FUTURE public :: setup_nh3 ! NH3emis , experimental version public :: reset_3d ! Exports results for i,j column to 3-D fields +! Indices for the species defined in this routine. Only set if found + ! Hard-coded for 2 specs just now. Could extend and allocate. + integer, private, parameter :: NROADDUST = 2 + integer, private, parameter :: iROADF=1, iROADC=2 + integer, private, save :: inat_RDF, inat_RDC, inat_Rn222 + integer, private, save :: itot_RDF=-999, itot_RDC=-999, itot_Rn222=-999 + + !DUST_ROAD_F + contains !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx subroutine setup_1d(i,j) @@ -175,22 +184,15 @@ subroutine setup_1d(i,j) tinv(:) = 1./temp(:) + ! 5 ) Rates (!!!!!!!!!! NEEDS TO BE AFTER RH, XN, etc. !!!!!!!!!!) call set_rct_rates() - - call set_rcmisc_rates() - if ( DEBUG_SETUP_1DCHEM .and. debug_proc .and. & i==debug_li .and. j==debug_lj .and. & current_date%seconds == 0 ) then - write(*,"(a,f7.2,10es10.3)") " DEBUG_SETUP_1DCHEM ", & - 1.0/tinv(KMAX_MID), o2(KMAX_MID), & - rcmisc(3,KMAX_MID), rcmisc(4,KMAX_MID), & - rcmisc(10,KMAX_MID), rcmisc(11,KMAX_MID), & - rcmisc(8,KMAX_MID), rcmisc(10,KMAX_MID) write(*,"(a,10es10.3)") " DEBUG_SETUP_1DCHEM RCT ", & rct(3,KMAX_MID), rct(4,KMAX_MID) write(*,"(a,10es10.3)") " DEBUG_SETUP_1DCHEM XN ", & @@ -198,8 +200,7 @@ subroutine setup_1d(i,j) xn_2d(IXADV_NO2+NSPEC_SHL,KMAX_MID) write(*,"(a,10es10.3)") " DEBUG_SETUP_1D-Riemer",& xn_2d(IXADV_SO4+NSPEC_SHL,KMAX_MID) & - ,xn_2d(IXADV_NO3_F+NSPEC_SHL,KMAX_MID) & - ,rcmisc(19,KMAX_MID) + ,xn_2d(IXADV_NO3_F+NSPEC_SHL,KMAX_MID) end if @@ -219,15 +220,24 @@ subroutine setup_rcemis(i,j) ! local integer :: iqrc,k, itot - real :: scaling, scaling_k real :: eland ! for Pb210 - emissions from land integer :: i_help,j_help,i_l,j_l - -! initilize + logical, save :: first_call = .true. + + if ( first_call ) then + inat_RDF = find_index( "DUST_ROAD_F", Emis_BioNat(:) ) + inat_RDC = find_index( "DUST_ROAD_C", Emis_BioNat(:) ) + itot_RDF = find_index( "DUST_ROAD_F", species(:)%name ) + itot_RDC = find_index( "DUST_ROAD_C", species(:)%name ) + itot_Rn222= find_index( "RN222", species(:)%name ) + first_call = .false. + end if + +! initilize ! initilize ! initilize ! initilize rcemis(:,:)=0. - rcss(:,:) = 0. !SeaS - rcwbd(:,:) = 0. ! Dust +! initilize ! initilize ! initilize ! initilize + do k=KEMISTOP,KMAX_MID do iqrc = 1, NRCEMIS @@ -262,6 +272,10 @@ subroutine setup_rcemis(i,j) endif ! VOLCANOES +! Contribution from Volcanic eruption. EruptionRate(i,j) returns an array of + if(USE_EMERGENCY.and.Eruption_found)& ! rcemis size, only SO2 and + rcemis(:,:)=rcemis(:,:)+EruptionRate(i,j) ! ASH tracers have rates/=0. + !/** lightning and aircraft ... Airial NOx emissions if required: if ( USE_LIGHTNING_EMIS ) then @@ -269,88 +283,67 @@ subroutine setup_rcemis(i,j) do k=KCHEMTOP, KMAX_MID rcemis(NO,k) = rcemis(NO,k) & - + 0.95 * (airn(k,i,j)+airlig(k,i,j)) + + 0.95 * airlig(k,i,j) rcemis(NO2,k) = rcemis(NO2,k) & - + 0.05 * (airn(k,i,j)+airlig(k,i,j)) + + 0.05 * airlig(k,i,j) enddo if ( DEBUG_SETUP_1DCHEM .and. debug_proc .and. & i==debug_li .and. j==debug_lj ) write(*,"(a,10es10.3)") & " DEBUG_SETUP_AIRNOX ", airn(KMAX_MID,i,j),airlig(KMAX_MID,i,j) - end if ! AIRNOX + end if ! LIGHTNING_EMIS + if ( USE_AIRCRAFT_EMIS ) then - !/** Add sea salt production - - if ( USE_SEASALT ) then - - do iqrc = 1, NSS - rcss(iqrc,KMAX_MID) = SS_prod(iqrc,i,j) - enddo + do k=KCHEMTOP, KMAX_MID - endif + rcemis(NO,k) = rcemis(NO,k) & + + 0.95 * airn(k,i,j) + rcemis(NO2,k) = rcemis(NO2,k) & + + 0.05 * airn(k,i,j) - !/** Add windblown dust production + enddo + if ( DEBUG_SETUP_1DCHEM .and. debug_proc .and. & + i==debug_li .and. j==debug_lj ) write(*,"(a,10es10.3)") & + " DEBUG_SETUP_AIRNOX ", airn(KMAX_MID,i,j),airlig(KMAX_MID,i,j) - if ( USE_DUST ) then + end if ! AIRCRAFT NOX - do iqrc = 1, NDU - rcwbd(iqrc,KMAX_MID) = DU_prod(iqrc,i,j) + !/** Add sea salt production -! if(debug) write(6,'(a25,3i4,2es12.3)') '>> WBDust emissions >>', & -! i_fdom(i), j_fdom(j), iqrc, DU_prod(iqrc,i,j), rcwbd(iqrc,KMAX_MID) - enddo + if ( USE_ROADDUST ) then ! Hard-code indices for now + rcemis(itot_RDF,KMAX_MID) = gridrcroadd(1,i,j) + rcemis(itot_RDC,KMAX_MID) = gridrcroadd(2,i,j) endif - if ( USE_FOREST_FIRES .and. burning(i,j) ) then + + if ( USE_FOREST_FIRES ) then + if ( burning(i,j) ) then call Fire_rcemis(i,j) + endif endif !ForestFires !Soil NOx - if( USE_SOIL_NOX)then + if( USE_GLOBAL_SOILNOX)then !NEEDS CHECKING NOV2011 rcemis(NO,KMAX_MID)=rcemis(NO,KMAX_MID)+SoilNOx(i,j) endif - !Mass Budget calculations - ! Adding up the emissions in each timestep - - - scaling = dt_advec * xmd(i,j)* gridwidth_m*gridwidth_m / GRAV - - do k = KCHEMTOP,KMAX_MID - - - scaling_k = scaling * (dA(k) + dB(k)*ps(i,j,1))/amk(k) - - do iqrc = 1, NSPEC_ADV - - itot = iqrc + NSPEC_SHL - totem( iqrc ) = totem( iqrc ) + & - rcemis( itot, k ) * scaling_k - !if ( DEBUG_SETUP_1DCHEM .and. debug_proc .and. & - ! i==debug_li .and. j==debug_lj ) then - ! write(6,"(a,2i3,es10.3,2i4)") "MASSEQV:", iqrc, & - ! rcemis( iqrc,k), qrc2ixadv(iqrc) - !end if - end do - - end do ! k loop ! Soil Rn222 emissions from non-ice covered land, + water ! at rate of 1 atom/cm2/s - eland = 1.0 - water_cover(i,j) - ice_landcover(i,j) - -! initialize, needed in My_Reactions - rc_Rn222(:)=0.0 + eland = 1.0 - water_fraction(i,j) - ice_landcover(i,j) ! z_bnd is in m, not cm, so need to divide by 100. - rc_Rn222(KMAX_MID) = & - ( 0.00182 * water_cover(i,j) + eland ) / & + + rcemis( itot_Rn222,KMAX_MID ) = & + ( 0.00182 * water_fraction(i,j) + eland ) / & ((z_bnd(i,j,KMAX_BND-1) - z_bnd(i,j,KMAX_BND))*100.) +!ESX rc_Rnwater(KMAX_MID) = water_fraction(i,j) / & +!ESX ((z_bnd(i,j,KMAX_BND-1) - z_bnd(i,j,KMAX_BND))*100.) end subroutine setup_rcemis diff --git a/Setup_1dfields_ml.f90 b/Setup_1dfields_ml.f90 index 907587b..062458b 100644 --- a/Setup_1dfields_ml.f90 +++ b/Setup_1dfields_ml.f90 @@ -1,9 +1,9 @@ ! -!*****************************************************************************! -!* +!*****************************************************************************! +!* !* Copyright (C) 2007-2011 met.no -!* +!* !* Contact information: !* Norwegian Meteorological Institute !* Box 43 Blindern @@ -11,32 +11,35 @@ !* NORWAY !* email: emep.mscw@met.no !* http://www.emep.int -!* +!* !* 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 Setup_1dfields_ml - ! Arrays of meteorology and concentration for 1-D column , for input to + ! Arrays of meteorology and concentration for 1-D column , for input to ! chemical solver ........ ! The k-dimension spans the ground (KMAX_MID) to the K-values ! specified by KCHEMTOP - here 2 ! ! - new aray added to keep o2, m, and for MADE oh, etc - use ModelConstants_ml, only : KMAX_MID, KCHEMTOP, KUPPER, NBVOC - use EmisDef_ml, only : NSS, NDU !SeaS, Dust +!DSA12 use ModelConstants_ml, only : KMAX_MID, KCHEMTOP, KUPPER, NBVOC, NSOIL_EMIS + use ModelConstants_ml, only : KMAX_MID, KCHEMTOP, KUPPER + !ESX use EmisDef_ml, only : NSS, NDU, NROADDUST, NPOL !SeaS, Dust + !use EmisDef_ml, only : NDU, NROADDUST, NPOL !SeaS, Dust + use EmisDef_ml, only : NROADDUST, NPOL !SeaS, Dust use ChemSpecs_tot_ml, only : NSPEC_TOT, FIRST_SEMIVOL, LAST_SEMIVOL use ChemSpecs_shl_ml, only : NSPEC_SHL use Chemfields_ml, only : NSPEC_COL @@ -49,12 +52,12 @@ module Setup_1dfields_ml logical, public, save :: first_call = .true. integer, public, save :: ncalls = 0 - !/-- the chemistry is calculated for arrays of size: + !/-- the chemistry is calculated for arrays of size: + + integer, public, parameter :: CHEMSIZE = KMAX_MID-KCHEMTOP+1 ! - integer, public, parameter :: CHEMSIZE = KMAX_MID-KCHEMTOP+1 ! - real, public, dimension(NSPEC_TOT,KCHEMTOP:KMAX_MID), save :: & - xn_2d ! Concentrations [molecules/cm3] + xn_2d ! Concentrations [molecules/cm3] ! For semivolatiles we track the farction as gas and particle- used for SOA ! We use NSPEC_TOT to allow us to write Fpart for FFUEL and WOOD also - @@ -66,18 +69,19 @@ module Setup_1dfields_ml !Emissions in column. We assume that these only involve advected species real, public, dimension(NSPEC_SHL+1:NSPEC_TOT,KCHEMTOP:KMAX_MID), save ::& - rcemis !emissions - + rcemis ! emissions ! We define a column array for isoprene and terpene for use in ! the chemical solver. All values except for k=KMAX_MID will ! remain zero however ! Emission arrays: - real, public, dimension(NBVOC,KCHEMTOP:KMAX_MID), save :: rcbio = 0.0 ! BVOC - !FUTURE real, public, dimension(KCHEMTOP:KMAX_MID), save :: rcnh3 - real, public, dimension(KCHEMTOP:KMAX_MID), save :: rc_Rn222 = 0.0 ! 210Pb - real, public, dimension(NSS,KCHEMTOP:KMAX_MID), save :: rcss = 0.0 ! Sea salt - real, public, dimension(NDU,KCHEMTOP:KMAX_MID), save :: rcwbd = 0.0 ! windblown dust + !FUTURE real, public, dimension(KCHEMTOP:KMAX_MID), save :: rcnh3 + ! real, public, dimension(KCHEMTOP:KMAX_MID), save :: rc_Rn222 = 0.0 ! 210Pb + ! real, public, dimension(KCHEMTOP:KMAX_MID), save :: rc_Rnwater = 0.0 ! TEST + !ESX real, public, dimension(NSS,KCHEMTOP:KMAX_MID), save :: rcss = 0.0 ! Sea salt + ! real, public, dimension(NDU,KCHEMTOP:KMAX_MID), save :: rcwbd = 0.0 ! windblown dust + ! real, public, dimension(NROADDUST,KCHEMTOP:KMAX_MID), save :: rcroadd = 0.0 ! road traffic dust + ! real, public, dimension(NPOL,KCHEMTOP:KMAX_MID), save :: rcpol = 0.0 ! Pollen (birch) real, public, dimension(KCHEMTOP:KMAX_MID), save :: & rh & ! RH (fraction, 0-1) diff --git a/Sites_ml.f90 b/Sites_ml.f90 index befdbce..560c224 100644 --- a/Sites_ml.f90 +++ b/Sites_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -93,8 +93,8 @@ module Sites_ml ! site_gindex stores the global index n asociated ! with each processor and local site -integer, private, save, dimension (0:NPROC-1,NSITES_MAX) :: site_gindex -integer, private, save, dimension (0:NPROC-1,NSONDES_MAX) :: sonde_gindex +integer, private, save, allocatable,dimension (:,:) :: site_gindex +integer, private, save, allocatable,dimension (:,:) :: sonde_gindex integer, private, save, dimension (NSITES_MAX) :: & site_gx, site_gy, site_gz & ! global coordinates @@ -143,6 +143,9 @@ subroutine sitesdef() sonde_gz(:) = 0 sonde_z(:) = 0 + allocate(site_gindex(0:NPROC-1,NSITES_MAX)) + allocate(sonde_gindex(0:NPROC-1,NSONDES_MAX)) + call Init_sites("sites",IO_SITES,NSITES_MAX, & nglobal_sites,nlocal_sites, & site_gindex, site_gx, site_gy, site_gz, & @@ -292,7 +295,7 @@ subroutine Init_sites(fname,io_num,NMAX, nglobal,nlocal, & s_gy(n) = iy s_gz(n) = lev - s_name(n) = s // comment + s_name(n) = s !!! remove comments// comment endif enddo SITELOOP @@ -416,7 +419,6 @@ subroutine siteswrt_surf(xn_adv,cfac,xn_shl) endif enddo - my_first_call = .false. do ispec = 1, NSHL_SITE out(NADV_SITE+ispec,i) = xn_shl( SITE_SHL(ispec) ,ix,iy,iz ) @@ -442,11 +444,22 @@ subroutine siteswrt_surf(xn_adv,cfac,xn_shl) "ABS(SITES OUT: '"//trim(SITE_XTRA_MISC(ispec))//"') TOO BIG" ) end do do ispec = 1, NXTRA_SITE_D2D - nn=nn+1 d2code = SITE_XTRA_D2D(ispec) d2index = find_index(d2code, f_2d(:)%name) - call CheckStop( d2index<1, "SITES D2D NOT FOUND"//trim(d2code) ) - out(nn,i) = d_2d(d2index,ix,iy,IOU_INST) + nn=nn+1 + + if ( d2index < 1 ) then + if( my_first_call) write(*,*) & + "WARNING: SITES D2D NOT FOUND"//trim(d2code) + !cycle + out(nn,i) = -999.9 + else + !call CheckStop( d2index<1, "SITES D2D NOT FOUND"//trim(d2code) ) + out(nn,i) = d_2d(d2index,ix,iy,IOU_INST) + end if + + !May25 call CheckStop( d2index<1, "SITES D2D NOT FOUND"//trim(d2code) ) + !May25 out(nn,i) = d_2d(d2index,ix,iy,IOU_INST) if( DEBUG_SITES ) & write(6,"(a,3i3,a,i4,es10.3)") "DEBUG_SITES ", me, nn, i,& trim(d2code), d2index, out(nn,i) @@ -456,6 +469,8 @@ subroutine siteswrt_surf(xn_adv,cfac,xn_shl) endif enddo + my_first_call = .false. + ! collect data into gout on me=0 t call siteswrt_out("sites",IO_SITES,NOUT_SITE, FREQ_SITE, & @@ -630,6 +645,7 @@ subroutine siteswrt_out(fname,io_num,nout,f,nglobal,nlocal, & integer, parameter :: NTYPES = 2 ! No. types, now 2 (sites, sondes) integer :: type=-1 ! = 1 for sites, 2 for sondes integer, save, dimension(NTYPES):: prev_month = (/ -99, -99 /) ! Initialise + integer, save, dimension(NTYPES):: prev_year = (/ -99, -99 /) ! Initialise select case (fname) case ("sites" ) @@ -641,28 +657,32 @@ subroutine siteswrt_out(fname,io_num,nout,f,nglobal,nlocal, & return end select - if ( MasterProc .and. current_date%month /= prev_month(type)) then +! if ( MasterProc .and. current_date%month /= prev_month(type)) then + if (MasterProc .and. current_date%year /= prev_year(type) ) then + + if ( prev_year(type) > 0 ) close(io_num) ! Close last-months file + prev_year(type) = current_date%year + + ! Open new file for write-out - if ( prev_month(type) > 0 ) close(io_num) ! Close last-months file - prev_month(type) = current_date%month + write(suffix,fmt="(i4)") current_date%year + outfile = fname // "_" // suffix // ".csv" - ! Open new file for write-out + open(file=outfile,unit=io_num,action="write",form='FORMATTED') - write(suffix,fmt="(2i2.2)") current_date%month, & - modulo(current_date%year,100) - outfile = fname // "." // suffix - open(file=outfile,unit=io_num,action="write") + write(io_num,"(i3,2x,a,a, 4i4)") nglobal, fname, " in domain",RUNDOMAIN + write(io_num,"(i3,a)") f, " Hours between outputs" - write(io_num,"(i3,2x,a,a, 4i4)") nglobal, fname, " in domain",RUNDOMAIN - write(io_num,"(i3,a)") f, " Hours between outputs" + do n = 1, nglobal + write(io_num,'(a50,3(",",i4))') s_name(n), s_gx(n), s_gy(n),s_gz(n) + end do ! nglobal - write(io_num,"(1(a50,3i4))")(s_name(n), s_gx(n), s_gy(n),s_gz(n),& - n=1,nglobal) + write(io_num,'(i3,a)') size(s_species), " Variables units: ppb" + write(io_num,'(a9,(",",a))')"site,date",(trim(s_species(i)),i=1,size(s_species)) + + endif ! first call - write(io_num,"(i3,a)") size(s_species), " Variables:" - write(io_num,"(1(i3,2x,a))")(n, s_species(n), n=1,size(s_species)) - endif ! New month if ( .not.MasterProc ) then ! send data to me=0 (MasterProc) @@ -695,8 +715,11 @@ subroutine siteswrt_out(fname,io_num,nout,f,nglobal,nlocal, & ! Final output do n = 1, nglobal - write(io_num,"(a20,i5,3i3,i5)") s_name(n), current_date - write(io_num,"(10es11.3)") g_out(:,n) + +!! Massimo Vieno change the ouput style make the output csv + write (io_num,'(a,",",i2.2,"/",i2.2,"/",i4.4," ",i2.2,":00",(",",es10.3))') & + trim(s_name(n)),& + current_date%day,current_date%month,current_date%year,current_date%hour,g_out(:,n) enddo ! n endif ! MasterProc diff --git a/SmallUtils_ml.f90 b/SmallUtils_ml.f90 index 68e077f..316775a 100644 --- a/SmallUtils_ml.f90 +++ b/SmallUtils_ml.f90 @@ -62,7 +62,8 @@ module SmallUtils_ml !=========================================================================== -subroutine wordsplit(text,nword_max,wordarray,nwords,errcode,separator) +subroutine wordsplit(text,nword_max,wordarray,nwords,errcode,separator,& + strict_separator,empty_words) !************************************************************** ! Subroutine takes in a character string and splits it into ! a word-array, of length nwords @@ -75,32 +76,42 @@ subroutine wordsplit(text,nword_max,wordarray,nwords,errcode,separator) character(len=*), dimension(:), intent(out) :: wordarray integer, intent(out) :: nwords ! No. words found - integer, intent(out) :: errcode ! No. words found - character(len=1), optional, intent(in) :: separator ! additional separators + integer, intent(out) :: errcode ! error status + character(len=1), optional, intent(in) :: & + separator, & ! additional separators + strict_separator ! only this separator + logical, optional, intent(in) :: empty_words ! keep empty strings !-- local - logical :: wasinword ! true if we are in or have just left a word + logical :: wasinword,& ! remove leading spaces on request + keep_empty ! keep empty strings on request integer :: i, is, iw - character(len=1) :: c,s + character(len=1) :: c,s(0:3) errcode = 0 wasinword = .false. !To be safe, with spaces at start of line is = 0 ! string index iw = 1 ! Word index - s=' ' - if(present(separator))s=separator + s(:)=(/' ',' ',',',':'/) + if(present(separator))s(0)=separator + if(present(strict_separator))s(:)=strict_separator wordarray(1) = "" + keep_empty=.false. + if(present(empty_words))then + keep_empty=empty_words + wasinword=keep_empty + endif do i = 1, len_trim(text) c = text(i:i) - if( c /= " " .and. c /= "," .and. c /= ":" .and. c /= s ) then + if( all(c/=s) ) then is = is + 1 wordarray(iw)(is:is) = c wasinword = .true. elseif ( wasinword ) then iw = iw + 1 wordarray(iw) = "" - wasinword = .false. + wasinword = keep_empty is = 0 endif enddo @@ -111,6 +122,12 @@ subroutine wordsplit(text,nword_max,wordarray,nwords,errcode,separator) print *,"Too many words" endif +! Remove leading spaces + if(keep_empty.or.present(strict_separator))then + do iw=1,nwords + wordarray(iw)=ADJUSTL(wordarray(iw)) + enddo + endif end subroutine wordsplit !============================================================================ diff --git a/SoilWater_ml.f90 b/SoilWater_ml.f90 index da40a3c..9b1f0b7 100644 --- a/SoilWater_ml.f90 +++ b/SoilWater_ml.f90 @@ -28,10 +28,12 @@ module SoilWater_ml use GridValues_ml, only : debug_proc, debug_li, debug_lj, i_fdom, j_fdom,& longitude => glon - use Landuse_ml, only : water_cover + use Io_Progs_ml, only : PrintLog + use Landuse_ml, only : water_fraction use LocalVariables_ml, only: Grid use Met_ml, only : extendarea - use MetFields_ml, only : SoilWater_deep, nwp_sea, SoilWaterSource + use MetFields_ml, only : SoilWater_deep, nwp_sea, SoilWaterSource,fSW & + ,foundSoilWater_deep ! false if no SW-deep use ModelConstants_ml, only : USE_SOILWATER, DEBUG_SOILWATER use Par_ml, only : limax, ljmax, MAXLIMAX, MAXLJMAX, me use TimeDate_ml, only : current_date, daynumber @@ -63,16 +65,13 @@ module SoilWater_ml ! DO NOT SET TO ZERO! ! real, dimension(366), public, save :: SWP = 0.0 ! daily soil water potential ! in MPa - real,public, save, dimension(MAXLIMAX,MAXLJMAX) :: & - fSW = 1.0 ! fSW= f(relative extractable water) = (sw-swmin)/(swFC-swmin) contains ! WARNING - THE SOIL MOISTURE WORK IS STILL UNDERWAY, AND IS NOT - ! FUNCTIONING FOR THE IFS METEOROLOGY USED IN THE OPENSOURCE 2011 - ! CODE. THE CODE BELOW WORKS FOR PARLAM METEOROLOGY, BUT STILL NEEDS - ! TESTING. RECOMMENDATION = USE_SOILWATER = .false. in ModelConstants_ml + ! FUNCTIONING FOR ALL POSSIBLE METEOROLOGY INPUTS. + ! If in doubt, set USE_SOILWATER = .false. in ModelConstants_ml subroutine Set_SoilWater() integer :: i, j, hourloc logical :: my_first_call = .true. @@ -83,6 +82,12 @@ subroutine Set_SoilWater() current_date%day, current_date%hour, current_date%seconds if ( .not. USE_SOILWATER ) return ! and fSW has been set to 1. at start + if ( .not. foundSoilWater_deep ) then + if( my_first_call ) & + call PrintLog("WARNING: USE_SOILWATER=true, but no deep SW found") + my_first_call = .false. + return ! and fSW has been set to 1. at start + end if ! We reset once per day, but need to loop through the cells to find @@ -98,8 +103,6 @@ subroutine Set_SoilWater() mydebug = ( DEBUG_SOILWATER .and. debug_proc.and. i==debug_li.and.j==debug_lj ) if ( mydebug ) write(*,*) "CHECK_SWF", hourloc, " date ", current_date -!TMP !if ( nwp_sea(i,j) .and. water_cover(i,j) < 0.9 ) then -!TMP if ( water_cover(i,j) < 0.9 ) then if ( my_first_call ) hourloc = 3 ! fake to get started if ( hourloc /= 3 ) cycle ! Only set one per day, at 3am @@ -127,7 +130,7 @@ subroutine Set_SoilWater() REW = SoilWater_deep(i,j,1) !done:/ SoilMAM write(*,"(a,f7.4,i4,f7.4,i4,2f12.4,L8,f12.4)") "DEBUG_SWF: ", & - water_cover(i,j), daynumber, SoilWater_deep(i,j,1), hourloc,& + water_fraction(i,j), daynumber, SoilWater_deep(i,j,1), hourloc,& REW, fSW(i,j), nwp_sea(i,j) end if diff --git a/Solver.f90 b/Solver.f90 index eab8cb0..18eaa15 100644 --- a/Solver.f90 +++ b/Solver.f90 @@ -1,9 +1,10 @@ + ! -!*****************************************************************************! -!* +!*****************************************************************************! +!* !* Copyright (C) 2007-2011 met.no -!* +!* !* Contact information: !* Norwegian Meteorological Institute !* Box 43 Blindern @@ -11,20 +12,20 @@ !* NORWAY !* email: emep.mscw@met.no !* http://www.emep.int -!* +!* !* 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 . -!*****************************************************************************! +!*****************************************************************************! !_____________________________________________________________________________ ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> ! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD @@ -35,8 +36,8 @@ module Chemsolver_ml !=======================================================================! ! The following chemical solver uses variable chemical timesteps and - ! is based on the scheme suggested in J.G. Verwer and D. Simpson (1995) - ! "Explicit methods for stiff ODEs from atmospheric chemistry", + ! is based on the scheme suggested in J.G. Verwer and D. Simpson (1995) + ! "Explicit methods for stiff ODEs from atmospheric chemistry", ! Aplied Numerical Mathematics 18 (1995) 413. ! ! Note that the exact formula used have been re-arranged for greater @@ -45,18 +46,18 @@ module Chemsolver_ml ! Note: decoupling of (NO3,N2O5), (PAN,CH3COO2), (MPAN,MACRO2) ! variable timestep (Peter Wind) !=======================================================================! - - use Aqueous_ml, only: aqrck, ICLOHSO2, ICLRC1, ICLRC2, ICLRC3 - use Biogenics_ml, only: BIO_ISOP, BIO_TERP + + use Aqueous_ml, only: aqrck, ICLOHSO2, ICLRC1, ICLRC2, ICLRC3 use CheckStop_ml, only: CheckStop use DefPhotolysis_ml ! => IDHNO3, etc. - use EmisDef_ml, only: QSSFI, QSSCO, QSSGI - use Emissions_ml, only: KEMISTOP + !ESX use EmisDef_ml, only: QSSFI, QSSCO, QDUFI, QDUCO, QPOL, & + !ESX QROADDUST_FI, QROADDUST_CO + use Emissions_ml, only: KEMISTOP use ChemGroups_ml, only: RO2_POOL, RO2_GROUP use ChemSpecs_tot_ml ! => NSPEC_TOT, O3, NO2, etc. - use Chemfields_ml, only : NSPEC_BGN ! => IXBGN_ indices and xn_2d_bgn + use Chemfields_ml, only : NSPEC_BGN ! => IXBGN_ indices and xn_2d_bgn use ChemRates_rct_ml, only: rct - use ChemRates_rcmisc_ml,only: rcmisc + !ESX use ChemRates_rcmisc_ml,only: rcmisc use GridValues_ml, only : GRIDWIDTH_M use Io_ml, only : IO_LOG, datewrite use ModelConstants_ml, only: KMAX_MID, KCHEMTOP, dt_advec,dt_advec_inv, & @@ -65,13 +66,11 @@ module Chemsolver_ml use Par_ml, only: me, MAXLIMAX, MAXLJMAX use PhysicalConstants_ml, only: RGAS_J use Setup_1dfields_ml, only: rcemis, & ! photolysis, emissions - rc_Rn222, & ! Pb210 - xn_2d, & - rh, & + xn_2d, & + rh, & Fgas, & ! fraction in gas-phase, for SOA - rcss,amk, & ! Sea salt emission rate + amk !FUTURE rcnh3, & ! NH3emis - rcbio ! bvoc use Setup_1dfields_ml, only : itemp, tinv, rh, x=> xn_2d, amk use ChemFunctions_ml, only :VOLFACSO4,VOLFACNO3,VOLFACNH4 !TEST TTTT implicit none @@ -84,7 +83,7 @@ module Chemsolver_ml integer:: STATUS(MPI_STATUS_SIZE),INFO integer, parameter:: nchemMAX=15 integer, parameter:: NUM_INITCHEM=5 ! Number of initial time-steps with shorter dt - real, save:: DT_INITCHEM=20.0 ! shorter dt for initial time-steps, reduced for + real, save:: DT_INITCHEM=20.0 ! shorter dt for initial time-steps, reduced for integer, parameter :: EXTRA_ITER = 1 ! Set > 1 for even more iteration @@ -99,8 +98,8 @@ subroutine chemistry(i,j,debug_flag) integer, intent(in) :: i,j ! Coordinates (needed for Dchem) logical, intent(in) :: debug_flag - real, dimension(NSPEC_TOT,KCHEMTOP:KMAX_MID,MAXLIMAX,MAXLJMAX), save :: & - Dchem=0.0 ! Concentration increments due to chemistry + real, dimension(:,:,:,:), save,allocatable :: & + Dchem ! Concentration increments due to chemistry logical, save :: first_call = .true. @@ -110,12 +109,12 @@ subroutine chemistry(i,j,debug_flag) integer, dimension(KCHEMTOP:KMAX_MID) :: toiter integer :: k, ichem, iter,n ! Loop indices integer, save :: nchem ! No chem time-steps - real :: dt2 + real :: dt2 real :: P, L ! Production, loss terms real :: xextrapol !help variable ! Concentrations : xold=old, x=current, xnew=predicted - ! - dimensioned to have same size as "x" + ! - dimensioned to have same size as "x" real, dimension(NSPEC_TOT) :: & x, xold ,xnew ! Working array [molecules/cm3] @@ -123,11 +122,12 @@ subroutine chemistry(i,j,debug_flag) dti ! variable timestep*(c+1)/(c+2) real, dimension(nchemMAX), save :: & coeff1,coeff2,cc ! coefficients for variable timestep - integer :: nextraiter !====================================================== if ( first_call ) then + allocate( Dchem(NSPEC_TOT,KCHEMTOP:KMAX_MID,MAXLIMAX,MAXLJMAX)) + Dchem=0.0 call makedt(dti,nchem,coeff1,coeff2,cc) if ( MasterProc ) then write(IO_LOG,"(a,i4)") 'Chem dts: nchemMAX: ', nchemMAX @@ -143,15 +143,15 @@ subroutine chemistry(i,j,debug_flag) !====================================================== - !** toiter gives the number of iterations used in TWOSTEP. + !** toiter gives the number of iterations used in TWOSTEP. !** Use more iterations near ground: toiter(KCHEMTOP:5) = 1 ! Upper levels - slow chemistry - toiter(6:KEMISTOP-1) = 2 ! Medium and cloud levels + toiter(6:KEMISTOP-1) = 2 ! Medium and cloud levels toiter(KEMISTOP:KMAX_MID) = 3 ! Near-ground, emis levels ! to get better accuracy if wanted (at CPU cost) - toiter = toiter * EXTRA_ITER + toiter = toiter * EXTRA_ITER !** Establishment of initial conditions: @@ -166,7 +166,7 @@ subroutine chemistry(i,j,debug_flag) x(:) = xn_2d(:,k) - Dchem(:,k,i,j)*dti(1)*1.5 x(:) = max (x(:), 0.0) - + !************************************* ! Start of integration loop * !************************************* @@ -178,6 +178,7 @@ subroutine chemistry(i,j,debug_flag) xextrapol = xnew(n) + (xnew(n)-x(n)) *cc(ichem) xold(n) = coeff1(ichem)*xnew(n) - coeff2(ichem)*x(n) + xold(n) = max( xold(n), 0.0 ) x(n) = xnew(n) xnew(n) = xextrapol @@ -185,7 +186,7 @@ subroutine chemistry(i,j,debug_flag) dt2 = dti(ichem) !*(1.0+cc(ichem))/(1.0+2.0*cc(ichem)) - where ( xnew(:) < CPINIT ) + where ( xnew(:) < CPINIT ) xnew(:) = CPINIT end where @@ -222,14 +223,14 @@ subroutine chemistry(i,j,debug_flag) !endif end do !! End iterations ! Just before SO4, look after slower? species - end if ! DEBUG_DRYRUN !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx include 'CM_Reactions2.inc' !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + end if ! DEBUG_DRYRUN + + end do ! ichem - end do ! ichem - !************************************* ! End of integration loop * !************************************* @@ -240,10 +241,6 @@ subroutine chemistry(i,j,debug_flag) Dchem(:,k,i,j) = (xnew(:) - xn_2d(:,k))*dt_advec_inv xn_2d(:,k) = xnew(:) - if (debug_flag.and.k==KMAX_MID) then - write(*,"(a,2i4,3es10.3)") "SOLVER ", C5H8, BIO_ISOP,& - RCEMIS(C5H8,K), RCBIO(BIO_ISOP,K), xn_2d(C5H8,k) - end if enddo ! End of vertical k-loop @@ -270,9 +267,9 @@ subroutine makedt(dti,nchem,coeff1,coeff2,cc) real, dimension(nchemMAX),intent(out) :: dti,coeff1,coeff2,cc integer, intent(out) :: nchem - real :: ttot,step,dt(nchemMAX) + real :: ttot, dt(nchemMAX) real :: dt_init ! time (seconds) with initially short time-steps - integer :: i,j + integer :: i !_________________________ nchem=nchemMax !number of chemical timesteps inside dt_advec @@ -288,9 +285,9 @@ subroutine makedt(dti,nchem,coeff1,coeff2,cc) !/ Used for >21km resolution and dt_advec>520 seconds: !.. timesteps from 6 to nchem - dt=(dt_advec - dt_init )/(nchem-NUM_INITCHEM) + dt=(dt_advec - dt_init )/(nchem-NUM_INITCHEM) - dt(1:NUM_INITCHEM)=DT_INITCHEM !.. first five timesteps + dt(1:NUM_INITCHEM)=DT_INITCHEM !.. first five timesteps if(dt_advec<= dt_init )then nchem=int(dt_advec/DT_INITCHEM)+1 @@ -322,7 +319,7 @@ subroutine makedt(dti,nchem,coeff1,coeff2,cc) endif -!.. Help variables from Verwer & Simpson +!.. Help variables from Verwer & Simpson cc(1)=1.0 coeff2(1)=1.0/(cc(1)**2+2*cc(1)) coeff1(1)=(cc(1)+1)**2*coeff2(1) diff --git a/StoFlux_ml.f90 b/StoFlux_ml.f90 index ef1948c..4166dbb 100644 --- a/StoFlux_ml.f90 +++ b/StoFlux_ml.f90 @@ -50,9 +50,6 @@ module StoFlux_ml lai_flux, & ! Fluxes to total LAI unit_flux ! Fluxes per m2 of leaf area (flag-leaf) - !real, public,save,dimension(MAXLIMAX,MAXLJMAX) :: & - ! SumVPD , & ! For critical VPD calcs, reset each day - ! old_gsun ! real, public,save, allocatable,dimension(:,:,:) :: & SumVPD , & ! For critical VPD calcs, reset each day old_gsun ! diff --git a/SubMet_ml.f90 b/SubMet_ml.f90 index 7d23926..d0d51e9 100644 --- a/SubMet_ml.f90 +++ b/SubMet_ml.f90 @@ -34,6 +34,9 @@ module SubMet_ml ! The sub-grid part of this module is also undergoing constant change!! !============================================================================= +use CheckStop_ml, only: StopAll +use Functions_ml, only : T_2_Tpot !needed if FluxPROFILE == Ln95 +use MetFields_ml, only : ps !needed if FluxPROFILE == Ln95 use BLPhysics_ml, only : MIN_USTAR_LAND use CheckStop_ml, only : CheckStop @@ -41,14 +44,17 @@ module SubMet_ml use Landuse_ml, only: LandCover use LocalVariables_ml, only: Grid, Sub use MicroMet_ml, only : PsiM, AerRes !functions +use MicroMet_ml, only : Launiainen1995 use ModelConstants_ml, only : DEBUG_SUBMET & ! Needs DEBUG_RUNCHEM to get debug_flag + , USE_ZREF & ! TEST + , FluxPROFILE & + , LANDIFY_MET & , USE_SOILWATER use PhysicalConstants_ml, only : PI, RGAS_KG, CP, GRAV, KARMAN, CHARNOCK, T0 implicit none private - public :: Get_Submet ! calculates met. data for sub-grid areas contains @@ -114,10 +120,11 @@ subroutine Get_Submet(iL, debug_flag ) real :: e ! vapour pressure at surface real :: Ra_2m ! to get 2m qw +real :: theta2 + ! initial guesses for u*, t*, 1/L Sub(iL)%ustar = Grid%ustar ! First guess = NWP value - !FEB2009 Sub(iL)%invL = Grid%invL ! First guess = NWP value Sub(iL)%invL = 0.0 ! Start at neutral... Sub(iL)%Hd = Grid%Hd ! First guess = NWP value Sub(iL)%LE = Grid%LE ! First guess = NWP value @@ -128,17 +135,21 @@ subroutine Get_Submet(iL, debug_flag ) Sub(iL)%is_water = LandType(iL)%is_water Sub(iL)%is_forest = LandType(iL)%is_forest + Sub(iL)%is_crop = LandType(iL)%is_crop if( USE_SOILWATER ) Sub(iL)%fSW = Grid%fSW ! If NWP thinks this is a sea-square, but we anyway have land, ! the surface temps will be wrong and so will stability gradients. - ! As a simple substitute, we assume neutral conditions for these + ! Use of LANDIFY_MET should have corrected this to some extent. If + ! not in use, as a simple substitute, we assume neutral conditions for these ! situations. - if( Grid%is_NWPsea .and. (.not. Sub(iL)%is_water) ) then - Sub(iL)%invL = 0.0 - Sub(iL)%Hd = 0.0 - end if + + if ( .not. LANDIFY_MET .and. & + Grid%is_NWPsea .and. (.not. Sub(iL)%is_water) ) then + Sub(iL)%invL = 0.0 + Sub(iL)%Hd = 0.0 + end if ! The zero-plane displacement (d) is the height that @@ -164,6 +175,7 @@ subroutine Get_Submet(iL, debug_flag ) ! relation is only valid for u* < 1 m/s, which gives z0 < 1 cm/s. + if ( Sub(iL)%is_water ) then ! water Sub(iL)%d = 0.0 Sub(iL)%z0 = CHARNOCK * Sub(iL)%ustar * Sub(iL)%ustar/GRAV @@ -174,11 +186,11 @@ subroutine Get_Submet(iL, debug_flag ) z_3m = 3.0 ! 3m above sea surface else if ( Sub(iL)%is_forest ) then ! forest - ! We restrict z0 to 0.5m, since comparison with CarboEurope - ! results shows that this provides the best u* values for + ! We restrict z0 to 1.0m, since comparison with CarboEurope + ! results shows that this provides better u* values for ! forests. Sub(iL)%d = 0.78 * Sub(iL)%hveg ! Jarvis, 1976 - Sub(iL)%z0 = min( 0.07 * Sub(iL)%hveg, 0.5 ) + Sub(iL)%z0 = min( 0.07 * Sub(iL)%hveg, 1.0 ) z_1m = (Sub(iL)%hveg + 1.0) - Sub(iL)%d z_3m = max(3.0,Sub(iL)%hveg) else @@ -193,12 +205,17 @@ subroutine Get_Submet(iL, debug_flag ) end if - Sub(iL)%z_refd = Grid%z_ref - Sub(iL)%d ! minus displacement height + if ( USE_ZREF ) then !EXPERIMENTAL. Not recommended so far + Sub(iL)%z_refd = Grid%z_ref + else + Sub(iL)%z_refd = Grid%z_ref - Sub(iL)%d ! minus displacement height + end if z_3md = z_3m - Sub(iL)%d ! minus displacement height rho_surf = Grid%psurf/(RGAS_KG * Sub(iL)%t2 ) + if( Grid%is_allNWPsea ) then Sub(iL)%ustar = Grid%ustar Sub(iL)%invL = Grid%invL @@ -208,6 +225,32 @@ subroutine Get_Submet(iL, debug_flag ) !TEST if ( Grid%Hd > -1 ) NITER = 2 ! Almost neutral to unstable !TEST if ( Grid%Hd > 1 ) NITER = 4 ! more unstable + if ( FluxPROFILE == "Ln95") then !TESTING + + theta2 = Grid%t2 * T_2_Tpot( Grid%psurf ) + call Launiainen1995( Grid%u_ref, Sub(iL)%z_refd, Sub(iL)%z0, Sub(iL)%z0, & + theta2, Grid%theta_ref, Sub(iL)%invL ) + + Sub(iL)%ustar = Grid%u_ref * KARMAN/ & + (log( Sub(iL)%z_refd/Sub(iL)%z0 ) - PsiM( Sub(iL)%z_refd*Sub(iL)%invL)& + + PsiM( Sub(iL)%z0*Sub(iL)%invL ) ) + + if ( DEBUG_SUBMET .and. debug_flag ) then + write(6,"(a12,i2,i3,5f8.3,10f12.3)") "VDHH SUBI", iter,iL, & + Sub(iL)%hveg, Sub(iL)%z0, Sub(iL)%d, & + Sub(iL)%z_refd, z_3md, & + Sub(iL)%invL, Sub(iL)%ustar, Grid%invL, Grid%ustar + write(6,"(a12,i2,i3,5f8.3,10f12.3)") "VDHH ZZZZ", iter,iL, & + Grid%z_mid, Grid%z_ref, Sub(iL)%z_refd + end if + + if( DEBUG_SUBMET .and. & + Sub(iL)%invL > 10.0 .or. Sub(iL)%invL < -10.0 ) then + call CheckStop("FluxPROFILE STOP") + end if + + else if ( FluxPROFILE == "Iter" ) then + do iter = 1, NITER ! **** @@ -219,17 +262,11 @@ subroutine Get_Submet(iL, debug_flag ) !..L=F(u*), since we do not know the EMEP subgrid averaged !..z0-values ... - if ( DEBUG_SUBMET .and. debug_flag ) then - write(6,"(a12,i2,5f8.3,10f12.3)") "UKDEP SUBI", iter, & + if ( DEBUG_SUBMET .and. debug_flag ) then + write(6,"(a12,i2,i3,5f8.3,2f12.3)") "SUBMET ITER", iter,iL, & Sub(iL)%hveg, Sub(iL)%z0, Sub(iL)%d, & Sub(iL)%z_refd, z_3md, Sub(iL)%invL, Sub(iL)%ustar - end if - - !FEB2009 Sub(iL)%ustar = Grid%u_ref * KARMAN/ & - !FEB2009 (log( Sub(iL)%z_refd/Sub(iL)%z0 ) - PsiM( Sub(iL)%z_refd*Sub(iL)%invL)& - !FEB2009 + PsiM( Sub(iL)%z0*Sub(iL)%invL ) ) - - !FEB2009 Sub(iL)%ustar = max( Sub(iL)%ustar, 1.0e-2) + end if ! We must use L (the Monin-Obukhov length) to calculate deposition, ! Thus, we calculate T* and then L, based on sub-grid data. @@ -242,31 +279,43 @@ subroutine Get_Submet(iL, debug_flag ) !.. we limit the range of 1/L to prevent numerical and printout problems ! This range is very wide anyway. - !FEB2009 Sub(iL)%invL = max( -1.0, Sub(iL)%invL ) !! limit very unstable + ! Sub(iL)%invL = max( -1.0, Sub(iL)%invL ) !! limit very unstable ! Sub(iL)%invL = min( 1.0, Sub(iL)%invL ) !! limit very stable ! To a good approx we could omit the PsiM(z0/L) term, but needed at ca. invL->-1 - Sub(iL)%ustar = Grid%u_ref * KARMAN/ & - (log( Sub(iL)%z_refd/Sub(iL)%z0 ) & - - PsiM( Sub(iL)%z_refd*Sub(iL)%invL) & - + PsiM( Sub(iL)%z0*Sub(iL)%invL )) + Sub(iL)%ustar = Grid%u_ref * KARMAN/ & + (log( Sub(iL)%z_refd/Sub(iL)%z0 ) & + - PsiM( Sub(iL)%z_refd*Sub(iL)%invL) & + + PsiM( Sub(iL)%z0*Sub(iL)%invL )) + + if ( DEBUG_SUBMET .and. debug_flag ) then + write(6,"(a12,i2,i3,5f8.3,2f12.3)") "SUBMET ITERi ", iter,iL, & + Sub(iL)%hveg, Sub(iL)%z0, Sub(iL)%d, & + Sub(iL)%z_refd, z_3md, Sub(iL)%invL, Sub(iL)%ustar + write(6,"(a12,i3,3f7.1,20g11.3)") "SUBMET ITERA ",iL, & + Sub(iL)%z0, Sub(iL)%d, & + Sub(iL)%z_refd, 0.001*Grid%psurf, Sub(iL)%t2, rho_surf, & + Sub(iL)%Hd, Sub(iL)%ustar, Sub(iL)%invL , & + log( Sub(iL)%z_refd/Sub(iL)%z0 ), & + PsiM( Sub(iL)%z_refd*Sub(iL)%invL ) + end if - if ( DEBUG_SUBMET .and. debug_flag ) then - write(6,"(a12,20f9.3)") "UKDEP SUBA", Sub(iL)%z0, Sub(iL)%d, & - Sub(iL)%z_refd, 0.001*Grid%psurf, Sub(iL)%t2, rho_surf, Sub(iL)%Hd,& - Sub(iL)%ustar, Sub(iL)%invL - ! , & log( Sub(iL)%z_refd/Sub(iL)%z0 ), & PsiM( Sub(iL)%z_refd*Sub(iL)%invL ) - end if Sub(iL)%ustar = max( Sub(iL)%ustar, MIN_USTAR_LAND ) end do ! iter - end if ! allNWPsea + else + call StopAll("Incorrect FluxPROFILE") + + end if ! FluxPROFILE + end if ! allNWPsea if ( DEBUG_SUBMET .and. debug_flag ) then - write(6,"(a12,10f9.3)") "UKDEP SUBL", Sub(iL)%z0, Sub(iL)%d, & - Sub(iL)%z_refd, 0.001*Grid%psurf, Sub(iL)%t2, rho_surf, Sub(iL)%Hd,& - Sub(iL)%ustar, Sub(iL)%t2, Sub(iL)%invL + write(6,"(a12,10f9.3)") "SUBMET" // trim(FluxProfile), Sub(iL)%z0, & + Sub(iL)%d, Sub(iL)%z_refd, 0.001*Grid%psurf, Sub(iL)%t2, rho_surf, & + Sub(iL)%Hd, Sub(iL)%ustar, Sub(iL)%t2, Sub(iL)%invL + write(*,*) "UKDEP LOGICS ", iL, & + Sub(iL)%is_water, Sub(iL)%is_forest, Grid%is_allNWPsea if ( my_first_call ) then ! title line diff --git a/TimeDate_ExtraUtil_ml.f90 b/TimeDate_ExtraUtil_ml.f90 index 7d771aa..c2b395a 100644 --- a/TimeDate_ExtraUtil_ml.f90 +++ b/TimeDate_ExtraUtil_ml.f90 @@ -32,7 +32,7 @@ MODULE TimeDate_ExtraUtil_ml use My_Outputs_ml, only: FREQ_HOURLY use TimeDate_ml, only: max_day,tdif_secs,tdif_days,add_secs,add_days,& ts2date=>make_current_date,date2ts=>make_timestamp,& - date,timestamp,startdate,enddate + timestamp,day_of_year,date,startdate,enddate use CheckStop_ml, only: CheckStop IMPLICIT NONE @@ -41,21 +41,33 @@ MODULE TimeDate_ExtraUtil_ml public :: & assign_NTERM, & ! set NTERM, the number of 3-hourly periods date2string, & ! date (various formats) --> formatted string + string2date, & ! formatted string & format (pattern) --> date (CD format) idate2nctime, & ! idate (int array)--> secs since(int)/days since(real) nctime2idate, & ! idate2nctime inverse + date2nctime, & ! date (various formats)--> secs since(int)/days since(real) + nctime2date, & ! date2nctime inverse nctime2string ! as date2string, but from secs/days since... interface date2string - module procedure detail2str,cd2str,int2str,ts2str + module procedure detail2str,cd2str,int2str,ts2str,cd2str_add,int2str_add end interface date2string interface idate2nctime - module procedure idate_to_secs1970,idate_to_days1900 + module procedure int_to_secs1970,int_to_days1900 end interface idate2nctime interface nctime2idate - module procedure secs1970_to_idate,days1900_to_idate + module procedure secs1970_to_int,days1900_to_int end interface nctime2idate +interface date2nctime + module procedure ts_to_secs1970,cd_to_secs1970,int_to_secs1970,& + ts_to_days1900,cd_to_days1900,int_to_days1900 +end interface date2nctime + +interface nctime2date + module procedure secs1970_to_ts,secs1970_to_cd,secs1970_to_int,& + days1900_to_ts,days1900_to_cd,days1900_to_int +end interface nctime2date interface nctime2string module procedure secs2str,days2str @@ -67,14 +79,15 @@ MODULE TimeDate_ExtraUtil_ml nctime_key ="12345678.12" private :: & - key2str, & ! basic keyword substitution + key2str,str2key, & ! basic keyword substitution ikey2str,rkey2str,& ! auxiliary keyword substitution tools - detail2str, & ! detailed date input--> formatted string - cd2str,int2str,ts2str, & ! date/idate (int array)/timestamp --> formatted string - idate_to_secs1970,& ! idate (int array)--> secs since 1970-01-01 00:00 UTC (int) - idate_to_days1900,& ! idate (int array)--> days since 1900-01-01 00:00 UTC (real) - secs1970_to_idate,& ! idate_to_secs1970 inverse - days1900_to_idate,& ! idate_to_days1900 inverse + detail2str,str2detail, & ! detailed date input<--> formatted string + cd2str,int2str,ts2str, & ! date/idate (int array)/timestamp --> formatted string + cd2str_add,int2str_add,& ! optional addsecs parameter + ts_to_secs1970,cd_to_secs1970,int_to_secs1970,& ! * --> secs since 1970-01-01 00:00 UTC (int) + ts_to_days1900,cd_to_days1900,int_to_days1900,& ! * --> days since 1900-01-01 00:00 UTC (real) + secs1970_to_ts,secs1970_to_cd,secs1970_to_int,& ! *_to_secs1970 inverse + days1900_to_ts,days1900_to_cd,days1900_to_int,& ! *_to_days1900 inverse to_stamp, & ! extended interface for make_timestamp (TimeDate_ml) to_date, & ! extended interface for make_current_date (TimeDate_ml) to_idate, & ! create int array from timestap or date @@ -110,6 +123,7 @@ function int2date (id) result (cd) case (3); cd=date(id(1),id(2),id(3),0,0) case (4); cd=date(id(1),id(2),id(3),id(4),0) case (5); cd=date(id(1),id(2),id(3),id(4),id(5)) + case (6); cd=date(id(1),id(2),id(3),id(4),id(5)*60+id(6)) case default; cd=date(-1,-1,-1,-1,-1) call CheckStop("ERROR in int2date: undetermined date") end select @@ -149,6 +163,16 @@ subroutine init_ts() ts1900=to_stamp(date(1900,1,1,0,0)) end subroutine init_ts +function str2key(str,fmt,key) result(val) + implicit none + character(len=*), intent(in) :: str,fmt,key + integer :: val + integer :: ind=0 + val=0 + ind=index(fmt,trim(key)) + if(ind>0)read(str(ind:ind+len_trim(key)-1),*)val +end function str2key + function ikey2str(iname,key,val) result(fname) implicit none character(len=*), intent(in) :: iname,key @@ -187,12 +211,51 @@ function rkey2str(iname,key,val) result(fname) enddo end function rkey2str -function detail2str(iname,year,month,day,hour,seconds,minute,second,& +subroutine str2detail(str,fmt,year,month,day,hour,seconds,minute,second,days,& + fstep,ntme,nlev,nlat,nlon,debug) + implicit none + character(len=*), intent(in) :: str,fmt + integer,intent(out),optional :: year,month,day,hour,seconds,& + minute,second,days,& + fstep,ntme,nlev,nlat,nlon + logical, intent(in),optional :: debug + if(present(seconds))seconds=str2key(str,fmt,'ssss')& + +str2key(str,fmt,'ss' )& + +str2key(str,fmt,'mm' )*60 + if(present(second ))second =str2key(str,fmt,'ss' ) + if(present(minute ))minute =str2key(str,fmt,'mm' ) + if(present(hour ))hour =str2key(str,fmt,'hh' ) + if(present(day ))day =str2key(str,fmt,'DD' ) + if(present(month ))month =str2key(str,fmt,'MM' ) + if(present(year ))year =str2key(str,fmt,'YYYY') +! if(present(year ))year =str2key(str,fmt,'YY' )+1900 + if(present(days ))days =str2key(str,fmt,'JJJ' ) ! day of the year + if(present(nlon ))nlon =str2key(str,fmt,'LON' ) + if(present(nlat ))nlat =str2key(str,fmt,'LAT' ) + if(present(nlev ))nlev =str2key(str,fmt,'LL' ) + if(present(ntme ))ntme =str2key(str,fmt,'TTT' ) + if(present(fstep ))fstep =str2key(str,fmt,'FFF' ) + if(present(debug))then + if(debug) write(*,*)'string2date: ',trim(str),'/',trim(fmt) + endif +end subroutine str2detail + +function string2date(str,fmt,debug) result(cd) + implicit none + character(len=*), intent(in) :: str,fmt + logical, intent(in), optional :: debug + type(date) :: cd + call str2detail(str,fmt,year=cd%year,month=cd%month,day=cd%day,& + hour=cd%hour,seconds=cd%seconds,debug=debug) +end function string2date + +function detail2str(iname,year,month,day,hour,seconds,minute,second,days,& fstep,ntme,nlev,nlat,nlon,debug) result(fname) implicit none character(len=*), intent(in) :: iname character(len=len(iname)) :: fname - integer, intent(in),optional :: year,month,day,hour,seconds,minute,second,& + integer, intent(in),optional :: year,month,day,hour,seconds,& + minute,second,days,& fstep,ntme,nlev,nlat,nlon logical, intent(in),optional :: debug fname=iname @@ -204,13 +267,14 @@ function detail2str(iname,year,month,day,hour,seconds,minute,second,& if(present(month ))fname=key2str(fname,'MM' ,month ) if(present(year ))fname=key2str(fname,'YYYY',year ) if(present(year ))fname=key2str(fname,'YY' ,mod(year,100)) + if(present(days ))fname=key2str(fname,'JJJ' ,days ) ! day of the year if(present(nlon ))fname=key2str(fname,'LON' ,nlon ) if(present(nlat ))fname=key2str(fname,'LAT' ,nlat ) if(present(nlev ))fname=key2str(fname,'LL' ,nlev ) if(present(ntme ))fname=key2str(fname,'TTT' ,ntme ) if(present(fstep ))fname=key2str(fname,'FFF' ,fstep ) if(present(debug))then - if(debug) print *,'date2string: ',trim(iname),'-->',trim(fname) + if(debug) write(*,*)'date2string: ',trim(iname),'-->',trim(fname) endif end function detail2str @@ -223,6 +287,8 @@ function cd2str(iname,cd,debug) result(fname) fname=detail2str(iname,year=cd%year,month=cd%month,day=cd%day,& hour=cd%hour,seconds=cd%seconds,& minute=cd%seconds/60,second=mod(cd%seconds,60),& + days=day_of_year(cd%year,cd%month,cd%day),& + fstep=nint(tdif_days(to_stamp(startdate),to_stamp(cd))*24),& debug=debug) end function cd2str @@ -235,82 +301,195 @@ function int2str(iname,id,debug) result(fname) fname=cd2str(iname,to_date(id),debug=debug) end function int2str -function ts2str(iname,ts,debug) result(fname) +! function ts2str(iname,ts,debug) result(fname) +! implicit none +! character(len=*), intent(in) :: iname +! character(len=len(iname)) :: fname +! type(timestamp), intent(in) :: ts +! logical, intent(in), optional :: debug +! fname=cd2str(iname,to_date(ts),debug=debug) +! end function ts2str + +function ts2str(iname,ts,addsecs,debug) result(fname) implicit none character(len=*), intent(in) :: iname character(len=len(iname)) :: fname type(timestamp), intent(in) :: ts + real, intent(in), optional :: addsecs logical, intent(in), optional :: debug - fname=cd2str(iname,to_date(ts),debug=debug) + type(timestamp) :: tts + tts=ts + if(present(addsecs))call add_secs(tts,addsecs) + fname=cd2str(iname,to_date(tts),debug=debug) end function ts2str -subroutine idate_to_secs1970(idate,nsecs,iotyp) +function cd2str_add(iname,cd,addsecs,debug) result(fname) + character(len=*), intent(in) :: iname + character(len=len(iname)) :: fname + type(date),intent(in) :: cd + real, intent(in) :: addsecs + logical, intent(in), optional :: debug + fname=ts2str(iname,to_stamp(cd),addsecs=addsecs,debug=debug) +end function cd2str_add + +function int2str_add(iname,id,addsecs,debug) result(fname) + implicit none + character(len=*), intent(in) :: iname + character(len=len(iname)) :: fname + integer, intent(in), dimension(:) :: id + real, intent(in) :: addsecs + logical, intent(in), optional :: debug + fname=ts2str(iname,to_stamp(id),addsecs=addsecs,debug=debug) +end function int2str_add + +subroutine ts_to_secs1970(ts,nsecs,iotyp) !calculate how many seconds have passed since the start of the year 1970 - integer, intent(in), dimension(:) :: idate + type(timestamp), intent(in) :: ts integer, intent(out) :: nsecs integer, optional, intent(in) :: iotyp + type(date) :: cd if(first_call)call init_ts() - nsecs=tdif_secs(ts1970,to_stamp(idate)) - call CheckStop(nsecs<0,"ERROR in idate_to_secs1970: date previous to 1970-01-01") + nsecs=tdif_secs(ts1970,ts) + call CheckStop(nsecs<0,"ERROR in date2nctime: date previous to 1970-01-01") if(present(iotyp))then select case (iotyp) !middle of period: NB WORKS ONLY FOR COMPLETE PERIODS - case (IOU_MON ); nsecs=nsecs-spd/2*max_day(idate(2),idate(1)) !#days(jan)=#days(dec) + case (IOU_MON ); cd=to_date(ts) + nsecs=nsecs-spd/2*max_day(cd%month,cd%year) !#days(jan)=#days(dec) case (IOU_DAY ); nsecs=nsecs-spd/2 case (IOU_HOUR_MEAN); nsecs=nsecs-sph/2*FREQ_HOURLY end select endif -end subroutine idate_to_secs1970 +end subroutine ts_to_secs1970 + +subroutine cd_to_secs1970(cd,nsecs,iotyp) +!calculate how many seconds have passed since the start of the year 1970 + type(date), intent(in) :: cd + integer, intent(out) :: nsecs + integer, optional, intent(in) :: iotyp -subroutine idate_to_days1900(idate,ndays,iotyp) + call ts_to_secs1970(to_stamp(cd),nsecs,iotyp=iotyp) +end subroutine cd_to_secs1970 + +subroutine int_to_secs1970(id,nsecs,iotyp) +!calculate how many seconds have passed since the start of the year 1970 + integer, intent(in), dimension(:) :: id + integer, intent(out) :: nsecs + integer, optional, intent(in) :: iotyp + + call ts_to_secs1970(to_stamp(id),nsecs,iotyp=iotyp) +end subroutine int_to_secs1970 + +subroutine ts_to_days1900(ts,ndays,iotyp) ! calculate how many days have passed since the start of the year 1900 - integer, intent(in), dimension(:) :: idate + type(timestamp), intent(in) :: ts real(kind=8), intent(out) :: ndays integer, optional, intent(in) :: iotyp + type(date) :: cd if(first_call)call init_ts() - ndays=tdif_days(ts1900,to_stamp(idate)) - call CheckStop(ndays<0,"ERROR in idate_to_days1900: date previous to 1900-01-01") + ndays=tdif_days(ts1900,ts) + call CheckStop(ndays<0,"ERROR in date2nctime: date previous to 1900-01-01") if(present(iotyp))then select case (iotyp) !middle of period: NB WORKS ONLY FOR COMPLETE PERIODS - case (IOU_MON ); ndays=ndays-0.5*max_day(idate(2),idate(1)) + case (IOU_MON ); cd=to_date(ts) + ndays=ndays-0.5*max_day(cd%month,cd%year) !#days(jan)=#days(dec) case (IOU_DAY ); ndays=ndays-0.5 case (IOU_HOUR_MEAN); ndays=ndays-FREQ_HOURLY/48.0 !1.0/48.0=half hour end select endif -end subroutine idate_to_days1900 +end subroutine ts_to_days1900 -subroutine secs1970_to_idate(idate,nsecs,msg) +subroutine cd_to_days1900(cd,ndays,iotyp) +! calculate how many days have passed since the start of the year 1900 + type(date), intent(in) :: cd + real(kind=8), intent(out) :: ndays + integer, optional, intent(in) :: iotyp + + call ts_to_days1900(to_stamp(cd),ndays,iotyp=iotyp) +end subroutine cd_to_days1900 + +subroutine int_to_days1900(id,ndays,iotyp) +! calculate how many days have passed since the start of the year 1900 + integer, intent(in), dimension(:) :: id + real(kind=8), intent(out) :: ndays + integer, optional, intent(in) :: iotyp + + call ts_to_days1900(to_stamp(id),ndays,iotyp=iotyp) +end subroutine int_to_days1900 + +subroutine secs1970_to_ts(ts,nsecs,msg) !calculate date from seconds that have passed since the start of the year 1970 - integer, intent(out), dimension(:) :: idate + type(timestamp), intent(out) :: ts integer, intent(in) :: nsecs character(len=*), intent(in), optional :: msg - type(timestamp) :: ts if(first_call)call init_ts() ts=ts1970 call add_days(ts,nsecs/spd) - idate=to_idate(ts,size(idate)) - if(present(msg)) print *,date2string(msg,idate) -end subroutine secs1970_to_idate + if(present(msg)) write(*,*)date2string(msg,ts) +end subroutine secs1970_to_ts + +subroutine secs1970_to_cd(cd,nsecs,msg) +!calculate date from seconds that have passed since the start of the year 1970 + type(date), intent(out) :: cd + integer, intent(in) :: nsecs + character(len=*), intent(in), optional :: msg + type(timestamp) :: ts + + call secs1970_to_ts(ts,nsecs,msg=msg) + cd=to_date(ts) +end subroutine secs1970_to_cd -subroutine days1900_to_idate(idate,ndays,msg) +subroutine secs1970_to_int(id,nsecs,msg) +!calculate date from seconds that have passed since the start of the year 1970 + integer, intent(out), dimension(:) :: id + integer, intent(in) :: nsecs + character(len=*), intent(in), optional :: msg + type(timestamp) :: ts + + call secs1970_to_ts(ts,nsecs,msg=msg) + id=to_idate(ts,size(id)) +end subroutine secs1970_to_int + +subroutine days1900_to_ts(ts,ndays,msg) !calculate date from seconds that have passed since the start of the year 1900 - integer, intent(out), dimension(:) :: idate + type(timestamp), intent(out) :: ts real(kind=8), intent(in) :: ndays character(len=*), intent(in), optional :: msg - type(timestamp) :: ts if(first_call)call init_ts() ts=ts1900 call add_days(ts,ndays) - idate=to_idate(ts,size(idate)) - if(present(msg)) print *,date2string(msg,idate) -end subroutine days1900_to_idate + if(present(msg)) write(*,*)date2string(msg,ts) +end subroutine days1900_to_ts + +subroutine days1900_to_cd(cd,ndays,msg) +!calculate date from seconds that have passed since the start of the year 1900 + type(date), intent(out) :: cd + real(kind=8), intent(in) :: ndays + character(len=*), intent(in), optional :: msg + type(timestamp) :: ts + + call days1900_to_ts(ts,ndays,msg=msg) + cd=to_date(ts) +end subroutine days1900_to_cd + +subroutine days1900_to_int(id,ndays,msg) +!calculate date from seconds that have passed since the start of the year 1900 + integer, intent(out), dimension(:) :: id + real(kind=8), intent(in) :: ndays + character(len=*), intent(in), optional :: msg + type(timestamp) :: ts + + call days1900_to_ts(ts,ndays,msg=msg) + if(size(id)<=4)ts%secs=ts%secs+0.1!correct for rounding errors + id=to_idate(ts,size(id)) +end subroutine days1900_to_int function secs2str(iname,nsecs,debug) result(fname) implicit none diff --git a/TimeDate_ml.f90 b/TimeDate_ml.f90 index 3a8a0c8..cfce9df 100644 --- a/TimeDate_ml.f90 +++ b/TimeDate_ml.f90 @@ -122,7 +122,7 @@ FUNCTION make_current_date (ts) RESULT (cd) INTEGER :: yy,mm,dd,hh,min,sc call get_ymd(ts%jdate,yy,mm,dd) call get_hms(ts%secs,hh,min,sc) - cd=date(yy,mm,dd,hh,min*60.0+sc) + cd=date(yy,mm,dd,hh,min*60+sc) END FUNCTION make_current_date SUBROUTINE dup_timestamp (ts1,ts2) diff --git a/Timefactors_ml.f90 b/Timefactors_ml.f90 index ec04e20..0baa203 100644 --- a/Timefactors_ml.f90 +++ b/Timefactors_ml.f90 @@ -2,7 +2,7 @@ ! Chemical transport Model> !*****************************************************************************! !* -!* Copyright (C) 2007-2011 met.no +!* Copyright (C) 2007-2012 met.no !* !* Contact information: !* Norwegian Meteorological Institute @@ -43,20 +43,32 @@ module Timefactors_ml ! ! Sets the day/night emissions variation in day_factor ! -! D. Simpson, 3/2/99 +! D. Simpson, 3/2/99-11 0 H. Fagerli, 2011 !_____________________________________________________________________________ + use CheckStop_ml, only : CheckStop use Country_ml, only : NLAND - use My_Emis_ml, only : NEMIS_FILES, EMIS_NAME - use EmisDef_ml, only : NSECTORS + use EmisDef_ml, only : NSECTORS, NEMIS_FILE, EMIS_FILE, ISNAP_DOM + use GridValues_ml , only : i_fdom,j_fdom, debug_proc,debug_li,debug_lj + use Met_ml, only : Getmeteofield + use ModelConstants_ml, only : MasterProc, DEBUG => DEBUG_EMISTIMEFACS + use ModelConstants_ml, only : IIFULLDOM, JJFULLDOM + use ModelConstants_ml, only : iyr_trend + use ModelConstants_ml, only : INERIS_SNAP1, INERIS_SNAP2 + use NetCDF_ml, only : GetCDF + use Par_ml, only : MAXLIMAX,MAXLJMAX, me, li0, lj0, li1, lj1 + use Par_ml, only : IRUNBEG, JRUNBEG, MSG_READ8 + use PhysicalConstants_ml, only : PI + use Io_ml, only : & + open_file, & ! subroutine + check_file, & ! subroutine + PrintLog, & + ios, IO_TIMEFACS ! i/o error number, i/o label use TimeDate_ml, only: & ! subroutine, sets: date, & ! date-type definition nmdays, nydays, & ! days per month (12), days per year day_of_week,& ! weekday day_of_year ! day count in year - use Io_ml, only : & - open_file, & ! subroutine - ios, IO_TIMEFACS ! i/o error number, i/o label implicit none private @@ -65,21 +77,36 @@ module Timefactors_ml public :: NewDayFactors public :: timefactors + public :: DegreeDayFactors !-- time factor stuff: real, public, save, & - dimension(NLAND,NSECTORS,NEMIS_FILES) :: timefac ! overall emission + dimension(NLAND,NSECTORS,NEMIS_FILE) :: timefac ! overall emission ! timefactor ! calculated daily real, public, save, & - dimension(NLAND,12,NSECTORS,NEMIS_FILES) :: fac_emm ! Monthly factors + dimension(NLAND,12,NSECTORS,NEMIS_FILE) :: fac_emm ! Monthly factors + + ! Hourly for each day ! From EURODELTA/INERIS real, public, save, & - dimension(NLAND, 7,NSECTORS,NEMIS_FILES) :: fac_edd ! Daily factors + dimension(NSECTORS,24,7) :: fac_ehh24x7 ! Hour factors for 7 days - real, public, save, dimension(NSECTORS,0:1):: day_factor ! Day/night factor + ! We keep track of min value for degree-day work + ! + real, public, save, & + dimension(NLAND,NSECTORS,NEMIS_FILE) :: fac_min ! Min of Monthly factors + ! + real, public, save, & + dimension(12) :: fac_cemm ! Change in monthly factors over the years - logical, private, parameter :: DEBUG = .false. + real, public, save, & + dimension(NLAND, 7,NSECTORS,NEMIS_FILE) :: fac_edd ! Daily factors + + ! Heating-degree day factor for SNAP-2. Independent of country: + logical, public, save :: Gridded_SNAP2_Factors = .false. + real, public, allocatable,dimension (:,:), save :: gridfac_HDD + !real, private, dimension (MAXLIMAX,MAXLJMAX), save :: tmpt2 ! Used for general file calls and mpi routines below @@ -107,33 +134,19 @@ subroutine timefactors(year) !-- local integer :: inland, insec ! Country and sector value read from femis - integer :: i, ic, isec, n, idd, iday, mm, mm2 ! Loop and count variables + integer :: i, ic, isec, n + integer :: idd, idd2, ihh, iday, mm, mm2 ! Loop and count variables integer :: iemis ! emission count variables integer :: weekday ! 1=monday, 2=tuesday etc. real :: xday, sumfac ! used in interpolation, testing + real :: tmp24(24) ! used for hourly factors character(len=100) :: errmsg + character(len=200) :: inputline + real :: fracchange + real, dimension(NLAND,NEMIS_FILE):: sumfacc !factor to normalize monthly changes - -! Factor giving nighttime emission ratio. -! Note this is hard-coded with NSECTORS=11. - - real, parameter, dimension(NSECTORS) :: & - DAY_NIGHT = (/ & - 1.0 &! 1. Power production - , 0.8 &! 2. Comm/res. combustion - , 0.8 &! 3. Industrial combustion - , 1.0 &! 4. Non-industrial combustion - , 1.0 &! 5. Processes - , 0.5 &! 6. Solvent use - , 0.5 &! 7. Road transport - , 0.8 &! 8. Other transport - , 1.0 &! 9. Waste - , 0.6 &! 10. Agriculture - , 1.0 &! 11. Nature - /) - - if (DEBUG) write(unit=6,fmt=*) "into timefactors.f " + if (DEBUG) write(unit=6,fmt=*) "into timefactors " call CheckStop( nydays < 365, & "Timefactors: ERR:Call set_nmdays before timefactors?") @@ -143,13 +156,32 @@ subroutine timefactors(year) ! ################################# -! 1) Read in Monthly factors +! 1) Read in Monthly factors, and determine min value (for baseload) fac_emm(:,:,:,:) = 1.0 + fac_min(:,:,:) = 1.0 + + ! Summer/winter SNAP1 ratios reduced from 1990 to 2010: + fac_cemm(:) = 1.0 + fracchange=0.005*(iyr_trend -1990) + fracchange=max(0.0,fracchange) !do not change before 1990 + fracchange=min(0.1,fracchange) !stop change after 2010 + !equal 1.1/0.9=1.22 summer/winter change + write(unit=6,fmt=*) "Change summer/winter ratio in SNAP1 by ", fracchange - do iemis = 1, NEMIS_FILES + do mm=1,12 + !Assume max change for august and february + fac_cemm(mm) = 1.0 + fracchange * cos ( 2 * PI * (mm - 8)/ 12.0 ) + write(unit=6,fmt="(a,i3,f8.3,a,f8.3)") "Change in fac_cemm ", mm,fac_cemm(mm) + enddo + write(*,"(a,f8.4)") "Mean fac_cemm ", sum( fac_cemm(:) )/12.0 - fname2 = "MonthlyFac." // trim ( EMIS_NAME(iemis) ) + if( INERIS_SNAP1 ) fac_cemm(:) = 1.0 + + + do iemis = 1, NEMIS_FILE + + fname2 = "MonthlyFac." // trim ( EMIS_FILE(iemis) ) call open_file(IO_TIMEFACS,"r",fname2,needed=.true.) call CheckStop( ios, & @@ -161,6 +193,14 @@ subroutine timefactors(year) (fac_emm(inland,mm,insec,iemis),mm=1,12) if ( ios < 0 ) exit ! End of file + !defined after renormalization and send to al processors: + ! fac_min(inland,insec,iemis) = minval( fac_emm(inland,:,insec,iemis) ) + + if( DEBUG.and.insec==ISNAP_DOM ) & + write(*,"(a,3i3,f7.3,a,12f6.1)") "emm tfac ", & + inland,insec,iemis, fac_min(inland,insec,iemis),& + " : ", ( fac_emm(inland,mm,insec,iemis), mm=1,12) + call CheckStop( ios, "Timefactors: Read error in Monthlyfac") n = n + 1 @@ -168,6 +208,20 @@ subroutine timefactors(year) close(IO_TIMEFACS) +! Apply change in monthly factors for SNAP 1 + sumfacc(:,:)=0.0 + do ic = 1, NLAND + do mm=1,12 + fac_emm(ic,mm,1,iemis)=fac_emm(ic,mm,1,iemis)*fac_cemm(mm) + sumfacc(ic,iemis)=sumfacc(ic,iemis)+fac_emm(ic,mm,1,iemis) + enddo + enddo +! normalize + do ic = 1, NLAND + do mm=1,12 + fac_emm(ic,mm,1,iemis)=fac_emm(ic,mm,1,iemis)*12./sumfacc(ic,iemis) + enddo + enddo if (DEBUG) write(unit=6,fmt=*) "Read ", n, " records from ", fname2 enddo ! iemis @@ -177,9 +231,9 @@ subroutine timefactors(year) fac_edd(:,:,:,:) = 1.0 - do iemis = 1, NEMIS_FILES + do iemis = 1, NEMIS_FILE - fname2 = "DailyFac." // trim ( EMIS_NAME(iemis) ) + fname2 = "DailyFac." // trim ( EMIS_FILE(iemis) ) call open_file(IO_TIMEFACS,"r",fname2,needed=.true.) call CheckStop( ios, & @@ -206,10 +260,70 @@ subroutine timefactors(year) close(IO_TIMEFACS) if (DEBUG) write(unit=6,fmt=*) "Read ", n, " records from ", fname2 - enddo ! NEMIS_FILES + enddo ! NEMIS_FILE + +! ################################# +! 3) Read in hourly (24x7) factors, options set in run script. + ! INERIS option has 11x24x7 emissions factor + ! TNO2005 option has 11x24 + ! EMEP2003 option has very simple day night +! + fname2 = "HOURLY-FACS" ! From EURODELTA/INERIS/TNO or EMEP2003 + write(unit=6,fmt=*) "Starting HOURLY-FACS" + call open_file(IO_TIMEFACS,"r",fname2,needed=.true.) + + fac_ehh24x7 = -999. + + n = 0 + do + read(IO_TIMEFACS,"(a)",iostat=ios) inputline + n = n + 1 + if(DEBUG)write(*,*) "HourlyFacs ", n, trim(inputline) + if ( ios < 0 ) exit ! End of file + if( index(inputline,"#")>0 ) then ! Headers + if(n==1) call PrintLog(trim(inputline)) + cycle + else + read(inputline,fmt=*,iostat=ios) idd, insec, & + (tmp24(ihh),ihh=1,24) + if( DEBUG ) write(*,*) "HOURLY=> ",idd, insec, tmp24(1), tmp24(13) + end if + + if( idd == 0 ) then ! same values very day + do idd2 = 1, 7 + fac_ehh24x7(insec,:,idd2) = tmp24(:) + end do + idd = 1 ! Used later + else + fac_ehh24x7(insec,:,idd) = tmp24(:) + end if + + !(fac_ehh24x7(insec,ihh,idd),ihh=1,24) + + ! Use sumfac for mean, and normalise within each day/sector + ! (Sector 10 had a sum of 1.00625) + sumfac = sum(fac_ehh24x7(insec,:,idd))/24.0 + if(DEBUG .and. MasterProc) write(*,"(a,2i3,3f12.5)") & + 'HOURLY-FACS mean min max', idd, insec, sumfac, & + minval(fac_ehh24x7(insec,:,idd)), & + maxval(fac_ehh24x7(insec,:,idd)) + + fac_ehh24x7(insec,:,idd) = fac_ehh24x7(insec,:,idd) * 1.0/sumfac + + ! if ( ios < 0 ) exit ! End of file + end do + !do insec=1, 11; do idd =1, 7; do ihh =1, 24 + ! if( fac_ehh24x7(insec,ihh,idd) < 0.0 ) then + ! print *, "Unfilled ", insec, idd, ihh, fac_ehh24x7(insec,ihh,idd) + ! end if + !end do; end do; end do + !call CheckStop ( any(fac_ehh24x7 < 0.0 ) , "Unfilled efac_ehh24x7") + if (DEBUG) write(unit=6,fmt=*) "Read ", n, " records from ", fname2 + call CheckStop ( any(fac_ehh24x7 < 0.0 ) , "Unfilled efac_ehh24x7") + ! ####################################################################### -! 3) Normalise the monthly-daily factors. This is needed in order to +! 4) Normalise the monthly-daily factors. This is needed in order to ! account for leap years (nydays=366) and for the fact that different ! years have different numbers of e.g. Saturdays/Sundays. ! Here we execute the same interpolations which are later done @@ -218,7 +332,7 @@ subroutine timefactors(year) write(unit=6,fmt="(a,I6,a,I5)")" Time factors normalisation: ",nydays,' days in ',year - do iemis = 1, NEMIS_FILES + do iemis = 1, NEMIS_FILE n = 0 do isec = 1, NSECTORS do ic = 1, NLAND @@ -276,23 +390,17 @@ subroutine timefactors(year) !######################################################################### ! -! Day/night factors are set from parameter DAY_NIGHT in emisdef_ml -! daytime = 2 - nightime : - - day_factor(:,0) = DAY_NIGHT(:) ! Night - day_factor(:,1) = 2.0 - day_factor(:,0) ! Day - -!################################# - if (DEBUG) write(unit=6,fmt=*) "End of subroutine timefactors" if (DEBUG ) then - print *, " test of time factors, UK: " + write( *,*) " test of time factors, UK: " do mm = 1, 12 - print "(i2,i6,f8.3,3f8.4)", mm, nydays, sumfac, & + write(*, "(i2,i6,f8.3,3f8.4)") mm, nydays, sumfac, & fac_emm(27,mm,2,1), fac_edd(27,1,2,1), fac_edd(27,7,2,1) end do ! mm - print *, " day factors traffic are", day_factor(7,0), day_factor(7,1) + write(*,"(a,4f8.3)") " day factors traffic 24x7", & + fac_ehh24x7(7,1,4),fac_ehh24x7(7,13,4), & + minval(fac_ehh24x7), maxval(fac_ehh24x7) end if ! DEBUG end subroutine timefactors @@ -343,7 +451,7 @@ subroutine NewDayFactors(newdate) ! Calculate monthly and daily factors for emissions - do iemis = 1, NEMIS_FILES + do iemis = 1, NEMIS_FILE do isec = 1, NSECTORS do iland = 1, NLAND @@ -356,8 +464,95 @@ subroutine NewDayFactors(newdate) enddo ! iland enddo ! isec enddo ! iemis + end subroutine NewDayFactors !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine DegreeDayFactors(daynumber) + +!..................................................................... +!** DESCRIPTION: +! Generally called with daynumber, and then reads the gridded degree-day +! based factors for emissions. +! If called with daynumber = 0, just checks existance of file. If not +! found, can use default country-based (GENEMIS) factors. + + integer, intent(in) :: daynumber ! daynumber (1,..... ,365) + + integer, save :: dd_old = -1 + integer,dimension(2) :: ijloc ! debug only + integer :: iii, jjj ! debug only + real :: checkmax + character(len=80) :: errmsg, units, varname + real, dimension(IIFULLDOM,JJFULLDOM) :: var2d_global + integer :: kmax=1, nfetch=1 ! for HDD + +! Gridded_SNAP2_Factors = .false. +! return + + !/ See if we have a file to work with.... + if ( daynumber == 0 ) then + call check_file("DegreeDayFactors.nc", Gridded_SNAP2_Factors,& + needed=.false., errmsg=errmsg ) + if ( Gridded_SNAP2_Factors ) then + call PrintLog("Found DEGREE-day factors", MasterProc) + else + call PrintLog("Not-found: DEGREE-day factors", MasterProc) + end if + return + end if + + !=============================================== + if ( .not. Gridded_SNAP2_Factors ) return ! + !=============================================== + + !/ We have a file, calculate every day ... . + + if (dd_old == daynumber) return ! Only calculate once per day max + dd_old= daynumber + +! write(*,*) "HDD inputs", me, " Day ", daynumber + + ! DegreeDays have the same domain/grid as the met data, so we can use: + if(MasterProc) call GetCDF('HDD_Facs','DegreeDayFactors.nc', & + var2d_global,IIFULLDOM,JJFULLDOM,1,daynumber,nfetch) + + if(.not.allocated(gridfac_HDD))then + allocate(gridfac_HDD(MAXLIMAX,MAXLJMAX)) + endif + + call global2local(var2d_global,gridfac_HDD,MSG_READ8,1,IIFULLDOM,JJFULLDOM,& + kmax,IRUNBEG,JRUNBEG) + call CheckStop(errmsg=="field_not_found", "INDegreeDay field not found:") + + if ( DEBUG ) then + ijloc = maxloc( gridfac_HDD(li0:li1,lj0:lj1)) + iii = ijloc(1)+li0-1 + jjj = ijloc(2)+lj0-1 + checkmax = maxval( gridfac_HDD(li0:li1,lj0:lj1)) + + write(*,"(a,2i4,2f10.2,20i4)") "DEBUG GRIDFAC MAx", me, daynumber, & + checkmax, gridfac_HDD(iii,jjj), & !!! tmpt2(iii,jjj), & + ijloc(1), ijloc(2), i_fdom(iii), j_fdom(jjj) + + if( debug_proc ) then + !write(*,"(a,3i4,2f12.3)") "GRIDFACDAYGEN ", daynumber, & + ! i_fdom(iii), j_fdom(jjj), tmpt2(iii,jjj), gridfac_HDD(iii,jjj) + write(*,"(a,i4,f12.3)") "GRIDFACDAY ", daynumber, & + gridfac_HDD(debug_li,debug_lj) + end if + end if + + + if ( DEBUG .and. debug_proc ) then + iii = debug_li + jjj = debug_lj + !write(*,*) "DEBUG GRIDFAC", me, daynumber, iii, jjj, tmpt2(iii,jjj), gridfac_HDD(iii, jjj) + write(*,*) "DEBUG GRIDFAC", me, daynumber, iii, jjj, gridfac_HDD(iii, jjj) + end if + + + end subroutine DegreeDayFactors + end module Timefactors_ml diff --git a/Trajectory_ml.f90 b/Trajectory_ml.f90 index 548dcff..01ef85e 100644 --- a/Trajectory_ml.f90 +++ b/Trajectory_ml.f90 @@ -111,14 +111,14 @@ subroutine trajectory_in endif iii = 1 -!su read on node 0 +! read on node 0 912 continue -!su now distribute +! now distribute CALL MPI_BCAST( iimax ,4*1,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) CALL MPI_BCAST( rhour ,8*iimax+1,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) CALL MPI_BCAST( kfalc ,8*iimax,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) CALL MPI_BCAST( fapos ,4*2*iimax,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) -!su all distributed +! all distributed endif endif @@ -147,8 +147,8 @@ subroutine trajectory_out if (ttt > rhour(iii) & .and. ttt < rhour(iii+1)) then -!su we have to synchronise the processors, since for next jjj(iii) -!su the aircraft can be on another processor !!!! +! we have to synchronise the processors, since for next jjj(iii) +! the aircraft can be on another processor !!!! CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) @@ -167,7 +167,6 @@ subroutine trajectory_out write(6,*) 'inne i tidsjekk4',me,kfalc(iii) open(IO_AIRCR,file='aircraft.dat' & ,position='append') -!ds uni.1: remove IXADV_O3 and replace by loop over FLIGHT_ADV write(IO_AIRCR,*) ttt & ,( xn_adv( FLIGHT_ADV(i),ii,jj,k)*PPBINV,& i=1, NADV_FLIGHT),k,z_mid(ii,jj,k),& diff --git a/Unimod.f90 b/Unimod.f90 index 3f2a8ed..f555af9 100644 --- a/Unimod.f90 +++ b/Unimod.f90 @@ -47,6 +47,7 @@ program myeul use Biogenics_ml, only: Init_BVOC, SetDailyBVOC use BoundaryConditions_ml, only: BoundaryConditions use CheckStop_ml, only: CheckStop +use Chemfields_ml, only: alloc_ChemFields use ChemChemicals_ml, only: define_chemicals use ChemGroups_ml, only: Init_ChemGroups use DefPhotolysis_ml, only: readdiss @@ -56,12 +57,12 @@ program myeul use EcoSystem_ml, only: Init_EcoSystems use Emissions_ml, only: Emissions, newmonth use ForestFire_ml, only: Fire_Emis -use GridValues_ml, only: MIN_ADVGRIDS, GRIDWIDTH_M, Poles +use GridValues_ml, only: MIN_ADVGRIDS, GRIDWIDTH_M, Poles, DefDebugProc, GridRead use Io_ml, only: IO_MYTIM,IO_RES,IO_LOG,IO_TMP,IO_DO3SE use Io_Progs_ml, only: read_line, PrintLog use Landuse_ml, only: InitLandUse, SetLanduse, Land_codes use MassBudget_ml, only: Init_massbudget, massbudget -use Met_ml, only: metvar, MetModel_LandUse, Meteoread, MeteoGridRead +use Met_ml, only: metvar, MetModel_LandUse, Meteoread use ModelConstants_ml,only: MasterProc, & ! set true for host processor, me==0 RUNDOMAIN, & ! Model domain NPROC, & ! No. processors @@ -70,9 +71,9 @@ program myeul runlabel2, & ! explanatory text nprint,nterm,iyr_trend, & IOU_INST,IOU_HOUR, IOU_YEAR,IOU_MON, IOU_DAY, & - USE_CONVECTION, USE_SOILWATER, USE_SOIL_NOX, & + USE_CONVECTION, USE_SOILWATER, USE_SOILNOX, & USE_FOREST_FIRES, USE_DUST,DO_SAHARA, & - USE_LIGHTNING_EMIS, & + USE_LIGHTNING_EMIS, USE_ROADDUST, & FORECAST ! FORECAST mode use NetCDF_ml, only: Init_new_netCDF use OutputChem_ml, only: WrtChem, wanted_iou @@ -129,21 +130,17 @@ program myeul nproc_mpi = NPROC CALL MPI_INIT(INFO) CALL MPI_COMM_RANK(MPI_COMM_WORLD, ME, INFO) +! Set a logical from ModelConstants, which can be used for +! specifying the master processor for print-outs and such +MasterProc = ( me == 0 ) CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc_mpi, INFO) +NPROC=nproc_mpi +55 format(A,I5,A) +if(MasterProc)write(*,55)' Found ',NPROC,' MPI processes available' -! MPI consistency checks -if(nproc_mpi /= NPROC)then - if(me==0) print *,"Wrong processor number!", & - " Program was compiled with NPROC = ",NPROC, & - " but MPI found ", nproc_mpi," processors available.", & - " Please change NPROCX or NPROCY in ModelConstants_ml.f90" - CALL MPI_FINALIZE(INFO) - stop -endif call CheckStop(digits(1.0)<50, & "COMPILED WRONGLY: Need double precision, e.g. f90 -r8") -call parinit(MIN_ADVGRIDS) !define MasterProc subdomains sizes and position if (MasterProc) then open(IO_RES,file='eulmod.res') @@ -158,8 +155,10 @@ program myeul call read_line(IO_TMP,runlabel2,status(1))! explanation text long call read_line(IO_TMP,txt,status(1)) ! meteo year,month,day to start the run read(txt,*)startdate(1:3) ! meteo hour to start the run is set in assign_NTERM +startdate(4)=0 call read_line(IO_TMP,txt,status(1)) ! meteo year,month,day to end the run read(txt,*)enddate(1:3) ! meteo hour to end the run is set in assign_NTERM +enddate(4)=0 if(FORECAST)then ! read dates of nested outputs on FORECAST mode do i=1,FORECAST_NDUMP @@ -177,18 +176,19 @@ program myeul call PrintLog( date2string("startdate = YYYYMMDD",startdate(1:3)) ) call PrintLog( date2string("enddate = YYYYMMDD",enddate (1:3)) ) write(unit=txt,fmt="(a,i4)") "iyr_trend= ", iyr_trend - call PrintLog( trim(txt) ) - write(unit=IO_LOG,fmt="(a12,4i4)")"RunDomain: ", RUNDOMAIN +! call PrintLog( trim(txt) ) +! write(unit=IO_LOG,fmt="(a12,4i4)")"RunDomain: ", RUNDOMAIN ! And record some settings to RunLog (will recode later) if( FORECAST ) call PrintLog("Forecast mode on") call PrintLog("Options used of (convec., soilwater, soilnox, forest fires)") if( USE_CONVECTION ) call PrintLog("Convection used") if( USE_SOILWATER ) call PrintLog("SoilWater switch on") - if( USE_SOIL_NOX ) call PrintLog("SoilNOx switch on") + if( USE_SOILNOX ) call PrintLog("SoilNOx switch on") if( USE_FOREST_FIRES)call PrintLog("ForestFires switch on") call PrintLog("Options used of (dust, sahara)") if( USE_DUST )call PrintLog("Dust switch on") + if( USE_ROADDUST )call PrintLog("Road Dust switch on") if( DO_SAHARA )call PrintLog("Sahara switch on") endif @@ -197,11 +197,22 @@ program myeul call Code_Timer(tim_before0) tim_before = tim_before0 -call MeteoGridRead(cyclicgrid) ! define grid projection and parameters + +call GridRead(cyclicgrid) !define: 1)grid sizes (IIFULLDOM, JJFULLDOM), + ! 2)projection (lon lat or Stereographic etc and Poles), + ! 3)rundomain size (GIMAX, GJMAX, IRUNBEG, JRUNBEG) + ! 4)subdomain partition (NPROCX, NPROCY, limax,ljmax) + ! 5)topology (neighbor, poles) + ! 5)grid properties arrays (xm, i_local, j_local etc.) + call Topology(cyclicgrid,Poles) ! def GlobalBoundaries & subdomain neighbors +call DefDebugProc() ! Sets debug_proc, debug_li, debuglj call assign_NTERM(NTERM) ! set NTERM, the number of 3-hourly periods call assign_dtadvec(GRIDWIDTH_M) ! set dt_advec +! daynumber needed for BCs, so call here to get initial +daynumber=day_of_year(current_date%year,current_date%month,current_date%day) + ! Decide the frequency of print-out ! nadd = 0 @@ -216,6 +227,7 @@ program myeul ! call Add_2timing(1,tim_after,tim_before,"Before define_Chemicals") +call alloc_ChemFields !allocate chemistry arrays call define_chemicals() ! sets up species details call Init_ChemGroups() ! sets up species details @@ -225,6 +237,8 @@ program myeul call Add_2timing(2,tim_after,tim_before,"After define_Chems, readpar") +call SetLandUse() ! Reads Inputs.Landuse, Inputs.LandPhen + call MeteoRead(1) call Add_2timing(3,tim_after,tim_before,"After infield") @@ -234,13 +248,8 @@ program myeul call Emissions(current_date%year) -! daynumber needed for BCs, so call here to get initial -daynumber=day_of_year(current_date%year,current_date%month,current_date%day) - call MetModel_LandUse(1) ! -call InitLandUse() ! Reads Inputs.Landuse, Inputs.LandPhen - ! Read data for DO3SE (deposition O3 and stomatal exchange) module ! (also used for other gases!) call Init_DO3SE(IO_DO3SE,"Inputs_DO3SE.csv",Land_codes, errmsg) @@ -273,8 +282,8 @@ program myeul call Init_new_netCDF(trim(runlabel1)//'_fullrun.nc',IOU_YEAR) if (wanted_iou(IOU_INST)) & call Init_new_netCDF(trim(runlabel1)//'_inst.nc',IOU_INST) - if (wanted_iou(IOU_HOUR).or.NHOURLY_OUT>0) & - call Init_new_netCDF(trim(runlabel1)//'_hour.nc',IOU_HOUR) +! if (wanted_iou(IOU_HOUR).or.NHOURLY_OUT>0) & +! call Init_new_netCDF(trim(runlabel1)//'_hour.nc',IOU_HOUR) if (wanted_iou(IOU_DAY)) & call Init_new_netCDF(trim(runlabel1)//'_day.nc',IOU_DAY) if (wanted_iou(IOU_MON)) & @@ -305,7 +314,7 @@ program myeul case(3:5) ;newseason = 2 case(6:8) ;newseason = 3 case(9:11) ;newseason = 4 - end select + endselect ! daynumber needed for BCs daynumber=day_of_year(current_date%year,current_date%month,current_date%day) @@ -334,7 +343,6 @@ program myeul call Add_2timing(8,tim_after,tim_before,"init_aqueous") endif ! mm_old.ne.mm - call Code_timer(tim_before) ! Monthly call to BoundaryConditions. if (mm_old /= mm) then ! START OF NEW MONTH !!!!! @@ -350,6 +358,7 @@ program myeul if (DEBUG_UNI) print *, "Finished Initmass" , me endif + oldseason = newseason mm_old = mm @@ -357,12 +366,14 @@ program myeul if (DEBUG_UNI) print *, "1st Infield" , me, " numu ", numt - call Meteoread(numt) - call Add_2timing(10,tim_after,tim_before,"Meteoread") - call SetLandUse() call Add_2timing(11,tim_after,tim_before,"SetLanduse") + + call Meteoread(numt) + call Add_2timing(10,tim_after,tim_before,"Meteoread") + + call SetDailyBVOC(daynumber) if (USE_FOREST_FIRES) call Fire_Emis(daynumber) @@ -370,10 +381,11 @@ program myeul call Add_2timing(12,tim_after,tim_before,"Fires+BVOC") daynumber=day_of_year(current_date%year,current_date%month,current_date%day) - if (MasterProc) print "(a,2I2.2,I4,3x,i2.2,a,i2.2,a,i2.2)",' current date and time: ',& - current_date%day,current_date%month,current_date%year,& - current_date%hour, ':',current_date%seconds/60,':',current_date%seconds-60*(current_date%seconds/60) - +! if(MasterProc) print "(a,2I2.2,I4,3x,i2.2,a,i2.2,a,i2.2)",' current date and time: ',& +! current_date%day,current_date%month,current_date%year,& +! current_date%hour, ':',current_date%seconds/60,':',current_date%seconds-60*(current_date%seconds/60) + if(MasterProc) print "(2(1X,A))",'current date and time:',& + date2string("YYYY-MM-DD hh:mm:ss",current_date) call Code_timer(tim_before) call metvar(numt) @@ -425,23 +437,3 @@ program myeul end program myeul !=========================================================================== -! Experimental NH3 emissions code moved here for safety -!FUTURE use calc_emis_potential_ml, only: NH3emis_potential,& ! NH3emis experimental -!FUTURE lNH3emis_pot, readNH3emis, lEmis50_nh3 -!FUTURE use NH3Emis_variation_ml, only: SetNH3 ! NH3emis experimental -!FUTURE use EmisDef_ml, only: NH3EMIS_VAR ! NH3emis experimental -!FUTURE IO_NH3_DEB ! NH3emis experimental -!FUTURE ! NH3emis experimental: write temporal emis variation for Tange to file -!FUTURE if (NH3EMIS_VAR) then -!FUTURE ! open(IO_NH3_DEB,FILE='out.Tange.dat') -!FUTURE ! write(IO_NH3_DEB,'(4a7,18a12)')"mm","dd","hh","TIME1","ISO_STABLE",& -!FUTURE ! "OPEN_STABLE","STORAGE","WIN_CROP","SPR_CROP",& -!FUTURE ! "SPR_SBEET","SPR_GRASS","MANURE1","MANURE2","MANURE3",& -!FUTURE ! "MANURE4","MANURE4a","MIN_SPRING","MIN_AUTUMN",& -!FUTURE ! "GRAZ_CATTLE","NH3_GRASS","TRAFFIC","SUM " -!FUTURE call readNH3emis() !read 16.7km activity NH3 emissions -!FUTURE print *,'New ammonia emissions on proc ',me,sum(lEmis50_nh3) -!FUTURE call NH3emis_potential(current_date%year) !calc emission potential -!FUTURE print *,'Potential emissions on proc ' ,me,sum(lNH3emis_pot) -!FUTURE endif -!FUTURE diff --git a/Units_ml.f90 b/Units_ml.f90 new file mode 100644 index 0000000..66d85ed --- /dev/null +++ b/Units_ml.f90 @@ -0,0 +1,238 @@ +module Units_ml +use CheckStop_ml, only: CheckStop +use ChemChemicals_ml, only: species_adv +use ChemGroups_ml, only: chemgroups +use ChemSpecs_adv_ml, only: NSPEC_ADV +use ChemSpecs_shl_ml, only: NSPEC_SHL +use ModelConstants_ml,only: PPBINV,ATWAIR,atwS,atwN,MFAC +!se PhysicalConstants_ml,only: AVOG +use OwnDataTypes_ml, only: TXTLEN_DERIV,TXTLEN_SHORT,Asc2D +use SmallUtils_ml, only: find_index + +implicit none +private + +! Subroutines & Functions +public :: & + Init_Units, & ! initalize conversion arrays + Units_Scale, & ! unit factor for single SPC + Group_Units, & ! unit factors for a GROUP + Group_Scale ! function version of Group_Units + +interface Group_Units + module procedure Group_Units_Asc2D,Group_Units_detail +end interface Group_Units + +! real, save :: ugPM = PPBINV /ATWAIR ! No multiplication needed +real, private, parameter :: & + atwC = 12.0, & + ugXm3 = PPBINV/ATWAIR, & ! will be multiplied by species(?)%molwt + ugSm3 = ugXm3*atwS, & ! species(?)%sulphurs + ugNm3 = ugXm3*atwN, & ! species(?)%nitrogens + ugCm3 = ugXm3*atwC, & ! species(?)%carbons + mgXm2 = 1e6, & ! will be multiplied by species(?)%molwt + mgSm2 = mgXm2*atwS, & ! species(?)%sulphurs + mgNm2 = mgXm2*atwN, & ! species(?)%nitrogens + mgCm2 = mgXm2*atwC, & ! species(?)%carbons +! Extinction coefficient [1/m] = %ExtC [m2/g] * mass [g/m3] + extX = ugXm3*1e-6, & ! will be multiplied by species(?)%molwt*%ExtC + s2h = 1.0/3600. ! sec to hour conversion factor + +real, public, parameter :: & + to_ugSIA=ugXm3, & ! conversion to ug + to_mgSIA=to_ugSIA*1e3, & ! conversion to mg + to_molec_cm3=MFAC, & + to_molec_cm2=to_molec_cm3*1e2 + +! Conversion to ug/m3 +! xn_adv(ixadv,ix,iy,k)*roa(ix,iy,k,1)*to_ug_ADV(ixadv) +! Conversion to ugX/m3 +! xn_adv(ixadv,ix,iy,k)*roa(ix,iy,k,1)*to_ug_X(ixadv) +! Hourly Output: use "ADVugXX" for ug output (ug/m3, ugC/m3, ugN/m3, ugS/m3) +! - for ug/m3 output use ADVugXX in combination with to_ug_ADV(ixadv); +! - for ugX/m3 output use ADVugXX in combination with to_ug_X(ixadv). +real, public, dimension(NSPEC_ADV), save :: & + to_ug_ADV, & ! conversion to ug + to_ug_C, & ! conversion to ug of C + to_ug_N, & ! conversion to ug of N + to_ug_S ! conversion to ug of S + +type, private :: umap + character(len=TXTLEN_SHORT) :: utxt,units ! short,NetCDF units + real, dimension(0:NSPEC_ADV) :: uconv ! conversion factor +endtype umap + +type, public :: group_umap + character(len=TXTLEN_DERIV) :: name = 'none' ! short name + integer,pointer,dimension(:) :: iadv =>null() ! advection index + real, pointer,dimension(:) :: uconv=>null() ! conversion factor +endtype group_umap + +type(umap), public, save :: unit_map(18)=(/& +! Air concentration + umap("mix_ratio","mol/mol",1.0),& ! Internal model unit + umap("ppb" ,"ppb" ,PPBINV),& + umap("ppbh","ppb h",s2h ),& ! PPBINV already included in AOT calculations + umap("ug" ,"ug/m3" ,ugXm3),& ! ug* units need to be further multiplied + umap("ugC","ugC/m3",ugCm3),& ! by the air density (roa) as part of the + umap("ugN","ugN/m3",ugNm3),& ! unit covnersion + umap("ugS","ugS/m3",ugSm3),& +! Dry/Wet deposition + umap("mm" ,"mm" ,1.0 ),& + umap("mg" ,"mg/m2" ,mgXm2),& + umap("mgC","mgC/m2",mgCm2),& + umap("mgN","mgN/m2",mgNm2),& + umap("mgS","mgS/m2",mgSm2),& +! Exposure to radioactive material + umap("uBq" ,"uBq/m3" ,ugXm3 ),& ! inst/mean exposure + umap("uBqh","uBq h/m3",ugXm3*s2h),& ! accumulated exposure + umap("mBq" ,"mBq/m2" ,mgXm2 ),& ! deposition +! Aerosol optical properties + umap("ext" ,"ext550nm",extX),&! ext* units need to be further multiplied... +! Coulumn output + umap("mcm2" ,"molec/cm2" ,to_molec_cm2),& + umap("e15mcm2","1e15molec/cm2",to_molec_cm2*1e-15)/) + +logical, private, save :: Initialize_Units = .true. + +contains + +subroutine Init_Units() + real, dimension(NSPEC_ADV) :: uconv_spec + integer :: i + if(.not.Initialize_Units) return + Initialize_Units = .false. + +! Use "ADVugXX" for ug output (ug/m3, ugC/m3, ugN/m3, ugS/m3) in Hourly Output +! For ug/m3 output use in combination with to_ug_ADV(ixadv). +! For ugX/m3 output use in combination with to_ug_X(ixadv). + to_ug_ADV = ugXm3*species_adv%molwt + to_ug_C = ugCm3*species_adv%carbons + to_ug_N = ugNm3*species_adv%nitrogens + to_ug_S = ugSm3*species_adv%sulphurs + + do i=1,size(unit_map) + select case (unit_map(i)%utxt) + case("ug","mg","uBq","uBqh","mBq") + uconv_spec = species_adv%molwt + case("ugC","mgC") + uconv_spec = species_adv%carbons + case("ugN","mgN") + uconv_spec = species_adv%nitrogens + case("ugS","mgS") + uconv_spec = species_adv%sulphurs + case("ext") + uconv_spec = species_adv%molwt*species_adv%ExtC + case default + uconv_spec = 1.0 + endselect + unit_map(i)%uconv(1:)=unit_map(i)%uconv(0)*uconv_spec + enddo +end subroutine Init_Units + +subroutine Group_Units_Asc2D(hr_out,gspec,gunit_conv,debug,name) + type(Asc2D), intent(in) :: hr_out + integer, pointer, dimension(:), intent(out) :: gspec ! group array of indexes + real, pointer, dimension(:), intent(out) :: gunit_conv ! group array of unit conv. factors + logical, intent(in) :: debug + character(len=TXTLEN_DERIV), intent(out),optional :: name ! For output file, species names + character(len=TXTLEN_DERIV) :: dname + integer :: i + + if(Initialize_Units) call Init_Units + call CheckStop((hr_out%spec<1).or.(hr_out%spec>size(chemgroups)),& + "Group_Units Error: Unknown group id, "//& + "variable "//trim(hr_out%name)//" type "//trim(hr_out%type)) + + dname=trim(chemgroups(hr_out%spec)%name)//"_"//trim(hr_out%unit) + if(present(name))name = trim(dname) + + if(associated(gspec)) deallocate(gspec) + allocate(gspec(size(chemgroups(hr_out%spec)%ptr))) + gspec=chemgroups(hr_out%spec)%ptr-NSPEC_SHL + if(debug) write(*,"(A,'=',30(A,':',I0,:,'+'))") & + trim(dname),(trim(species_adv(gspec(i))%name),gspec(i),i=1,size(gspec)) + + i=find_index(hr_out%unit,unit_map(:)%utxt) + if(i<1)i=find_index(hr_out%unit,unit_map(:)%units) + call CheckStop(i<1,"Group_Units Error: Unknown unit "//trim(hr_out%unit)) + + if(associated(gunit_conv)) deallocate(gunit_conv) + allocate(gunit_conv(size(gspec))) + gunit_conv(:)=unit_map(i)%uconv(gspec) +end subroutine Group_Units_Asc2D + +subroutine Group_Units_detail(igrp,unit,gspec,gunit_conv,debug) + integer, intent(in) :: igrp + character(len=*), intent(in) :: unit + integer, pointer, dimension(:), intent(out) :: gspec ! group array of indexes + real, pointer, dimension(:), intent(out) :: gunit_conv ! group array of unit conv. factors + logical, intent(in) :: debug + type(Asc2D) :: hr_out + hr_out%spec=igrp + hr_out%unit=unit//"" + hr_out%type="Group_Units_detail" + call Group_Units_Asc2D(hr_out,gspec,gunit_conv,debug) +end subroutine Group_Units_detail + +function Group_Scale(igrp,unit,debug) result(gmap) + integer, intent(in) :: igrp + character(len=*), intent(in) :: unit + logical, intent(in) :: debug + type(group_umap) :: gmap + type(Asc2D) :: hr_out + hr_out%spec=igrp + hr_out%unit=unit//"" + hr_out%type="Group_Scale" + call Group_Units_Asc2D(hr_out,gmap%iadv,gmap%uconv,debug,name=gmap%name) +end function Group_Scale + + +function Units_Scale(txtin,iadv,unitstxt,volunit,needroa,debug_msg) result(unitscale) + character(len=*), intent(in) :: txtin + integer, intent(in) :: iadv ! species_adv index, used if > 0 + character(len=*), intent(out), optional :: unitstxt + logical, intent(out), optional :: volunit,needroa + character(len=*), intent(in), optional :: debug_msg + character(len=len(txtin)) :: txt + real :: unitscale + integer :: i + + if(Initialize_Units) call Init_Units + txt=ADJUSTL(txtin) ! Remove leading spaces + select case (txt) + case("ugSS","ugSS/m3","ugP","ugP/m3",& + "mgSS","mgSS/m2","mgP","mgP/m2") + txt=txt(1:2) + case("mol/mol","mole mole-1","mixratio") + txt="mix_ratio" + !case default + ! txt=txtin + endselect + i=find_index(txt,unit_map(:)%utxt) + if(i<1)i=find_index(txt,unit_map(:)%units) + call CheckStop(i<1,"Units_Scale Error: Unknown unit "// trim(txtin) ) + + if(present(unitstxt))unitstxt = unit_map(i)%units + if(present(volunit )) volunit = any(txt==(/"ppb","ppbh","ppb h"/)) + if(present(needroa )) needroa = any(txt(1:2)==(/"ug","uB","ex"/)) + select case (iadv) + case (-1) +! groups (called iadv==-1) do not get a scaling factor at this stage. +! A second call with a valid iadv will provide the full conversion factor. + unitscale = 1.0 + case (0) +! return the conversion factor without the specie specific part (eg %molwt) + unitscale = unit_map(i)%uconv(iadv) + case (1:NSPEC_ADV) + unitscale = unit_map(i)%uconv(iadv) + if(present(debug_msg)) & + call CheckStop(unitscale==0.0,"Units_Scale Error: 0.0 conversion for "//& + trim(species_adv(iadv)%name)//" in "//trim(unitstxt)//" at "//trim(debug_msg)) + case default + call CheckStop(iadv,"Units_Scale Error: Unknown iadv.") + endselect + +end function Units_Scale + +end module Units_ml diff --git a/Volcanos_ml.f90 b/Volcanos_ml.f90 index 31521be..fd0fae1 100644 --- a/Volcanos_ml.f90 +++ b/Volcanos_ml.f90 @@ -42,19 +42,29 @@ module Volcanos_ml use CheckStop_ml, only: CheckStop use ChemChemicals_ml, only: species -use ChemSpecs_tot_ml, only: SO2 +use ChemSpecs_shl_ml, only: NSPEC_SHL +use ChemSpecs_tot_ml, only: NSPEC_TOT, SO2 +use ChemGroups_ml, only: chemgroups use EmisDef_ml, only: VOLCANOES_LL use GridValues_ml, only: GRIDWIDTH_M, xm2, sigma_bnd, & - i_local, j_local, lb2ij + i_local, j_local, lb2ij, & + GridArea_m2,coord_in_processor,coord_in_gridbox use Io_ml, only: ios, NO_FILE, open_file, & - IO_VOLC, Read_Headers, read_line -use ModelConstants_ml, only: KMAX_BND, KMAX_MID, PT, MasterProc, & - DEBUG=>DEBUG_VOLC -use MetFields_ml, only: roa, ps -use Par_ml, only: IRUNBEG, JRUNBEG, li0, lj0, li1, lj1, & + IO_VOLC, Read_Headers, read_line,IO_TMP +use SmallUtils_ml, only: wordsplit,find_index +use ModelConstants_ml, only: KCHEMTOP, KMAX_BND, KMAX_MID, PT, MasterProc, & + DEBUG=>DEBUG_VOLC,& + USE_EMERGENCY,DEBUG_EMERGENCY,& ! Emergency: Volcanic Eruption + TXTLEN_NAME +use OwnDataTypes_ml, only: TXTLEN_SHORT +use MetFields_ml, only: roa, ps, z_bnd +use Par_ml, only: me, IRUNBEG, JRUNBEG, ljmax, limax, & gi0, gi1, gj0, gj1 ! Test if on correct processor use PhysicalConstants_ml, only: GRAV, AVOG -use TimeDate_ml, only: nydays ! No. days per year +use TimeDate_ml, only: nydays,& ! No. days per year + startdate,enddate,current_date,& + make_timestamp,tdif_secs +use TimeDate_ExtraUtil_ml,only: date2string,string2date use KeyValue_ml, only: KeyVal implicit none @@ -64,6 +74,7 @@ module Volcanos_ml public :: VolcGet public :: Set_Volc public :: Scale_Volc +public :: EruptionRate ! Emergency: Volcanic Eruption integer, public, parameter :: & NMAX_VOLC = 12 ! Max number of volcanoes @@ -85,6 +96,48 @@ module Volcanos_ml rcemis_volc, & ! Emissions part varying every time-step emis_volc = 0.0 ! Volcanoes' emissions +! Emergency: Volcanic Eruption +integer, public, parameter :: & + NMAX_VENT = 10, & ! Max number of Vents (erupting) on processor/subdomain + NMAX_ERUP = 90 ! Max number of Eruption def (~3 months per vent) + +integer, private, save :: & ! No. of ... found on processor/subdomain + nvent = -1, & ! Vents + nerup(0:NMAX_VENT) = -1 ! Eruption events per Vent + +logical, parameter :: & + DEBUG_EM=DEBUG.or.DEBUG_EMERGENCY + +logical, private, save :: & + Vent_found=USE_EMERGENCY ! Any Vent found on this processor/subdomain? + +logical, public, save :: & + Eruption_found=USE_EMERGENCY ! Any Eruption found on this processor/subdomain? + +type, private :: vent + character(len=9) :: id ='' ! e.g. V1702A02B + character(len=TXTLEN_NAME) :: name='' ! e.g. Eyjafjöll + real :: lat=-1.0,lon=-1.0,elev=-1.0 ! vent coords and elevation + character(len=2) :: etype='' ! e.g. S0 + integer :: grp=-1 ! Which (ash)goup ... + !character(len=TXTLEN_SHORT) :: location,vtype ! other info +endtype vent +type(vent), private, save, dimension(NMAX_VENT):: & + ventdef=vent('UNDEF','UNKNOWN',-999.0,-999.0,-999.0,"??",-99) + +character(len=*), private , parameter :: SDATE_FMT="YYYY-MM-DD hh:mm:ss" +type, private :: erup + character(len=9) :: id ='' ! e.g. V1702A02B + character(len=TXTLEN_NAME) :: name='' ! e.g. SO2 + real :: base=-1.0,top=-1.0,& ! Column Base & Height [m asl] + rate=-1.0 ! Source strenght: Total release for period [kg/s] + character(len=len(SDATE_FMT)) :: sbeg=SDATE_FMT,send=SDATE_FMT + integer :: vent=-1,spc=-1 ! Which vent,(adv)spc... + logical :: edef=.true. ! default setings? +endtype erup +type(erup), private, save, dimension(0:NMAX_VENT,NMAX_ERUP):: & + erupdef=erup('UNDEF','UNKNOWN',-999.0,-999.0,-999.0,"??","??",.true.) + INCLUDE 'mpif.h' INTEGER STATUS(MPI_STATUS_SIZE),INFO @@ -226,11 +279,11 @@ subroutine Set_Volc if (DEBUG) print '(A,4I6,6I6,4I6)','Volcan: check1 ', & i,j, i_volc(volc_no),j_volc(volc_no), & - i_local(i),j_local(j), li0, li1, lj0, lj1, & + i_local(i),j_local(j), 1, limax, 1, ljmax, & gi0,gi1,gj0,gj1 - if ((i_local(i)>=li0).and.(i_local(i)<=li1).and. & - (j_local(j)>=lj0).and.(j_local(j)<=lj1)) then + if ((i_local(i)>=1).and.(i_local(i)<=limax).and. & + (j_local(j)>=1).and.(j_local(j)<=ljmax)) then unit_conv1 = GRAV* 0.001*AVOG/ & (sigma_bnd(KMAX_BND-k+1) - sigma_bnd(KMAX_BND-k)) @@ -258,11 +311,11 @@ subroutine Scale_Volc if (DEBUG) print '(A,4I6,6I6,4I6)','Volcan: check2 ', & i,j, i_volc(volc_no),j_volc(volc_no), & - i_local(i),j_local(j), li0, li1, lj0, lj1, & + i_local(i),j_local(j), 1, limax,1, ljmax, & gi0,gi1,gj0,gj1 - if ((i_local(i)>=li0).and.(i_local(i)<=li1).and. & - (j_local(j)>=lj0).and.(j_local(j)<=lj1)) then + if ((i_local(i)>=1).and.(i_local(i)<=limax).and. & + (j_local(j)>=1).and.(j_local(j)<=ljmax)) then i_l = i_local(i) !local i j_l = j_local(j) !local j @@ -277,5 +330,340 @@ subroutine Scale_Volc endif enddo ! volc_no end subroutine Scale_Volc +!-----------------------------------------------------------------------! +! Emergency: Volcanic Eruption. Ash & SO2, other species are possible. +!-----------------------------------------------------------------------! +!----------------------------! +! Get Volcanic Eruption Emiss. +!----------------------------! +function EruptionRate(i,j) result(emiss) + integer, intent(in) :: i,j + real, dimension(NSPEC_SHL+1:NSPEC_TOT,KCHEMTOP:KMAX_MID) :: emiss + character(len=*),parameter :: & + MSG_FMT="('EMERGENCY:',1X,A,5(:,1X,I0,':',A),3(:,1X,G,':',A))" + logical, save :: first_call=.true. + character(len=len(SDATE_FMT)) :: & ! Time strings in SDATE_FMT format + sbeg=SDATE_FMT,& ! Begin + snow=SDATE_FMT,& ! Now (current date) + send=SDATE_FMT ! End + integer :: v,e,itot,k1,k0 + real :: uconv +!----------------------------! +! +!----------------------------! + if(first_call) call setRate() + first_call=.false. + emiss(:,:)=0.0 + if(.not.Eruption_found)return + snow=date2string(SDATE_FMT,current_date) +!----------------------------! +! +!----------------------------! + doVENT: do v=1,nvent + if(.not.coord_in_gridbox(ventdef(v)%lon,ventdef(v)%lat,i,j))& + cycle doVENT ! Wrong gridbox + if(nerup(v)<1)cycle doVENT ! Not erupting + if(DEBUG_EM) & + write(*,MSG_FMT)snow//' Vent',me,'me',v,ventdef(v)%id,i,"i",j,"j" + doERUP: do e=1,nerup(v) + sbeg=date2string(erupdef(v,e)%sbeg,current_date) + send=date2string(erupdef(v,e)%send,current_date) + if(snow 10^6 g/s + uconv=1e-3 ! Kg/s --> 10^6 g/s + uconv=uconv/(GridArea_m2(i,j)*DIM(z_bnd(i,j,k1),z_bnd(i,j,k0+1))) ! --> g/s/cm3 + uconv=uconv*AVOG/species(itot)%molwt ! --> molecules/s/cm3 + emiss(itot,k1:k0)=emiss(itot,k1:k0)+erupdef(v,e)%rate*uconv + if(DEBUG_EM) & + write(*,MSG_FMT)snow//' Erup.',me,'me',e,erupdef(v,e)%sbeg,& + itot,trim(species(itot)%name),k1,'k1',k0,'k0',& + emiss(itot,k1),'emiss',erupdef(v,e)%rate,'rate',uconv,'uconv' + enddo doERUP + enddo doVENT +!----------------------------! + contains +!----------------------------! +! Model level for a given height +!----------------------------! + function getModLev(i,j,height) result(k) + integer, intent(in) :: i,j + real, intent(in) :: height + integer :: k + k=KMAX_MID + if(height<=0.0)return + do while(k>0.and.height>z_bnd(i,j,k)) + k=k-1 + enddo + end function getModLev +!----------------------------! +! Set Volcanic Eruption Param. +!----------------------------! + subroutine setRate() + character(len=*),parameter :: & + fventdef="volcanoes.csv", & + ferupdef="eruptions.csv", & + ERR_VENT_CSV="EruptionSet VENT def.file "//fventdef, & + ERR_ERUP_CSV="EruptionSet ERUP def.file "//ferupdef, & + ERR_VENT_MAX="EruptionSet NMAX_VENT exceeded in "//fventdef, & + ERR_ERUP_MAX="EruptionSet NMAX_ERUP exceeded in "//ferupdef + logical, save :: second_call=.true. + character(len=80) :: txtline ! Long enough for a full line + type(vent) :: dvent + type(erup) :: derup + integer :: stat,l,v,e,g +! Particles classes & default split as London VAAC setup for NAME +! from Witham&al:2011 Table 1 +! Evolution of volcanic ash modelling at the London VAAC April 2010 --- April 2011 +! UK Met Office. Technical Summary (v1.0). May 2011. +! C. Witham, M. Hort, D. Thomson, S. Leadbetter, B. Devenish and H. Webster. + real, target :: & !0.0<0.1<0.3<1.0<3.0<10.0<30.0<100.0 + VAAC_7BIN_SPLIT(7)=(/0.0,0.1,0.5,5.0,20.0,70.0,4.4/)*1e-2,& + VAAC_2BIN_SPLIT(2)=(/ 5.6,20.0 /)*1e-2 + real, pointer, dimension(:) :: binsplit => NULL() + !----------------------------! + ! + !----------------------------! + if(.not.USE_EMERGENCY)then + Eruption_found=.false. + if(MasterProc.and.DEBUG_EM.and.first_call) & + write(*,MSG_FMT)'Code is off. No Volcanic Ash.' + first_call=.false. + return + endif + if(.not.first_call)then + if(MasterProc.and.DEBUG_EM.and.second_call) & + write(*,MSG_FMT)'No need for reset volc.def...' + second_call=.false. + return + endif + first_call=.false. + !----------------------------! + ! Read Vent CVS + !----------------------------! + if(DEBUG_EM) CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) + if(MasterProc)then + call open_file(IO_TMP,"r",fventdef,needed=.true.,iostat=stat) + call CheckStop(stat,ERR_VENT_CSV//' not found') + endif + nvent=0 + doVENT: do l=1,NMAX_VENT+1 + call read_line(IO_TMP,txtline,stat) + if(stat/=0) exit doVENT ! End of file + txtline=ADJUSTL(txtline) ! Remove leading spaces + if(txtline(1:1)=='#')cycle doVENT ! Comment line + dvent=getVent(txtline) + if(coord_in_processor(dvent%lon,dvent%lat))then + nvent=nvent+1 + call CheckStop(nvent>NMAX_VENT,ERR_VENT_MAX//" read") + ventdef(nvent)=dvent + if(DEBUG_EM) & + write(*,MSG_FMT)'Vent',me,'in',nvent,trim(dvent%id),& + dvent%grp,trim(dvent%name) +! else +! if(DEBUG_EM) & +! write(*,MSG_FMT)'Vent',me,'out',-1,trim(dvent%id),& +! dvent%grp,trim(dvent%name) + endif + enddo doVENT + if(MasterProc) close(IO_TMP) + Eruption_found=(nvent>0) + !----------------------------! + ! Read Eruption CVS + !----------------------------! + if(DEBUG_EM) CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) + if(MasterProc)then + call open_file(IO_TMP,"r",ferupdef,needed=.true.,iostat=stat) + call CheckStop(stat,ERR_ERUP_CSV//' not found') + endif + nerup(:)=0 + doERUP: do l=1,NMAX_ERUP+1 + call read_line(IO_TMP,txtline,stat) + if(stat/=0) exit doERUP ! End of file + if(.not.Eruption_found)cycle doERUP ! There is no vents on subdomain + txtline=ADJUSTL(txtline) ! Remove leading spaces + if(txtline(1:1)=='#')cycle doERUP ! Comment line + derup=getErup(txtline) + if(derup%edef)then ! Default + nerup(0)=nerup(0)+1 + call CheckStop(nerup(0)>NMAX_ERUP,ERR_ERUP_MAX//" read") + erupdef(0,nerup(derup%vent))=derup + if(DEBUG_EM) & + write(*,MSG_FMT)'Erup.Default',me,'in',nerup(0),derup%id + elseif(derup%vent>0.and.derup%spc>0)then ! Specific + nerup(derup%vent)=nerup(derup%vent)+1 + call CheckStop(nerup(derup%vent)>NMAX_ERUP,ERR_ERUP_MAX//" read") + erupdef(derup%vent,nerup(derup%vent))=derup + if(DEBUG_EM) & + write(*,MSG_FMT)'Erup.Specific',me,'in',nerup(derup%vent),trim(derup%id),& + derup%spc,trim(derup%name) +! else ! Vent Outside domain +! if(DEBUG_EM) & ! or Unknown Vent/SPC +! write(*,MSG_FMT)'Erup.Specific',me,'out',-1,trim(derup%id),& +! derup%spc,trim(derup%name) + endif + enddo doERUP + if(MasterProc) close(IO_TMP) + Eruption_found=any(nerup(1:nvent)>0) + !----------------------------! + ! Expand Eruption Defaults + !----------------------------! + if(DEBUG_EM) CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) + if(nerup(0)<1)then + if(DEBUG_EM) & + write(*,MSG_FMT)'Erup.Default',me,'not found' + return + endif + doVENTe: do v=1,nvent + if(nerup(v)>0)cycle doVENTe ! Specific found --> no need for Default + e=find_index(ventdef(v)%etype,erupdef(0,:nerup(0))%id) + if(e<1) cycle doVENTe ! No Default found + if(DEBUG_EM) & + write(*,MSG_FMT)'Erup.Default',me,'Expand',& + v,trim(ventdef(v)%id),e,trim(erupdef(0,e)%id) + derup=erupdef(0,e) + if(derup%spc<0.and.derup%name(1:3)=="ASH")then ! Expand variable name + derup%name=trim(ventdef(v)%id)//trim(derup%name(4:)) ! e.g. ASH_F --> V1702A02B_F + derup%spc=find_index(derup%name,species(:)%name) ! Specie (total) + endif + if(derup%spc>0)then ! Expand single SPC + nerup(v)=nerup(v)+1 + call CheckStop(nerup(v)>NMAX_ERUP,ERR_ERUP_MAX//" expand") + erupdef(v,nerup(v))=derup + if(DEBUG_EM) & + write(*,MSG_FMT)'Erup.Default',me,'Expand SPC',nerup(v),trim(derup%id) + elseif(ventdef(v)%grp>0)then ! Expand GROUP of SPC + select case (size(chemgroups(ventdef(v)%grp)%ptr)) + case(2);binsplit=>VAAC_2BIN_SPLIT + case(7);binsplit=>VAAC_7BIN_SPLIT + case default + call CheckStop(ERR_ERUP_CSV//' can not expand '//trim(ventdef(v)%id)) + endselect + do g=1,size(chemgroups(ventdef(v)%grp)%ptr) + derup%spc=chemgroups(ventdef(v)%grp)%ptr(g) ! Specie (total) + derup%name=species(derup%spc)%name + derup%rate=erupdef(0,e)%rate*binsplit(g) + nerup(v)=nerup(v)+1 + call CheckStop(nerup(v)>NMAX_ERUP,ERR_ERUP_MAX//" expand") + erupdef(v,nerup(v))=derup + if(DEBUG_EM) & + write(*,MSG_FMT)'Erup.Default',me,'Expand GRP',nerup(v),trim(derup%id),& + derup%spc,trim(derup%name) + enddo + else + if(DEBUG_EM) & + write(*,MSG_FMT)'Erup.Default',me,'not found' + endif + enddo doVENTe + Eruption_found=any(nerup(1:nvent)>0) + end subroutine setRate +!----------------------------! +! Extract Vent info from CVS line +!----------------------------! + function getVent(line) result(def) + character(len=*) :: line + type(vent) :: def + character(len=TXTLEN_SHORT) :: words(10)='' ! Array of paramaters + real :: lat,lon,elev ! vent coord and elevation + integer :: stat,nwords,igrp + call wordsplit(line,size(words),words,nwords,stat,strict_separator=",",empty_words=.true.) + call CheckStop(stat,"EMERGENCY: Wrong/Unknown line format "//trim(line)) + call CheckStop(nwords,size(words),"EMERGENCY: Missing data in line "//trim(line)) +!#1:NUMBER,2:NAME,3:LOCATION,4:LATITUDE,5:NS,6:LONGITUDE,7:EW,8:ELEV,9:TYPE,10:ERUPTION TYPE +!V1702A02B,Eyjafjöll,Iceland-S,63.63,N,19.62,W,1666,Stratovolcano,S0 + read(words(4),*)lat + select case (words(5)) ! NS + case("N","n","degN") ! degN + case("S","s","degS");lat=-lat ! degS + case default + call CheckStop("EMERGENCY: Unknown degN/S "//trim(words(5))) + endselect + read(words(6),*)lon + select case (words(7)) ! EW + case("E","e","degE") ! degE + case("W","w","degW");lon=-lon ! degW + case default + call CheckStop("EMERGENCY: Unknown degE/W "//trim(words(7))) + endselect + read(words(8),*)elev + igrp=find_index(words(1),chemgroups(:)%name) + def=vent(trim(words(1)),trim(words(2)),lat,lon,elev,trim(words(10)),igrp) + end function getVent +!----------------------------! +! Extract Erup. info from CVS line +!----------------------------! + function getErup(line) result(def) + character(len=*) :: line + type(erup) :: def + character(len=TXTLEN_SHORT) :: words(10)='' ! Array of paramaters + logical :: edef=.true. ! default setings? + integer :: stat,nwords,ivent,ispc=0,ind + real :: base,top,rate,m63,dhh + call wordsplit(line,size(words),words,nwords,stat,strict_separator=",",empty_words=.true.) + call CheckStop(stat,"EMERGENCY: Wrong/Unknown line format "//trim(line)) + call CheckStop(nwords,size(words),"EMERGENCY: Missing data in line "//trim(line)) +!#1:TYPE/VOLCANO,2:VARIABLE,3:BASE[km],4:H[km above vent],5:D[h],6:dM/dt[kg/s],7:m63[-],8:START[code/date],9:END[code/date],10:DESCRIPTION +!S0 , , , 11.000, 3.00, 4e6, 0.40,SR ,SR+D,Silicic standard +!V1702A02B,SO2 , 0, 8.000, 24.00, 15, ,2010-04-14 00:00:00,SE+D,Eyja 20100414 SO2 +!V1702A02B,ASH_F, 0, 2.000, 24.00, 0, ,2010-05-23 00:00:00,SE+D,Eyja 20100523 PM fine + ivent=find_index(words(1),ventdef(:nvent)%id) ! Vent Specific + edef=(ivent<1).and.any(ventdef(:nvent)%etype==words(1)) ! Vent Default + if(ivent>0.and.words(2)(1:3)=="ASH")& ! Expand variable name + words(2)=trim(words(1))//trim(words(2)(4:)) ! e.g. ASH_F --> V1702A02B_F + ispc=find_index(words(2),species(:)%name) ! Specie (total) + read(words(4),*)top ! [km] + top=top*1e3 ! [m] + select case (words(3)) ! base + case("VENT"," ") ! From the vent + base=0.0 + if(ivent>0)base=ventdef(ivent)%elev ! [m] + top=top+base ! [m] + case("SURF","0") ! From the model surface + base=0.0 + case default + read(words(3),*)base ! [km] + base=base*1e3 ! [m] + endselect + read(words(5),*)dhh + read(words(6),*)rate + select case (words(7)) ! m63 + case(" ") ;m63=1.0 + case default;read(words(7),*)m63 + endselect + words(8)=getDate(words(8),words(8),words(9),dhh,debug=DEBUG_EM) ! Start [date/code] + words(9)=getDate(words(9),words(8),words(9),dhh,debug=DEBUG_EM) ! End [date/code] + def=erup(trim(words(1)),trim(words(2)),base,top,rate*m63,& + trim(words(8)),trim(words(9)),max(ivent,0),max(ispc,0),edef) + end function getErup +!----------------------------! +! Time/Date CODE--> YYYY-MM-DD hh:mm:ss +!----------------------------! + function getDate(code,se,ee,dh,debug) result(str) + character(len=*), intent(in) :: code,se,ee + real, intent(in) :: dh ! [hours] + logical, intent(in), optional:: debug + character(len=TXTLEN_SHORT) :: str + select case (code) + case("SR") ! Start of the simulation + str=date2string(SDATE_FMT,startdate,debug=debug) + case("SR+D") ! Start of the simulation + dh + str=date2string(SDATE_FMT,startdate,addsecs=dh*36e2,debug=debug) + case("SE+D") ! Start eruption + dh; no wildcards in SE allowed + str=date2string(SDATE_FMT,string2date(se,SDATE_FMT,debug=debug),addsecs=dh*36e2,debug=debug) + case("EE+D") ! End eruption - dh; no wildcards in EE allowed + str=date2string(SDATE_FMT,string2date(ee,SDATE_FMT,debug=debug),addsecs=-dh*36e2,debug=debug) + case("ER-D") ! End of the simulation - dh + str=date2string(SDATE_FMT,enddate,addsecs=-dh*36e2,debug=debug) + case("ER") ! End of the simulation + str=date2string(SDATE_FMT,enddate,debug=debug) + case default + str=code + endselect + end function getDate +end function EruptionRate end module Volcanos_ml diff --git a/Wesely_ml.f90 b/Wesely_ml.f90 index 767a5f8..5098d99 100644 --- a/Wesely_ml.f90 +++ b/Wesely_ml.f90 @@ -1,9 +1,9 @@ ! -!*****************************************************************************! -!* +!*****************************************************************************! +!* !* Copyright (C) 2007-2011 met.no -!* +!* !* Contact information: !* Norwegian Meteorological Institute !* Box 43 Blindern @@ -11,25 +11,25 @@ !* NORWAY !* email: emep.mscw@met.no !* http://www.emep.int -!* +!* !* 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 Wesely_ml !.............................................................................. ! specifies data for deposition modelling using procedures recommended by ! Wesely, 1989, Atmos. Environ., 23, No.6, pp. 1293-1304 -! +! !.............................................................................. @@ -92,63 +92,66 @@ module Wesely_ml ! Schmidt to Prandtl numbers integer, public, parameter :: & - WES_SO2 = 1, WES_O3 = 2, WES_NO2 = 3, WES_NO = 4, WES_HNO3 = 5, & - WES_H2O2= 6, WES_ALD= 7, WES_HCHO= 8, WES_OP = 9, WES_PAA = 10, & - WES_ORA = 11, WES_NH3= 12, WES_PAN = 13, WES_HNO2 = 14 + WES_SO2 = 1, WES_O3 = 2, WES_NO2 = 3, WES_NO = 4, WES_HNO3 = 5, & + WES_H2O2= 6, WES_ALD= 7, WES_HCHO= 8, WES_OP = 9, WES_PAA = 10, & + WES_ORA = 11, WES_NH3= 12, WES_PAN = 13, WES_HNO2=14 +!/** Variables used in deposition calculations - !/** Variables used in deposition calculations +! DDEP_xx gives the index that will be used in the EMEP model +! WES_xx gives the index of the Wesely gas to which this corresponds - ! DDEP_xx gives the index that will be used in the EMEP model - ! WES_xx gives the index of the Wesely gas to which this corresponds - - ! Here we define the minimum set of species which has different - ! deposition velocities. We calculate Vg for these, and then - ! can use the rates for other similar species. (e.g. AMSU can use - ! the Vg for SO4. Must set NDRYDEP_CALC species - - !/** IMPORTANT: the variables below must match up in the sense that, for - ! example, if DDEP_NH3=4 then the 4th element of DRYDEP must be WES_NH3. +! Here we define the minimum set of species which has different +! deposition velocities. We calculate Vg for these, and then +! can use the rates for other similar species. (e.g. AMSU can use +! the Vg for SO4. Must set NDRYDEP_CALC species - integer, public, parameter :: NDRYDEP_GASES = 11 ! gases - integer, public, parameter :: NDRYDEP_AER = 4 ! aerosols - integer, public, parameter :: NDRYDEP_CALC = NDRYDEP_GASES + NDRYDEP_AER +!/** IMPORTANT: the variables below must match up in the sense that, for +! example, if DDEP_NH3=4 then the 4th element of DRYDEP must be WES_NH3. +integer, public, parameter :: NDRYDEP_GASES = 11 ! gases +integer, public, parameter :: NDRYDEP_AER = 6 ! aerosols +integer, public, parameter :: NDRYDEP_CALC = NDRYDEP_GASES + NDRYDEP_AER - integer, public, parameter :: & - CDDEP_HNO3 = 1, CDDEP_O3 = 2, CDDEP_SO2 = 3 & - ,CDDEP_NH3 = 4, CDDEP_NO2 = 5, CDDEP_PAN = 6 & - ,CDDEP_H2O2 = 7, CDDEP_ALD = 8, CDDEP_HCHO = 9, & - CDDEP_ROOH = 10, CDDEP_HNO2 = 11 !, CDDEP_PMf = 12, CDDEP_PMc = 13 +integer, public, parameter :: & + CDDEP_HNO3 = 1, CDDEP_O3 = 2, CDDEP_SO2 = 3, & + CDDEP_NH3 = 4, CDDEP_NO2 = 5, CDDEP_PAN = 6, & + CDDEP_H2O2 = 7, CDDEP_ALD = 8, CDDEP_HCHO= 9, & + CDDEP_ROOH = 10, CDDEP_HNO2= 11 !, CDDEP_PMf = 12, CDDEP_PMc = 13 +integer, public, parameter :: CDDEP_RCHO = CDDEP_ALD ! Convenience !OP renamed to ROOH, FIN to PMf, COA to PMc ! specials for aerosols. we have 2 fine, 1 coarse and 1 'giant'type - integer, public, parameter :: & - CDDEP_PMfS = 12, CDDEP_PMfN = 13, CDDEP_PMc = 14, CDDEP_PMg = 15 - integer, dimension(CDDEP_PMfS:CDDEP_PMg), public, parameter :: & - AERO_SIZE = (/ 1, 1, 2, 3 /) !1=fine,2=coarse,3='giant' +integer, public, parameter :: & + CDDEP_PMfS= 12, CDDEP_PMfN= 13, CDDEP_PMc = 14, & + CDDEP_SSc = 15, CDDEP_DUc = 16, CDDEP_POLLd= 17 +integer, public, parameter :: & + CDDEP_ASH1=CDDEP_PMfS,CDDEP_ASH2=CDDEP_PMfS,CDDEP_ASH3=CDDEP_PMfS,& + CDDEP_ASH4=CDDEP_PMfS,CDDEP_ASH5=CDDEP_PMc ,CDDEP_ASH6=CDDEP_PMc, & + CDDEP_ASH7=CDDEP_PMc - integer, public, parameter :: CDDEP_SET = -99 +integer, dimension(CDDEP_PMfS:CDDEP_POLLd), public, parameter :: & + AERO_SIZE = (/ 1, 1, 2, 3, 4, 5/) !1=fine,2=coarse,3=coarse sea salt, 4=dust, 5 = pollen - integer, public, parameter, dimension(NDRYDEP_GASES) :: & - DRYDEP_GASES = (/ WES_HNO3, WES_O3, WES_SO2, & - WES_NH3, WES_NO2 , WES_PAN, & - WES_H2O2, WES_ALD, WES_HCHO, WES_OP, WES_HNO2 /) +integer, public, parameter :: CDDEP_SET = -99 +integer, public, parameter, dimension(NDRYDEP_GASES) :: & + DRYDEP_GASES = (/ WES_HNO3, WES_O3, WES_SO2, & + WES_NH3, WES_NO2, WES_PAN, & + WES_H2O2, WES_ALD, WES_HCHO, WES_OP, WES_HNO2 /) contains -!========================================================== +!========================================================== subroutine Init_GasCoeff() +!========================================================== +!Description: +!calculates: +! 1) DRx - ratio of diffusivities of ozone to gas requried +! 2) Rb_corr - the two-thirds power of the Schmidt to Prandtl +!number ratio values for all 14 gases listed in Wesely_tab2 - !========================================================== - !Description: - !calculates: - ! 1) DRx - ratio of diffusivities of ozone to gas requried - ! 2) Rb_corr - the two-thirds power of the Schmidt to Prandtl - !number ratio values for all 14 gases listed in Wesely_tab2 - - !========================================================== - ! -> Calculated Rb_cor +!========================================================== +! -> Calculated Rb_cor !Declaration of local variables @@ -157,10 +160,10 @@ subroutine Init_GasCoeff() GASLOOP: do icmp = 1, NWESELY - DRx (icmp) = Wesely_tab2(1,WES_O3)/Wesely_tab2(1,icmp) - Schmidt = Sc_H20* Wesely_tab2(1,icmp) - Rb_cor(icmp) = (Schmidt/PRANDTL)**(2.0/3.0) - end do GASLOOP + DRx (icmp) = Wesely_tab2(1,WES_O3)/Wesely_tab2(1,icmp) + Schmidt = Sc_H20* Wesely_tab2(1,icmp) + Rb_cor(icmp) = (Schmidt/PRANDTL)**(2.0/3.0) + enddo GASLOOP end subroutine Init_GasCoeff end module Wesely_ml diff --git a/dependencies b/dependencies index 5448cca..6d67260 100644 --- a/dependencies +++ b/dependencies @@ -1,3 +1,7 @@ +FOBJ=Aero_Vds_ml.o Ammonium_ml.o AOD_PM_ml.o Advection_ml.o AirEmis_ml.o AOTnPOD_ml.o Aqueous_n_WetDep_ml.o BLPhysics_ml.o Biogenics_ml.o BoundaryConditions_ml.o CellMet_ml.o CheckStop_ml.o Chem_ml.o CoDep_ml.o Country_ml.o ChemFunctions_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemRates_ml.o Convection_ml.o DefPhotolysis_ml.o Derived_ml.o DerivedFields_ml.o DO3SE_ml.o DryDep_ml.o DustProd_ml.o EcoSystem_ml.o EmisDef_ml.o EmisGet_ml.o Emissions_ml.o ForestFire_ml.o Functions_ml.o GlobalBCs_ml.o GridAllocate_ml.o GridValues_ml.o InterpolationRoutines_ml.o Io_ml.o Io_Nums_ml.o Io_Progs_ml.o KeyValue_ml.o LandDefs_ml.o Landuse_ml.o LandPFT_ml.o LocalVariables_ml.o MARS_ml.o MARS_Aero_water_ml.o MassBudget_ml.o Met_ml.o MetFields_ml.o EQSAM_ml.o MicroMet_ml.o ModelConstants_ml.o MosaicOutputs_ml.o My_Aerosols_ml.o My_Derived_ml.o My_ExternalBICs_ml.o My_SOA_ml.o My_Outputs_ml.o NetCDF_ml.o Nest_ml.o Output_hourly.o OutputChem_ml.o OwnDataTypes_ml.o Par_ml.o PhysicalConstants_ml.o Radiation_ml.o Rb_ml.o ReadField_ml.o Rsurface_ml.o Runchem_ml.o Setup_1d_ml.o Setup_1dfields_ml.o Sites_ml.o SmallUtils_ml.o SoilWater_ml.o Solver.o SeaSalt_ml.o StoFlux_ml.o SubMet_ml.o Tabulations_ml.o TimeDate_ml.o TimeDate_ExtraUtil_ml.o Timefactors_ml.o Timing_ml.o Trajectory_ml.o Units_ml.o Unimod.o Volcanos_ml.o Wesely_ml.o global2local.o local2global.o PhyChem_ml.o + +$(PROG): $(FOBJ) + $(F90) -o $@ $+ $(LDFLAGS) Aero_Vds_ml.o : Aero_Vds_ml.f90 ModelConstants_ml.o My_Aerosols_ml.o PhysicalConstants_ml.o Ammonium_ml.o : Ammonium_ml.f90 CM_ChemSpecs_ml.o Setup_1dfields_ml.o ModelConstants_ml.o @@ -5,10 +9,10 @@ AOD_PM_ml.o : AOD_PM_ml.f90 Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o Advection_ml.o : Advection_ml.f90 Par_ml.o Timing_ml.o MassBudget_ml.o MetFields_ml.o ModelConstants_ml.o Io_ml.o GridValues_ml.o Convection_ml.o CheckStop_ml.o CM_ChemSpecs_ml.o Chem_ml.o AirEmis_ml.o : AirEmis_ml.f90 TimeDate_ml.o MetFields_ml.o PhysicalConstants_ml.o GridValues_ml.o Io_ml.o ModelConstants_ml.o Par_ml.o AOTnPOD_ml.o : AOTnPOD_ml.f90 TimeDate_ml.o Par_ml.o OwnDataTypes_ml.o ModelConstants_ml.o MetFields_ml.o LocalVariables_ml.o Landuse_ml.o LandDefs_ml.o Io_Progs_ml.o GridValues_ml.o CM_ChemSpecs_ml.o Chem_ml.o CheckStop_ml.o -Aqueous_n_WetDep_ml.o : Aqueous_n_WetDep_ml.f90 CM_WetDep.inc SmallUtils_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o OwnDataTypes_ml.o My_SOA_ml.o MetFields_ml.o ModelConstants_ml.o MassBudget_ml.o Io_ml.o GridValues_ml.o DerivedFields_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o My_Derived_ml.o -BLPhysics_ml.o : BLPhysics_ml.f90 PhysicalConstants_ml.o ModelConstants_ml.o -Biogenics_ml.o : Biogenics_ml.f90 TimeDate_ml.o SmallUtils_ml.o Setup_1dfields_ml.o Radiation_ml.o PhysicalConstants_ml.o Par_ml.o OwnDataTypes_ml.o NetCDF_ml.o ModelConstants_ml.o LocalVariables_ml.o Landuse_ml.o LandPFT_ml.o LandDefs_ml.o KeyValue_ml.o Io_ml.o GridValues_ml.o CheckStop_ml.o -BoundaryConditions_ml.o : BoundaryConditions_ml.f90 CM_BoundaryConditions.inc SmallUtils_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o LocalVariables_ml.o Io_Progs_ml.o GridValues_ml.o GlobalBCs_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Chem_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o +Aqueous_n_WetDep_ml.o : Aqueous_n_WetDep_ml.f90 CM_WetDep.inc Units_ml.o SmallUtils_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o OwnDataTypes_ml.o My_SOA_ml.o MetFields_ml.o ModelConstants_ml.o MassBudget_ml.o Io_ml.o GridValues_ml.o DerivedFields_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o My_Derived_ml.o +BLPhysics_ml.o : BLPhysics_ml.f90 PhysicalConstants_ml.o ModelConstants_ml.o MetFields_ml.o Landuse_ml.o +Biogenics_ml.o : Biogenics_ml.f90 CM_EmisBioNat.inc TimeDate_ml.o SmallUtils_ml.o Setup_1dfields_ml.o Radiation_ml.o PhysicalConstants_ml.o Par_ml.o OwnDataTypes_ml.o NetCDF_ml.o ModelConstants_ml.o MetFields_ml.o LocalVariables_ml.o Landuse_ml.o LandPFT_ml.o LandDefs_ml.o KeyValue_ml.o Io_ml.o GridValues_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o +BoundaryConditions_ml.o : BoundaryConditions_ml.f90 CM_BoundaryConditions.inc SmallUtils_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o LocalVariables_ml.o Io_Progs_ml.o GridValues_ml.o GlobalBCs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Chem_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o CellMet_ml.o : CellMet_ml.f90 TimeDate_ml.o SubMet_ml.o SoilWater_ml.o PhysicalConstants_ml.o ModelConstants_ml.o MetFields_ml.o MicroMet_ml.o LocalVariables_ml.o Landuse_ml.o GridValues_ml.o CheckStop_ml.o CheckStop_ml.o : CheckStop_ml.f90 Chem_ml.o : Chem_ml.f90 CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o ModelConstants_ml.o Par_ml.o @@ -20,73 +24,74 @@ CM_ChemSpecs_ml.o : CM_ChemSpecs_ml.f90 CM_ChemRates_ml.o : CM_ChemRates_ml.f90 ModelConstants_ml.o CM_ChemSpecs_ml.o Setup_1dfields_ml.o ChemFunctions_ml.o Convection_ml.o : Convection_ml.f90 PhysicalConstants_ml.o Par_ml.o GridValues_ml.o MetFields_ml.o ModelConstants_ml.o CM_ChemSpecs_ml.o Chem_ml.o DefPhotolysis_ml.o : DefPhotolysis_ml.f90 LocalVariables_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o Io_ml.o GridValues_ml.o CheckStop_ml.o -Derived_ml.o : Derived_ml.f90 TimeDate_ml.o SmallUtils_ml.o PhysicalConstants_ml.o Par_ml.o OwnDataTypes_ml.o MosaicOutputs_ml.o ModelConstants_ml.o MetFields_ml.o Io_Progs_ml.o GridValues_ml.o Emissions_ml.o EcoSystem_ml.o DerivedFields_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemGroups_ml.o Chem_ml.o CheckStop_ml.o Biogenics_ml.o AOTnPOD_ml.o My_Emis_ml.o My_Derived_ml.o +Derived_ml.o : Derived_ml.f90 Units_ml.o TimeDate_ml.o SmallUtils_ml.o PhysicalConstants_ml.o Par_ml.o OwnDataTypes_ml.o MosaicOutputs_ml.o ModelConstants_ml.o MetFields_ml.o Io_Progs_ml.o GridValues_ml.o Emissions_ml.o EmisDef_ml.o EcoSystem_ml.o DerivedFields_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemGroups_ml.o Chem_ml.o CheckStop_ml.o Biogenics_ml.o AOTnPOD_ml.o Aero_Vds_ml.o My_Derived_ml.o DerivedFields_ml.o : DerivedFields_ml.f90 OwnDataTypes_ml.o DO3SE_ml.o : DO3SE_ml.f90 TimeDate_ml.o ModelConstants_ml.o LocalVariables_ml.o CheckStop_ml.o DryDep_ml.o : DryDep_ml.f90 CM_DryDep.inc Wesely_ml.o TimeDate_ml.o CM_ChemSpecs_ml.o StoFlux_ml.o SoilWater_ml.o Setup_1dfields_ml.o Rsurface_ml.o Rb_ml.o PhysicalConstants_ml.o Par_ml.o OwnDataTypes_ml.o MosaicOutputs_ml.o ModelConstants_ml.o MicroMet_ml.o MetFields_ml.o MassBudget_ml.o LocalVariables_ml.o LandDefs_ml.o Landuse_ml.o Io_Progs_ml.o GridValues_ml.o EcoSystem_ml.o DO3SE_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Chem_ml.o CheckStop_ml.o Aero_Vds_ml.o My_Aerosols_ml.o -DustProd_ml.o : DustProd_ml.f90 Setup_1dfields_ml.o TimeDate_ml.o PhysicalConstants_ml.o Par_ml.o MicroMet_ml.o ModelConstants_ml.o MetFields_ml.o LocalVariables_ml.o LandDefs_ml.o Landuse_ml.o Io_ml.o GridValues_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Functions_ml.o EmisDef_ml.o CheckStop_ml.o +DustProd_ml.o : DustProd_ml.f90 TimeDate_ml.o SmallUtils_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o MicroMet_ml.o ModelConstants_ml.o MetFields_ml.o LocalVariables_ml.o LandDefs_ml.o Landuse_ml.o Io_ml.o GridValues_ml.o CM_ChemSpecs_ml.o Functions_ml.o CheckStop_ml.o Biogenics_ml.o EcoSystem_ml.o : EcoSystem_ml.f90 Par_ml.o OwnDataTypes_ml.o ModelConstants_ml.o LandDefs_ml.o GridValues_ml.o CheckStop_ml.o -EmisDef_ml.o : EmisDef_ml.f90 -EmisGet_ml.o : EmisGet_ml.f90 CM_EmisSpecs.inc Volcanos_ml.o SmallUtils_ml.o Par_ml.o ModelConstants_ml.o KeyValue_ml.o Io_ml.o GridAllocate_ml.o EmisDef_ml.o My_Emis_ml.o Country_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o -Emissions_ml.o : Emissions_ml.f90 NetCDF_ml.o AirEmis_ml.o Volcanos_ml.o Timefactors_ml.o TimeDate_ml.o ReadField_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o Io_Progs_ml.o Io_Nums_ml.o GridValues_ml.o EmisGet_ml.o EmisDef_ml.o My_Emis_ml.o Country_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o -ForestFire_ml.o : ForestFire_ml.f90 TimeDate_ml.o SmallUtils_ml.o Setup_1dfields_ml.o ReadField_ml.o PhysicalConstants_ml.o Par_ml.o OwnDataTypes_ml.o NetCDF_ml.o ModelConstants_ml.o MetFields_ml.o Io_ml.o GridValues_ml.o EmisGet_ml.o My_Emis_ml.o EmisDef_ml.o Country_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o +EmisDef_ml.o : EmisDef_ml.f90 CM_EmisFiles.inc +EmisGet_ml.o : EmisGet_ml.f90 CM_EmisSpecs.inc Volcanos_ml.o SmallUtils_ml.o Par_ml.o ModelConstants_ml.o KeyValue_ml.o Io_ml.o GridAllocate_ml.o EmisDef_ml.o Country_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o +Emissions_ml.o : Emissions_ml.f90 AirEmis_ml.o Volcanos_ml.o Timefactors_ml.o TimeDate_ml.o ReadField_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o NetCDF_ml.o ModelConstants_ml.o MetFields_ml.o Io_Progs_ml.o Io_Nums_ml.o GridValues_ml.o EmisGet_ml.o EmisDef_ml.o Country_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o Biogenics_ml.o +ForestFire_ml.o : ForestFire_ml.f90 BiomassBurningMapping.inc TimeDate_ExtraUtil_ml.o TimeDate_ml.o SmallUtils_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o OwnDataTypes_ml.o NetCDF_ml.o ModelConstants_ml.o MetFields_ml.o Io_ml.o GridValues_ml.o EmisDef_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o Functions_ml.o : Functions_ml.f90 PhysicalConstants_ml.o GlobalBCs_ml.o : GlobalBCs_ml.f90 TimeDate_ExtraUtil_ml.o TimeDate_ml.o PhysicalConstants_ml.o Par_ml.o NetCDF_ml.o ModelConstants_ml.o MetFields_ml.o LocalVariables_ml.o Io_ml.o Functions_ml.o GridValues_ml.o CheckStop_ml.o GridAllocate_ml.o : GridAllocate_ml.f90 GridValues_ml.o Par_ml.o CheckStop_ml.o -GridValues_ml.o : GridValues_ml.f90 PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o Functions_ml.o +GridValues_ml.o : GridValues_ml.f90 TimeDate_ExtraUtil_ml.o TimeDate_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o Io_Nums_ml.o Functions_ml.o CheckStop_ml.o InterpolationRoutines_ml.o : InterpolationRoutines_ml.f90 Io_ml.o : Io_ml.f90 Io_Progs_ml.o Io_Nums_ml.o Io_Nums_ml.o : Io_Nums_ml.f90 Io_Progs_ml.o : Io_Progs_ml.f90 TimeDate_ExtraUtil_ml.o TimeDate_ml.o SmallUtils_ml.o Par_ml.o KeyValue_ml.o ModelConstants_ml.o Io_Nums_ml.o GridValues_ml.o CheckStop_ml.o KeyValue_ml.o : KeyValue_ml.f90 LandDefs_ml.o : LandDefs_ml.f90 SmallUtils_ml.o ModelConstants_ml.o LandPFT_ml.o KeyValue_ml.o Io_ml.o CheckStop_ml.o -Landuse_ml.o : Landuse_ml.f90 TimeDate_ml.o SmallUtils_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o LandPFT_ml.o LandDefs_ml.o KeyValue_ml.o Io_ml.o GridValues_ml.o GridAllocate_ml.o DO3SE_ml.o CheckStop_ml.o +Landuse_ml.o : Landuse_ml.f90 TimeDate_ml.o SmallUtils_ml.o Par_ml.o NetCDF_ml.o ModelConstants_ml.o MetFields_ml.o LandPFT_ml.o LandDefs_ml.o KeyValue_ml.o Io_ml.o GridValues_ml.o GridAllocate_ml.o DO3SE_ml.o CheckStop_ml.o LandPFT_ml.o : LandPFT_ml.f90 SmallUtils_ml.o Par_ml.o NetCDF_ml.o ModelConstants_ml.o GridValues_ml.o CheckStop_ml.o LocalVariables_ml.o : LocalVariables_ml.f90 Wesely_ml.o ModelConstants_ml.o -MARS_ml.o : MARS_ml.f90 Par_ml.o ModelConstants_ml.o MARS_Aero_water_ml.o Io_ml.o +MARS_ml.o : MARS_ml.f90 Par_ml.o ModelConstants_ml.o MARS_Aero_water_ml.o Io_ml.o CheckStop_ml.o MARS_Aero_water_ml.o : MARS_Aero_water_ml.f90 -MassBudget_ml.o : MassBudget_ml.f90 Setup_1dfields_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o Io_ml.o GridValues_ml.o Chem_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o -Met_ml.o : Met_ml.f90 TimeDate_ExtraUtil_ml.o NetCDF_ml.o ReadField_ml.o Io_ml.o TimeDate_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o MicroMet_ml.o MetFields_ml.o Landuse_ml.o GridValues_ml.o Functions_ml.o CheckStop_ml.o BLPhysics_ml.o -MetFields_ml.o : MetFields_ml.f90 Par_ml.o ModelConstants_ml.o +MassBudget_ml.o : MassBudget_ml.f90 Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o Io_ml.o GridValues_ml.o Chem_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o +Met_ml.o : Met_ml.f90 TimeDate_ExtraUtil_ml.o NetCDF_ml.o ReadField_ml.o TimeDate_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o MicroMet_ml.o MetFields_ml.o Landuse_ml.o Io_ml.o GridValues_ml.o Functions_ml.o CheckStop_ml.o BLPhysics_ml.o +MetFields_ml.o : MetFields_ml.f90 EQSAM_ml.o : EQSAM_ml.f90 ModelConstants_ml.o -MicroMet_ml.o : MicroMet_ml.f90 +MicroMet_ml.o : MicroMet_ml.f90 ModelConstants_ml.o ModelConstants_ml.o : ModelConstants_ml.f90 PhysicalConstants_ml.o MosaicOutputs_ml.o : MosaicOutputs_ml.f90 Wesely_ml.o TimeDate_ml.o SmallUtils_ml.o OwnDataTypes_ml.o ModelConstants_ml.o MetFields_ml.o LocalVariables_ml.o Landuse_ml.o LandDefs_ml.o Io_Progs_ml.o EcoSystem_ml.o DerivedFields_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o AOTnPOD_ml.o -My_Aerosols_ml.o : My_Aerosols_ml.f90 Chem_ml.o EQSAM_ml.o MARS_ml.o PhysicalConstants_ml.o CM_ChemSpecs_ml.o ModelConstants_ml.o CM_ChemSpecs_ml.o Setup_1dfields_ml.o -My_Derived_ml.o : My_Derived_ml.f90 TimeDate_ml.o SmallUtils_ml.o Par_ml.o OwnDataTypes_ml.o MosaicOutputs_ml.o ModelConstants_ml.o MetFields_ml.o LandDefs_ml.o GridValues_ml.o CM_ChemSpecs_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Chem_ml.o CheckStop_ml.o AOTnPOD_ml.o My_Emis_ml.o -My_Emis_ml.o : My_Emis_ml.f90 -My_SOA_ml.o : My_SOA_ml.f90 CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o ModelConstants_ml.o -My_Outputs_ml.o : My_Outputs_ml.f90 TimeDate_ml.o SmallUtils_ml.o Par_ml.o OwnDataTypes_ml.o ModelConstants_ml.o DerivedFields_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o +My_Aerosols_ml.o : My_Aerosols_ml.f90 Setup_1dfields_ml.o PhysicalConstants_ml.o ModelConstants_ml.o MARS_ml.o EQSAM_ml.o Chem_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o +My_Derived_ml.o : My_Derived_ml.f90 TimeDate_ml.o SmallUtils_ml.o Par_ml.o OwnDataTypes_ml.o MosaicOutputs_ml.o ModelConstants_ml.o MetFields_ml.o LandDefs_ml.o Io_Progs_ml.o GridValues_ml.o EmisDef_ml.o CM_ChemSpecs_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Chem_ml.o CheckStop_ml.o AOTnPOD_ml.o +My_ExternalBICs_ml.o : My_ExternalBICs_ml.f90 TimeDate_ExtraUtil_ml.o Io_ml.o CheckStop_ml.o ModelConstants_ml.o +My_SOA_ml.o : My_SOA_ml.f90 TimeDate_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o GridValues_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Chem_ml.o Functions_ml.o +My_Outputs_ml.o : My_Outputs_ml.f90 Units_ml.o TimeDate_ml.o SmallUtils_ml.o Par_ml.o OwnDataTypes_ml.o ModelConstants_ml.o DerivedFields_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o NetCDF_ml.o : NetCDF_ml.f90 SmallUtils_ml.o Functions_ml.o TimeDate_ExtraUtil_ml.o TimeDate_ml.o PhysicalConstants_ml.o Par_ml.o OwnDataTypes_ml.o ModelConstants_ml.o InterpolationRoutines_ml.o GridValues_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o Chem_ml.o My_Outputs_ml.o -Nest_ml.o : Nest_ml.f90 TimeDate_ExtraUtil_ml.o Chem_ml.o Par_ml.o ModelConstants_ml.o Functions_ml.o NetCDF_ml.o Io_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o GridValues_ml.o TimeDate_ml.o OwnDataTypes_ml.o -Output_hourly.o : Output_hourly.f90 TimeDate_ml.o Par_ml.o NetCDF_ml.o MetFields_ml.o ModelConstants_ml.o Io_ml.o GridValues_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o OwnDataTypes_ml.o DerivedFields_ml.o Derived_ml.o CM_ChemGroups_ml.o Chem_ml.o CheckStop_ml.o My_Outputs_ml.o +Nest_ml.o : Nest_ml.f90 Units_ml.o TimeDate_ExtraUtil_ml.o TimeDate_ml.o Par_ml.o OwnDataTypes_ml.o NetCDF_ml.o MetFields_ml.o ModelConstants_ml.o Io_ml.o GridValues_ml.o Functions_ml.o CM_ChemSpecs_ml.o Chem_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o My_ExternalBICs_ml.o +Output_hourly.o : Output_hourly.f90 Units_ml.o TimeDate_ExtraUtil_ml.o TimeDate_ml.o Par_ml.o NetCDF_ml.o MetFields_ml.o ModelConstants_ml.o Io_ml.o GridValues_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o OwnDataTypes_ml.o DerivedFields_ml.o Derived_ml.o CM_ChemGroups_ml.o Chem_ml.o CheckStop_ml.o My_Outputs_ml.o OutputChem_ml.o : OutputChem_ml.f90 TimeDate_ExtraUtil_ml.o TimeDate_ml.o Par_ml.o OwnDataTypes_ml.o NetCDF_ml.o ModelConstants_ml.o Io_ml.o My_Outputs_ml.o GridValues_ml.o DerivedFields_ml.o Derived_ml.o CheckStop_ml.o OwnDataTypes_ml.o : OwnDataTypes_ml.f90 -Par_ml.o : Par_ml.f90 ModelConstants_ml.o CheckStop_ml.o +Par_ml.o : Par_ml.f90 ModelConstants_ml.o Io_Nums_ml.o CheckStop_ml.o PhysicalConstants_ml.o : PhysicalConstants_ml.f90 Radiation_ml.o : Radiation_ml.f90 TimeDate_ml.o PhysicalConstants_ml.o Rb_ml.o : Rb_ml.f90 Wesely_ml.o PhysicalConstants_ml.o ModelConstants_ml.o ReadField_ml.o : ReadField_ml.f90 Io_ml.o Par_ml.o ModelConstants_ml.o CheckStop_ml.o -Rsurface_ml.o : Rsurface_ml.f90 MetFields_ml.o Wesely_ml.o TimeDate_ml.o Radiation_ml.o ModelConstants_ml.o LocalVariables_ml.o DO3SE_ml.o CoDep_ml.o CheckStop_ml.o LandDefs_ml.o -Runchem_ml.o : Runchem_ml.f90 TimeDate_ml.o Setup_1dfields_ml.o Setup_1d_ml.o SeaSalt_ml.o Par_ml.o My_SOA_ml.o ModelConstants_ml.o Io_Progs_ml.o GridValues_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o DustProd_ml.o DryDep_ml.o DefPhotolysis_ml.o Solver.o Chem_ml.o CheckStop_ml.o CellMet_ml.o Biogenics_ml.o Aqueous_n_WetDep_ml.o AOD_PM_ml.o Ammonium_ml.o Timing_ml.o My_Aerosols_ml.o -Setup_1d_ml.o : Setup_1d_ml.f90 Volcanos_ml.o TimeDate_ml.o Tabulations_ml.o SeaSalt_ml.o Setup_1dfields_ml.o Radiation_ml.o PhysicalConstants_ml.o Par_ml.o Landuse_ml.o ModelConstants_ml.o MetFields_ml.o MassBudget_ml.o LocalVariables_ml.o GridValues_ml.o CM_ChemRates_ml.o CM_ChemRates_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Functions_ml.o ForestFire_ml.o Emissions_ml.o EmisGet_ml.o EmisDef_ml.o DustProd_ml.o DerivedFields_ml.o CheckStop_ml.o Chem_ml.o AirEmis_ml.o +Rsurface_ml.o : Rsurface_ml.f90 Par_ml.o MetFields_ml.o Wesely_ml.o TimeDate_ml.o Radiation_ml.o ModelConstants_ml.o LocalVariables_ml.o DO3SE_ml.o CoDep_ml.o CheckStop_ml.o LandDefs_ml.o +Runchem_ml.o : Runchem_ml.f90 TimeDate_ml.o Setup_1dfields_ml.o Setup_1d_ml.o SeaSalt_ml.o Par_ml.o My_SOA_ml.o ModelConstants_ml.o MassBudget_ml.o Io_Progs_ml.o GridValues_ml.o DustProd_ml.o DryDep_ml.o DefPhotolysis_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Solver.o Chem_ml.o CheckStop_ml.o CellMet_ml.o Biogenics_ml.o Aqueous_n_WetDep_ml.o AOD_PM_ml.o Ammonium_ml.o Timing_ml.o My_Aerosols_ml.o +Setup_1d_ml.o : Setup_1d_ml.f90 Volcanos_ml.o TimeDate_ml.o Tabulations_ml.o SmallUtils_ml.o Setup_1dfields_ml.o Radiation_ml.o PhysicalConstants_ml.o Par_ml.o Landuse_ml.o ModelConstants_ml.o MetFields_ml.o MassBudget_ml.o LocalVariables_ml.o Io_Progs_ml.o GridValues_ml.o CM_ChemRates_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Functions_ml.o ForestFire_ml.o Emissions_ml.o EmisGet_ml.o DerivedFields_ml.o CheckStop_ml.o Chem_ml.o Biogenics_ml.o AirEmis_ml.o Setup_1dfields_ml.o : Setup_1dfields_ml.f90 Chem_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o EmisDef_ml.o ModelConstants_ml.o Sites_ml.o : Sites_ml.f90 KeyValue_ml.o TimeDate_ml.o Tabulations_ml.o SmallUtils_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o CM_ChemSpecs_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o Io_ml.o GridValues_ml.o Functions_ml.o DerivedFields_ml.o My_Outputs_ml.o CheckStop_ml.o SmallUtils_ml.o : SmallUtils_ml.f90 -SoilWater_ml.o : SoilWater_ml.f90 TimeDate_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o Met_ml.o LocalVariables_ml.o Landuse_ml.o GridValues_ml.o -Solver.o : Solver.f90 CM_Reactions2.inc CM_Reactions1.inc ChemFunctions_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o Io_ml.o GridValues_ml.o CM_ChemRates_ml.o CM_ChemRates_ml.o Chem_ml.o CM_ChemSpecs_ml.o CM_ChemGroups_ml.o Emissions_ml.o EmisDef_ml.o DefPhotolysis_ml.o CheckStop_ml.o Biogenics_ml.o Aqueous_n_WetDep_ml.o -SeaSalt_ml.o : SeaSalt_ml.f90 TimeDate_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o MicroMet_ml.o MetFields_ml.o LocalVariables_ml.o Landuse_ml.o GridValues_ml.o EmisDef_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o +SoilWater_ml.o : SoilWater_ml.f90 TimeDate_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o Met_ml.o LocalVariables_ml.o Landuse_ml.o Io_Progs_ml.o GridValues_ml.o +Solver.o : Solver.f90 CM_Reactions2.inc CM_Reactions1.inc ChemFunctions_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o Io_ml.o GridValues_ml.o CM_ChemRates_ml.o Chem_ml.o CM_ChemSpecs_ml.o CM_ChemGroups_ml.o Emissions_ml.o DefPhotolysis_ml.o CheckStop_ml.o Aqueous_n_WetDep_ml.o +SeaSalt_ml.o : SeaSalt_ml.f90 TimeDate_ml.o SmallUtils_ml.o Setup_1dfields_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o MicroMet_ml.o MetFields_ml.o LocalVariables_ml.o Landuse_ml.o Io_Progs_ml.o GridValues_ml.o CM_ChemSpecs_ml.o Biogenics_ml.o StoFlux_ml.o : StoFlux_ml.f90 Wesely_ml.o SmallUtils_ml.o PhysicalConstants_ml.o Par_ml.o ModelConstants_ml.o MicroMet_ml.o LocalVariables_ml.o LandDefs_ml.o Io_Progs_ml.o DO3SE_ml.o CheckStop_ml.o -SubMet_ml.o : SubMet_ml.f90 PhysicalConstants_ml.o ModelConstants_ml.o MicroMet_ml.o LocalVariables_ml.o Landuse_ml.o LandDefs_ml.o CheckStop_ml.o BLPhysics_ml.o +SubMet_ml.o : SubMet_ml.f90 PhysicalConstants_ml.o ModelConstants_ml.o MicroMet_ml.o LocalVariables_ml.o Landuse_ml.o LandDefs_ml.o BLPhysics_ml.o MetFields_ml.o Functions_ml.o CheckStop_ml.o Tabulations_ml.o : Tabulations_ml.f90 ModelConstants_ml.o PhysicalConstants_ml.o TimeDate_ml.o : TimeDate_ml.f90 TimeDate_ExtraUtil_ml.o : TimeDate_ExtraUtil_ml.f90 CheckStop_ml.o TimeDate_ml.o My_Outputs_ml.o ModelConstants_ml.o -Timefactors_ml.o : Timefactors_ml.f90 Io_ml.o TimeDate_ml.o EmisDef_ml.o My_Emis_ml.o Country_ml.o CheckStop_ml.o +Timefactors_ml.o : Timefactors_ml.f90 TimeDate_ml.o Io_ml.o PhysicalConstants_ml.o Par_ml.o NetCDF_ml.o ModelConstants_ml.o Met_ml.o GridValues_ml.o EmisDef_ml.o Country_ml.o CheckStop_ml.o Timing_ml.o : Timing_ml.f90 Trajectory_ml.o : Trajectory_ml.f90 TimeDate_ml.o Par_ml.o ModelConstants_ml.o MetFields_ml.o Io_ml.o GridValues_ml.o CM_ChemSpecs_ml.o Chem_ml.o My_Outputs_ml.o -Unimod.o : Unimod.f90 Nest_ml.o Trajectory_ml.o TimeDate_ExtraUtil_ml.o TimeDate_ml.o Tabulations_ml.o Sites_ml.o PhyChem_ml.o Par_ml.o OutputChem_ml.o NetCDF_ml.o ModelConstants_ml.o Met_ml.o MassBudget_ml.o Landuse_ml.o Io_Progs_ml.o Io_ml.o GridValues_ml.o ForestFire_ml.o Emissions_ml.o EcoSystem_ml.o DO3SE_ml.o DerivedFields_ml.o Derived_ml.o DefPhotolysis_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o BoundaryConditions_ml.o Biogenics_ml.o AirEmis_ml.o Aqueous_n_WetDep_ml.o Advection_ml.o Timing_ml.o My_Outputs_ml.o -Volcanos_ml.o : Volcanos_ml.f90 KeyValue_ml.o TimeDate_ml.o PhysicalConstants_ml.o Par_ml.o MetFields_ml.o ModelConstants_ml.o Io_ml.o GridValues_ml.o EmisDef_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o +Units_ml.o : Units_ml.f90 SmallUtils_ml.o OwnDataTypes_ml.o ModelConstants_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o +Unimod.o : Unimod.f90 Nest_ml.o Trajectory_ml.o TimeDate_ExtraUtil_ml.o TimeDate_ml.o Tabulations_ml.o Sites_ml.o PhyChem_ml.o Par_ml.o OutputChem_ml.o NetCDF_ml.o ModelConstants_ml.o Met_ml.o MassBudget_ml.o Landuse_ml.o Io_Progs_ml.o Io_ml.o GridValues_ml.o ForestFire_ml.o Emissions_ml.o EcoSystem_ml.o DO3SE_ml.o DerivedFields_ml.o Derived_ml.o DefPhotolysis_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o Chem_ml.o CheckStop_ml.o BoundaryConditions_ml.o Biogenics_ml.o AirEmis_ml.o Aqueous_n_WetDep_ml.o Advection_ml.o Timing_ml.o My_Outputs_ml.o +Volcanos_ml.o : Volcanos_ml.f90 KeyValue_ml.o TimeDate_ExtraUtil_ml.o TimeDate_ml.o PhysicalConstants_ml.o Par_ml.o MetFields_ml.o OwnDataTypes_ml.o ModelConstants_ml.o SmallUtils_ml.o Io_ml.o GridValues_ml.o EmisDef_ml.o CM_ChemGroups_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CM_ChemSpecs_ml.o CheckStop_ml.o Wesely_ml.o : Wesely_ml.f90 PhysicalConstants_ml.o global2local.o : global2local.f90 Par_ml.o ModelConstants_ml.o local2global.o : local2global.f90 Par_ml.o ModelConstants_ml.o -PhyChem_ml.o : PhyChem_ml.f90 Timefactors_ml.o Sites_ml.o Runchem_ml.o Radiation_ml.o Trajectory_ml.o TimeDate_ml.o SoilWater_ml.o Par_ml.o Nest_ml.o ModelConstants_ml.o MetFields_ml.o Met_ml.o GridValues_ml.o Emissions_ml.o DryDep_ml.o DerivedFields_ml.o Derived_ml.o Chem_ml.o Advection_ml.o Timing_ml.o My_Outputs_ml.o CM_ChemSpecs_ml.o CoDep_ml.o +PhyChem_ml.o : PhyChem_ml.f90 Timefactors_ml.o Sites_ml.o Runchem_ml.o Radiation_ml.o Trajectory_ml.o TimeDate_ml.o SoilWater_ml.o Par_ml.o Nest_ml.o ModelConstants_ml.o MetFields_ml.o Met_ml.o GridValues_ml.o Emissions_ml.o DryDep_ml.o DerivedFields_ml.o Derived_ml.o Chem_ml.o Advection_ml.o Timing_ml.o My_Outputs_ml.o CM_ChemSpecs_ml.o CoDep_ml.o Biogenics_ml.o diff --git a/eulmod.res b/eulmod.res deleted file mode 100644 index e69de29..0000000 diff --git a/modrun.sh b/modrun.sh new file mode 100755 index 0000000..2d93fb9 --- /dev/null +++ b/modrun.sh @@ -0,0 +1,32 @@ +#!/bin/bash + +# Minimalistic script for run the Unified EMEP model + +# Link the input data +inputdir=. +ln -s $inputdir/met/* . # Driving meteorology +ln -s $inputdir/input/* . # Other input files + +# Define some run parameters +trendyear=2010 # emission year +runlabel1=Base # short label +runlabel2=Opensource_setup # long label +startdate="2010 01 01" # start date (metdata) + enddate="2010 12 31" # end date (metdata) + +# Put the run parameters in a temporary file +cat > INPUT.PARA << EOF +$trendyear +$runlabel1 +$runlabel2 +$startdate +$enddate +EOF + +# Run the model +mpirun $inputdir/code/Unimod + +# Clean the links to the input data and remove INPUT.PARA +ls $inputdir/met |xargs rm +ls $inputdir/input|xargs rm +rm INPUT.PARA