From 181250c701ca7104e8a9410097bc5a99ef27efec Mon Sep 17 00:00:00 2001 From: Alvaro Valdebenito Date: Fri, 19 Aug 2016 12:33:15 +0000 Subject: [PATCH] import rv3 source code from ftp site --- Advection_ml.f90 | 3952 +++++++++++++++++++++++++++++++++++++ Aero_Rb_ml.f90 | 210 ++ Aero_water_ml.f90 | 372 ++++ AirEmis_ml.f90 | 520 +++++ Ammonium_ml.f90 | 273 +++ Aqueous_ml.f90 | 559 ++++++ Biogenics_ml.f90 | 174 ++ BoundaryConditions_ml.f90 | 699 +++++++ CellMet_ml.f90 | 154 ++ CheckStop_ml.f90 | 147 ++ Chem_ml.f90 | 65 + CoDep_ml.f90 | 235 +++ Country_ml.f90 | 348 ++++ DO3SE_ml.f90 | 304 +++ DefPhotolysis_ml.f90 | 337 ++++ Derived_ml.f90 | 1199 +++++++++++ DryDep_ml.f90 | 603 ++++++ EQSAM_ml.f90 | 654 ++++++ EmisDef_ml.f90 | 179 ++ EmisGet_ml.f90 | 598 ++++++ Emissions_ml.f90 | 963 +++++++++ Functions_ml.f90 | 471 +++++ GlobalBCs_ml.f90 | 808 ++++++++ GridAllocate_ml.f90 | 267 +++ GridValues_ml.f90 | 671 +++++++ Io_Nums_ml.f90 | 80 + Io_Progs_ml.f90 | 611 ++++++ Io_ml.f90 | 31 + KeyValue_ml.f90 | 86 + LandDefs_ml.f90 | 200 ++ Landuse_ml.f90 | 476 +++++ LocalVariables_ml.f90 | 186 ++ MARS_ml.f90 | 1237 ++++++++++++ Makefile | 61 + Makefile.SRCS | 21 + Makefile_njord | 53 + Makefile_snow | 51 + Makefile_stallo | 50 + MassBudget_ml.f90 | 446 +++++ Met_ml.f90 | 3812 +++++++++++++++++++++++++++++++++++ MicroMet_ml.f90 | 209 ++ ModelConstants_ml.f90 | 159 ++ My_Aerosols_ml.f90 | 316 +++ My_BoundConditions_ml.f90 | 319 +++ My_Chem_ml.f90 | 665 +++++++ My_Derived_ml.f90 | 416 ++++ My_DryDep_ml.f90 | 475 +++++ My_Emis_ml.f90 | 196 ++ My_FastReactions.inc | 1246 ++++++++++++ My_MassBudget_ml.f90 | 94 + My_Outputs_ml.f90 | 357 ++++ My_Reactions.inc | 152 ++ My_WetDep_ml.f90 | 131 ++ N2O5_hydrolysis_ml.f90 | 115 ++ Nest_ml.f90 | 711 +++++++ NetCDF_ml.f90 | 1477 ++++++++++++++ OrganicAerosol_ml.f90 | 79 + OutputChem_ml.f90 | 354 ++++ Output_hourly.f90 | 420 ++++ Par_ml.f90 | 383 ++++ PhyChem_ml.f90 | 262 +++ PhysicalConstants_ml.f90 | 93 + Radiation_ml.f90 | 440 +++++ Rb_ml.f90 | 105 + ReadField_ml.f90 | 236 +++ Rsurface_ml.f90 | 342 ++++ Runchem_ml.f90 | 221 +++ SOA_ml.f90 | 78 + SeaSalt_ml.f90 | 317 +++ Setup_1d_ml.f90 | 399 ++++ Setup_1dfields_ml.f90 | 75 + Sites_ml.f90 | 727 +++++++ SmallUtils_ml.f90 | 291 +++ SoilWater_ml.f90 | 41 + Solver.f90 | 293 +++ StoFlux_ml.f90 | 182 ++ SubMet_ml.f90 | 333 ++++ Tabulations_ml.f90 | 206 ++ TimeDate_ml.f90 | 384 ++++ Timefactors_ml.f90 | 363 ++++ Timing_ml.f90 | 133 ++ Trajectory_ml.f90 | 197 ++ Unimod.f90 | 457 +++++ Volcanos_ml.f90 | 239 +++ Wesely_ml.f90 | 129 ++ global2local.f90 | 269 +++ local2global.f90 | 92 + modrun.pl | 717 +++++++ 88 files changed, 38058 insertions(+) create mode 100644 Advection_ml.f90 create mode 100644 Aero_Rb_ml.f90 create mode 100644 Aero_water_ml.f90 create mode 100644 AirEmis_ml.f90 create mode 100644 Ammonium_ml.f90 create mode 100644 Aqueous_ml.f90 create mode 100644 Biogenics_ml.f90 create mode 100644 BoundaryConditions_ml.f90 create mode 100644 CellMet_ml.f90 create mode 100644 CheckStop_ml.f90 create mode 100644 Chem_ml.f90 create mode 100644 CoDep_ml.f90 create mode 100644 Country_ml.f90 create mode 100644 DO3SE_ml.f90 create mode 100644 DefPhotolysis_ml.f90 create mode 100644 Derived_ml.f90 create mode 100644 DryDep_ml.f90 create mode 100644 EQSAM_ml.f90 create mode 100644 EmisDef_ml.f90 create mode 100644 EmisGet_ml.f90 create mode 100644 Emissions_ml.f90 create mode 100644 Functions_ml.f90 create mode 100644 GlobalBCs_ml.f90 create mode 100644 GridAllocate_ml.f90 create mode 100644 GridValues_ml.f90 create mode 100644 Io_Nums_ml.f90 create mode 100644 Io_Progs_ml.f90 create mode 100644 Io_ml.f90 create mode 100644 KeyValue_ml.f90 create mode 100644 LandDefs_ml.f90 create mode 100644 Landuse_ml.f90 create mode 100644 LocalVariables_ml.f90 create mode 100644 MARS_ml.f90 create mode 100644 Makefile create mode 100644 Makefile.SRCS create mode 100755 Makefile_njord create mode 100644 Makefile_snow create mode 100755 Makefile_stallo create mode 100644 MassBudget_ml.f90 create mode 100644 Met_ml.f90 create mode 100644 MicroMet_ml.f90 create mode 100644 ModelConstants_ml.f90 create mode 100644 My_Aerosols_ml.f90 create mode 100644 My_BoundConditions_ml.f90 create mode 100644 My_Chem_ml.f90 create mode 100644 My_Derived_ml.f90 create mode 100644 My_DryDep_ml.f90 create mode 100644 My_Emis_ml.f90 create mode 100644 My_FastReactions.inc create mode 100644 My_MassBudget_ml.f90 create mode 100644 My_Outputs_ml.f90 create mode 100644 My_Reactions.inc create mode 100644 My_WetDep_ml.f90 create mode 100644 N2O5_hydrolysis_ml.f90 create mode 100644 Nest_ml.f90 create mode 100644 NetCDF_ml.f90 create mode 100644 OrganicAerosol_ml.f90 create mode 100644 OutputChem_ml.f90 create mode 100644 Output_hourly.f90 create mode 100644 Par_ml.f90 create mode 100644 PhyChem_ml.f90 create mode 100644 PhysicalConstants_ml.f90 create mode 100644 Radiation_ml.f90 create mode 100644 Rb_ml.f90 create mode 100644 ReadField_ml.f90 create mode 100644 Rsurface_ml.f90 create mode 100644 Runchem_ml.f90 create mode 100644 SOA_ml.f90 create mode 100644 SeaSalt_ml.f90 create mode 100644 Setup_1d_ml.f90 create mode 100644 Setup_1dfields_ml.f90 create mode 100644 Sites_ml.f90 create mode 100644 SmallUtils_ml.f90 create mode 100644 SoilWater_ml.f90 create mode 100644 Solver.f90 create mode 100644 StoFlux_ml.f90 create mode 100644 SubMet_ml.f90 create mode 100644 Tabulations_ml.f90 create mode 100644 TimeDate_ml.f90 create mode 100644 Timefactors_ml.f90 create mode 100644 Timing_ml.f90 create mode 100644 Trajectory_ml.f90 create mode 100644 Unimod.f90 create mode 100644 Volcanos_ml.f90 create mode 100644 Wesely_ml.f90 create mode 100644 global2local.f90 create mode 100644 local2global.f90 create mode 100755 modrun.pl diff --git a/Advection_ml.f90 b/Advection_ml.f90 new file mode 100644 index 0000000..3a98edd --- /dev/null +++ b/Advection_ml.f90 @@ -0,0 +1,3952 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Advection_ml + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! DESCRIPTION +! +! This module contains the routines for advection and diffusion. +! The sequence of advection in x y or z direction and vertical diffusion, +! is controlled in the advecdiff routine. +! +! The horizontal advection is performed in the advx and advy routines using +! "Bott's fourth order scheme". The routine preadvx and preadvy take care of +! the transfer of information between processors before the advection step. +! +! The advvk routine performs the vertical advection. The advvdifvk does both +! vertical advection and diffusion. Bott's second order scheme with variable +! grid distance is used. The calculation of the coefficients used for this +! scheme is done in the routine vgrid. +! +! Corrected version by pw, 1/11/01: xn_adv(k=top) is updated in +! advvdifvk. We update fluxin and fluxout to account for the change in +! concentrations which occur when the top layer is "reset". +! +! Notes from Peter; 7/11/01 +! About the division by the surface pressure (p*): +! In my opinion the best way is to divide by the advected p*, (corresponding +! to the option where NSPEC_ADD_ADV is NOT equal to 0). This should ensure +! that, in the case of a uniform mixing ratio, we end up with a uniform mixing +! ratio, whatever the meteo. The problem is that if the meteo is not +! consistent (air is "created", or surface pressure does not corespond to the +! quantity of air) the total weight of species may vary, creating problems for +! the mass budget. I see however no simple solution for this problem. +! +! +! Peter, January 2002: The advecdiff routine has been completely reorganised, +! in order to allow for flexible timesteps. The timestep dt_advec can now be large. +! The advecdiff routine will divide dt_advec in several advection steps if the +! CFL condition is not met. For small dt_advec (600s in a 50x50 km2 grid)) +! these changes should usually have no effect on the result. +! Some small changes have been made in the Bott's scheme in the advx, advy and +! vgrid routines. The effect of these changes is estimated to be less than 1% on +! average monthly values. +! +! Peter, January 2003: The vertical diffusion and the division by p* have been +! extracted out of the advvdifvk routine. Now they are done separately. +! The number of diffusion iterations can be chosen (ndiff). +! A new option ADVEC_TYPE=2 can be chosen. This use the surface pressure of +! next meteo step for p* before division. This should make the advection scheme +! exactly mass conservative (?). ndiff and ADVEC_TYPE=2 have not yet been tested. +! +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + use Chemfields_ml, only : xn_adv + use GenSpec_adv_ml , only : NSPEC_ADV + use GridValues_ml, only : GRIDWIDTH_M,xm2,xmd,xm2ji,xmdji,carea,xm_i + use ModelConstants_ml, only : KMAX_BND,KMAX_MID,NMET, nstep, nmax, & + dt_advec, dt_advec_inv, PT,KCHEMTOP, NPROCX,NPROCY, NPROC + use Met_ml ,only : ps,sdot,skh,u,v + use MassBudget_ml, only : fluxin,fluxout + use My_Timing_ml, only : Code_timer, Add_2timing, tim_before,tim_after + use Par_ml, only : MAXLIMAX,MAXLJMAX,GJMAX,GIMAX,me,mex,mey,& + li0,li1,lj0,lj1 ,limax,ljmax, gi0, IRUNBEG,gj0, JRUNBEG & + ,neighbor,WEST,EAST,SOUTH,NORTH,NOPROC & + ,MSG_NORTH2,MSG_EAST2,MSG_SOUTH2,MSG_WEST2 + + implicit none + private + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE) + real :: MPIbuff(KMAX_MID*max(gimax,gjmax)) + integer, private, parameter :: NADVS = 3 + + real, private, save, dimension(KMAX_BND) :: dhs1, dhs1i, dhs2i + +! for vertical advection (nonequidistant spacing) + + 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, dimension(MAXLIMAX,KMAX_MID,NMET) :: vs,vn + + integer, public, parameter :: ADVEC_TYPE = 1 ! Divides by advected p* +! integer, public, parameter :: ADVEC_TYPE = 2 ! Divides by advected p* + + public :: assign_dtadvec + public :: assign_nmax + public :: vgrid + public :: advecdiff + public :: advecdiff_poles + public :: adv_var + public :: adv_int + + private :: advvk + private :: advvdifvk + private :: advx + private :: advy + private :: preadvx + private :: preadvy + + contains + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine assign_dtadvec(GRIDWIDTH_M) +! +! dt_advec is set according to the grid resolution +! The choosed timestep should lead to a Courant number <1 for +! "normal" wind speeds, but this is not a strict limitation. +! +! The values of dt_advec must be an integer fraction of 3600 +! +! The values put here are only suggestions +! + + implicit none + real, intent(in) ::GRIDWIDTH_M + + if(GRIDWIDTH_M>76000.0) dt_advec=1800.0 + if(GRIDWIDTH_M<61000.0) dt_advec=1200.0 + if(GRIDWIDTH_M<21000.0) dt_advec=600.0 + if(GRIDWIDTH_M<11000.0) dt_advec=300.0 + if(GRIDWIDTH_M<6000.0) dt_advec=180.0 + + dt_advec_inv=1.0/dt_advec + + if(me==0)write(*,*)'dt_advec set to: ',dt_advec + + end subroutine assign_dtadvec + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine assign_nmax(metstep) + + implicit none + integer, intent(in) :: metstep + +! local + integer nhelp + +! Assigne number of time-steps for the inner time-loop (over 6 hours) +! from dt_advec + + nhelp = nint(dt_advec) + if(mod(nhelp,60).ne.0) then + if (me .eq. 0) then + write(6,*) + write(6,*)'**********************************************' + write(6,*)& + 'Impossible dt_advec, dt_advec = (dt_advec/60) must be an integer' + write(6,*) + endif + endif + + nhelp = nhelp/60 + + if(mod(60,nhelp).ne.0) then + if (me .eq. 0) then + write(6,*) + write(6,*)'**********************************************' + write(6,*)'Impossible dt_advec,60/(dt_advec/60) must be an integer' + write(6,*) + endif + endif + + nmax = 60/(nhelp)*metstep + + if (me .eq. 0) then + write(6,*) + write(6,*)'**********************************************' + write(6,*)'nmax and dt_advec : ',nmax,dt_advec + write(6,*)'**********************************************' + write(6,*) + endif + + end subroutine assign_nmax + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine advecdiff +!___________________________________________________________________________________ +!Flexible timestep. Peter Wind january-2002 +! +! dt_advec : time interval between two advections calls +! (controls time splitting between advection and chemistry ) +! +! dt_xys : time intervall between vertical and horizontal advection steps +!(controls time splitting between vertical and horizontal advection) +! There is one sequence (z),(x,y,y,x),(z) during each dt_xys +! +! dt_xy : time intervall for horizontal advection iterations +!(controls time splitting between x and y advection) +! There is one sequence x,y,y,x during each dt_xy +! +! dt_s : time intervall for vertical advection iterations +! +! dt_advec >= dt_xys >= max(dt_xy, dt_s) +! + + implicit none + +! local + + integer i,j,k,n,l,info + real dtsave,dth + real xntop(NSPEC_ADV,MAXLIMAX,MAXLJMAX) + real xnw(3*NSPEC_ADV,MAXLJMAX),xne(3*NSPEC_ADV,MAXLJMAX) + real xnn(3*NSPEC_ADV,MAXLIMAX), xns(3*NSPEC_ADV,MAXLIMAX) + real ps3d(MAXLIMAX,MAXLJMAX,KMAX_MID),psi + real psw(3,MAXLJMAX),pse(3,MAXLJMAX) + real psn(3,MAXLIMAX), pss(3,MAXLIMAX) + real ds3(2:KMAX_MID),ds4(2:KMAX_MID) + real ulmin,ulmax,vlmin,vlmax,ucmax,vcmax + integer inadvst + logical lvertsplit + real dhskmax,sdotmax,sdotmin + real sdotmaxk,sdotmink + real sdotmaxadv,sum + + real xcmax(KMAX_MID),ycmax(KMAX_MID),scmax,sdcmax,c_max + real dt_xysmax,dt_xymax(KMAX_MID),dt_smax + real dt_xys,dt_xy(KMAX_MID),dt_s,div + integer niterxys,niterxy(KMAX_MID),niters,nxy,ndiff + integer iterxys,iterxy,iters + logical,save :: firstcall = .true. + integer numt,pwdebug,idebug,jdebug,i_fdom,j_fdom + logical, parameter :: DEBUG_ADV = .false. + pwdebug=0 + idebug=0 + jdebug=0 + +13 format(10E16.7) + + + call Code_timer(tim_before) + + if(KCHEMTOP==2)then + xntop(:,:,:)=xn_adv(:,:,:,1) + endif + +! convert from mixing ratio to concentration before advection + + do k = 1,KMAX_MID + do j = 1,ljmax + do i = 1,limax + + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*(ps(i,j,1)-PT) + + ps3d(i,j,k) = ps(i,j,1) - PT + + end do + end do + end do + + call Add_2timing(25,tim_after,tim_before,"advecdiff:ps") + +! time-splitting is used for the physical and chemical operators. +! second-order accuracy in time is obtained by alternating the order +! of the advx and advy operators from one time-step to another. + +! +! Determine timestep for horizontal advection. +! +! Courant criterion, which takes into account the mapping factor xm2: +! left face: xm2(i) u(i) dt/dx < 1 when u(i) > 0 +! right face: xm2(i) |u(i-1)| dt/dx < 1 when u(i-1) < 0 +! +! In the case where the flux is streaming out of the cell i from both faces, +! then the total should be < 1: +! xm2(i) |u(i-1)| dt/dx + xm2(i) u(i) dt/dx < 1 for u(i-1)<0 and u(i)>0 +! +! The three conditions can be written as: +! +! max(xm2(i)*u(i)*dt/dx , 0.0) - min(xm2(i)*u(i-1)*dt/dx , 0.0) < 1 +! +! or equivalently: +! dt < dx / ( max(xm2(i)*u(i) , 0.0) - min(xm2(i)*u(i-1) , 0.0) ) +! +! In the case of variable cell size, dx is defined as dx(i) in these formula. +! +! The value 1.e-30 is to ensure that we don't divide by 0 when all the velocities are 0. + + dth = dt_advec/GRIDWIDTH_M + + do k=1,KMAX_MID + + xcmax(k) = maxval(amax1(u(1:limax,1:ljmax,k,1)*xm2(1:limax,1:ljmax), 1.e-30) & + -amin1(u(0:limax-1,1:ljmax,k,1)*xm2(1:limax,1:ljmax), 0.0) ) + ycmax(k) = maxval(amax1(v(1:limax,1:ljmax,k,1)*xm2(1:limax,1:ljmax), 0.0) & + -amin1(v(1:limax,0:ljmax-1,k,1)*xm2(1:limax,1:ljmax), 0.0) ) + + xcmax(k) = amax1(xcmax(k),ycmax(k)) + enddo + MPIbuff(1:KMAX_MID)= xcmax(1:KMAX_MID) + CALL MPI_ALLREDUCE(MPIbuff, xcmax, KMAX_MID,MPI_DOUBLE_PRECISION, MPI_MAX, & + MPI_COMM_WORLD, INFO) + + + do k=1,KMAX_MID + dt_xymax(k)=GRIDWIDTH_M/xcmax(k) + enddo +44 format('k =',I4,6F12.4) + + + +!Courant number in vertical sigma coordinates: sigmadot*dt/deltasigma +! +!Note that dhs1(k+1) denotes thickness of layer k +! and sdot(k+1) denotes sdot at the boundary between layer k and k+1 +! +!flux through wall k+1: sdot(k+1) *dt/dhs1(k+1)<1 for sdot(k+1)>0 +! |sdot(k+1)|*dt/dhs1(k+2)<1 for sdot(k+1)<0 +! +!layer k: sdot(k+1)*dt/dhs1(k+1) + |sdot(k)|*dt/dhs1(k+1) <1 for sdot(k+1)>0 and sdot(k)<0 +! +!total out of layer k: amax1(sdot(1:limax,1:ljmax,k+1,1),0.0)-amin1(sdot(1:limax,1:ljmax,k,1),0.0) +! + scmax = 1.e-30 + do k = 1,KMAX_MID + sdcmax=maxval( amax1(sdot(1:limax,1:ljmax,k+1,1),0.0) & + -amin1(sdot(1:limax,1:ljmax,k,1),0.0) ) + scmax = amax1(sdcmax/dhs1(k+1),scmax) + enddo + + MPIbuff(1:1)= scmax + CALL MPI_ALLREDUCE(MPIbuff, scmax, 1,MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, INFO) + dt_smax = 1./scmax + + dt_xysmax = amax1(dt_smax, maxval(dt_xymax(1:KMAX_MID))) + niterxys = int(dt_advec/dt_xysmax)+1 + + dt_xys = dt_advec/real(niterxys) + niters = int(dt_xys/dt_smax)+1 + + dt_s = dt_xys/real(niters) +! if(me.eq.0)then +! write(*,45)dt_xysmax,dt_xys,niterxys +! write(*,45)dt_smax,dt_s,niters +! endif + nxy=0 + do k=1,KMAX_MID + niterxy(k) = int(dt_xys/dt_xymax(k))+1 + dt_xy(k) = dt_xys/real(niterxy(k)) + nxy=nxy+niterxy(k) +! if(me.eq.0)then +! write(*,46)k,dt_xymax(k),dt_xy(k),niterxy(k) +! endif + enddo + if(me.eq.0)then + c_max=maxval(xcmax(1:KMAX_MID)*dt_xy(1:KMAX_MID)/GRIDWIDTH_M) + if (DEBUG_ADV) write(*,47)niterxys-1,nxy-KMAX_MID,niters-1, & + c_max,xcmax(KMAX_MID)*dt_xy(KMAX_MID)/GRIDWIDTH_M + endif +! if(me.eq.0)then +! write(*,47)nxy,nxy/20. +! endif +45 format(2F12.4,I6) +46 format('k = ',I6,2F12.4,I6,2F12.4,I6) +47 format('extra iterations (xyz,xy,z), C_max, C_max_surface:',3I3,2F7.3) + + call Add_2timing(20,tim_after,tim_before, & + "advecdiff:synchronization") + +! Start xys advection loop: + iterxys = 0 + do while (iterxys < niterxys) + if(mod(nstep,2) /= 0 .or. iterxys /= 0)then !start a xys sequence + + iterxys = iterxys + 1 + do k = 1,KMAX_MID + dth = dt_xy(k)/GRIDWIDTH_M + do iterxy=1,niterxy(k) + + ! send/receive in x-direction + + call preadvx(1100+k & + ,xn_adv(1,1,1,k),ps3d(1,1,k),u(0,1,k,1) & + ,xnw,xne & + ,psw,pse) + + ! x-direction + do j = lj0,lj1 + call advx( & + u(0,j,k,1),uw(j,k,1),ue(j,k,1) & + ,xn_adv(1,1,j,k),xnw(1,j),xne(1,j) & + ,ps3d(1,j,k),psw(1,j),pse(1,j) & + ,xm2(0,j),xmd(0,j) & + ,dth,carea(k)) + + enddo + + call Add_2timing(21,tim_after,tim_before,"advecdiff:preadvx,advx") + + ! send/receive in y-direction + + call preadvy(1300+k & + ,xn_adv(1,1,1,k),ps3d(1,1,k),v(1,0,k,1) & + ,xns, xnn & + ,pss, psn) + + ! y-direction + +! call Add_2timing(22,tim_after,tim_before, & +! "advecdiff:preadvy") + + do i = li0,li1 + call advy( & + v(i,0,k,1),vs(i,k,1),vn(i,k,1) & + ,xn_adv(1,i,1,k),xns(1,i),xnn(1,i) & + ,ps3d(i,1,k),pss(1,i),psn(1,i) & + ,xm2ji(0,i),xmdji(0,i) & + ,dth,carea(k)) + + enddo + + call Add_2timing(23,tim_after,tim_before,"advecdiff:advy") + + enddo !iterxy horizontal (xy) advection + enddo !k horizontal (xy) advection + + + do iters=1,niters + + !perform only vertical advection + do j = lj0,lj1 + do i = li0,li1 + + call advvk(xn_adv(1,i,j,1),ps3d(i,j,1) & + ,sdot(i,j,1,1),dt_s) + + enddo + enddo + + + enddo ! vertical (s) advection + call Add_2timing(24,tim_after,tim_before,"advecdiff:advvk") + + else !start a yxs sequence + + iterxys = iterxys + 1 + + do k = 1,KMAX_MID + dth = dt_xy(k)/GRIDWIDTH_M + do iterxy=1,niterxy(k) + + ! send/receive in y-direction + + call preadvy(1300+k & + ,xn_adv(1,1,1,k),ps3d(1,1,k),v(1,0,k,1) & + ,xns, xnn & + ,pss, psn) + + ! y-direction + +! call Add_2timing(22,tim_after,tim_before, & +! "advecdiff:preadvy") + + do i = li0,li1 + call advy( & + v(i,0,k,1),vs(i,k,1),vn(i,k,1) & + ,xn_adv(1,i,1,k),xns(1,i),xnn(1,i) & + ,ps3d(i,1,k),pss(1,i),psn(1,i) & + ,xm2ji(0,i),xmdji(0,i) & + ,dth,carea(k)) + + enddo + + call Add_2timing(23,tim_after,tim_before,"advecdiff:advy") + + ! send/receive in x-direction + + call preadvx(1100+k & + ,xn_adv(1,1,1,k),ps3d(1,1,k),u(0,1,k,1) & + ,xnw,xne & + ,psw,pse) + + ! x-direction + do j = lj0,lj1 + call advx( & + u(0,j,k,1),uw(j,k,1),ue(j,k,1) & + ,xn_adv(1,1,j,k),xnw(1,j),xne(1,j) & + ,ps3d(1,j,k),psw(1,j),pse(1,j) & + ,xm2(0,j),xmd(0,j) & + ,dth,carea(k)) + + enddo + + call Add_2timing(21,tim_after,tim_before,"advecdiff:preadvx,advx") + + enddo !iterxy horizontal (xy) advection + enddo !k horizontal (xy) advection + + do iters=1,niters + + !perform only vertical advection + do j = lj0,lj1 + do i = li0,li1 + + call advvk(xn_adv(1,i,j,1),ps3d(i,j,1) & + ,sdot(i,j,1,1),dt_s) + + enddo + enddo + + + enddo ! vertical (s) advection + call Add_2timing(24,tim_after,tim_before,"advecdiff:advvk") + + endif ! yxs sequence + enddo + + +! division by p*, to transform back into mixing ratios units + if(ADVEC_TYPE==2)then !this option is "mass conservative" + div = 1./real(nmax-(nstep-1)) +! do k=1,KMAX_MID +! ps3d(:,:,k) = (ps(:,:,1) & +! + (ps(:,:,2) - ps(:,:,1))*div-PT) +! enddo + do j = lj0,lj1 + do i = li0,li1 + psi = 1./(ps(i,j,1)+(ps(i,j,2) - ps(i,j,1))*div-PT) + do k=1,KMAX_MID + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*psi + enddo + enddo + enddo + elseif(ADVEC_TYPE==1)then !this option is recommended (?). + !It is "mixing ratio conservative" (uses advected p*) + do k=1,KMAX_MID + do j = lj0,lj1 + do i = li0,li1 + psi = 1./ps3d(i,j,k) + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*psi + enddo + enddo + enddo + else + do k=1,KMAX_MID + do j = lj0,lj1 + do i = li0,li1 + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)/(ps(i,j,1)-PT) + enddo + enddo + enddo + endif + + call Add_2timing(25,tim_after,tim_before,"advecdiff:ps") + +!vertical diffusion + ndiff = 1 !number of vertical diffusion iterations (the larger the better) + do k = 2,KMAX_MID + ds3(k) = dt_advec*dhs1i(k)*dhs2i(k) + ds4(k) = dt_advec*dhs1i(k+1)*dhs2i(k) + enddo + + !sum is conserved under vertical diffusion +! sum = 0. +! do k=1,KMAX_MID +! sum = sum + xn_adv(1,4,4,k)/dhs1i(k+1) +! enddo +! write(*,*)'sum before diffusion ',me,sum + do j = lj0,lj1 + do i = li0,li1 + call vertdiffn(xn_adv(1,i,j,1),skh(i,j,1,1),ds3,ds4,ndiff) + enddo + enddo +! sum = 0. +! do k=1,KMAX_MID +! sum = sum + xn_adv(1,4,4,k)/dhs1i(k+1) +! enddo +! write(*,*)'sum after diffusion ',me,sum + call Add_2timing(22,tim_after,tim_before,"advecdiff:diffusion") + + + if(lj0.ne.1)then + do k=KCHEMTOP,KMAX_MID + do i = 1,limax + xn_adv(:,i,1,k) = xn_adv(:,i,1,k)/(ps(i,1,1)-PT) + enddo + enddo + endif + if(li0.ne.1)then + do k=KCHEMTOP,KMAX_MID + do j=lj0,lj1 + xn_adv(:,1,j,k) = xn_adv(:,1,j,k)/(ps(1,j,1)-PT) + enddo + enddo + endif + if(li1.ne.limax)then + do k=KCHEMTOP,KMAX_MID + do j=lj0,lj1 + xn_adv(:,limax,j,k) = xn_adv(:,limax,j,k) & + /(ps(limax,j,1)-PT) + enddo + enddo + endif + if(lj1.ne.ljmax)then + do k=KCHEMTOP,KMAX_MID + do i = 1,limax + xn_adv(:,i,ljmax,k) = xn_adv(:,i,ljmax,k) & + /(ps(i,ljmax,1)-PT) + enddo + enddo + endif + + if(KCHEMTOP==2)then + +!pw since the xn_adv are changed it corresponds to a flux in or +! out of the system: + + do i = li0,li1 + do j = lj0,lj1 + where(xn_adv(:,i,j,1) .gt. xntop(:,i,j)) + fluxout(:) = fluxout(:) + & + (xn_adv(:,i,j,1) - xntop(:,i,j)) & + *(ps(i,j,1)-PT)*carea(1)*xmd(i,j) + elsewhere + fluxin(:) = fluxin(:) + & + (xntop(:,i,j) - xn_adv(:,i,j,1)) & + *(ps(i,j,1)-PT)*carea(1)*xmd(i,j) + end where + + + enddo + enddo + xn_adv(:,:,:,1) = xntop(:,:,:) + + endif + +! call Add_2timing(24,tim_after,tim_before,"advecdiff:advvkdiff") + return + + + end subroutine advecdiff + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine advecdiff_poles + !___________________________________________________________________________________ + !Uses more robust options: + !1)Advect i,j directions independently and 1D with own timestep + !2)Do not advect but only "mix" the concentrations near poles ("near" + ! poles is determined by NITERXMAX. + ! + !Flexible timestep. Peter Wind january-2002 + ! + ! dt_advec : time interval between two advections calls + ! (controls time splitting between advection and chemistry ) + ! + ! dt_xys : time intervall between vertical and horizontal advection steps + !(controls time splitting between vertical and horizontal advection) + ! There is one sequence (z),(x,y,y,x),(z) during each dt_xys + ! + ! dt_xy : time intervall for horizontal advection iterations + !(controls time splitting between x and y advection) + ! There is one sequence x,y,y,x during each dt_xy + ! + ! dt_s : time intervall for vertical advection iterations + ! + ! dt_advec >= dt_xys >= max(dt_xy, dt_s) + ! + + implicit none + + ! local + + integer i,j,k,n,l,info + real dtsave,dth + real xntop(NSPEC_ADV,MAXLIMAX,MAXLJMAX) + real xnw(3*NSPEC_ADV),xne(3*NSPEC_ADV) + real xnn(3*NSPEC_ADV), xns(3*NSPEC_ADV) + real ps3d(MAXLIMAX,MAXLJMAX,KMAX_MID),psi + real psw(3),pse(3) + real psn(3), pss(3) + real ds3(2:KMAX_MID),ds4(2:KMAX_MID) + real ulmin,ulmax,vlmin,vlmax,ucmax,vcmax + integer inadvst + logical lvertsplit + real dhskmax,sdotmax,sdotmin + real sdotmaxk,sdotmink + real sdotmaxadv,sum + + real xcmax(KMAX_MID,GJMAX),ycmax(KMAX_MID,GIMAX),scmax,sdcmax,c_max + real dt_xysmax,dt_xymax(KMAX_MID),dt_smax + real dt_xys,dt_xy(KMAX_MID),dt_s,div + real dt_x(MAXLJMAX,KMAX_MID),dt_y(MAXLIMAX,KMAX_MID) + real dt_xmax(MAXLJMAX,KMAX_MID),dt_ymax(MAXLIMAX,KMAX_MID) + integer niterx(MAXLJMAX,KMAX_MID),nitery(MAXLIMAX,KMAX_MID) + + integer niterxys,niterxy(KMAX_MID),niters,nxy,ndiff + integer iterxys,iterxy,iters,iterx,itery,nxx,nxxmin,nyy + logical,save :: firstcall = .true. + integer numt,pwdebug,idebug,jdebug,i_fdom,j_fdom + + real ::hours,houre,houra,date_ad + integer ::isum,isumtot,iproc + real :: xn_advjktot(NSPEC_ADV),xn_advjk(NSPEC_ADV),rfac + + + !NITERXMAX=max value of iterations accepted for fourth order Bott scheme. + !If the calculated number of iterations (determined from Courant number) + !exceeds NITERXMAX, the advection is not done, but instead all the mixing + !ratio along that line are averaged (1D). + !This case can arises where there is a singularity close to the + !poles in long-lat coordinates. + integer,parameter :: NITERXMAX=10 + + +13 format(10E16.7) + + call Code_timer(tim_before) + + if(firstcall)then + if(NPROCY>2.and.me==0)write(*,*)& + 'COMMENT: Advection routine will work faster if NDY = 2 (or 1)' + endif + + if(KCHEMTOP==2)then + xntop(:,:,:)=xn_adv(:,:,:,1) + endif + + ! convert from mixing ratio to concentration before advection + + do k = 1,KMAX_MID + do j = 1,ljmax + do i = 1,limax + + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*(ps(i,j,1)-PT) + + ps3d(i,j,k) = ps(i,j,1) - PT + + end do + end do + end do + + call Add_2timing(25,tim_after,tim_before,"advecdiff:ps") + + ! time-splitting is used for the physical and chemical operators. + ! second-order accuracy in time is obtained by alternating the order + ! of the advx and advy operators from one time-step to another. + + ! + ! Determine timestep for horizontal advection. + ! + ! Courant criterion, which takes into account the mapping factor xm2: + ! left face: xm2(i) u(i) dt/dx < 1 when u(i) > 0 + ! right face: xm2(i) |u(i-1)| dt/dx < 1 when u(i-1) < 0 + ! + ! In the case where the flux is streaming out of the cell i from both faces, + ! then the total should be < 1: + ! xm2(i) |u(i-1)| dt/dx + xm2(i) u(i) dt/dx < 1 for u(i-1)<0 and u(i)>0 + ! + ! The three conditions can be written as: + ! + ! max(xm2(i)*u(i)*dt/dx , 0.0) - min(xm2(i)*u(i-1)*dt/dx , 0.0) < 1 + ! + ! or equivalently: + ! dt < dx / ( max(xm2(i)*u(i) , 0.0) - min(xm2(i)*u(i-1) , 0.0) ) + ! + ! In the case of variable cell size, dx is defined as dx(i) in these formula. + ! + ! The value 1.e-30 is to ensure that we don't divide by 0 when all the velocities are 0. + + dth = dt_advec/GRIDWIDTH_M + xcmax=0.0 + ycmax=0.0 + do k=1,KMAX_MID + + do j=1,ljmax + xcmax(k,j+gj0-1) = maxval(amax1(u(1:limax,j,k,1)*& + xm2(1:limax,j), 1.e-30) & + -amin1(u(0:limax-1,j,k,1)*& + xm2(1:limax,j), 0.0) ) + enddo + do i=1,limax + ycmax(k,i+gi0-1) = maxval(amax1(v(i,1:ljmax,k,1)*xm2(i,1:ljmax), 0.0) & + -amin1(v(i,0:ljmax-1,k,1)*xm2(i,1:ljmax), 0.0) ) + enddo + + enddo + + n=0 + do j=1,gjmax + do k=1,KMAX_MID + n=n+1 + MPIbuff(n)= xcmax(k,j) + enddo + enddo + CALL MPI_ALLREDUCE(MPIbuff, xcmax, KMAX_MID*gjmax,MPI_DOUBLE_PRECISION, & + MPI_MAX, MPI_COMM_WORLD, INFO) + + + n=0 + do i=1,gimax + do k=1,KMAX_MID + n=n+1 + MPIbuff(n)= ycmax(k,i) + enddo + enddo + CALL MPI_ALLREDUCE(MPIbuff, ycmax, KMAX_MID*gimax,MPI_DOUBLE_PRECISION, & + MPI_MAX, MPI_COMM_WORLD, INFO) + + do i=1,limax + do k=1,KMAX_MID + dt_ymax(i,k)=GRIDWIDTH_M/ycmax(k,i+gi0-1) + enddo + enddo + do j=1,ljmax + do k=1,KMAX_MID + dt_xmax(j,k)=GRIDWIDTH_M/xcmax(k,j+gj0-1) + enddo + enddo + + niterx=1 + do k=1,KMAX_MID + do j=1,ljmax + niterx(j,k) = int(dt_advec/dt_xmax(j,k))+1 + dt_x(j,k) = dt_advec/real(niterx(j,k)) + !if(me==0)write(*,*)'x',me,j,k,niterx(j,k),xcmax(k,j+gj0-1) + enddo + enddo + + do k=1,KMAX_MID + do i=1,limax + nitery(i,k) = int(dt_advec/dt_ymax(i,k))+1 + dt_y(i,k) = dt_advec/real(nitery(i,k)) + enddo + enddo + +44 format('k =',I4,6F12.4) + + !Courant number in vertical sigma coordinates: sigmadot*dt/deltasigma + ! + !Note that dhs1(k+1) denotes thickness of layer k + ! and sdot(k+1) denotes sdot at the boundary between layer k and k+1 + ! + !flux through wall k+1: sdot(k+1) *dt/dhs1(k+1)<1 for sdot(k+1)>0 + ! |sdot(k+1)|*dt/dhs1(k+2)<1 for sdot(k+1)<0 + ! + !layer k: sdot(k+1)*dt/dhs1(k+1) + |sdot(k)|*dt/dhs1(k+1) <1 for sdot(k+1)>0 and sdot(k)<0 + ! + !total out of layer k: amax1(sdot(1:limax,1:ljmax,k+1,1),0.0)-amin1(sdot(1:limax,1:ljmax,k,1),0.0) + ! + scmax = 1.e-30 + do k = 1,KMAX_MID + sdcmax=maxval( amax1(sdot(1:limax,1:ljmax,k+1,1),0.0) & + -amin1(sdot(1:limax,1:ljmax,k,1),0.0) ) + scmax = amax1(sdcmax/dhs1(k+1),scmax) + enddo + + MPIbuff(1:1)= scmax + CALL MPI_ALLREDUCE(MPIbuff, scmax, 1,MPI_DOUBLE_PRECISION, MPI_MAX, MPI_COMM_WORLD, INFO) + dt_smax = 1./scmax +42 FORMAT(A,F10.2) + if(me==0.and. firstcall)write(*,42)'dt_smax',dt_smax + niters = int(dt_advec/dt_smax)+1 + dt_s = dt_advec/real(niters) + + niterxys = 1 + + + nxy=0 + nxx=0 + nxxmin=0 + nyy=0 + do k=1,KMAX_MID + do j=1,ljmax + nxy=nxy+niterx(j,k)-1 + nxx=nxx+niterx(j,k)-1 + if(niterx(j,k)>NITERXMAX)then + nxxmin=nxxmin+niterx(j,k) + endif + enddo + do i=1,limax + nxy=nxy+nitery(i,k)-1 + nyy=nyy+nitery(i,k)-1 + enddo + + enddo + if(me.eq.0)then + write(*,43)KMAX_MID*ljmax,nxx,nxxmin,KMAX_MID*limax,nyy,niters + endif +43 format('total iterations x, y, k: ',I4,' +',I4,' -',I4,', ',I5,' +',I3,',',I4) + + + ! stop + +45 format(2F12.4,I6) +46 format('k = ',I6,2F12.4,I6,2F12.4,I6) +47 format('extra iterations (xyz,xy,z), C_max, C_max_surface:',3I3,2F7.3) + + call Add_2timing(20,tim_after,tim_before, & + "advecdiff:synchronization") + + ! Start xys advection loop: + + iterxys = 0 + do while (iterxys < niterxys) + if(mod(nstep,2) /= 0 .or. iterxys /= 0)then !start a xys sequence + ! if(.true.)then !start a xys sequence + + iterxys = iterxys + 1 + do k = 1,KMAX_MID + + do j = lj0,lj1 + + if(niterx(j,k)<=NITERXMAX)then + dth = dt_x(j,k)/GRIDWIDTH_M + do iterx=1,niterx(j,k) + call preadvx2(110+k+KMAX_MID*j & + ,xn_adv(1,1,j,k),ps3d(1,j,k),u(0,j,k,1) & + ,xnw,xne & + ,psw,pse) + + ! x-direction + call advx( & + u(0,j,k,1),uw(j,k,1),ue(j,k,1) & + ,xn_adv(1,1,j,k),xnw,xne & + ,ps3d(1,j,k),psw,pse & + ,xm2(0,j),xmd(0,j) & + ,dth,carea(k)) + + + enddo !iter + + endif + enddo !j + + enddo !k horizontal (x) advection + !renormalize with p* + do k=1,KMAX_MID + do j = lj0,lj1 + do i = li0,li1 + + psi = (ps(i,j,1) - PT)/ps3d(i,j,k) + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*psi + ps3d(i,j,k) = ps(i,j,1) - PT + + enddo + enddo + enddo + + call Add_2timing(21,tim_after,tim_before,"advecdiff:advx") + + ! y-direction + do k = 1,KMAX_MID + do i = li0,li1 + dth = dt_y(i,k)/GRIDWIDTH_M + do itery=1,nitery(i,k) + + call preadvy2(520+k & + ,xn_adv(1,1,1,k),ps3d(1,1,k),v(1,0,k,1) & + ,xns, xnn & + ,pss, psn,i) + + call advy( & + v(i,0,k,1),vs(i,k,1),vn(i,k,1) & + ,xn_adv(1,i,1,k),xns,xnn & + ,ps3d(i,1,k),pss,psn & + ,xm2ji(0,i),xmdji(0,i) & + ,dth,carea(k)) + + enddo !iter + + + enddo !i + enddo !k horizontal (y) advection + call Add_2timing(23,tim_after,tim_before,"advecdiff:advy") + + !renormalize with p* + do k=1,KMAX_MID + do j = lj0,lj1 + do i = li0,li1 + + psi = (ps(i,j,1) - PT)/ps3d(i,j,k) + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*psi + ps3d(i,j,k) = ps(i,j,1) - PT + + enddo + enddo + enddo + + + do iters=1,niters + + !perform only vertical advection + do j = lj0,lj1 + do i = li0,li1 + + call advvk(xn_adv(1,i,j,1),ps3d(i,j,1) & + ,sdot(i,j,1,1),dt_s) + + enddo + enddo + + + enddo ! vertical (s) advection + call Add_2timing(24,tim_after,tim_before,"advecdiff:advvk") + + else !start a yxs sequence + + iterxys = iterxys + 1 + + + do k = 1,KMAX_MID + do i = li0,li1 + dth = dt_y(i,k)/GRIDWIDTH_M + do itery=1,nitery(i,k) + ! send/receive in y-direction + call preadvy2(13000+k+KMAX_MID*itery+1000*i & + ,xn_adv(1,1,1,k),ps3d(1,1,k),v(1,0,k,1) & + ,xns, xnn & + ,pss, psn,i) + + ! y-direction + + ! call Add_2timing(22,tim_after,tim_before, & + ! "advecdiff:preadvy") + + call advy( & + v(i,0,k,1),vs(i,k,1),vn(i,k,1) & + ,xn_adv(1,i,1,k),xns,xnn & + ,ps3d(i,1,k),pss,psn & + ,xm2ji(0,i),xmdji(0,i) & + ,dth,carea(k)) + + enddo !iter + + + enddo !i + enddo !k horizontal (y) advection + !renormalize with p* + do k=1,KMAX_MID + do j = lj0,lj1 + do i = li0,li1 + + psi = (ps(i,j,1) - PT)/ps3d(i,j,k) + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*psi + ps3d(i,j,k) = ps(i,j,1) - PT + + enddo + enddo + enddo + call Add_2timing(23,tim_after,tim_before,"advecdiff:advy") + + do k = 1,KMAX_MID + do j = lj0,lj1 + if(niterx(j,k)<=NITERXMAX)then + dth = dt_x(j,k)/GRIDWIDTH_M + do iterx=1,niterx(j,k) + + ! send/receive in x-direction + call preadvx2(21000+k+KMAX_MID*iterx+1000*j & + ,xn_adv(1,1,j,k),ps3d(1,j,k),u(0,j,k,1) & + ,xnw,xne & + ,psw,pse) + + + ! x-direction + call advx( & + u(0,j,k,1),uw(j,k,1),ue(j,k,1) & + ,xn_adv(1,1,j,k),xnw,xne & + ,ps3d(1,j,k),psw,pse & + ,xm2(0,j),xmd(0,j) & + ,dth,carea(k)) + + enddo !iter + endif + enddo !j + + + enddo !k horizontal (x) advection + call Add_2timing(21,tim_after,tim_before,"advecdiff:advx") + + !renormalize with p* + do k=1,KMAX_MID + do j = lj0,lj1 + do i = li0,li1 + + psi = (ps(i,j,1) - PT)/ps3d(i,j,k) + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*psi + ps3d(i,j,k) = ps(i,j,1) - PT + + enddo + enddo + enddo + + do iters=1,niters + + !perform only vertical advection + do j = lj0,lj1 + do i = li0,li1 + + call advvk(xn_adv(1,i,j,1),ps3d(i,j,1) & + ,sdot(i,j,1,1),dt_s) + + enddo + enddo + + + enddo ! vertical (s) advection + call Add_2timing(24,tim_after,tim_before,"advecdiff:advvk") + + endif ! yxs sequence + enddo + ! stop + + + ! division by p*, to transform back into mixing ratios units + if(ADVEC_TYPE==2)then !this option is "mass conservative" + div = 1./real(nmax-(nstep-1)) + do j = lj0,lj1 + do i = li0,li1 + psi = 1./(ps(i,j,1)+(ps(i,j,2) - ps(i,j,1))*div-PT) + do k=1,KMAX_MID + ! if(niterx(j,k)<=NITERXMAX)then + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*psi + ! endif + enddo + enddo + enddo + elseif(ADVEC_TYPE==1)then !this option is recommended (?). + !It is "mixing ratio conservative" (uses advected p*) + + do k=1,KMAX_MID + do j = lj0,lj1 + do i = li0,li1 + ! if(niterx(j,k)<=NITERXMAX)then + psi = 1./ps3d(i,j,k) + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)*psi + ! endif + enddo + enddo + enddo + else + do k=1,KMAX_MID + do j = lj0,lj1 + do i = li0,li1 + ! if(niterx(j,k)<=NITERXMAX)then + xn_adv(:,i,j,k) = xn_adv(:,i,j,k)/(ps(i,j,1)-PT) + ! endif + enddo + enddo + enddo + endif + do k=1,KMAX_MID + do j = lj0,lj1 + if(niterx(j,k)>NITERXMAX)then + !if(mex==0)write(*,*)'Simplified advection',k,j,niterx(j,k) + !simplified "advection": average the mixing ratios over all x + ! average 1D + xn_advjk=0.0 + isum=0 + do i = li0,li1 + ! psi=1.0/(ps(i,j,1)-PT) + xn_advjk(:) = xn_advjk(:)+xn_adv(:,i,j,k)!*psi + isum=isum+1 + enddo + !sum over all processors along i direction. mex=0 collects the sum + !me = mex + mey*NPROCX + if(mex>0)then + + CALL MPI_SEND(xn_advjk , 8*NSPEC_ADV, MPI_BYTE, & + mey*NPROCX, 100*mey+j+1000, MPI_COMM_WORLD, INFO) + !receive averages from mex=0 + CALL MPI_RECV( xn_advjk, 8*NSPEC_ADV, MPI_BYTE, & + mey*NPROCX, 100*mey+j+3000, MPI_COMM_WORLD, STATUS, INFO) + + else + xn_advjktot(:)= xn_advjk(:) + isumtot=isum + do iproc=1,NPROCX-1 + CALL MPI_RECV( xn_advjk, 8*NSPEC_ADV, MPI_BYTE, & + iproc+mey*NPROCX, 100*mey+j+1000, MPI_COMM_WORLD, STATUS, INFO) + xn_advjktot(:)= xn_advjktot(:)+xn_advjk(:) + ! isumtot=isumtot+isum + enddo + rfac=1.0/GIMAX + xn_advjk(:)=xn_advjktot(:)*rfac + ! write(*,*)'ISUM',mey,isumtot,isum,GIMAX + !send result to all processors in i direction + do iproc=1,NPROCX-1 + CALL MPI_SEND(xn_advjk , 8*NSPEC_ADV, MPI_BYTE, & + iproc+mey*NPROCX, 100*mey+j+3000, MPI_COMM_WORLD, INFO) + enddo + + endif + do i = li0,li1 + xn_adv(:,i,j,k)= xn_advjk(:) + enddo + + endif + enddo + enddo + call Add_2timing(25,tim_after,tim_before,"advecdiff:ps") + + !vertical diffusion + ndiff = 1 !number of vertical diffusion iterations (the larger the better) + do k = 2,KMAX_MID + ds3(k) = dt_advec*dhs1i(k)*dhs2i(k) + ds4(k) = dt_advec*dhs1i(k+1)*dhs2i(k) + enddo + + !sum is conserved under vertical diffusion + ! sum = 0. + ! do k=1,KMAX_MID + ! sum = sum + xn_adv(1,4,4,k)/dhs1i(k+1) + ! enddo + ! write(*,*)'sum before diffusion ',me,sum + do j = lj0,lj1 + do i = li0,li1 + call vertdiffn(xn_adv(1,i,j,1),skh(i,j,1,1),ds3,ds4,ndiff) + enddo + enddo + ! sum = 0. + ! do k=1,KMAX_MID + ! sum = sum + xn_adv(1,4,4,k)/dhs1i(k+1) + ! enddo + ! write(*,*)'sum after diffusion ',me,sum + call Add_2timing(22,tim_after,tim_before,"advecdiff:diffusion") + + + if(lj0.ne.1)then + do k=KCHEMTOP,KMAX_MID + do i = 1,limax + xn_adv(:,i,1,k) = xn_adv(:,i,1,k)/(ps(i,1,1)-PT) + enddo + enddo + endif + if(li0.ne.1)then + do k=KCHEMTOP,KMAX_MID + do j=lj0,lj1 + xn_adv(:,1,j,k) = xn_adv(:,1,j,k)/(ps(1,j,1)-PT) + enddo + enddo + endif + if(li1.ne.limax)then + do k=KCHEMTOP,KMAX_MID + do j=lj0,lj1 + xn_adv(:,limax,j,k) = xn_adv(:,limax,j,k) & + /(ps(limax,j,1)-PT) + enddo + enddo + endif + if(lj1.ne.ljmax)then + do k=KCHEMTOP,KMAX_MID + do i = 1,limax + xn_adv(:,i,ljmax,k) = xn_adv(:,i,ljmax,k) & + /(ps(i,ljmax,1)-PT) + enddo + enddo + endif + + if(KCHEMTOP==2)then + + !pw since the xn_adv are changed it corresponds to a flux in or + ! out of the system: + + do i = li0,li1 + do j = lj0,lj1 + where(xn_adv(:,i,j,1) .gt. xntop(:,i,j)) + fluxout(:) = fluxout(:) + & + (xn_adv(:,i,j,1) - xntop(:,i,j)) & + *(ps(i,j,1)-PT)*carea(1)*xmd(i,j) + elsewhere + fluxin(:) = fluxin(:) + & + (xntop(:,i,j) - xn_adv(:,i,j,1)) & + *(ps(i,j,1)-PT)*carea(1)*xmd(i,j) + end where + + + enddo + enddo + xn_adv(:,:,:,1) = xntop(:,:,:) + + endif + + firstcall=.false. + return + + end subroutine advecdiff_poles + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine vgrid +! +! inclusion of the variable grid spacing when interpolating the +! polynominal is done by introducing new local coordinates, cor. +! +! +! modified by pw january 2002: alfnew is modified such that +! a Courant number of one corresponds exactly to "empty" a cell. +! (small effects on results: less than 1%) +! + + + use GridValues_ml, only : sigma_bnd,sigma_mid + implicit none + + integer k,i,j + real cor1, cor2, dcorl + real hscor1(KMAX_BND+2),hscor2(KMAX_MID+2) + real alfa1(NADVS), alfa2(NADVS), dei + real corl1(KMAX_BND), corl2(KMAX_BND) + + real alf(9,2:KMAX_BND) + + do k=1,KMAX_MID + hscor1(k+1) = sigma_bnd(k) + hscor2(k+1) = sigma_mid(k) + enddo + hscor1(KMAX_BND+1) = sigma_bnd(KMAX_BND) + + hscor1(1) = - sigma_bnd(2) + hscor1(KMAX_BND+2) = 2.*sigma_bnd(KMAX_BND) - sigma_bnd(KMAX_BND-1) + hscor2(1) = 2.*sigma_mid(1) - sigma_mid(2) + hscor2(KMAX_MID+2) = 2.*sigma_mid(KMAX_MID) - sigma_mid(KMAX_MID-1) + + do k=1,KMAX_BND + dhs1(k) = hscor1(k+1) - hscor1(k) + dhs1i(k) = 1./dhs1(k) + dhs2i(k) = 1./(hscor2(k+1) - hscor2(k)) + enddo + + do k=2,KMAX_BND + + corl1(k) = (hscor1(k) - hscor2(k))*dhs1i(k) + corl2(k) = (hscor1(k+1) - hscor2(k))*dhs1i(k) + dcorl = corl2(k) - corl1(k) + alfa1(NADVS-1) = (corl2(k)**2 - corl1(k)**2)/(2.*dcorl) + alfa2(NADVS-1) = (corl2(k)**3 - corl1(k)**3)/(3.*dcorl) + + cor1 = (hscor1(k-1) - hscor2(k))*dhs1i(k) +! cor2 = (hscor1(k) - hscor2(k))*dhs1i(k) + dcorl = corl1(k) - cor1 + alfa1(NADVS-2) = (corl1(k)**2 - cor1**2)/(2.*dcorl) + alfa2(NADVS-2) = (corl1(k)**3 - cor1**3)/(3.*dcorl) + +! cor1 = (hscor1(k+1) - hscor2(k))*dhs1i(k) + cor2 = (hscor1(k+2) - hscor2(k))*dhs1i(k) + dcorl = cor2 - corl2(k) + alfa1(NADVS) = (cor2**2 - corl2(k)**2)/(2.*dcorl) + alfa2(NADVS) = (cor2**3 - corl2(k)**3)/(3.*dcorl) + + dei = alfa1(NADVS-1)*alfa2(NADVS) - alfa1(NADVS)*alfa2(NADVS-1) & + - alfa1(NADVS-2)*(alfa2(NADVS) - alfa2(NADVS-1)) & + + alfa2(NADVS-2)*(alfa1(NADVS) - alfa1(NADVS-1)) + dei = 1./dei + + alf(1,k) = dei & + *(alfa1(NADVS-1)*alfa2(NADVS)-alfa1(NADVS)*alfa2(NADVS-1)) + alf(4,k) = dei & + *(alfa2(NADVS-2)*alfa1(NADVS)- alfa2(NADVS)*alfa1(NADVS-2)) + alf(7,k) = dei & + *(alfa2(NADVS-1)*alfa1(NADVS-2)-alfa2(NADVS-2)*alfa1(NADVS-1)) + alf(2,k) = dei & + *(alfa2(NADVS-1) - alfa2(NADVS))/2. + alf(5,k) = dei & + *(alfa2(NADVS) - alfa2(NADVS-2))/2. + alf(8,k) = dei & + *(alfa2(NADVS-2) - alfa2(NADVS-1))/2. + alf(3,k) = dei & + *(alfa1(NADVS) - alfa1(NADVS-1))/3. + alf(6,k) = dei & + *(alfa1(NADVS-2) - alfa1(NADVS))/3. + alf(9,k) = dei & + *(alfa1(NADVS-1) - alfa1(NADVS-2))/3. + enddo + + do k=2,KMAX_MID + alfnew(1,k,0) = alf(1,k) + 2.*alf(2,k)*corl2(k) & + + 3.*alf(3,k)*corl2(k)*corl2(k) + alfnew(1,k,1) = -(alf(1,k+1) + 2.*alf(2,k+1)*corl1(k+1) & + + 3.*alf(3,k+1)*corl1(k+1)*corl1(k+1)) + alfnew(4,k,0) = alf(4,k) + 2.*alf(5,k)*corl2(k) & + + 3.*alf(6,k)*corl2(k)*corl2(k) + alfnew(4,k,1) = -(alf(4,k+1) + 2.*alf(5,k+1)*corl1(k+1) & + + 3.*alf(6,k+1)*corl1(k+1)*corl1(k+1)) + alfnew(7,k,0) = alf(7,k) + 2.*alf(8,k)*corl2(k) & + + 3.*alf(9,k)*corl2(k)*corl2(k) + alfnew(7,k,1) = -(alf(7,k+1) + 2.*alf(8,k+1)*corl1(k+1) & + + 3.*alf(9,k+1)*corl1(k+1)*corl1(k+1)) +!pw alfnew(2,k,0) = -(alf(2,k) + 3.*alf(3,k)*corl2(k)) & +! *dhs2i(k) +! alfnew(2,k,1) = (alf(2,k+1) + 3.*alf(3,k+1)*corl1(k+1)) & +! *dhs2i(k) + alfnew(2,k,0) = -(alf(2,k) + 3.*alf(3,k)*corl2(k)) & + *dhs1i(k) + alfnew(2,k,1) = (alf(2,k+1) + 3.*alf(3,k+1)*corl1(k+1)) & + *dhs1i(k+1) +!pw alfnew(5,k,0) = -(alf(5,k) + 3.*alf(6,k)*corl2(k)) & +! *dhs2i(k) +! alfnew(5,k,1) = (alf(5,k+1) + 3.*alf(6,k+1)*corl1(k+1)) & +! *dhs2i(k) + alfnew(5,k,0) = -(alf(5,k) + 3.*alf(6,k)*corl2(k)) & + *dhs1i(k) + alfnew(5,k,1) = (alf(5,k+1) + 3.*alf(6,k+1)*corl1(k+1)) & + *dhs1i(k+1) +!pw alfnew(8,k,0) = -(alf(8,k) + 3.*alf(9,k)*corl2(k)) & +! *dhs2i(k) +! alfnew(8,k,1) = (alf(8,k+1) + 3.*alf(9,k+1)*corl1(k+1)) & +! *dhs2i(k) + alfnew(8,k,0) = -(alf(8,k) + 3.*alf(9,k)*corl2(k)) & + *dhs1i(k) + alfnew(8,k,1) = (alf(8,k+1) + 3.*alf(9,k+1)*corl1(k+1)) & + *dhs1i(k+1) +!pw alfnew(3,k,0) = alf(3,k)*dhs2i(k)*dhs2i(k) +! alfnew(3,k,1) = -alf(3,k+1)*dhs2i(k)*dhs2i(k) +! alfnew(6,k,0) = alf(6,k)*dhs2i(k)*dhs2i(k) +! alfnew(6,k,1) = -alf(6,k+1)*dhs2i(k)*dhs2i(k) +! alfnew(9,k,0) = alf(9,k)*dhs2i(k)*dhs2i(k) +! alfnew(9,k,1) = -alf(9,k+1)*dhs2i(k)*dhs2i(k) + alfnew(3,k,0) = alf(3,k)*dhs1i(k)*dhs1i(k) + alfnew(3,k,1) = -alf(3,k+1)*dhs1i(k+1)*dhs1i(k+1) + alfnew(6,k,0) = alf(6,k)*dhs1i(k)*dhs1i(k) + alfnew(6,k,1) = -alf(6,k+1)*dhs1i(k+1)*dhs1i(k+1) + alfnew(9,k,0) = alf(9,k)*dhs1i(k)*dhs1i(k) + alfnew(9,k,1) = -alf(9,k+1)*dhs1i(k+1)*dhs1i(k+1) + enddo + + alfbegnew(1) = alfnew(1,2,0)+alfnew(4,2,0) + alfbegnew(2) = alfnew(2,2,0)+alfnew(5,2,0) + alfbegnew(3) = alfnew(3,2,0)+alfnew(6,2,0) + alfendnew(1) = alfnew(4,KMAX_MID,1)+alfnew(7,KMAX_MID,1) + alfendnew(2) = alfnew(5,KMAX_MID,1)+alfnew(8,KMAX_MID,1) + alfendnew(3) = alfnew(6,KMAX_MID,1)+alfnew(9,KMAX_MID,1) + + end subroutine vgrid + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine advvk(xn_adv,ps3d,sdot,dt_s) + +! executes advection with a. bott's integreated flux-form +! using 2'nd order polynomial in the vertical. + + use ModelConstants_ml , only : EPSIL, dt_advec + use GenSpec_adv_ml , only : NSPEC_ADV + implicit none + +! input + real,intent(in):: sdot(0:MAXLIMAX*MAXLJMAX*KMAX_BND-1),dt_s + +! input+output + real ,intent(inout):: xn_adv(NSPEC_ADV,0:MAXLIMAX*MAXLJMAX*KMAX_MID-1) + real ,intent(inout):: ps3d(0:MAXLIMAX*MAXLJMAX*KMAX_MID-1) + +! local + real fluxk(NSPEC_ADV,KMAX_MID),fluxps(KMAX_MID),fc(KMAX_MID) + +! local + integer k, n1k,k1 + integer klimlow,klimhig + real zzfl1,zzfl2,zzfl3,totk(NSPEC_ADV),totps + real fc1,fc2,fc3 + + do k = 1,KMAX_MID-1 + fc(k) = sdot(k*MAXLIMAX*MAXLJMAX)*dt_s + enddo + + fc(KMAX_MID) = -1. +!-------------- calculate the advection ---------------------------- + + klimlow = 1 + if(fc(1).ge.0.)klimlow=2 + klimhig = KMAX_MID-1 + if(fc(KMAX_MID-1).lt.0.)klimhig = KMAX_MID-2 + + fluxk(:,1) = 0. + fluxps(1) = 0. + + if(fc(1).ge.0.)then + + fc1 = fc(1) + fc2 = fc1*fc1 + fc3 = fc1*fc2 + zzfl2 = alfbegnew(1)*fc1 & + + alfbegnew(2)*fc2 & + + alfbegnew(3)*fc3 + zzfl3 = alfnew(7,2,0)*fc1 & + + alfnew(8,2,0)*fc2 & + + alfnew(9,2,0)*fc3 + + fluxk(:,2) = amax1(0.,xn_adv(:,0)*zzfl2 & + +xn_adv(:,MAXLIMAX*MAXLJMAX)*zzfl3) + fluxps(2) = amax1(0.,ps3d(0)*zzfl2 & + +ps3d(MAXLIMAX*MAXLJMAX)*zzfl3) + + endif + do k = klimlow,klimhig + + fc1 = fc(k) + fc2 = fc1*fc1 + 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 + zzfl2 = alfnew(4,k+1,n1k)*fc1 & + + alfnew(5,k+1,n1k)*fc2 & + + alfnew(6,k+1,n1k)*fc3 + zzfl3 = alfnew(7,k+1,n1k)*fc1 & + + alfnew(8,k+1,n1k)*fc2 & + + alfnew(9,k+1,n1k)*fc3 + + k1 = k-1+n1k + + fluxk(:,k+1) = amax1(0.,xn_adv(:,(k1-1)*MAXLIMAX*MAXLJMAX)*zzfl1 & + +xn_adv(:,k1*MAXLIMAX*MAXLJMAX)*zzfl2 & + +xn_adv(:,(k1+1)*MAXLIMAX*MAXLJMAX)*zzfl3) + fluxps(k+1) = amax1(0.,ps3d((k1-1)*MAXLIMAX*MAXLJMAX)*zzfl1 & + +ps3d(k1*MAXLIMAX*MAXLJMAX)*zzfl2 & + +ps3d((k1+1)*MAXLIMAX*MAXLJMAX)*zzfl3) + + enddo + if(fc(KMAX_MID-1).lt.0.)then + + fc1 = fc(KMAX_MID-1) + fc2 = fc1*fc1 + fc3 = fc1*fc2 + zzfl1 = alfnew(1,KMAX_MID,1)*fc1 & + + alfnew(2,KMAX_MID,1)*fc2 & + + alfnew(3,KMAX_MID,1)*fc3 + zzfl2 = alfendnew(1)*fc1 & + + alfendnew(2)*fc2 & + + alfendnew(3)*fc3 + + fluxk(:,KMAX_MID) = & + amax1(0.,xn_adv(:,(KMAX_MID-2)*MAXLIMAX*MAXLJMAX)*zzfl1 & + +xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX)*zzfl2) + fluxps(KMAX_MID) = & + amax1(0.,ps3d((KMAX_MID-2)*MAXLIMAX*MAXLJMAX)*zzfl1 & + +ps3d((KMAX_MID-1)*MAXLIMAX*MAXLJMAX)*zzfl2) + + endif + + k=1 + + do while(k.lt.KMAX_MID) + + if(fc(k).lt.0.) then + + if(fc(k+1).ge.0.) then + totk(:) = amin1(xn_adv(:,k*MAXLIMAX*MAXLJMAX) & + *dhs1(k+2)/ & + (fluxk(:,k+1) + fluxk(:,k+2)+ EPSIL),1.) + fluxk(:,k+1) = -fluxk(:,k+1)*totk(:) + fluxk(:,k+2) = fluxk(:,k+2)*totk(:) + xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) = & + amax1(0., xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) & + -(fluxk(:,k+1) - fluxk(:,k))*dhs1i(k+1)) + xn_adv(:,k*MAXLIMAX*MAXLJMAX) = & + amax1(0., xn_adv(:,k*MAXLIMAX*MAXLJMAX) & + -(fluxk(:,k+2) - fluxk(:,k+1))*dhs1i(k+2)) + + totps = amin1(ps3d(k*MAXLIMAX*MAXLJMAX) & + *dhs1(k+2)/ & + (fluxps(k+1) + fluxps(k+2)+ EPSIL),1.) + fluxps(k+1) = -fluxps(k+1)*totps + fluxps(k+2) = fluxps(k+2)*totps + ps3d((k-1)*MAXLIMAX*MAXLJMAX) = & + amax1(0., ps3d((k-1)*MAXLIMAX*MAXLJMAX) & + -(fluxps(k+1) - fluxps(k))*dhs1i(k+1)) + ps3d(k*MAXLIMAX*MAXLJMAX) = & + amax1(0., ps3d(k*MAXLIMAX*MAXLJMAX) & + -(fluxps(k+2) - fluxps(k+1))*dhs1i(k+2)) + k = k+2 + else + fluxk(:,k+1) = & + -amin1(xn_adv(:,k*MAXLIMAX*MAXLJMAX)*dhs1(k+2), & + fluxk(:,k+1)) + xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) = & + amax1(0., xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) & + -(fluxk(:,k+1) - fluxk(:,k))*dhs1i(k+1)) + fluxps(k+1) = & + -amin1(ps3d(k*MAXLIMAX*MAXLJMAX)*dhs1(k+2), & + fluxps(k+1)) + ps3d((k-1)*MAXLIMAX*MAXLJMAX) = & + amax1(0., ps3d((k-1)*MAXLIMAX*MAXLJMAX) & + -(fluxps(k+1) - fluxps(k))*dhs1i(k+1)) + + k = k+1 + endif + else + + fluxk(:,k+1) = amin1(xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX)*dhs1(k+1), & + fluxk(:,k+1)) + xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) = & + amax1(0., xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) & + -(fluxk(:,k+1) - fluxk(:,k))*dhs1i(k+1)) + fluxps(k+1) = amin1(ps3d((k-1)*MAXLIMAX*MAXLJMAX)*dhs1(k+1), & + fluxps(k+1)) + ps3d((k-1)*MAXLIMAX*MAXLJMAX) = & + amax1(0., ps3d((k-1)*MAXLIMAX*MAXLJMAX) & + -(fluxps(k+1) - fluxps(k))*dhs1i(k+1)) + + k = k+1 + endif + + enddo + + xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX) = & + amax1(0., xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX) & + + fluxk(:,KMAX_MID)*dhs1i(KMAX_MID+1)) + ps3d((KMAX_MID-1)*MAXLIMAX*MAXLJMAX) = & + amax1(0., ps3d((KMAX_MID-1)*MAXLIMAX*MAXLJMAX) & + + fluxps(KMAX_MID)*dhs1i(KMAX_MID+1)) + + end subroutine advvk + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine advvdifvk(xn_adv,ps3d,sdot,skh & + ,ds3,ds4 & + ,psfac,dt_s) + +! executes advection with a. bott's integreated flux-form +! using 2'nd order polynomial in the vertical. + + use ModelConstants_ml , only : KCHEMTOP, EPSIL + use GenSpec_adv_ml , only : NSPEC_ADV +!hf u2 use My_Runmode_ml , only : ADVEC_TYPE + implicit none + +! input + real,intent(in):: sdot(0:MAXLIMAX*MAXLJMAX*KMAX_BND-1) + real,intent(in):: skh(0:MAXLIMAX*MAXLJMAX*KMAX_BND-1) + real,intent(in):: ds3(KMAX_MID-1),ds4(KMAX_MID-1) + real,intent(in):: psfac,dt_s + +! output + real ,intent(inout):: xn_adv(NSPEC_ADV,0:MAXLIMAX*MAXLJMAX*KMAX_MID-1) + real ,intent(inout):: ps3d(0:MAXLIMAX*MAXLJMAX*KMAX_MID-1) + +! local + real fluxk(NSPEC_ADV,KMAX_MID),fluxps(KMAX_MID),fc(KMAX_MID) + +! local + + integer k,n,k1 + integer klimlow,klimhig,n1k + real totk(NSPEC_ADV),totps + real zzfl1,zzfl2,zzfl3 + real adif(KMAX_MID),bdif(KMAX_MID),cdif(KMAX_MID) & + ,e1(KMAX_MID),f1(NSPEC_ADV,KMAX_MID),fps(KMAX_MID) + real fc1,fc2,fc3 + + do k = 1,KMAX_MID-1 + fc(k) = sdot(k*MAXLIMAX*MAXLJMAX)*dt_s +! adif(k) = skh(k*MAXLIMAX*MAXLJMAX)*ds3(k) +! bdif(k+1) = skh(k*MAXLIMAX*MAXLJMAX)*ds4(k) + enddo + fc(KMAX_MID) = -1. + +!-------------- calculate the advection ---------------------------- + + klimlow = 2 + if(fc(1).ge.0.)klimlow=3 + klimhig = KMAX_MID + if(fc(KMAX_MID-1).lt.0)klimhig = KMAX_MID-1 + + fluxk(:,1) = 0. + fluxps(1) = 0. + + if(fc(1).ge.0.)then + + fc1 = fc(1) + fc2 = fc1*fc1 + fc3 = fc1*fc2 + zzfl2 = alfbegnew(1)*fc1 & + + alfbegnew(2)*fc2 & + + alfbegnew(3)*fc3 + zzfl3 = alfnew(7,2,0)*fc1 & + + alfnew(8,2,0)*fc2 & + + alfnew(9,2,0)*fc3 + + fluxk(:,2) = amax1(0.,xn_adv(:,0)*zzfl2 & + +xn_adv(:,MAXLIMAX*MAXLJMAX)*zzfl3) + fluxps(2) = amax1(0.,ps3d(0)*zzfl2 & + +ps3d(MAXLIMAX*MAXLJMAX)*zzfl3) + + endif + + do k = klimlow,klimhig + fc1 = fc(k-1) + fc2 = fc1*fc1 + fc3 = fc1*fc2 + n1k = 0 + if(fc1.lt.0.)n1k=1 + + 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 + + k1 = k-2+n1k + + fluxk(:,k) = amax1(0.,xn_adv(:,(k1-1)*MAXLIMAX*MAXLJMAX)*zzfl1 & + +xn_adv(:,k1*MAXLIMAX*MAXLJMAX)*zzfl2 & + +xn_adv(:,(k1+1)*MAXLIMAX*MAXLJMAX)*zzfl3) + fluxps(k) = amax1(0.,ps3d((k1-1)*MAXLIMAX*MAXLJMAX)*zzfl1 & + +ps3d(k1*MAXLIMAX*MAXLJMAX)*zzfl2 & + +ps3d((k1+1)*MAXLIMAX*MAXLJMAX)*zzfl3) + + enddo + + if(fc(KMAX_MID-1).lt.0.)then + + fc1 = fc(KMAX_MID-1) + fc2 = fc1*fc1 + fc3 = fc1*fc2 + zzfl1 = alfnew(1,KMAX_MID,1)*fc1 & + + alfnew(2,KMAX_MID,1)*fc2 & + + alfnew(3,KMAX_MID,1)*fc3 + zzfl2 = alfendnew(1)*fc1 & + + alfendnew(2)*fc2 & + + alfendnew(3)*fc3 + + fluxk(:,KMAX_MID) = amax1(0. & + ,xn_adv(:,(KMAX_MID-2)*MAXLIMAX*MAXLJMAX)*zzfl1 & + +xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX)*zzfl2) + fluxps(KMAX_MID) = amax1(0. & + ,ps3d((KMAX_MID-2)*MAXLIMAX*MAXLJMAX)*zzfl1 & + +ps3d((KMAX_MID-1)*MAXLIMAX*MAXLJMAX)*zzfl2) + + endif + + k=2 + + do while(.true.) + + do while(fc(k-1).ge.0.) + fluxk(:,k) = & + amin1(xn_adv(:,(k-2)*MAXLIMAX*MAXLJMAX)*dhs1(k), & + fluxk(:,k)) + f1(:,k-1) = amax1(0.,xn_adv(:,(k-2)*MAXLIMAX*MAXLJMAX) - & + (fluxk(:,k) - fluxk(:,k-1))*dhs1i(k)) + fluxps(k) = & + amin1(ps3d((k-2)*MAXLIMAX*MAXLJMAX)*dhs1(k), & + fluxps(k)) + fps(k-1) = amax1(0.,ps3d((k-2)*MAXLIMAX*MAXLJMAX) - & + (fluxps(k) - fluxps(k-1))*dhs1i(k)) +! ps3d((k-2)*MAXLIMAX*MAXLJMAX)= amax1(0.,ps3d((k-2)*MAXLIMAX*MAXLJMAX) - & +! (fluxps(k) - fluxps(k-1))*dhs1i(k)) + k=k+1 + if(k.gt.KMAX_MID)goto 435 + enddo + + do while(fc(k).lt.0.) + fluxk(:,k) = -amin1(xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) & + *dhs1(k+1),fluxk(:,k)) + f1(:,k-1) = amax1(0.,xn_adv(:,(k-2)*MAXLIMAX*MAXLJMAX) - & + (fluxk(:,k) - fluxk(:,k-1))*dhs1i(k)) + fluxps(k) = -amin1(ps3d((k-1)*MAXLIMAX*MAXLJMAX) & + *dhs1(k+1),fluxps(k)) + fps(k-1) = amax1(0.,ps3d((k-2)*MAXLIMAX*MAXLJMAX) - & + (fluxps(k) - fluxps(k-1))*dhs1i(k)) +! ps3d((k-2)*MAXLIMAX*MAXLJMAX) = amax1(0.,ps3d((k-2)*MAXLIMAX*MAXLJMAX) - & +! (fluxps(k) - fluxps(k-1))*dhs1i(k)) + + k=k+1 + if(k.gt.KMAX_MID)goto 435 + enddo + totk(:) = amin1(xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX)*dhs1(k+1)/ & + (fluxk(:,k) & + + fluxk(:,k+1)+ EPSIL),1.) + fluxk(:,k) = -fluxk(:,k)*totk(:) + fluxk(:,k+1) = fluxk(:,k+1)*totk(:) + f1(:,k-1) = amax1(0.,xn_adv(:,(k-2)*MAXLIMAX*MAXLJMAX) - & + (fluxk(:,k) - fluxk(:,k-1))*dhs1i(k)) + f1(:,k) = amax1(0.,xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) - & + (fluxk(:,k+1) - fluxk(:,k))*dhs1i(k+1)) + + totps = amin1(ps3d((k-1)*MAXLIMAX*MAXLJMAX)*dhs1(k+1)/ & + (fluxps(k)+ fluxps(k+1)+ EPSIL),1.) + + fluxps(k) = -fluxps(k)*totps + fluxps(k+1) = fluxps(k+1)*totps + fps(k-1) = amax1(0.,ps3d((k-2)*MAXLIMAX*MAXLJMAX) - & + (fluxps(k) - fluxps(k-1))*dhs1i(k)) + fps(k) = amax1(0.,ps3d((k-1)*MAXLIMAX*MAXLJMAX) - & + (fluxps(k+1) - fluxps(k))*dhs1i(k+1)) +! ps3d((k-2)*MAXLIMAX*MAXLJMAX)= amax1(0.,ps3d((k-2)*MAXLIMAX*MAXLJMAX) - & +! (fluxps(k) - fluxps(k-1))*dhs1i(k)) +! ps3d((k-1)*MAXLIMAX*MAXLJMAX)= amax1(0.,ps3d((k-1)*MAXLIMAX*MAXLJMAX) - & +! (fluxps(k+1) - fluxps(k))*dhs1i(k+1)) + k = k+2 + + if(k.gt.KMAX_MID)goto 435 + + enddo + +435 continue + + + if(ADVEC_TYPE==1)then + fps(KMAX_MID) = & + amax1(0.,ps3d((KMAX_MID-1)*MAXLIMAX*MAXLJMAX) & + + fluxps(KMAX_MID)*dhs1i(KMAX_MID+1)) +! ps3d((KMAX_MID-1)*MAXLIMAX*MAXLJMAX) = & +! amax1(0.,ps3d((KMAX_MID-1)*MAXLIMAX*MAXLJMAX) & +! + fluxps(KMAX_MID)*dhs1i(KMAX_MID+1)) + endif + if(ADVEC_TYPE==0)then + fps(:) = psfac + endif + + f1(:,KMAX_MID) = amax1(0.,xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX) & + + fluxk(:,KMAX_MID)*dhs1i(KMAX_MID+1)) + + do k = 1,KMAX_MID +! xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) = f1(:,k)/fps(k) + xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) = f1(:,k) + ps3d((k-1)*MAXLIMAX*MAXLJMAX) = fps(k) + enddo + + return + + end subroutine advvdifvk + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine vertdiff(xn_adv,skh,ds3,ds4) + + ! executes vertical diffusion + + use ModelConstants_ml , only : KCHEMTOP, EPSIL + use GenSpec_adv_ml , only : NSPEC_ADV + + implicit none + +! input + real,intent(in):: skh(0:MAXLIMAX*MAXLJMAX*KMAX_BND-1) + real,intent(in):: ds3(KMAX_MID-1),ds4(KMAX_MID-1) + + ! output + real ,intent(inout):: xn_adv(NSPEC_ADV,0:MAXLIMAX*MAXLJMAX*(KMAX_MID-1)) + +! local + + integer k + real adif(KMAX_MID),bdif(KMAX_MID),cdif(KMAX_MID) & + ,e1(KMAX_MID) + + + do k = 1,KMAX_MID-1 + adif(k) = skh(k*MAXLIMAX*MAXLJMAX)*ds3(k) + bdif(k+1) = skh(k*MAXLIMAX*MAXLJMAX)*ds4(k) + enddo + + cdif(KMAX_MID) = 1./(1. + bdif(KMAX_MID)) + e1(KMAX_MID) = bdif(KMAX_MID)*cdif(KMAX_MID) + xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX) = & + xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX)*cdif(KMAX_MID) + + do k = KMAX_MID-1,2,-1 + + cdif(k) = 1./(1. + bdif(k) + adif(k) - adif(k)*e1(k+1)) + e1(k) = bdif(k)*cdif(k) + xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) = & + (xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) + & + adif(k)*xn_adv(:,(k)*MAXLIMAX*MAXLJMAX))*cdif(k) + + enddo + + cdif(1) = 1./(1. + adif(1) - adif(1)*e1(2)) + xn_adv(:,0) = (xn_adv(:,0) + adif(1)*xn_adv(:,MAXLIMAX*MAXLJMAX))*cdif(1) + + do k = 2,KMAX_MID + xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) = & + e1(k)*xn_adv(:,(k-2)*MAXLIMAX*MAXLJMAX) & + + xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) + enddo + + + end subroutine vertdiff + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine vertdiffn(xn_adv,skh,ds3,ds4,ndiff) + + ! executes vertical diffusion ndiff times + +! skh(k) mixes xn_adv(k) and xn_adv(k-1) +! +! adif(k) -> mixing of layers k and k+1: +! skh(k+1)*ds3(k+1)= skh(k+1)*dt_advec*dhs1i(k+1)*dhs2i(k+1) +! = skh(k+1)*dt_advec/(sigma_bnd(k+1)-sigma_bnd(k))/(sigma_mid(k+1)-sigma_mid(k)) +! +! bdif(k) -> mixing of layers k and k-1: +! skh(k)*ds4(k)= skh(k)*dt_advec*dhs1i(k+1)*dhs2i(k) +! = skh(k+1)*dt_advec/(sigma_bnd(k+1)-sigma_bnd(k))/(sigma_mid(k)-sigma_mid(k-1)) + + use ModelConstants_ml , only : KCHEMTOP, EPSIL + use GenSpec_adv_ml , only : NSPEC_ADV + + implicit none + +! input + real,intent(in):: skh(0:MAXLIMAX*MAXLJMAX*KMAX_BND-1) + real,intent(in):: ds3(KMAX_MID-1),ds4(KMAX_MID-1) + integer,intent(in):: ndiff + + ! output + real ,intent(inout):: xn_adv(NSPEC_ADV,0:MAXLIMAX*MAXLJMAX*(KMAX_MID-1)) + +! local + + integer k,n + + real adif(0:KMAX_MID-1),bdif(0:KMAX_MID-1),cdif(0:KMAX_MID-1) & + ,e1(0:KMAX_MID-1) + + real ndiffi + + ndiffi=1./ndiff + + do k = 1,KMAX_MID-1 + adif(k-1) = skh(k*MAXLIMAX*MAXLJMAX)*ds3(k)*ndiffi + bdif(k) = skh(k*MAXLIMAX*MAXLJMAX)*ds4(k)*ndiffi + enddo + + cdif(KMAX_MID-1) = 1./(1. + bdif(KMAX_MID-1)) + e1(KMAX_MID-1) = bdif(KMAX_MID-1)*cdif(KMAX_MID-1) + + do k = KMAX_MID-2,1,-1 + cdif(k) = 1./(1. + bdif(k) + adif(k) - adif(k)*e1(k+1)) + e1(k) = bdif(k)*cdif(k) + enddo + + cdif(0) = 1./(1. + adif(0) - adif(0)*e1(1)) + + do n=1,ndiff + + xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX) = & + xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX)*cdif(KMAX_MID-1) + do k = KMAX_MID-2,0,-1 + xn_adv(:,k*MAXLIMAX*MAXLJMAX) = & + (xn_adv(:,k*MAXLIMAX*MAXLJMAX) + & + adif(k)*xn_adv(:,(k+1)*MAXLIMAX*MAXLJMAX))*cdif(k) + enddo + + do k = 1,KMAX_MID-1 + xn_adv(:,k*MAXLIMAX*MAXLJMAX) = & + e1(k)*xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) & + + xn_adv(:,k*MAXLIMAX*MAXLJMAX) + enddo + + enddo ! ndiff + + end subroutine vertdiffn + + subroutine vertdiffn2(xn_adv,skh,ds3,ds4,ndiff) + + ! executes vertical diffusion ndiff times + + use ModelConstants_ml , only : KCHEMTOP, EPSIL + use GenSpec_adv_ml , only : NSPEC_ADV + + implicit none + +! input + real,intent(in):: skh(0:MAXLIMAX*MAXLJMAX*KMAX_BND-1) + real,intent(in):: ds3(KMAX_MID-1),ds4(KMAX_MID-1) + integer,intent(in):: ndiff + + ! output + real ,intent(inout):: xn_adv(NSPEC_ADV,0:MAXLIMAX*MAXLJMAX*(KMAX_MID-1)) + +! local + + integer k,n + + real adif(KMAX_MID),bdif(KMAX_MID),cdif(KMAX_MID) & + ,e1(KMAX_MID) + + real ndiffi + + ndiffi=1./ndiff + + do k = 1,KMAX_MID-1 + adif(k) = skh(k*MAXLIMAX*MAXLJMAX)*ds3(k)*ndiffi + bdif(k+1) = skh(k*MAXLIMAX*MAXLJMAX)*ds4(k)*ndiffi + enddo + + cdif(KMAX_MID) = 1./(1. + bdif(KMAX_MID)) + e1(KMAX_MID) = bdif(KMAX_MID)*cdif(KMAX_MID) + + do k = KMAX_MID-1,2,-1 + cdif(k) = 1./(1. + bdif(k) + adif(k) - adif(k)*e1(k+1)) + e1(k) = bdif(k)*cdif(k) + enddo + + cdif(1) = 1./(1. + adif(1) - adif(1)*e1(2)) + + do n=1,ndiff + + xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX) = & + xn_adv(:,(KMAX_MID-1)*MAXLIMAX*MAXLJMAX)*cdif(KMAX_MID) + do k = KMAX_MID-2,0,-1 + xn_adv(:,k*MAXLIMAX*MAXLJMAX) = & + (xn_adv(:,k*MAXLIMAX*MAXLJMAX) + & + adif(k+1)*xn_adv(:,(k+1)*MAXLIMAX*MAXLJMAX))*cdif(k+1) + enddo + + do k = 1,KMAX_MID-1 + xn_adv(:,k*MAXLIMAX*MAXLJMAX) = & + e1(k+1)*xn_adv(:,(k-1)*MAXLIMAX*MAXLJMAX) & + + xn_adv(:,k*MAXLIMAX*MAXLJMAX) + enddo + + enddo ! ndiff + + end subroutine vertdiffn2 + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine advx(vel,velbeg,velend & + ,xn_adv,xnbeg,xnend & + ,ps3d,psbeg,psend & + ,xm2loc,xmdloc & + ,dth,fac1) + +! executes advection with a.bott's integrated flux method using +! 4'th order polynomials in the y-direction. +! +! modified by pw february 2002: Takes into account the mapping factor +! in such a way that a Courant number of one corresponds exactly to "empty" a cell. +! (small effects on results: less than 1%) + + use Par_ml , only : me,li0,li1,limax + use GenSpec_adv_ml , only : NSPEC_ADV + use MassBudget_ml , only : fluxin,fluxout + implicit none + +! parameter: +! input + real,intent(in):: vel(0:MAXLIMAX),velbeg, velend + real,intent(in):: xnbeg(NSPEC_ADV,3) & + ,xnend(NSPEC_ADV,3) + real,intent(in):: psbeg(3) & + ,psend(3) & + ,xm2loc(0:MAXLIMAX+1) & + ,xmdloc(0:MAXLIMAX+1) + real,intent(in):: dth,fac1 + +! input+output + real ,intent(inout)::xn_adv(NSPEC_ADV,MAXLIMAX) + real ,intent(inout)::ps3d(MAXLIMAX) + +! output fluxin,fluxout + +! local + + integer ij, ijn,ijll,nn + integer limtlow,limthig + integer lijb,lije + real ijn1 + real x1, x2, x3,hh3,hh4 + real y0,y1,y2,y3 + real zzfc(5,-1:MAXLIMAX+1) + real fc(-1:MAXLIMAX+1) + real flux(NSPEC_ADV,-1:MAXLIMAX+1) + real fluxps(-1:MAXLIMAX+1) + real hel1(NSPEC_ADV),hel2(NSPEC_ADV) + real hel1ps,hel2ps + integer ijpasses + integer ijb1(MAXLIMAX),ije1(MAXLIMAX) + integer ijb2(MAXLIMAX),ije2(MAXLIMAX),ijb3(MAXLIMAX) + logical ijdoend + +!----------------------------------------------------------------------- + + limtlow = li0-1 + if (li0.eq.1) then + if (vel(0) .gt. 0..and.velbeg.lt.0.) then + fc(-1) = velbeg*dth + fc(-1)=min(1.0, fc(-1)) + fc(-1)=max(-1.0, fc(-1)) + limtlow = -1 + + y0 = fc(-1) + x1 = 1.+2.*y0*xm2loc(0) + x2 = x1*x1 + y3 = xmdloc(0)*(1.-x2)/3840. + y1 = 5.*y3 + y2 = x1*y3 + hh3 = (116.-4.*x2)*y2 + hh4 = (2.*x2-66.)*y1 + zzfc(3,-1) = - y0 - (214. - 6.*x2)*y2 + zzfc(5,-1) = (y2-y1)*(x2-9.) + zzfc(1,-1) = (y2+y1)*(x2-9.) + zzfc(4,-1) = hh3+hh4 + zzfc(2,-1) = hh3-hh4 + + endif + endif + + do 10 ij = li0-1,li1 + fc(ij) = vel(ij)*dth + fc(ij)=min(1.0, fc(ij)) + fc(ij)=max(-1.0, fc(ij)) + + ijn1 = sign(1.,fc(ij)) + ijn = ij + nint(0.5*(1-ijn1)) + + y0 = ijn1*fc(ij) + x1 = 1.-2.*y0*xm2loc(ijn) + x2 = x1*x1 + y3 = xmdloc(ijn)*(1.-x2)/3840. + y1 = 5.*ijn1*y3 + y2 = x1*y3 + hh3 = (116.-4.*x2)*y2 + hh4 = (66.-2.*x2)*y1 + zzfc(3,ij) = y0 - (214. - 6.*x2)*y2 + zzfc(5,ij) = (y2+y1)*(x2-9.) + zzfc(1,ij) = (y2-y1)*(x2-9.) + zzfc(4,ij) = hh3+hh4 + zzfc(2,ij) = hh3-hh4 + +10 continue + + limthig = li1 + if (li1.eq.limax) then + if (vel(li1).lt.0..and.velend.gt.0.)then + fc(li1+1) = velend*dth + fc(li1+1)=min(1.0, fc(li1+1)) + fc(li1+1)=max(-1.0, fc(li1+1)) + + + limthig = li1+1 + + y0 = fc(li1+1) + x1 = 1.-2.*y0*xm2loc(li1+1) + x2 = x1*x1 + y3 = xmdloc(li1+1)*(1.-x2)/3840. + y1 = 5.*y3 + y2 = x1*y3 + hh3 = (116.-4.*x2)*y2 + hh4 = (66.-2.*x2)*y1 + zzfc(3,li1+1) = y0 - (214.-6.*x2)*y2 + zzfc(5,li1+1) = (y2+y1)*(x2-9.) + zzfc(1,li1+1) = (y2-y1)*(x2-9.) + zzfc(4,li1+1) = hh3+hh4 + zzfc(2,li1+1) = hh3-hh4 + + endif + endif + +!------- boundary treatment ----------------------------------------- + +! helping values at the boundaries are found by linear +! extrapolation in cases of outflow, and by assuming constant +! values in inflow cases. + +! calculate the coefficients in the polynomial, the +! normalized fluxes, and limit them for positivness + + if(limtlow.eq.-1)then + +! integrated flux form + + flux(:,-1) = max(0.,xn_adv(:,2)*zzfc(5,-1) & + + xn_adv(:,1)*zzfc(4,-1) & + + xnbeg(:,3)*zzfc(3,-1) & + + xnbeg(:,2)*zzfc(2,-1) + xnbeg(:,1)*zzfc(1,-1)) + flux(:,0) = max(0.,xn_adv(:,2)*zzfc(5,0) & + + xn_adv(:,1)*zzfc(4,0) & + + xnbeg(:,3)*zzfc(3,0) & + + xnbeg(:,2)*zzfc(2,0) + xnbeg(:,1)*zzfc(1,0)) + fluxps(-1) = max(0.,ps3d(2)*zzfc(5,-1) & + + ps3d(1)*zzfc(4,-1) & + + psbeg(3)*zzfc(3,-1) & + + psbeg(2)*zzfc(2,-1) + psbeg(1)*zzfc(1,-1)) + fluxps(0) = max(0.,ps3d(2)*zzfc(5,0) & + + ps3d(1)*zzfc(4,0) & + + psbeg(3)*zzfc(3,0) & + + psbeg(2)*zzfc(2,0) + psbeg(1)*zzfc(1,0)) + + else + +! integrated flux form + + if(fc(li0-1).ge.0.)then + flux(:,li0-1) = max(0.,xn_adv(:,li0+1)*zzfc(5,li0-1) & + + xn_adv(:,li0)*zzfc(4,li0-1) & + + xnbeg(:,3)*zzfc(3,li0-1) & + + xnbeg(:,2)*zzfc(2,li0-1) + xnbeg(:,1)*zzfc(1,li0-1)) + fluxps(li0-1) = max(0.,ps3d(li0+1)*zzfc(5,li0-1) & + + ps3d(li0)*zzfc(4,li0-1) & + + psbeg(3)*zzfc(3,li0-1) & + + psbeg(2)*zzfc(2,li0-1) + psbeg(1)*zzfc(1,li0-1)) + else + flux(:,li0-1) = max(0.,xn_adv(:,li0+2)*zzfc(5,li0-1) & + + xn_adv(:,li0+1)*zzfc(4,li0-1) & + + xn_adv(:,li0)*zzfc(3,li0-1) & + + xnbeg(:,3)*zzfc(2,li0-1) + xnbeg(:,2)*zzfc(1,li0-1)) + fluxps(li0-1) = max(0.,ps3d(li0+2)*zzfc(5,li0-1) & + + ps3d(li0+1)*zzfc(4,li0-1) & + + ps3d(li0)*zzfc(3,li0-1) & + + psbeg(3)*zzfc(2,li0-1) + psbeg(2)*zzfc(1,li0-1)) + endif + endif + +! integrated flux form + + if(fc(li0).ge.0.)then + flux(:,li0) = max(0.,xn_adv(:,li0+2)*zzfc(5,li0) & + + xn_adv(:,li0+1)*zzfc(4,li0) & + + xn_adv(:,li0)*zzfc(3,li0) & + + xnbeg(:,3)*zzfc(2,li0) + xnbeg(:,2)*zzfc(1,li0)) + fluxps(li0) = max(0.,ps3d(li0+2)*zzfc(5,li0) & + + ps3d(li0+1)*zzfc(4,li0) & + + ps3d(li0)*zzfc(3,li0) & + + psbeg(3)*zzfc(2,li0) + psbeg(2)*zzfc(1,li0)) + else + flux(:,li0) = max(0.,xn_adv(:,li0+3)*zzfc(5,li0) & + + xn_adv(:,li0+2)*zzfc(4,li0) & + + xn_adv(:,li0+1)*zzfc(3,li0) & + + xn_adv(:,li0)*zzfc(2,li0) + xnbeg(:,3)*zzfc(1,li0)) + fluxps(li0) = max(0.,ps3d(li0+3)*zzfc(5,li0) & + + ps3d(li0+2)*zzfc(4,li0) & + + ps3d(li0+1)*zzfc(3,li0) & + + ps3d(li0)*zzfc(2,li0) + psbeg(3)*zzfc(1,li0)) + endif + + if(fc(li0+1).ge.0.)then + +! integrated flux form + + flux(:,li0+1) = max(0.,xn_adv(:,li0+3)*zzfc(5,li0+1) & + + xn_adv(:,li0+2)*zzfc(4,li0+1) & + + xn_adv(:,li0+1)*zzfc(3,li0+1) & + + xn_adv(:,li0)*zzfc(2,li0+1) + xnbeg(:,3)*zzfc(1,li0+1)) + fluxps(li0+1) = max(0.,ps3d(li0+3)*zzfc(5,li0+1) & + + ps3d(li0+2)*zzfc(4,li0+1) & + + ps3d(li0+1)*zzfc(3,li0+1) & + + ps3d(li0)*zzfc(2,li0+1) + psbeg(3)*zzfc(1,li0+1)) + endif + + lijb = li0+2 + if(fc(li0+1).lt.0.)lijb = li0+1 + lije = li1-3 + if(fc(li1-2).ge.0.)lije = li1-2 + + do ij = lijb,lije + + ijn1 = sign(1.,fc(ij)) + +! integrated flux form + + ijn = ij+nint(0.5*(1.-ijn1)) + flux(:,ij) = max(0.,xn_adv(:,ijn+2)*zzfc(5,ij) & + + xn_adv(:,ijn+1)*zzfc(4,ij) & + + xn_adv(:,ijn)*zzfc(3,ij) & + + xn_adv(:,ijn-1)*zzfc(2,ij) & + + xn_adv(:,ijn-2)*zzfc(1,ij)) + fluxps(ij) = max(0.,ps3d(ijn+2)*zzfc(5,ij) & + + ps3d(ijn+1)*zzfc(4,ij) & + + ps3d(ijn)*zzfc(3,ij) & + + ps3d(ijn-1)*zzfc(2,ij) & + + ps3d(ijn-2)*zzfc(1,ij)) + + enddo + + if(fc(li1-2).lt.0)then + +! integrated flux form + + flux(:,li1-2) = max(0.,xnend(:,1)*zzfc(5,li1-2) & + + xn_adv(:,li1)*zzfc(4,li1-2) & + + xn_adv(:,li1-1)*zzfc(3,li1-2) & + + xn_adv(:,li1-2)*zzfc(2,li1-2) & + + xn_adv(:,li1-3)*zzfc(1,li1-2)) + fluxps(li1-2) = max(0.,psend(1)*zzfc(5,li1-2) & + + ps3d(li1)*zzfc(4,li1-2) & + + ps3d(li1-1)*zzfc(3,li1-2) & + + ps3d(li1-2)*zzfc(2,li1-2) & + + ps3d(li1-3)*zzfc(1,li1-2)) + endif + +! integrated flux form + + if(fc(li1-1).ge.0)then + flux(:,li1-1) = max(0.,xnend(:,1)*zzfc(5,li1-1) & + + xn_adv(:,li1)*zzfc(4,li1-1) & + + xn_adv(:,li1-1)*zzfc(3,li1-1) & + + xn_adv(:,li1-2)*zzfc(2,li1-1) & + + xn_adv(:,li1-3)*zzfc(1,li1-1)) + fluxps(li1-1) = max(0.,psend(1)*zzfc(5,li1-1) & + + ps3d(li1)*zzfc(4,li1-1) & + + ps3d(li1-1)*zzfc(3,li1-1) & + + ps3d(li1-2)*zzfc(2,li1-1) & + + ps3d(li1-3)*zzfc(1,li1-1)) + else + flux(:,li1-1) = max(0.,xnend(:,2)*zzfc(5,li1-1) & + + xnend(:,1)*zzfc(4,li1-1) & + + xn_adv(:,li1)*zzfc(3,li1-1) & + + xn_adv(:,li1-1)*zzfc(2,li1-1) & + + xn_adv(:,li1-2)*zzfc(1,li1-1)) + fluxps(li1-1) = max(0.,psend(2)*zzfc(5,li1-1) & + + psend(1)*zzfc(4,li1-1) & + + ps3d(li1)*zzfc(3,li1-1) & + + ps3d(li1-1)*zzfc(2,li1-1) & + + ps3d(li1-2)*zzfc(1,li1-1)) + endif + +! integrated flux form + if(limthig.eq.li1)then + + if(fc(li1).ge.0)then + flux(:,li1) = max(0.,xnend(:,2)*zzfc(5,li1) & + + xnend(:,1)*zzfc(4,li1) & + + xn_adv(:,li1)*zzfc(3,li1) & + + xn_adv(:,li1-1)*zzfc(2,li1) & + + xn_adv(:,li1-2)*zzfc(1,li1)) + fluxps(li1) = max(0.,psend(2)*zzfc(5,li1) & + + psend(1)*zzfc(4,li1) & + + ps3d(li1)*zzfc(3,li1) & + + ps3d(li1-1)*zzfc(2,li1) & + + ps3d(li1-2)*zzfc(1,li1)) + else + flux(:,li1) = max(0.,xnend(:,3)*zzfc(5,li1) & + + xnend(:,2)*zzfc(4,li1) & + + xnend(:,1)*zzfc(3,li1) & + + xn_adv(:,li1)*zzfc(2,li1) & + + xn_adv(:,li1-1)*zzfc(1,li1)) + fluxps(li1) = max(0.,psend(3)*zzfc(5,li1) & + + psend(2)*zzfc(4,li1) & + + psend(1)*zzfc(3,li1) & + + ps3d(li1)*zzfc(2,li1) & + + ps3d(li1-1)*zzfc(1,li1)) + endif + + else + +! integrated flux form + + flux(:,li1) = max(0.,xnend(:,3)*zzfc(5,li1) & + + xnend(:,2)*zzfc(4,li1) & + + xnend(:,1)*zzfc(3,li1) & + + xn_adv(:,li1)*zzfc(2,li1) & + + xn_adv(:,li1-1)*zzfc(1,li1)) + flux(:,li1+1) = max(0.,xnend(:,3)*zzfc(5,li1+1) & + + xnend(:,2)*zzfc(4,li1+1) & + + xnend(:,1)*zzfc(3,li1+1) & + + xn_adv(:,li1)*zzfc(2,li1+1) & + + xn_adv(:,li1-1)*zzfc(1,li1+1)) + fluxps(li1) = max(0.,psend(3)*zzfc(5,li1) & + + psend(2)*zzfc(4,li1) & + + psend(1)*zzfc(3,li1) & + + ps3d(li1)*zzfc(2,li1) & + + ps3d(li1-1)*zzfc(1,li1)) + fluxps(li1+1) = max(0.,psend(3)*zzfc(5,li1+1) & + + psend(2)*zzfc(4,li1+1) & + + psend(1)*zzfc(3,li1+1) & + + ps3d(li1)*zzfc(2,li1+1) & + + ps3d(li1-1)*zzfc(1,li1+1)) + + endif + + + if(limtlow.eq.-1)then + hel1(:) = xnbeg(:,3)*xmdloc(0) + hel2(:) = flux(:,0) + flux(:,-1) + where(hel1(:).lt.hel2(:))flux(:,0) & + = flux(:,0)*hel1(:)/(hel2(:)+1.0E-100) + hel1ps = psbeg(3)*xmdloc(0) + hel2ps = fluxps(0) + fluxps(-1) + if(hel1ps.lt.hel2ps)fluxps(0) = fluxps(0)*hel1ps/hel2ps + ij = 1 + else + if(fc(li0-1).ge.0.) then + flux(:,li0-1) = amin1(xnbeg(:,3) & + *xmdloc(li0-1) & + ,flux(:,li0-1)) + fluxps(li0-1) = amin1(psbeg(3) & + *xmdloc(li0-1) & + ,fluxps(li0-1)) + ij = li0 + else + if(fc(li0).lt.0.) then + flux(:,li0-1) = -amin1(xn_adv(:,li0) & + *xmdloc(li0),flux(:,li0-1)) + fluxps(li0-1) = -amin1(ps3d(li0) & + *xmdloc(li0),fluxps(li0-1)) + ij = li0 + else + hel1(:) = xn_adv(:,li0)*xmdloc(li0) + hel2(:) = flux(:,li0) + flux(:,li0-1) + where(hel1(:).lt.hel2(:)) + flux(:,li0-1) = -flux(:,li0-1)*hel1(:)/(hel2(:)+1.0E-100) + flux(:,li0) = flux(:,li0)*hel1(:)/(hel2(:)+1.0E-100) + xn_adv(:,li0) = 0. + elsewhere + flux(:,li0-1) = -flux(:,li0-1) + xn_adv(:,li0) =xm2loc(li0)*(hel1(:)-hel2(:)) + end where + hel1ps = ps3d(li0)*xmdloc(li0) + hel2ps = fluxps(li0) + fluxps(li0-1) + if(hel1ps.lt.hel2ps)then + fluxps(li0-1) = - fluxps(li0-1)*hel1ps/hel2ps + fluxps(li0) = fluxps(li0)*hel1ps/hel2ps + ps3d(li0) = 0. + else + fluxps(li0-1) = -fluxps(li0-1) + ps3d(li0) =xm2loc(li0)*(hel1ps-hel2ps) + endif + ij = li0+1 + endif + endif + endif + + ijpasses = 0 + do while(.true.) + + ijpasses = ijpasses+1 + ijb1(ijpasses) = ij + ije1(ijpasses) = -5 + do while(fc(ij).ge.0.) + ije1(ijpasses) = ij + ij = ij+1 + if(ij.gt.li1-1)then + ijb2(ijpasses) = ij + ije2(ijpasses) = -5 + ijb3(ijpasses) = -5 + goto 257 + endif + enddo + ijb2(ijpasses) = ij + ije2(ijpasses) = -5 + do while(fc(ij+1).lt.0.) + ije2(ijpasses) = ij + ij = ij+1 + if(ij.gt.li1-1)then + ijb3(ijpasses) = -5 + goto 257 + endif + enddo + ijb3(ijpasses) = ij + ij = ij+2 + if(ij.gt.li1-1)goto 257 + enddo + +257 continue + ijdoend = .false. + if(ij.eq.li1)ijdoend=.true. + + do ijll = 1,ijpasses + + do ij = ijb1(ijll),ije1(ijll) + flux(:,ij) = amin1(xn_adv(:,ij)*xmdloc(ij) & + ,flux(:,ij)) + xn_adv(:,ij) = & + amax1(0.,xn_adv(:,ij) & + -xm2loc(ij) & + *(flux(:,ij) - flux(:,ij-1))) + fluxps(ij) = amin1(ps3d(ij)*xmdloc(ij) & + ,fluxps(ij)) + ps3d(ij) = & + amax1(0.,ps3d(ij) & + -xm2loc(ij) & + *(fluxps(ij) - fluxps(ij-1))) + enddo + do ij = ijb2(ijll),ije2(ijll) + flux(:,ij) = -amin1(xn_adv(:,ij+1)*xmdloc(ij+1) & + ,flux(:,ij)) + xn_adv(:,ij) = & + amax1(0.,xn_adv(:,ij) & + -xm2loc(ij)*(flux(:,ij) & + - flux(:,ij-1))) + fluxps(ij) = -amin1(ps3d(ij+1)*xmdloc(ij+1) & + ,fluxps(ij)) + ps3d(ij) = & + amax1(0.,ps3d(ij) & + -xm2loc(ij)*(fluxps(ij) & + - fluxps(ij-1))) + enddo + ij = ijb3(ijll) + if(ij.lt.-3) goto 357 + hel1(:) = xn_adv(:,ij+1)*xmdloc(ij+1) + hel2(:) = flux(:,ij+1) + flux(:,ij) + + where(hel1(:).lt.hel2(:)) +!On IBM machine the division can give overflow if hel2 is too small + flux(:,ij) = - (flux(:,ij)*hel1(:))/(hel2(:)+1.0E-100) + flux(:,ij+1) = (flux(:,ij+1)*hel1(:))/(hel2(:)+1.0E-100) + xn_adv(:,ij+1) = 0. + elsewhere + flux(:,ij) = -flux(:,ij) + xn_adv(:,ij+1) = xm2loc(ij+1)*(hel1(:)-hel2(:)) + end where + + + xn_adv(:,ij) = & + amax1(0.,xn_adv(:,ij) & + -xm2loc(ij)*(flux(:,ij) - flux(:,ij-1))) + hel1ps = ps3d(ij+1)*xmdloc(ij+1) + hel2ps = fluxps(ij+1) + fluxps(ij) + if(hel1ps.lt.hel2ps)then + fluxps(ij) = -fluxps(ij)*hel1ps/hel2ps + fluxps(ij+1) = fluxps(ij+1)*hel1ps/hel2ps + ps3d(ij+1) = 0. + else + fluxps(ij) = -fluxps(ij) + ps3d(ij+1) = xm2loc(ij+1)*(hel1ps-hel2ps) + endif + ps3d(ij) = & + amax1(0.,ps3d(ij) & + -xm2loc(ij)*(fluxps(ij) - fluxps(ij-1))) + enddo + +357 continue + + if(ijdoend)then + if(limthig.eq.li1+1)then + + hel1(:) = xnend(:,1)*xmdloc(li1+1) + hel2(:) = flux(:,li1+1) + flux(:,li1) + where(hel1(:).lt.hel2(:)) + flux(:,li1) = & + - flux(:,li1)*hel1(:)/(hel2(:)+1.0E-100) + elsewhere + flux(:,li1) = -flux(:,li1) + end where + xn_adv(:,li1) =amax1(0. & + ,xn_adv(:,li1)-xm2loc(li1) & + *(flux(:,li1)- flux(:,li1-1))) + hel1ps = psend(1)*xmdloc(li1+1) + hel2ps = fluxps(li1+1) + fluxps(li1) + if(hel1ps.lt.hel2ps)then + fluxps(li1) = & + -fluxps(li1)*hel1ps/hel2ps + else + fluxps(li1) = -fluxps(li1) + endif + ps3d(li1) =amax1(0. & + ,ps3d(li1)-xm2loc(li1) & + *(fluxps(li1)- fluxps(li1-1))) + + else + + if(fc(li1).ge.0.) then + flux(:,li1) = amin1(xn_adv(:,li1) & + *xmdloc(li1),flux(:,li1)) + xn_adv(:,li1) =amax1(0. & + ,xn_adv(:,li1) & + -xm2loc(li1)*(flux(:,li1)- flux(:,li1-1))) + fluxps(li1) = amin1(ps3d(li1) & + *xmdloc(li1),fluxps(li1)) + ps3d(li1) =amax1(0. & + ,ps3d(li1) & + -xm2loc(li1)*(fluxps(li1)- fluxps(li1-1))) + else + flux(:,li1) = -amin1(xnend(:,1)*xmdloc(li1+1) & + ,flux(:,li1)) + xn_adv(:,li1) =amax1(0. & + ,xn_adv(:,li1)-xm2loc(li1) & + *(flux(:,li1)- flux(:,li1-1))) + fluxps(li1) = -amin1(psend(1)*xmdloc(li1+1) & + ,fluxps(li1)) + ps3d(li1) =amax1(0. & + ,ps3d(li1)-xm2loc(li1) & + *(fluxps(li1)- fluxps(li1-1))) + endif + endif + endif + +! accumulation of the boundary fluxes + + if (li0.eq.2) then + if(fc(1).ge.0.)then + fluxin(:) = fluxin(:) + flux(:,1)*fac1 + else + fluxout(:) = fluxout(:) - flux(:,1)*fac1 + endif + endif + + if (li1.eq.limax-1) then + if(fc(li1).ge.0.)then + fluxout(:) = fluxout(:) + flux(:,li1)*fac1 + else + fluxin(:) = fluxin(:) - flux(:,li1)*fac1 + endif + endif + + end subroutine advx + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine advy(vel,velbeg,velend & + ,xn_adv,xnbeg,xnend & + ,ps3d,psbeg,psend & + ,xm2loc,xmdloc & + ,dth,fac1) + +! executes advection with a.bott's integrated flux method using +! 4'th order polynomials in the y-direction. +! +! modified by pw february 2002: Takes into account the mapping factor +! in such a way that a Courant number of one corresponds exactly to "empty" a cell. +! (small effects on results: less than 1%) +! + + use Par_ml , only : lj0,lj1,ljmax + use GenSpec_adv_ml , only : NSPEC_ADV + use MassBudget_ml , only : fluxin,fluxout + implicit none + +! parameter: +! input + real,intent(in):: vel(0:MAXLIMAX*MAXLJMAX),velbeg, velend + real,intent(in):: xnbeg(NSPEC_ADV,3) & + ,xnend(NSPEC_ADV,3) + real,intent(in):: psbeg(3) & + ,psend(3) & + ,xm2loc(0:MAXLJMAX+1) & + ,xmdloc(0:MAXLJMAX+1) + real,intent(in):: dth,fac1 + +! input+output + real ,intent(inout)::xn_adv(NSPEC_ADV,MAXLIMAX:MAXLIMAX*MAXLJMAX) + real ,intent(inout)::ps3d(MAXLIMAX:MAXLIMAX*MAXLJMAX) + +! output fluxin,fluxout + +! local + + integer ij, ijn,ijll + integer limtlow,limthig + integer lijb,lije + real ijn1 + real x1, x2, x3,hh3,hh4 + real y0,y1,y2,y3 + real zzfc(5,-1:MAXLJMAX+1) + real fc(-1:MAXLJMAX+1) + real flux(NSPEC_ADV,-1:MAXLJMAX+1) + real fluxps(-1:MAXLJMAX+1) + real hel1(NSPEC_ADV),hel2(NSPEC_ADV) + real hel1ps,hel2ps + integer ijpasses + integer ijb1(MAXLJMAX),ije1(MAXLJMAX) + integer ijb2(MAXLJMAX),ije2(MAXLJMAX),ijb3(MAXLJMAX) + logical ijdoend + +!----------------------------------------------------------------------- + + limtlow = lj0-1 + if (lj0.eq.1) then + if (vel(0) .gt. 0..and.velbeg.lt.0.) then + fc(-1) = velbeg*dth + fc(-1)=min(1.0, fc(-1)) + fc(-1)=max(-1.0, fc(-1)) + limtlow = -1 + + y0 = fc(-1) + x1 = 1.+2.*y0*xm2loc(0) + x2 = x1*x1 + y3 = xmdloc(0)*(1.-x2)/3840. + y1 = 5.*y3 + y2 = x1*y3 + hh3 = (116.-4.*x2)*y2 + hh4 = (2.*x2-66.)*y1 + zzfc(3,-1) = - y0 - (214.-6.*x2)*y2 + zzfc(5,-1) = (y2-y1)*(x2-9.) + zzfc(1,-1) = (y2+y1)*(x2-9.) + zzfc(4,-1) = hh3+hh4 + zzfc(2,-1) = hh3-hh4 + + endif + endif + + do 10 ij = lj0-1,lj1 + fc(ij) = vel(ij*MAXLIMAX)*dth + fc(ij)=min(1.0, fc(ij)) + fc(ij)=max(-1.0, fc(ij)) + + ijn1 = sign(1.,fc(ij)) + ijn = ij + nint(0.5*(1-ijn1)) + + y0 = ijn1*fc(ij) + x1 = 1.-2.*y0*xm2loc(ijn) + x2 = x1*x1 + y3 = xmdloc(ijn)*(1.-x2)/3840. + y1 = 5.*ijn1*y3 + y2 = x1*y3 + hh3 = (116.-4.*x2)*y2 + hh4 = (66.-2.*x2)*y1 + zzfc(3,ij) = y0 - (214.-6.*x2)*y2 + zzfc(5,ij) = (y2+y1)*(x2-9.) + zzfc(1,ij) = (y2-y1)*(x2-9.) + zzfc(4,ij) = hh3+hh4 + zzfc(2,ij) = hh3-hh4 + +10 continue + + limthig = lj1 + if (lj1.eq.ljmax) then + if (vel(lj1*MAXLIMAX).lt.0..and.velend.gt.0.)then + fc(lj1+1) = velend*dth + fc(lj1+1)=min(1.0, fc(lj1+1)) + fc(lj1+1)=max(-1.0, fc(lj1+1)) + limthig = lj1+1 + + y0 = fc(lj1+1) + x1 = 1.-2.*y0*xm2loc(lj1+1) + x2 = x1*x1 + y3 = xmdloc(lj1+1)*(1.-x2)/3840. + y1 = 5.*y3 + y2 = x1*y3 + hh3 = (116.-4.*x2)*y2 + hh4 = (66.-2.*x2)*y1 + zzfc(3,lj1+1) = y0 - (214.-6.*x2)*y2 + zzfc(5,lj1+1) = (y2+y1)*(x2-9.) + zzfc(1,lj1+1) = (y2-y1)*(x2-9.) + zzfc(4,lj1+1) = hh3+hh4 + zzfc(2,lj1+1) = hh3-hh4 + + endif + endif + +!------- boundary treatment ----------------------------------------- + +! helping values at the boundaries are found by linear +! extrapolation in cases of outflow, and by assuming constant +! values in inflow cases. + +! calculate the coefficients in the polynomial, the +! normalized fluxes, and limit them for positivness + + if(limtlow.eq.-1) then + + +! integrated flux form + + flux(:,-1) = max(0.,xn_adv(:,2*MAXLIMAX)*zzfc(5,-1) & + + xn_adv(:,MAXLIMAX)*zzfc(4,-1) & + + xnbeg(:,3)*zzfc(3,-1) & + + xnbeg(:,2)*zzfc(2,-1) + xnbeg(:,1)*zzfc(1,-1)) + flux(:,0) = max(0.,xn_adv(:,(2)*MAXLIMAX)*zzfc(5,0) & + + xn_adv(:,1*MAXLIMAX)*zzfc(4,0) & + + xnbeg(:,3)*zzfc(3,0) & + + xnbeg(:,2)*zzfc(2,0) + xnbeg(:,1)*zzfc(1,0)) + fluxps(-1) = max(0.,ps3d(2*MAXLIMAX)*zzfc(5,-1) & + + ps3d(MAXLIMAX)*zzfc(4,-1) & + + psbeg(3)*zzfc(3,-1) & + + psbeg(2)*zzfc(2,-1) + psbeg(1)*zzfc(1,-1)) + fluxps(0) = max(0.,ps3d((2)*MAXLIMAX)*zzfc(5,0) & + + ps3d(1*MAXLIMAX)*zzfc(4,0) & + + psbeg(3)*zzfc(3,0) & + + psbeg(2)*zzfc(2,0) + psbeg(1)*zzfc(1,0)) + + else +! integrated flux form + + if(fc(lj0-1).ge.0.)then + flux(:,lj0-1) = max(0.,xn_adv(:,(lj0+1)*MAXLIMAX)*zzfc(5,lj0-1)& + + xn_adv(:,lj0*MAXLIMAX)*zzfc(4,lj0-1) & + + xnbeg(:,3)*zzfc(3,lj0-1) & + + xnbeg(:,2)*zzfc(2,lj0-1) + xnbeg(:,1)*zzfc(1,lj0-1)) + fluxps(lj0-1) = max(0.,ps3d((lj0+1)*MAXLIMAX)*zzfc(5,lj0-1) & + + ps3d(lj0*MAXLIMAX)*zzfc(4,lj0-1) & + + psbeg(3)*zzfc(3,lj0-1) & + + psbeg(2)*zzfc(2,lj0-1) + psbeg(1)*zzfc(1,lj0-1)) + else + flux(:,lj0-1) = max(0.,xn_adv(:,(lj0+2)*MAXLIMAX)*zzfc(5,lj0-1)& + + xn_adv(:,(lj0+1)*MAXLIMAX)*zzfc(4,lj0-1) & + + xn_adv(:,lj0*MAXLIMAX)*zzfc(3,lj0-1) & + + xnbeg(:,3)*zzfc(2,lj0-1) + xnbeg(:,2)*zzfc(1,lj0-1)) + fluxps(lj0-1) = max(0.,ps3d((lj0+2)*MAXLIMAX)*zzfc(5,lj0-1) & + + ps3d((lj0+1)*MAXLIMAX)*zzfc(4,lj0-1) & + + ps3d(lj0*MAXLIMAX)*zzfc(3,lj0-1) & + + psbeg(3)*zzfc(2,lj0-1) + psbeg(2)*zzfc(1,lj0-1)) + endif + endif + +! integrated flux form + + if(fc(lj0).ge.0.)then + flux(:,lj0) = max(0.,xn_adv(:,(lj0+2)*MAXLIMAX)*zzfc(5,lj0) & + + xn_adv(:,(lj0+1)*MAXLIMAX)*zzfc(4,lj0) & + + xn_adv(:,lj0*MAXLIMAX)*zzfc(3,lj0) & + + xnbeg(:,3)*zzfc(2,lj0) + xnbeg(:,2)*zzfc(1,lj0)) + fluxps(lj0) = max(0.,ps3d((lj0+2)*MAXLIMAX)*zzfc(5,lj0) & + + ps3d((lj0+1)*MAXLIMAX)*zzfc(4,lj0) & + + ps3d(lj0*MAXLIMAX)*zzfc(3,lj0) & + + psbeg(3)*zzfc(2,lj0) + psbeg(2)*zzfc(1,lj0)) + else + flux(:,lj0) = max(0.,xn_adv(:,(lj0+3)*MAXLIMAX)*zzfc(5,lj0) & + + xn_adv(:,(lj0+2)*MAXLIMAX)*zzfc(4,lj0) & + + xn_adv(:,(lj0+1)*MAXLIMAX)*zzfc(3,lj0) & + + xn_adv(:,lj0*MAXLIMAX)*zzfc(2,lj0) + xnbeg(:,3)*zzfc(1,lj0)) + fluxps(lj0) = max(0.,ps3d((lj0+3)*MAXLIMAX)*zzfc(5,lj0) & + + ps3d((lj0+2)*MAXLIMAX)*zzfc(4,lj0) & + + ps3d((lj0+1)*MAXLIMAX)*zzfc(3,lj0) & + + ps3d(lj0*MAXLIMAX)*zzfc(2,lj0) + psbeg(3)*zzfc(1,lj0)) + endif + + if(fc(lj0+1).ge.0.)then + +! integrated flux form + + flux(:,lj0+1) = max(0.,xn_adv(:,(lj0+3)*MAXLIMAX)*zzfc(5,lj0+1)& + + xn_adv(:,(lj0+2)*MAXLIMAX)*zzfc(4,lj0+1) & + + xn_adv(:,(lj0+1)*MAXLIMAX)*zzfc(3,lj0+1) & + + xn_adv(:,lj0*MAXLIMAX)*zzfc(2,lj0+1) + xnbeg(:,3)*zzfc(1,lj0+1)) + fluxps(lj0+1) = max(0.,ps3d((lj0+3)*MAXLIMAX)*zzfc(5,lj0+1) & + + ps3d((lj0+2)*MAXLIMAX)*zzfc(4,lj0+1) & + + ps3d((lj0+1)*MAXLIMAX)*zzfc(3,lj0+1) & + + ps3d(lj0*MAXLIMAX)*zzfc(2,lj0+1) + psbeg(3)*zzfc(1,lj0+1)) + endif + + + lijb = lj0+2 + if(fc(lj0+1).lt.0.)lijb = lj0+1 + lije = lj1-3 + if(fc(lj1-2).ge.0.)lije = lj1-2 + + do ij = lijb,lije + + ijn1 = sign(1.,fc(ij)) + +! integrated flux form + + ijn = ij+nint(0.5*(1.-ijn1)) + flux(:,ij) = max(0.,xn_adv(:,(ijn+2)*MAXLIMAX)*zzfc(5,ij) & + + xn_adv(:,(ijn+1)*MAXLIMAX)*zzfc(4,ij) & + + xn_adv(:,ijn*MAXLIMAX)*zzfc(3,ij) & + + xn_adv(:,(ijn-1)*MAXLIMAX)*zzfc(2,ij) & + + xn_adv(:,(ijn-2)*MAXLIMAX)*zzfc(1,ij)) + fluxps(ij) = max(0.,ps3d((ijn+2)*MAXLIMAX)*zzfc(5,ij) & + + ps3d((ijn+1)*MAXLIMAX)*zzfc(4,ij) & + + ps3d(ijn*MAXLIMAX)*zzfc(3,ij) & + + ps3d((ijn-1)*MAXLIMAX)*zzfc(2,ij) & + + ps3d((ijn-2)*MAXLIMAX)*zzfc(1,ij)) + + enddo + + if(fc(lj1-2).lt.0.)then + +! integrated flux form + + + flux(:,lj1-2) = max(0.,xnend(:,1)*zzfc(5,lj1-2) & + + xn_adv(:,lj1*MAXLIMAX)*zzfc(4,lj1-2) & + + xn_adv(:,(lj1-1)*MAXLIMAX)*zzfc(3,lj1-2) & + + xn_adv(:,(lj1-2)*MAXLIMAX)*zzfc(2,lj1-2) & + + xn_adv(:,(lj1-3)*MAXLIMAX)*zzfc(1,lj1-2)) + fluxps(lj1-2) = max(0.,psend(1)*zzfc(5,lj1-2) & + + ps3d(lj1*MAXLIMAX)*zzfc(4,lj1-2) & + + ps3d((lj1-1)*MAXLIMAX)*zzfc(3,lj1-2) & + + ps3d((lj1-2)*MAXLIMAX)*zzfc(2,lj1-2) & + + ps3d((lj1-3)*MAXLIMAX)*zzfc(1,lj1-2)) + + endif + +! integrated flux form + + if(fc(lj1-1).ge.0.)then + + flux(:,lj1-1) = max(0.,xnend(:,1)*zzfc(5,lj1-1) & + + xn_adv(:,lj1*MAXLIMAX)*zzfc(4,lj1-1) & + + xn_adv(:,(lj1-1)*MAXLIMAX)*zzfc(3,lj1-1) & + + xn_adv(:,(lj1-2)*MAXLIMAX)*zzfc(2,lj1-1) & + + xn_adv(:,(lj1-3)*MAXLIMAX)*zzfc(1,lj1-1)) + fluxps(lj1-1) = max(0.,psend(1)*zzfc(5,lj1-1) & + + ps3d(lj1*MAXLIMAX)*zzfc(4,lj1-1) & + + ps3d((lj1-1)*MAXLIMAX)*zzfc(3,lj1-1) & + + ps3d((lj1-2)*MAXLIMAX)*zzfc(2,lj1-1) & + + ps3d((lj1-3)*MAXLIMAX)*zzfc(1,lj1-1)) + + else + + flux(:,lj1-1) = max(0.,xnend(:,2)*zzfc(5,lj1-1) & + + xnend(:,1)*zzfc(4,lj1-1) & + + xn_adv(:,lj1*MAXLIMAX)*zzfc(3,lj1-1) & + + xn_adv(:,(lj1-1)*MAXLIMAX)*zzfc(2,lj1-1) & + + xn_adv(:,(lj1-2)*MAXLIMAX)*zzfc(1,lj1-1)) + fluxps(lj1-1) = max(0.,psend(2)*zzfc(5,lj1-1) & + + psend(1)*zzfc(4,lj1-1) & + + ps3d(lj1*MAXLIMAX)*zzfc(3,lj1-1) & + + ps3d((lj1-1)*MAXLIMAX)*zzfc(2,lj1-1) & + + ps3d((lj1-2)*MAXLIMAX)*zzfc(1,lj1-1)) + + endif + +! integrated flux form + if(limthig.eq.lj1)then + + if(fc(lj1).ge.0.)then + + flux(:,lj1) = max(0.,xnend(:,2)*zzfc(5,lj1) & + + xnend(:,1)*zzfc(4,lj1) & + + xn_adv(:,lj1*MAXLIMAX)*zzfc(3,lj1) & + + xn_adv(:,(lj1-1)*MAXLIMAX)*zzfc(2,lj1) & + + xn_adv(:,(lj1-2)*MAXLIMAX)*zzfc(1,lj1)) + fluxps(lj1) = max(0.,psend(2)*zzfc(5,lj1) & + + psend(1)*zzfc(4,lj1) & + + ps3d(lj1*MAXLIMAX)*zzfc(3,lj1) & + + ps3d((lj1-1)*MAXLIMAX)*zzfc(2,lj1) & + + ps3d((lj1-2)*MAXLIMAX)*zzfc(1,lj1)) + + else + + flux(:,lj1) = max(0.,xnend(:,3)*zzfc(5,lj1) & + + xnend(:,2)*zzfc(4,lj1) & + + xnend(:,1)*zzfc(3,lj1) & + + xn_adv(:,lj1*MAXLIMAX)*zzfc(2,lj1) & + + xn_adv(:,(lj1-1)*MAXLIMAX)*zzfc(1,lj1)) + fluxps(lj1) = max(0.,psend(3)*zzfc(5,lj1) & + + psend(2)*zzfc(4,lj1) & + + psend(1)*zzfc(3,lj1) & + + ps3d(lj1*MAXLIMAX)*zzfc(2,lj1) & + + ps3d((lj1-1)*MAXLIMAX)*zzfc(1,lj1)) + + endif + + else + +! integrated flux form + + flux(:,lj1) = max(0.,xnend(:,3)*zzfc(5,lj1) & + + xnend(:,2)*zzfc(4,lj1) & + + xnend(:,1)*zzfc(3,lj1) & + + xn_adv(:,lj1*MAXLIMAX)*zzfc(2,lj1) & + + xn_adv(:,(lj1-1)*MAXLIMAX)*zzfc(1,lj1)) + flux(:,lj1+1) = max(0.,xnend(:,3)*zzfc(5,lj1+1) & + + xnend(:,2)*zzfc(4,lj1+1) & + + xnend(:,1)*zzfc(3,lj1+1) & + + xn_adv(:,lj1*MAXLIMAX)*zzfc(2,lj1+1) & + + xn_adv(:,(lj1-1)*MAXLIMAX)*zzfc(1,lj1+1)) + fluxps(lj1) = max(0.,psend(3)*zzfc(5,lj1) & + + psend(2)*zzfc(4,lj1) & + + psend(1)*zzfc(3,lj1) & + + ps3d(lj1*MAXLIMAX)*zzfc(2,lj1) & + + ps3d((lj1-1)*MAXLIMAX)*zzfc(1,lj1)) + fluxps(lj1+1) = max(0.,psend(3)*zzfc(5,lj1+1) & + + psend(2)*zzfc(4,lj1+1) & + + psend(1)*zzfc(3,lj1+1) & + + ps3d(lj1*MAXLIMAX)*zzfc(2,lj1+1) & + + ps3d((lj1-1)*MAXLIMAX)*zzfc(1,lj1+1)) + + endif + + if(limtlow.eq.-1)then + hel1(:) = xnbeg(:,3)*xmdloc(0) + hel2(:) = flux(:,0) + flux(:,-1) + where(hel1(:).lt.hel2(:))flux(:,0) & + = flux(:,0)*hel1(:)/(hel2(:)+1.0E-100) + hel1ps = psbeg(3)*xmdloc(0) + hel2ps = fluxps(0) + fluxps(-1) + if(hel1ps.lt.hel2ps)fluxps(0) & + = fluxps(0)*hel1ps/hel2ps + ij = 1 + else + if(fc(lj0-1).ge.0.) then + flux(:,lj0-1) = amin1(xnbeg(:,3) & + *xmdloc(lj0-1) & + ,flux(:,lj0-1)) + fluxps(lj0-1) = amin1(psbeg(3) & + *xmdloc(lj0-1) & + ,fluxps(lj0-1)) + ij = lj0 + else + if(fc(lj0).lt.0.) then + flux(:,lj0-1) = -amin1(xn_adv(:,lj0*MAXLIMAX) & + *xmdloc(lj0),flux(:,lj0-1)) + fluxps(lj0-1) = -amin1(ps3d(lj0*MAXLIMAX) & + *xmdloc(lj0),fluxps(lj0-1)) + ij = lj0 + else + hel1(:) = xn_adv(:,lj0*MAXLIMAX)*xmdloc(lj0) + hel2(:) = flux(:,lj0) + flux(:,lj0-1) + where(hel1(:).lt.hel2(:)) + flux(:,lj0-1) = - flux(:,lj0-1)*hel1(:)/(hel2(:)+1.0E-100) + flux(:,lj0) = flux(:,lj0)*hel1(:)/(hel2(:)+1.0E-100) + xn_adv(:,lj0*MAXLIMAX) = 0. + elsewhere + flux(:,lj0-1) = -flux(:,lj0-1) + xn_adv(:,lj0*MAXLIMAX) =xm2loc(lj0) & + *(hel1(:)-hel2(:)) + end where + hel1ps = ps3d(lj0*MAXLIMAX)*xmdloc(lj0) + hel2ps = fluxps(lj0) + fluxps(lj0-1) + if(hel1ps.lt.hel2ps)then + fluxps(lj0-1) = - fluxps(lj0-1)*hel1ps/hel2ps + fluxps(lj0) = fluxps(lj0)*hel1ps/hel2ps + ps3d(lj0*MAXLIMAX) = 0. + else + fluxps(lj0-1) = -fluxps(lj0-1) + ps3d(lj0*MAXLIMAX) =xm2loc(lj0)*(hel1ps-hel2ps) + endif + ij = lj0+1 + endif + endif + endif + + ijpasses = 0 + do while(.true.) + + ijpasses = ijpasses+1 + ijb1(ijpasses) = ij + ije1(ijpasses) = -5 + do while(fc(ij).ge.0.) + ije1(ijpasses) = ij + ij = ij+1 + if(ij.gt.lj1-1)then + ijb2(ijpasses) = ij + ije2(ijpasses) = -5 + ijb3(ijpasses) = -5 + goto 257 + endif + enddo + ijb2(ijpasses) = ij + ije2(ijpasses) = -5 + do while(fc(ij+1).lt.0.) + ije2(ijpasses) = ij + ij = ij+1 + if(ij.gt.lj1-1)then + ijb3(ijpasses) = -5 + goto 257 + endif + enddo + ijb3(ijpasses) = ij + ij = ij+2 + if(ij.gt.lj1-1)goto 257 + enddo + +257 continue + ijdoend = .false. + if(ij.eq.lj1)ijdoend=.true. + + do ijll = 1,ijpasses + + do ij = ijb1(ijll),ije1(ijll) + flux(:,ij) = amin1(xn_adv(:,ij*MAXLIMAX)*xmdloc(ij) & + ,flux(:,ij)) + xn_adv(:,ij*MAXLIMAX) = & + amax1(0.,xn_adv(:,ij*MAXLIMAX) & + -xm2loc(ij) & + *(flux(:,ij) - flux(:,ij-1))) + fluxps(ij) = amin1(ps3d(ij*MAXLIMAX)*xmdloc(ij) & + ,fluxps(ij)) + ps3d(ij*MAXLIMAX) = & + amax1(0.,ps3d(ij*MAXLIMAX) & + -xm2loc(ij) & + *(fluxps(ij) - fluxps(ij-1))) + enddo + do ij = ijb2(ijll),ije2(ijll) + flux(:,ij) = -amin1(xn_adv(:,(ij+1)*MAXLIMAX)*xmdloc(ij+1)& + ,flux(:,ij)) + xn_adv(:,ij*MAXLIMAX) = & + amax1(0.,xn_adv(:,ij*MAXLIMAX) & + -xm2loc(ij)*(flux(:,ij) & + - flux(:,ij-1))) + fluxps(ij) = -amin1(ps3d((ij+1)*MAXLIMAX)*xmdloc(ij+1) & + ,fluxps(ij)) + ps3d(ij*MAXLIMAX) = & + amax1(0.,ps3d(ij*MAXLIMAX) & + -xm2loc(ij)*(fluxps(ij) & + - fluxps(ij-1))) + enddo + ij = ijb3(ijll) + if(ij.lt.-3) goto 357 + hel1(:) = xn_adv(:,(ij+1)*MAXLIMAX)*xmdloc(ij+1) + hel2(:) = flux(:,ij+1) + flux(:,ij) + where(hel1(:).lt.hel2(:)) +!On IBM machine the division can give overflow if hel2 is too small + flux(:,ij) = - flux(:,ij)*hel1(:)/(hel2(:)+1.0E-100) + flux(:,ij+1) = flux(:,ij+1)*hel1(:)/(hel2(:)+1.0E-100) + xn_adv(:,(ij+1)*MAXLIMAX) = 0. + elsewhere + flux(:,ij) = -flux(:,ij) + xn_adv(:,(ij+1)*MAXLIMAX) = xm2loc(ij+1)*(hel1(:)-hel2(:)) + end where + xn_adv(:,ij*MAXLIMAX) = & + amax1(0.,xn_adv(:,ij*MAXLIMAX) & + -xm2loc(ij)*(flux(:,ij) - flux(:,ij-1))) + hel1ps = ps3d((ij+1)*MAXLIMAX)*xmdloc(ij+1) + hel2ps = fluxps(ij+1) + fluxps(ij) + if(hel1ps.lt.hel2ps)then + fluxps(ij) = -fluxps(ij)*hel1ps/hel2ps + fluxps(ij+1) = fluxps(ij+1)*hel1ps/hel2ps + ps3d((ij+1)*MAXLIMAX) = 0. + else + fluxps(ij) = -fluxps(ij) + ps3d((ij+1)*MAXLIMAX) = xm2loc(ij+1)*(hel1ps-hel2ps) + endif + ps3d(ij*MAXLIMAX) = & + amax1(0.,ps3d(ij*MAXLIMAX) & + -xm2loc(ij)*(fluxps(ij) - fluxps(ij-1))) + enddo + +357 continue + + if(ijdoend)then + if(limthig.eq.lj1+1)then + + hel1(:) = xnend(:,1)*xmdloc(lj1+1) + hel2(:) = flux(:,lj1+1) + flux(:,lj1) + where(hel1(:).lt.hel2(:)) + flux(:,lj1) & + = -flux(:,lj1)*hel1(:)/(hel2(:)+1.0E-100) + elsewhere + flux(:,lj1) = -flux(:,lj1) + end where + xn_adv(:,lj1*MAXLIMAX) =amax1(0. & + ,xn_adv(:,lj1*MAXLIMAX)-xm2loc(lj1) & + *(flux(:,lj1)- flux(:,lj1-1))) + hel1ps = psend(1)*xmdloc(lj1+1) + hel2ps = fluxps(lj1+1) + fluxps(lj1) + if(hel1ps.lt.hel2ps)then + fluxps(lj1) & + = -fluxps(lj1)*hel1ps/hel2ps + else + fluxps(lj1) = -fluxps(lj1) + endif + ps3d(lj1*MAXLIMAX) =amax1(0. & + ,ps3d(lj1*MAXLIMAX)-xm2loc(lj1) & + *(fluxps(lj1)- fluxps(lj1-1))) + + else + + if(fc(lj1).ge.0.) then + flux(:,lj1) = amin1(xn_adv(:,lj1*MAXLIMAX) & + *xmdloc(lj1),flux(:,lj1)) + xn_adv(:,lj1*MAXLIMAX) =amax1(0. & + ,xn_adv(:,lj1*MAXLIMAX) & + -xm2loc(lj1)*(flux(:,lj1)- flux(:,lj1-1))) + fluxps(lj1) = amin1(ps3d(lj1*MAXLIMAX) & + *xmdloc(lj1),fluxps(lj1)) + ps3d(lj1*MAXLIMAX) =amax1(0. & + ,ps3d(lj1*MAXLIMAX) & + -xm2loc(lj1)*(fluxps(lj1)- fluxps(lj1-1))) + else + flux(:,lj1) = -amin1(xnend(:,1)*xmdloc(lj1+1) & + ,flux(:,lj1)) + xn_adv(:,lj1*MAXLIMAX) =amax1(0. & + ,xn_adv(:,lj1*MAXLIMAX) & + -xm2loc(lj1) & + *(flux(:,lj1)- flux(:,lj1-1))) + fluxps(lj1) = -amin1(psend(1)*xmdloc(lj1+1) & + ,fluxps(lj1)) + ps3d(lj1*MAXLIMAX) =amax1(0. & + ,ps3d(lj1*MAXLIMAX)-xm2loc(lj1) & + *(fluxps(lj1)- fluxps(lj1-1))) + endif + endif + endif + +! accumulation of the boundary fluxes + + if (lj0.eq.2) then + if(fc(1).ge.0.)then + fluxin(:) = fluxin(:) + flux(:,1)*fac1 + else + fluxout(:) = fluxout(:) - flux(:,1)*fac1 + endif + endif + + if (lj1.eq.ljmax-1) then + if(fc(lj1).ge.0.)then + fluxout(:) = fluxout(:) + flux(:,lj1)*fac1 + else + fluxin(:) = fluxin(:) - flux(:,lj1)*fac1 + endif + endif + + end subroutine advy + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine preadvx(msgnr & + ,xn_adv,ps3d,vel & + ,xnbeg, xnend & + ,psbeg, psend) + + use Par_ml , only : lj0,lj1,li1 & + ,neighbor,WEST,EAST + use GenSpec_adv_ml , only : NSPEC_ADV + implicit none + +! input + integer,intent(in):: msgnr + real,intent(in):: xn_adv(NSPEC_ADV,MAXLIMAX:MAXLIMAX*(MAXLJMAX+1)) + real,intent(in):: ps3d(MAXLIMAX:MAXLIMAX*(MAXLJMAX+1)) & + ,vel(MAXLIMAX+1:(MAXLIMAX+1)*(MAXLJMAX+1)) + +! output + real,intent(out):: xnend(NSPEC_ADV,3,MAXLJMAX) & + , xnbeg(NSPEC_ADV,3,MAXLJMAX) + real,intent(out):: psend(3,MAXLJMAX) & + , psbeg(3,MAXLJMAX) + +! local + integer i, info + + integer request1, request2, & + request_ps_w, request_ps_e, & + request_xn_w, request_xn_e + real buf_xn_w(NSPEC_ADV, 3, MAXLJMAX), & + buf_xn_e(NSPEC_ADV, 3, MAXLJMAX), & + buf_ps_w(3, MAXLJMAX), & + buf_ps_e(3, MAXLJMAX) + +! Initialize arrays holding boundary slices + +! send to WEST neighbor if any + + if (neighbor(WEST).ge.0) then + do i = lj0,lj1 + buf_xn_w(:,1,i) = xn_adv(:,i*MAXLIMAX) + buf_xn_w(:,2,i) = xn_adv(:,i*MAXLIMAX+1) + buf_xn_w(:,3,i) = xn_adv(:,i*MAXLIMAX+2) + + buf_ps_w(1,i) = ps3d(i*MAXLIMAX) + buf_ps_w(2,i) = ps3d(i*MAXLIMAX+1) + buf_ps_w(3,i) = ps3d(i*MAXLIMAX+2) + enddo + CALL MPI_ISEND( buf_xn_w , 8*3*MAXLJMAX*NSPEC_ADV, MPI_BYTE,& + neighbor(WEST), msgnr, MPI_COMM_WORLD, request_xn_w, INFO) + CALL MPI_ISEND( buf_ps_w , 8*3*MAXLJMAX, MPI_BYTE,& + neighbor(WEST), msgnr+100, MPI_COMM_WORLD, request_ps_w, INFO) + + endif + + if (neighbor(EAST).ge.0) then + do i = lj0,lj1 + buf_xn_e(:,1,i) = xn_adv(:,i*MAXLIMAX+li1-3) + buf_xn_e(:,2,i) = xn_adv(:,i*MAXLIMAX+li1-2) + buf_xn_e(:,3,i) = xn_adv(:,i*MAXLIMAX+li1-1) + + buf_ps_e(1,i) = ps3d(i*MAXLIMAX+li1-3) + buf_ps_e(2,i) = ps3d(i*MAXLIMAX+li1-2) + buf_ps_e(3,i) = ps3d(i*MAXLIMAX+li1-1) + enddo + + CALL MPI_ISEND( buf_xn_e , 8*3*MAXLJMAX*NSPEC_ADV, MPI_BYTE,& + neighbor(EAST), msgnr+200, MPI_COMM_WORLD, request_xn_e, INFO) + CALL MPI_ISEND( buf_ps_e , 8*3*MAXLJMAX, MPI_BYTE,& + neighbor(EAST), msgnr+300, MPI_COMM_WORLD, request_ps_e, INFO) + endif + + + if (neighbor(WEST).lt.0) then + do i = lj0,lj1 + if(vel(i*(MAXLIMAX+1)+1).lt.0)then + xnbeg(:,2,i) = 3.*xn_adv(:,i*MAXLIMAX+1) & + -2.*xn_adv(:,i*MAXLIMAX+2) + xnbeg(:,3,i) = 2.*xn_adv(:,i*MAXLIMAX+1) & + -xn_adv(:,i*MAXLIMAX+2) + + psbeg(2,i) = 3.*ps3d(i*MAXLIMAX+1)-2.*ps3d(i*MAXLIMAX+2) + psbeg(3,i) = 2.*ps3d(i*MAXLIMAX+1)-ps3d(i*MAXLIMAX+2) + else + xnbeg(:,1,i) = xn_adv(:,i*MAXLIMAX) + xnbeg(:,2,i) = xn_adv(:,i*MAXLIMAX) + xnbeg(:,3,i) = xn_adv(:,i*MAXLIMAX) + + psbeg(1,i) = ps3d(i*MAXLIMAX) + psbeg(2,i) = ps3d(i*MAXLIMAX) + psbeg(3,i) = ps3d(i*MAXLIMAX) + endif + enddo + else + CALL MPI_RECV( xnbeg, 8*MAXLJMAX*3*NSPEC_ADV, MPI_BYTE, & + neighbor(WEST), msgnr+200, MPI_COMM_WORLD, STATUS, INFO) + CALL MPI_RECV( psbeg, 8*MAXLJMAX*3, MPI_BYTE, & + neighbor(WEST), msgnr+300, MPI_COMM_WORLD, STATUS, INFO) + endif + + if (neighbor(EAST).lt.0) then + do i = lj0,lj1 + if(vel(i*(MAXLIMAX+1)+li1).ge.0)then + xnend(:,1,i) = 2.*xn_adv(:,i*MAXLIMAX+li1-1) & + -xn_adv(:,i*MAXLIMAX+li1-2) + xnend(:,2,i) = 3.*xn_adv(:,i*MAXLIMAX+li1-1) & + -2.*xn_adv(:,i*MAXLIMAX+li1-2) + + psend(1,i) = 2.*ps3d(i*MAXLIMAX+li1-1) & + -ps3d(i*MAXLIMAX+li1-2) + psend(2,i) = 3.*ps3d(i*MAXLIMAX+li1-1) & + -2.*ps3d(i*MAXLIMAX+li1-2) + else + xnend(:,1,i) = xn_adv(:,i*MAXLIMAX+li1) + xnend(:,2,i) = xn_adv(:,i*MAXLIMAX+li1) + xnend(:,3,i) = xn_adv(:,i*MAXLIMAX+li1) + + psend(1,i) = ps3d(i*MAXLIMAX+li1) + psend(2,i) = ps3d(i*MAXLIMAX+li1) + psend(3,i) = ps3d(i*MAXLIMAX+li1) + endif + enddo + else + CALL MPI_RECV( xnend, 8*MAXLJMAX*3*NSPEC_ADV, MPI_BYTE, & + neighbor(EAST), msgnr, MPI_COMM_WORLD, STATUS, INFO) + CALL MPI_RECV( psend, 8*MAXLJMAX*3, MPI_BYTE, & + neighbor(EAST), msgnr+100, MPI_COMM_WORLD, STATUS, INFO) + endif + + ! synchronizing sent buffers (must be done for all ISENDs!!!) + if (neighbor(WEST) .ge. 0) then + CALL MPI_WAIT(request_xn_w, STATUS, INFO) + CALL MPI_WAIT(request_ps_w, STATUS, INFO) + endif + if (neighbor(EAST) .ge. 0) then + CALL MPI_WAIT(request_xn_e, STATUS, INFO) + CALL MPI_WAIT(request_ps_e, STATUS, INFO) + endif + end subroutine preadvx + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine preadvx2(msgnr & + ,xn_adv,ps3d,vel & + ,xnbeg, xnend & + ,psbeg, psend) + +!send only one row + + use Par_ml , only : lj0,lj1,li1 & + ,neighbor,WEST,EAST + use GenSpec_adv_ml , only : NSPEC_ADV + implicit none + +! input + integer,intent(in):: msgnr + real,intent(in):: xn_adv(NSPEC_ADV,MAXLIMAX:MAXLIMAX*(MAXLJMAX+1)) + real,intent(in):: ps3d(MAXLIMAX:MAXLIMAX*(MAXLJMAX+1)) & + ,vel(MAXLIMAX+1:(MAXLIMAX+1)*(MAXLJMAX+1)) + +! output + real,intent(out):: xnend(NSPEC_ADV,3) & + , xnbeg(NSPEC_ADV,3) + real,intent(out):: psend(3) & + , psbeg(3) + +! local + integer i, info + + integer request1, request2, & + request_ps_w, request_ps_e, & + request_xn_w, request_xn_e + real buf_xn_w(NSPEC_ADV, 3), & + buf_xn_e(NSPEC_ADV, 3), & + buf_ps_w(3), & + buf_ps_e(3) + +! Initialize arrays holding boundary slices + +! send to WEST neighbor if any + + if (neighbor(WEST).ge.0) then + do i = 1,1!lj0,lj1 + buf_xn_w(:,1) = xn_adv(:,i*MAXLIMAX) + buf_xn_w(:,2) = xn_adv(:,i*MAXLIMAX+1) + buf_xn_w(:,3) = xn_adv(:,i*MAXLIMAX+2) + + buf_ps_w(1) = ps3d(i*MAXLIMAX) + buf_ps_w(2) = ps3d(i*MAXLIMAX+1) + buf_ps_w(3) = ps3d(i*MAXLIMAX+2) + enddo + CALL MPI_ISEND( buf_xn_w , 8*3*NSPEC_ADV, MPI_BYTE,& + neighbor(WEST), msgnr, MPI_COMM_WORLD, request_xn_w, INFO) + CALL MPI_ISEND( buf_ps_w , 8*3, MPI_BYTE,& + neighbor(WEST), msgnr+100, MPI_COMM_WORLD, request_ps_w, INFO) + + endif + + if (neighbor(EAST).ge.0) then + do i = 1,1!lj0,lj1 + buf_xn_e(:,1) = xn_adv(:,i*MAXLIMAX+li1-3) + buf_xn_e(:,2) = xn_adv(:,i*MAXLIMAX+li1-2) + buf_xn_e(:,3) = xn_adv(:,i*MAXLIMAX+li1-1) + + buf_ps_e(1) = ps3d(i*MAXLIMAX+li1-3) + buf_ps_e(2) = ps3d(i*MAXLIMAX+li1-2) + buf_ps_e(3) = ps3d(i*MAXLIMAX+li1-1) + enddo + + CALL MPI_ISEND( buf_xn_e , 8*3*NSPEC_ADV, MPI_BYTE,& + neighbor(EAST), msgnr+200, MPI_COMM_WORLD, request_xn_e, INFO) + CALL MPI_ISEND( buf_ps_e , 8*3, MPI_BYTE,& + neighbor(EAST), msgnr+300, MPI_COMM_WORLD, request_ps_e, INFO) + endif + + + if (neighbor(WEST).lt.0) then + do i = 1,1!lj0,lj1 + if(vel(i*(MAXLIMAX+1)+1).lt.0)then + xnbeg(:,2) = 3.*xn_adv(:,i*MAXLIMAX+1) & + -2.*xn_adv(:,i*MAXLIMAX+2) + xnbeg(:,3) = 2.*xn_adv(:,i*MAXLIMAX+1) & + -xn_adv(:,i*MAXLIMAX+2) + + psbeg(2) = 3.*ps3d(i*MAXLIMAX+1)-2.*ps3d(i*MAXLIMAX+2) + psbeg(3) = 2.*ps3d(i*MAXLIMAX+1)-ps3d(i*MAXLIMAX+2) + else + xnbeg(:,1) = xn_adv(:,i*MAXLIMAX) + xnbeg(:,2) = xn_adv(:,i*MAXLIMAX) + xnbeg(:,3) = xn_adv(:,i*MAXLIMAX) + + psbeg(1) = ps3d(i*MAXLIMAX) + psbeg(2) = ps3d(i*MAXLIMAX) + psbeg(3) = ps3d(i*MAXLIMAX) + endif + enddo + else + CALL MPI_RECV( xnbeg, 8*3*NSPEC_ADV, MPI_BYTE, & + neighbor(WEST), msgnr+200, MPI_COMM_WORLD, STATUS, INFO) + CALL MPI_RECV( psbeg, 8*3, MPI_BYTE, & + neighbor(WEST), msgnr+300, MPI_COMM_WORLD, STATUS, INFO) + endif + + if (neighbor(EAST).lt.0) then + do i = 1,1!lj0,lj1 + if(vel(i*(MAXLIMAX+1)+li1).ge.0)then + xnend(:,1) = 2.*xn_adv(:,i*MAXLIMAX+li1-1) & + -xn_adv(:,i*MAXLIMAX+li1-2) + xnend(:,2) = 3.*xn_adv(:,i*MAXLIMAX+li1-1) & + -2.*xn_adv(:,i*MAXLIMAX+li1-2) + + psend(1) = 2.*ps3d(i*MAXLIMAX+li1-1) & + -ps3d(i*MAXLIMAX+li1-2) + psend(2) = 3.*ps3d(i*MAXLIMAX+li1-1) & + -2.*ps3d(i*MAXLIMAX+li1-2) + else + xnend(:,1) = xn_adv(:,i*MAXLIMAX+li1) + xnend(:,2) = xn_adv(:,i*MAXLIMAX+li1) + xnend(:,3) = xn_adv(:,i*MAXLIMAX+li1) + + psend(1) = ps3d(i*MAXLIMAX+li1) + psend(2) = ps3d(i*MAXLIMAX+li1) + psend(3) = ps3d(i*MAXLIMAX+li1) + endif + enddo + else + CALL MPI_RECV( xnend, 8*3*NSPEC_ADV, MPI_BYTE, & + neighbor(EAST), msgnr, MPI_COMM_WORLD, STATUS, INFO) + CALL MPI_RECV( psend, 8*3, MPI_BYTE, & + neighbor(EAST), msgnr+100, MPI_COMM_WORLD, STATUS, INFO) + endif + + ! synchronizing sent buffers (must be done for all ISENDs!!!) + if (neighbor(WEST) .ge. 0) then + CALL MPI_WAIT(request_xn_w, STATUS, INFO) + CALL MPI_WAIT(request_ps_w, STATUS, INFO) + endif + if (neighbor(EAST) .ge. 0) then + CALL MPI_WAIT(request_xn_e, STATUS, INFO) + CALL MPI_WAIT(request_ps_e, STATUS, INFO) + endif + end subroutine preadvx2 + + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine preadvy(msgnr & + ,xn_adv,ps3d,vel & + ,xnbeg, xnend & + ,psbeg, psend) + + use Par_ml , only : li0,li1,lj0,lj1,ljmax & + ,neighbor,NORTH,SOUTH + use GenSpec_adv_ml , only : NSPEC_ADV + implicit none + +! input + integer,intent(in):: msgnr + real,intent(in):: xn_adv(NSPEC_ADV,MAXLIMAX*MAXLJMAX) + real,intent(in):: ps3d(MAXLIMAX*MAXLJMAX) & + ,vel(MAXLIMAX*(MAXLJMAX+1)) + +! output + real,intent(out):: xnend(NSPEC_ADV,3,MAXLIMAX) & + , xnbeg(NSPEC_ADV,3,MAXLIMAX) + real,intent(out):: psend(3,MAXLIMAX) & + , psbeg(3,MAXLIMAX) + +! local + integer i, info + + integer request1, request2, & + request_ps_n, request_ps_s, & + request_xn_n, request_xn_s + real buf_xn_n(NSPEC_ADV, 3, MAXLIMAX), & + buf_xn_s(NSPEC_ADV, 3, MAXLIMAX), & + buf_ps_n(3, MAXLIMAX), & + buf_ps_s(3, MAXLIMAX) + +! Initialize arrays holding boundary slices + +! send to SOUTH neighbor if any + + if (neighbor(SOUTH) .ge. 0) then + ! send to SOUTH neighbor if any + do i = li0,li1 + + buf_xn_s(:,1,i) = xn_adv(:,i) + buf_xn_s(:,2,i) = xn_adv(:,i+MAXLIMAX) + buf_xn_s(:,3,i) = xn_adv(:,i+2*MAXLIMAX) + + buf_ps_s(1,i) = ps3d(i) + buf_ps_s(2,i) = ps3d(i+MAXLIMAX) + buf_ps_s(3,i) = ps3d(i+2*MAXLIMAX) + + enddo + + CALL MPI_ISEND( buf_xn_s , 8*3*MAXLIMAX*NSPEC_ADV, MPI_BYTE,& + neighbor(SOUTH), msgnr, MPI_COMM_WORLD, request_xn_s, INFO) + CALL MPI_ISEND( buf_ps_s , 8*3*MAXLIMAX, MPI_BYTE,& + neighbor(SOUTH), msgnr+100, MPI_COMM_WORLD, request_ps_s, INFO) + endif + + if (neighbor(NORTH) .ge. 0) then + do i = li0,li1 + buf_xn_n(:,1,i) = xn_adv(:,i+(lj1-3)*MAXLIMAX) + buf_xn_n(:,2,i) = xn_adv(:,i+(lj1-2)*MAXLIMAX) + buf_xn_n(:,3,i) = xn_adv(:,i+(lj1-1)*MAXLIMAX) + + buf_ps_n(1,i) = ps3d(i+(lj1-3)*MAXLIMAX) + buf_ps_n(2,i) = ps3d(i+(lj1-2)*MAXLIMAX) + buf_ps_n(3,i) = ps3d(i+(lj1-1)*MAXLIMAX) + enddo + CALL MPI_ISEND( buf_xn_n , 8*3*MAXLIMAX*NSPEC_ADV, MPI_BYTE,& + neighbor(NORTH), msgnr, MPI_COMM_WORLD, request_xn_n, INFO) + CALL MPI_ISEND( buf_ps_n , 8*3*MAXLIMAX, MPI_BYTE& + , neighbor(NORTH), msgnr+100, MPI_COMM_WORLD, request_ps_n, INFO) + + endif + +! receive from SOUTH neighbor if any + + if (neighbor(SOUTH).lt.0) then + do i = li0,li1 + if(vel(i+MAXLIMAX).lt.0.and.lj0==2)then + xnbeg(:,3,i) = 2.*xn_adv(:,i+MAXLIMAX) & + -xn_adv(:,i+2*MAXLIMAX) + xnbeg(:,2,i) = 3.*xn_adv(:,i+MAXLIMAX) & + -2.*xn_adv(:,i+2*MAXLIMAX) + xnbeg(:,1,i) = xnbeg(:,2,i) + + psbeg(3,i) = 2.*ps3d(i+MAXLIMAX)-ps3d(i+2*MAXLIMAX) + psbeg(2,i) = 3.*ps3d(i+MAXLIMAX)-2.*ps3d(i+2*MAXLIMAX) + psbeg(1,i) = psbeg(2,i) + else + + xnbeg(:,1,i) = xn_adv(:,i) + xnbeg(:,2,i) = xn_adv(:,i) + xnbeg(:,3,i) = xn_adv(:,i) + + psbeg(1,i) = ps3d(i) + psbeg(2,i) = ps3d(i) + psbeg(3,i) = ps3d(i) + + endif + enddo + else + CALL MPI_RECV( xnbeg, 8*MAXLIMAX*3*NSPEC_ADV, MPI_BYTE,& + neighbor(SOUTH), msgnr, MPI_COMM_WORLD, STATUS, INFO) + CALL MPI_RECV( psbeg, 8*MAXLIMAX*3, MPI_BYTE,& + neighbor(SOUTH), msgnr+100, MPI_COMM_WORLD, STATUS, INFO) + endif + + if (neighbor(NORTH).lt.0) then + do i = li0,li1 + + if(vel(i+lj1*MAXLIMAX).ge.0.and.ljmax/=lj1)then + xnend(:,1,i) = 2.*xn_adv(:,i+(lj1-1)*MAXLIMAX) & + -xn_adv(:,i+(lj1-2)*MAXLIMAX) + xnend(:,2,i) = 3.*xn_adv(:,i+(lj1-1)*MAXLIMAX) & + -2.*xn_adv(:,i+(lj1-2)*MAXLIMAX) + xnend(:,3,i) = xnend(:,2,i) + + psend(1,i) = 2.*ps3d(i+(lj1-1)*MAXLIMAX) & + -ps3d(i+(lj1-2)*MAXLIMAX) + psend(2,i) = 3.*ps3d(i+(lj1-1)*MAXLIMAX) & + -2.*ps3d(i+(lj1-2)*MAXLIMAX) + psend(3,i) = psend(2,i) + + else + xnend(:,1,i) = xn_adv(:,i+(ljmax-1)*MAXLIMAX) + xnend(:,2,i) = xn_adv(:,i+(ljmax-1)*MAXLIMAX) + xnend(:,3,i) = xn_adv(:,i+(ljmax-1)*MAXLIMAX) + + psend(1,i) = ps3d(i+(ljmax-1)*MAXLIMAX) + psend(2,i) = ps3d(i+(ljmax-1)*MAXLIMAX) + psend(3,i) = ps3d(i+(ljmax-1)*MAXLIMAX) + endif + enddo + else + CALL MPI_RECV( xnend, 8*MAXLIMAX*3*NSPEC_ADV, MPI_BYTE,& + neighbor(NORTH), msgnr, MPI_COMM_WORLD, STATUS, INFO) + CALL MPI_RECV( psend, 8*MAXLIMAX*3, MPI_BYTE,& + neighbor(NORTH), msgnr+100, MPI_COMM_WORLD, STATUS, INFO) + endif + +! synchronizing sent buffers (must be done for all ISENDs!!!) + if (neighbor(SOUTH) .ge. 0) then + CALL MPI_WAIT(request_xn_s, STATUS, INFO) + CALL MPI_WAIT(request_ps_s, STATUS, INFO) + endif + if (neighbor(NORTH) .ge. 0) then + CALL MPI_WAIT(request_xn_n, STATUS, INFO) + CALL MPI_WAIT(request_ps_n, STATUS, INFO) + endif + + end subroutine preadvy + + subroutine preadvy2(msgnr & + ,xn_adv,ps3d,vel & + ,xnbeg, xnend & + ,psbeg, psend,i_send) + + use Par_ml , only : li0,li1,lj0,lj1,ljmax & + ,neighbor,NORTH,SOUTH + use GenSpec_adv_ml , only : NSPEC_ADV + implicit none + +! input + integer,intent(in):: msgnr,i_send + real,intent(in):: xn_adv(NSPEC_ADV,MAXLIMAX*MAXLJMAX) + real,intent(in):: ps3d(MAXLIMAX*MAXLJMAX) & + ,vel(MAXLIMAX*(MAXLJMAX+1)) + +! output + real,intent(out):: xnend(NSPEC_ADV,3) & + , xnbeg(NSPEC_ADV,3) + real,intent(out):: psend(3) & + , psbeg(3) + +! local + integer i, info + + integer request1, request2, & + request_ps_n, request_ps_s, & + request_xn_n, request_xn_s + real buf_xn_n(NSPEC_ADV, 3), & + buf_xn_s(NSPEC_ADV, 3), & + buf_ps_n(3), & + buf_ps_s(3) + +! Initialize arrays holding boundary slices + +! send to SOUTH neighbor if any + + if (neighbor(SOUTH) .ge. 0) then + ! send to SOUTH neighbor if any + do i = i_send,i_send + + buf_xn_s(:,1) = xn_adv(:,i) + buf_xn_s(:,2) = xn_adv(:,i+MAXLIMAX) + buf_xn_s(:,3) = xn_adv(:,i+2*MAXLIMAX) + + buf_ps_s(1) = ps3d(i) + buf_ps_s(2) = ps3d(i+MAXLIMAX) + buf_ps_s(3) = ps3d(i+2*MAXLIMAX) + + enddo + + CALL MPI_ISEND( buf_xn_s , 8*3*NSPEC_ADV, MPI_BYTE,& + neighbor(SOUTH), msgnr, MPI_COMM_WORLD, request_xn_s, INFO) + CALL MPI_ISEND( buf_ps_s , 8*3, MPI_BYTE,& + neighbor(SOUTH), msgnr+100, MPI_COMM_WORLD, request_ps_s, INFO) + endif + + if (neighbor(NORTH) .ge. 0) then + do i = i_send,i_send + buf_xn_n(:,1) = xn_adv(:,i+(lj1-3)*MAXLIMAX) + buf_xn_n(:,2) = xn_adv(:,i+(lj1-2)*MAXLIMAX) + buf_xn_n(:,3) = xn_adv(:,i+(lj1-1)*MAXLIMAX) + + buf_ps_n(1) = ps3d(i+(lj1-3)*MAXLIMAX) + buf_ps_n(2) = ps3d(i+(lj1-2)*MAXLIMAX) + buf_ps_n(3) = ps3d(i+(lj1-1)*MAXLIMAX) + enddo + CALL MPI_ISEND( buf_xn_n , 8*3*NSPEC_ADV, MPI_BYTE,& + neighbor(NORTH), msgnr, MPI_COMM_WORLD, request_xn_n, INFO) + CALL MPI_ISEND( buf_ps_n , 8*3, MPI_BYTE,& + neighbor(NORTH), msgnr+100, MPI_COMM_WORLD, request_ps_n, INFO) + + endif + +! receive from SOUTH neighbor if any + + if (neighbor(SOUTH).lt.0) then + do i = i_send,i_send + if(vel(i+MAXLIMAX).lt.0.and.lj0==2)then + xnbeg(:,2) = 3.*xn_adv(:,i+MAXLIMAX) & + -2.*xn_adv(:,i+2*MAXLIMAX) + xnbeg(:,3) = 2.*xn_adv(:,i+MAXLIMAX) & + -xn_adv(:,i+2*MAXLIMAX) + xnbeg(:,1) = xnbeg(:,2) + + psbeg(2) = 3.*ps3d(i+MAXLIMAX)-2.*ps3d(i+2*MAXLIMAX) + psbeg(3) = 2.*ps3d(i+MAXLIMAX)-ps3d(i+2*MAXLIMAX) + psbeg(1) = psbeg(2) + else + + xnbeg(:,1) = xn_adv(:,i) + xnbeg(:,2) = xnbeg(:,1) + xnbeg(:,3) = xnbeg(:,1) + + psbeg(1) = ps3d(i) + psbeg(2) = psbeg(1) + psbeg(3) = psbeg(1) + + endif + enddo + else + CALL MPI_RECV( xnbeg, 8*3*NSPEC_ADV, MPI_BYTE,& + neighbor(SOUTH), msgnr, MPI_COMM_WORLD, STATUS, INFO) + CALL MPI_RECV( psbeg, 8*3, MPI_BYTE,& + neighbor(SOUTH), msgnr+100, MPI_COMM_WORLD, STATUS, INFO) + endif + + if (neighbor(NORTH).lt.0) then + do i = i_send,i_send + + if(vel(i+lj1*MAXLIMAX).ge.0.and.ljmax/=lj1)then + xnend(:,1) = 2.*xn_adv(:,i+(lj1-1)*MAXLIMAX) & + -xn_adv(:,i+(lj1-2)*MAXLIMAX) + xnend(:,2) = 3.*xn_adv(:,i+(lj1-1)*MAXLIMAX) & + -2.*xn_adv(:,i+(lj1-2)*MAXLIMAX) + xnend(:,3) = xnend(:,2) + + psend(1) = 2.*ps3d(i+(lj1-1)*MAXLIMAX) & + -ps3d(i+(lj1-2)*MAXLIMAX) + psend(2) = 3.*ps3d(i+(lj1-1)*MAXLIMAX) & + -2.*ps3d(i+(lj1-2)*MAXLIMAX) + psend(3) = psend(2) + else + xnend(:,1) = xn_adv(:,i+(ljmax-1)*MAXLIMAX) + xnend(:,2) = xnend(:,1) + xnend(:,3) = xnend(:,1) + + psend(1) = ps3d(i+(ljmax-1)*MAXLIMAX) + psend(2) = psend(1) + psend(3) = psend(1) + + endif + enddo + else + CALL MPI_RECV( xnend, 8*3*NSPEC_ADV, MPI_BYTE,& + neighbor(NORTH), msgnr, MPI_COMM_WORLD, STATUS, INFO) + CALL MPI_RECV( psend, 8*3, MPI_BYTE& + , neighbor(NORTH), msgnr+100, MPI_COMM_WORLD, STATUS, INFO) + endif + +! synchronizing sent buffers (must be done for all ISENDs!!!) + if (neighbor(SOUTH) .ge. 0) then + CALL MPI_WAIT(request_xn_s, STATUS, INFO) + CALL MPI_WAIT(request_ps_s, STATUS, INFO) + endif + if (neighbor(NORTH) .ge. 0) then + CALL MPI_WAIT(request_xn_n, STATUS, INFO) + CALL MPI_WAIT(request_ps_n, STATUS, INFO) + endif + + end subroutine preadvy2 + + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine adv_var(numt) + integer,intent(in):: numt + +! local + + integer i,j,k,info,nr + real dhskmax,sdotmax,sdotmin + real sdotmaxk,sdotmink + real ulmin,ulmax,vlmin,vlmax + integer request_s,request_n,request_e,request_w + real buf_uw(MAXLJMAX,KMAX_MID) + real buf_ue(MAXLJMAX,KMAX_MID) + real buf_vn(MAXLIMAX,KMAX_MID) + real buf_vs(MAXLIMAX,KMAX_MID) + + nr = 2 + if (numt.eq.1) nr = 1 + +! send to WEST neighbor if any + + if (neighbor(WEST) .ne. NOPROC) then + if(neighbor(WEST) .ne. me)then + do k = 1,KMAX_MID + do j = 1,ljmax + buf_uw(j,k) = u(1,j,k,nr) + enddo + enddo + CALL MPI_ISEND(buf_uw(1,1), 8*MAXLJMAX*KMAX_MID, MPI_BYTE, neighbor(WEST),& + MSG_EAST2,MPI_COMM_WORLD, request_w, INFO) + + else + !cyclic grid: own neighbor + do k = 1,KMAX_MID + do j = 1,ljmax + ue(j,k,nr) = u(1,j,k,nr) + enddo + enddo + endif + endif + +! send to EAST neighbor if any + + if (neighbor(EAST) .ne. NOPROC) then + if (neighbor(EAST) .ne. me) then + do k = 1,KMAX_MID + do j = 1,ljmax + buf_ue(j,k) = u(limax-1,j,k,nr) + enddo + enddo + CALL MPI_ISEND(buf_ue(1,1), 8*MAXLJMAX*KMAX_MID, MPI_BYTE, neighbor(EAST),& + MSG_WEST2,MPI_COMM_WORLD, request_e, INFO) + else + !cyclic grid: own neighbor + do k = 1,KMAX_MID + do j = 1,ljmax + uw(j,k,nr) = u(limax-1,j,k,nr) + enddo + enddo + endif + endif +! send to SOUTH neighbor if any + + if (neighbor(SOUTH) .ne. NOPROC) then + do k = 1,KMAX_MID + do i = 1,limax + buf_vs(i,k) = v(i,1,k,nr) + enddo + enddo + CALL MPI_ISEND(buf_vs(1,1), 8*MAXLIMAX*KMAX_MID, MPI_BYTE, neighbor(SOUTH),& + MSG_NORTH2,MPI_COMM_WORLD, request_s, INFO) + endif + +! send to NORTH neighbor if any + + if (neighbor(NORTH) .ne. NOPROC) then + do k = 1,KMAX_MID + do i = 1,limax + buf_vn(i,k) = v(i,ljmax-1,k,nr) + enddo + enddo + CALL MPI_ISEND(buf_vn(1,1), 8*MAXLIMAX*KMAX_MID, MPI_BYTE, neighbor(NORTH),& + MSG_SOUTH2,MPI_COMM_WORLD, request_n, INFO) + endif + +! receive from EAST neighbor if any + + if (neighbor(EAST) .ne. NOPROC .and. neighbor(EAST) .ne.me ) then + CALL MPI_RECV(ue(1,1,nr), 8*MAXLJMAX*KMAX_MID, MPI_BYTE, neighbor(EAST), MSG_EAST2,& + MPI_COMM_WORLD, STATUS, INFO) + endif + +! receive from WEST neighbor if any + + if (neighbor(WEST) .ne. NOPROC .and. neighbor(WEST) .ne. me) then + CALL MPI_RECV(uw(1,1,nr), 8*MAXLJMAX*KMAX_MID, MPI_BYTE, neighbor(WEST), MSG_WEST2,& + MPI_COMM_WORLD, STATUS, INFO) + endif + +! receive from NORTH neighbor if any + + if (neighbor(NORTH) .ne. NOPROC) then + CALL MPI_RECV(vn(1,1,nr), 8*MAXLIMAX*KMAX_MID, MPI_BYTE, neighbor(NORTH), MSG_NORTH2,& + MPI_COMM_WORLD, STATUS, INFO) + endif + +! receive from SOUTH neighbor if any + + if (neighbor(SOUTH) .ne. NOPROC) then + CALL MPI_RECV(vs(1,1,nr), 8*MAXLIMAX*KMAX_MID, MPI_BYTE, neighbor(SOUTH), MSG_SOUTH2,& + MPI_COMM_WORLD, STATUS, INFO) + endif + if (neighbor(EAST) .ne. NOPROC .and. neighbor(EAST) .ne.me ) then + CALL MPI_WAIT(request_e, STATUS, INFO) + endif + + if (neighbor(WEST) .ne. NOPROC .and. neighbor(WEST) .ne. me) then + CALL MPI_WAIT(request_w, STATUS, INFO) + endif + + if (neighbor(NORTH) .ne. NOPROC) then + CALL MPI_WAIT(request_n, STATUS, INFO) + endif + + if (neighbor(SOUTH) .ne. NOPROC) then + CALL MPI_WAIT(request_s, STATUS, INFO) + endif + + + return + + + end subroutine adv_var + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine adv_int + implicit none + + real div + + if (nstep.lt.nmax) then + div = 1./real(nmax-(nstep-1)) + ue(:,:,1) = ue(:,:,1) + (ue(:,:,2) - ue(:,:,1))*div + uw(:,:,1) = uw(:,:,1) + (uw(:,:,2) - uw(:,:,1))*div + vs(:,:,1) = vs(:,:,1) + (vs(:,:,2) - vs(:,:,1))*div + vn(:,:,1) = vn(:,:,1) + (vn(:,:,2) - vn(:,:,1))*div + + else + + ue(:,:,1) = ue(:,:,2) + uw(:,:,1) = uw(:,:,2) + vs(:,:,1) = vs(:,:,2) + vn(:,:,1) = vn(:,:,2) + + endif + + end subroutine adv_int + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end module Advection_ml diff --git a/Aero_Rb_ml.f90 b/Aero_Rb_ml.f90 new file mode 100644 index 0000000..dc5715c --- /dev/null +++ b/Aero_Rb_ml.f90 @@ -0,0 +1,210 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Aero_DryDep_ml +!============================================================================== + + ! DESCRIPTION + ! Calculates laminar sub-layer resistance (rb) and gravitational settling + ! velocity (vs) for particles + ! Finally: vd= vs+1/(ra+rb+ra*rb*vs), where + ! vs - gravitational settling velocity, + ! ra - aerodynamic resistance, rb - viscous sub-layer resistance, + ! rc - surface resistance (assumed zero for particles) + !--------------------------------------------------------------------------- + use My_Aerosols_ml, only : NSIZE + use LandDefs_ml, only: LandType + use PhysicalConstants_ml , only : PI, GRAV, KARMAN, VISCO, BOLTZMANN, FREEPATH + + implicit none + private + + public :: Aero_Rb + +contains + + ! =========================================================== + subroutine Aero_Rb (ustar, conv, roa, v50, lu, & ! IN + snow, wetarea, tsK, & ! IN + vs, rb, rbw) ! OUT + + !------------------------------------------------------------------- + ! Calculates size dependent laminar layer resistance and gravitation + ! settling for particles (presently only for (1)PM2.5 and (2)PM10 ) + ! rb - over dry surface (bounce-off for coarse PM) + ! rbw - over wet surface (rain last 3 hours) + !----------------------------------------------------------- ------ + +! parameter (VISCO=1.46e-5, BOLTZ=1.381e-23 & +! ,FREEPATH=0.065e-6, DENSPART=2.2e3 ) + + integer, intent(in) :: lu, snow + real, intent(in) :: ustar, conv, roa, v50, tsK + real, intent(in) :: wetarea + real, intent(out) :: vs(NSIZE), rb(NSIZE) & ! over dry surface + , rbw(NSIZE) ! over wet surface + + !== local + real, parameter, dimension(NSIZE) :: & + diam = (/ 0.3e-6, 4.0e-6 /) & + , sigma = (/ 1.8, 2.0 /) & + , PMdens = (/ 1600., 2200. /) + real, parameter :: AHAT = 1.e-3 !! charact. "radius" of grass blades, needlies etc. + integer :: imod + real :: stdlog,sig, dg, knut,slip, & + Di1,Di, vind, & + stoke, schmidt, & ! Stoke's and Schmidt numbers + vsmo, vs1, & ! Settling velocity + coleff, reb, convfac + + real, save :: log10 + logical, save :: my_first_call = .true. + + if ( my_first_call ) then + log10 = log(10.0) !ds + my_first_call = .false. + end if + +!================================================ + + MODEloop: do imod = 1, NSIZE + + stdlog = log(sigma(imod)) + sig = stdlog * stdlog ! (log(STD))^2 + +!... mass median diameter -> geometric diameter + + dg = exp (log(diam(imod)) - 3.* sig ) + + knut = 2.*FREEPATH/dg ! Knut's number +!... slip correction coefficient +! slipmo= 1.+ knut* & ! for monodisperse +! (1.257+0.4*exp(-1.1* /knut)) + slip = 1.+ 1.246*knut ! for polydisperse + +!== monodisperse aerosols ===== +! Dimo =BOLTZMANN*tsK*slipmo/(3*PI*dg *VISCO*roa) ! diffusion coefficient +! vsmo =dg*dg *PMdens(imod) *GRAV*slipmo/(18.*VISCO*roa) ! gravitational settling + +!== polydisperse aerosols (log-normal size distribution) ===== + Di1 =BOLTZMANN*tsK/(3*PI*dg *VISCO *roa) + Di = Di1*(exp(-2.5*sig)+1.246*knut*exp(-4.*sig)) ! diffusion coefficient + + vs1=dg*dg * PMdens(imod)*GRAV/18./VISCO/roa + vs(imod) = vs1*(exp(8.*sig)+1.246*knut*exp(3.5*sig)) ! gravitational settling + +! ------------------------------------------------------------------- + +!// Stokes and Schmidt numbers: + + ! == monodisperse ====== + ! STmo=vsmo*ustar*ustar/VISCO/GRAV + ! SCmo=VISCO/dimo + ! == polydisperse ====== + schmidt = VISCO/Di ! Schmidt number + stoke = vs(imod)*ustar*ustar/VISCO/GRAV ! Stoke number(based on depth + ! of laminar layer) + + !// collection efficiency ======================= + ! coleff=1./sc**(2./3.) + 1./10.**(3/stoke) + !================================================= + + vind = max( 0.005, v50 ) ! wind at 50m height + + + + if( LandType(lu)%is_water ) then !//=== WATER surface ( Slinn & Slinn, 1980 ) = + + coleff= ustar / (KARMAN * vind) * & ! polydisperse + (exp(-0.5*log(schmidt)) + exp(-3./stoke*log10) ) + + elseif ( LandType(lu)%is_conif ) then !//=== CONIFEROUS ============== + + stoke = vs(imod)*ustar/(AHAT*GRAV) ! vegetation (Slinn, 1982) + coleff= exp(-2./3.*log(schmidt)) + stoke/(1.+ stoke*stoke) ! Slinn + + elseif ( LandType(lu)%is_veg ) then !//=== other VEGETATIVE surfaces ====== + + if ( snow > 0 .or. tsK <= 273.) then !... covered with snow or frozen + + coleff= exp(-2./3.*log(schmidt)) + exp(-3./stoke*log10) ! polydisperse + + else !... snowfree + + stoke = vs(imod)*ustar/(AHAT*GRAV) ! Stoke for vegetation (Slinn, 1982) + coleff= exp(-2./3.*log(schmidt)) + stoke/(1.+ stoke*stoke) ! Slinn + endif + + else !//==== urban/desert/ice always =============================== + !.. Slinn at al(1978), Seinfeld(1997), Binkowski + + coleff= exp(-2./3.*log(schmidt)) + exp(-3./stoke*log10) ! polydisperse + + endif + +! .. laminar layer resistance ..................................... + ! rb= 1./ustar/colef ! Seinfeld + ! rb= 0.4*vind/(ustar*ustar*colef) ! Slinn + +!// == bounce-off for coarse particles (Slinn, 1982) =============== + !... for fine aerosol + + reb = 1. + + !... for coarse aerosol + + if(imod == NSIZE ) then + + if( .not. (LandType(lu)%is_water .and. wetarea == 0.0)) & ! not on water/wet surface + + reb = max (1.e-7, exp(-2. * sqrt(stoke))) + endif + +!//== enhanced dry.dep under convective conditions (Wesely at al,1985) ==== + + convfac = 0. + +! only for (low) vegetation + + if (LandType(lu)%is_veg .and. snow == 0) convfac = conv + +!// == sub-laminar layer resistance ==================== + + rb (imod) = 1. /(ustar*(1.+ 0.24 *convfac)) /(coleff*reb) + rbw (imod) = 1. /(ustar*(1.+ 0.24 *convfac)) /coleff ! no bounce-off on + ! wet surfaces + +!..monodisperse: rb1= 1./(ustar*(1. + 0.24 * conv))/(colef1*reb) + + end do MODEloop + + end subroutine Aero_Rb +! ================================================================= + +end module Aero_DryDep_ml + diff --git a/Aero_water_ml.f90 b/Aero_water_ml.f90 new file mode 100644 index 0000000..25c29c6 --- /dev/null +++ b/Aero_water_ml.f90 @@ -0,0 +1,372 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Aero_water_ml + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! DESCRIPTION +! +! Purpose : Calculates aerosols' liquid water content +! +! Subroutine: Awater +! Input: - relative humidity: relh +! - number of micromoles/(m^3 of air) for sulfate, +! ammonium, and nitrate: mso4, mnh4, mno3 +! Output: - water amount in micrograms/(m^3 of air): wh2o +! +! Author : Dr. Francis S. Binkowski, 4/8/96 +! : modified slightly for EMEP model +! +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + implicit none + private + +! subroutines: + public :: Awater + +! functions + private :: poly4, poly6 + + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + +! coefficients for polynomials (function poly4) to be defined +! at start of routine: + +! Define saved variables: + real, private,parameter, dimension(4) :: & !(for x = 0, 1, 1.5 and 2) + C0 = (/ 0.798079, -1.574367, 2.536686, -1.735297 /),& + C1 = (/ 0.9995178, -0.7952896, 0.99683673, -1.143874 /),& + C15= (/ 1.697092, -4.045936, 5.833688, -3.463783 /),& + C2 = (/ 2.085067, -6.024139, 8.967967, -5.002934 /) + + real, private,parameter, dimension(6) :: & + KNO3 = (/ 0.2906, 6.83665, -26.9093, 46.6983, -38.803, 11.8837/),& + KSO4 = (/ 2.27515, -11.147, 36.3369, -64.2134, 56.8341 ,-20.0953/) + + ! Set molecular weights: + + real, private, parameter :: & + MWSO4 = 96.0 & + ,MWNH4 = 18.0 & + ,MWNO3 = 62.0 & + ,MW2 = MWSO4 + 2.0 * MWNH4 & + ,MWANO3 = MWNO3 + MWNH4 + + + contains + + subroutine Awater(relh,mso4,mnh4,mno3,wh2o) + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! This routine uses polynomials rather than tables, and uses empirical +! polynomials for the mass fraction of solute (mfs) as a function of +! water activity where: +! +! mfs = ms / ( ms + mw) +! ms - the mass of solute +! mw - the mass of water +! +! Define y = mw / ms +! +! then mfs = 1 / (1 + y) +! +! y can then be obtained from the values of mfs as +! +! y = (1 - mfs) / mfs +! +! The aerosol is assumed to be in a metastable state if the relative +! humidity (rh) is is below the rh of deliquescence, but above the +! rh of crystallization. +! +! The Zdanovskii-Stokes-Robinson relation ('ZSR') is used for sulfates +! with x (molar ratio of ammonium to sulfate) in the range 0 <= x <= 2, +! subdivided into four sections: +! +! section 1: 0 <= x < 1 +! section 2: 1 <= x < 1.5 +! section 3: 1.5 <= x < 2.0 +! section 4: 2 <= x +! +! In sections 1 through 3 only the sulfates can affect the amount +! of water on the particles. In section 4 we have fully neutralized +! sulfate, and extra ammonium which allows more nitrate to be present. +! Thus, the ammount of water is calculated using ZSR for ammonium +! sulfate and ammonium nitrate. Crystallization is assumed to occur +! in sections 2, 3, and 4 (see detailed discussion below). +! +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! Description of variables used in the routine: +! +! +! mso4, mnh4, and mno3 : number of micromoles/(cubic meter of air) for +! sulfate, ammonium, and nitrate, respectively +! relh : relative humidity (%) +! wh2o : returned water amount in micrograms /(cubic meter of air) +! x : molar ratio of ammonium to sulfate +! y0, y1, y15, y2 : water contents in mass of water/mass of solute +! for pure aqueous solutions with x equal to 0, 1, +! 1.5, and 2, respectively +! y3 : the value of the mass ratio of water to solute for a pure +! ammonium nitrate solution. +! +! +! C1, C15, C2: (defined at start of routine!) +! The polynomials use data for relh as a function of mfs from Tang +! and Munkelwitz, JGR. 99: 18801-18808, 1994. +! The polynomials were fit to Tang's values of water activity as a +! function of mfs. +! C1, C15, C2 are the coefficients of polynomials fit to Tang and +! Munkelwitz data giving mfs as a function of water activity. +! +! C0: (defined at start of routine!) +! fit to data from +! Nair and Vohra J. Aerosol Sci., 6: 265-271, 1975 +! Giaque et al. J. Am. Chem. Soc., 82: 62-70, 1960 +! Zeleznik J. Phys. Chem. ref. data, 20: 157-1200 +! +! KNO3, KSO4: (defined at start of routine!) +! The polynomials for ammonium nitrate and ammonium sulfate are from: +! Chan et al.1992, atmospheric environment (26a): 1661-1673. +! +! +! tso4, tnh4, tno3: mole concentrations used in the calculations +! ( tso4 = max(mso4,0.), tnh4 = max(mnh4,0.), tno3 = max(mno3,0.) ) +! +! aw : relative humidity used in the calculations (.01 0.) then + x = tnh4 / tso4 + else +! ... otherwise check for non-zero nitrate and ammonium + if (tno3 > 0. .and. tnh4 > 0.) x = 10. + end if + +! Begin screen on x for calculating wh2o: + if ( x < 1. ) then + + mfs0 = poly4(C0,aw) + mfs1 = poly4(C1,aw) + y0 = ( 1. - mfs0 ) / mfs0 + y1 = ( 1. - mfs1 ) / mfs1 + y = ( 1. - x ) * y0 + x * y1 + + else if ( x < 1.5) then + + if ( aw >= 0.40 ) then + + mfs1 = poly4(C1,aw) + mfs15 = poly4(C15,aw) + y1 = (1. - mfs1 ) / mfs1 + y15 = (1. - mfs15) / mfs15 + y = 2. * ( y1 * (1.5 - x) + y15 *( x - 1.) ) + + else + +! Setup for crystalization: + +! Crystallization is done as follows: +! +! for 1.5 <= x : crystallization is assumed to occur at rh = 0.4 +! for x <= 1.0 : crystallization is assumed to occur at an rh < 0.01 +! +! and since the code does not allow rh < 0.01, crystallization is +! assumed not to occur in this range. +! +! for 1.0 <= x <= 1.5 : the crystallization curve is a straight line +! from a value of y15 at rh = 0.4 to a value of +! zero at y1. From point b to point a in the +! diagram the algorithm does a double inter- +! polation to calculate the amount of water. +! +! y1(0.40) y15(0.40) +! + + point b +! +! +! +! +---------------------+ +! x=1 x=1.5 +! point a +! + + awc = 0.80 * (x - 1.0) ! rh along the crystallization curve. + + y = 0.0 + u=0.40 + + if ( aw >= awc ) then + +! Interpolate using crystalization curve: + + mfs1 = poly4(C1,u) + mfs15 = poly4(C15,u) + y140 = (1.0 - mfs1 ) / mfs1 + y1540 = (1.0 - mfs15) / mfs15 + y40 = 2.0 * ( y140 * (1.5 - x) + y1540 *( x - 1.0) ) + yc = 2.0 * y1540 * (x -1.0) ! y along crystallization curve + y = y40 - (y40 - yc) * (u - aw) / (u - awc) + + end if ! end of "if ( aw >= awc ) then" + + end if ! end of "if ( aw >= 0.40 ) then" + + else if ( x < 1.9999) then + + y= 0.0 + + if (aw >= 0.40) then + mfs15 = poly4(C15,aw) + mfs2 = poly4(C2,aw) + y15 = (1.0 - mfs15) / mfs15 + y2 = (1.0 - mfs2) / mfs2 + y = 2.0 * (y15 * (2.0 - x) + y2 * (x - 1.5) ) + end if ! end of check for crystallization + + else + +! i.e. x >= 1.9999 +! +! Regime where ammonium sulfate and ammonium nitrate are in solution! +! +! Following cf&s for both ammonium sulfate and ammonium nitrate +! Check for crystallization here. Their data indicate a 40% value +! is appropriate. + + y2 = 0.0 + y3 = 0.0 + + if (aw >= 0.40) then + mfsso4 = poly6(KSO4,aw) + mfsno3 = poly6(KNO3,aw) + y2 = (1.0 - mfsso4) / mfsso4 + y3 = (1.0 - mfsno3) / mfsno3 + end if + + end if ! end of 'if ( x < 1. ) then' + +! Now set up output of wh2o +! +! wh2o units are micrograms(liquid water) / (cubic meter of air) + + if ( x < 1.9999) then + + wh2o = y * (tso4 * MWSO4 + tnh4 * MWNH4 ) + + else + +! This is the case when all the sulfate is ammonium sulfate +! and the excess ammonium forms ammonum nitrate + + wh2o = y2 * tso4 * MW2 + y3 * tno3 * MWANO3 + + end if + + + end subroutine Awater + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + real function poly4 (a,x) + +! Calculates the polynomial based on 4 coefficients a(1:4): + +!-- arguments + real, dimension(4), intent(in) :: a + real, intent(in) :: x + + poly4 = a(1) + x * ( a(2) + x * ( a(3) + x * ( a(4) ) ) ) + + end function poly4 + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + real function poly6(a,x) + +! Calculates the polynomial based on 6 coefficients a(1:6): + +!-- arguments + real, dimension(6), intent(in) :: a + real, intent(in) :: x + + poly6 = a(1) + x * ( a(2) + x * ( a(3) + x * ( a(4) + & + x * ( a(5) + x * (a(6) ) ) ) ) ) + + end function poly6 + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC + + end module Aero_water_ml + diff --git a/AirEmis_ml.f90 b/AirEmis_ml.f90 new file mode 100644 index 0000000..04dbdff --- /dev/null +++ b/AirEmis_ml.f90 @@ -0,0 +1,520 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 AirEmis_ml + ! NOx Emissions from Aircraft and Lightning. + ! ANCAT emissions converted from Kg/month/gridcell to flux + ! in molecules cm-3 s-1 on ANCAT grid (2.8 X 2.8 degree). + ! Emissions on (finer) model grid then assigned from the ANCAT grid where + ! model grid falls within. Note that aircraft emissions is given on a t42 + ! and lightning on t21. + ! + ! Ref: Gardner et.al., 1997, The ANCAT/EC global inventory of NOx emission + ! from aircraft, Atm. Environ., 31(12), 1751-1766. + ! + ! + ! Variable listing is given below + ! + ! + use Par_ml , only : MAXLIMAX, MAXLJMAX, limax,ljmax, me + use ModelConstants_ml , only : KCHEMTOP, KMAX_MID, KMAX_BND, NPROC + use Io_ml , only : IO_AIRN, IO_LIGHT, ios, open_file + use GridValues_ml , only : gl,gb, GRIDWIDTH_M + use PhysicalConstants_ml , only : AVOG + use Met_ml , only : z_bnd + use TimeDate_ml, only : current_date + + implicit none + private + + real, public, dimension(KCHEMTOP:KMAX_MID,MAXLIMAX,MAXLJMAX), save :: & + airn & ! aircraft NOx emissions + ,airlig ! lightning NOx emissions + + public :: aircraft_nox !reads in the raw data + public :: lightning + + private :: air_inter !interpolate the data into required grid + + include 'mpif.h' + + integer STATUS(MPI_STATUS_SIZE),INFO + real MPIbuff + integer,private ,parameter :: ILEV=18 + logical, parameter :: MY_DEBUG = .false. + + contains + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine aircraft_nox(newseason) + + +!input + integer,intent(in):: newseason + +!local + integer, parameter :: ILON = 128, IGL = 32, GGL = 64 + real, parameter :: DLON = 4.21875-1.40625,RLON0 = -1.40625 + + integer i, j, k, nlon, ngl, nlev, level,nlevb + real zrmin, zfak, secmonth + +! Definition of the ancat grid ~ t42 : +! Data read in from N --> S and from longitude 0 ( not from +-180 ) + + real, dimension(GGL) :: ygrida ! grid mid. pt. N-S + real, dimension(IGL) :: ygrdum & ! grid mid. pt. N-S + ,area ! grid area N-S + real, dimension(ILON+1) :: rlon ! + + integer, dimension(ILON,GGL) :: intnox ! global emission kg/month/cell + real, dimension(ILON,GGL,-1:ILEV) :: flux ! emission converted to flux + ! molecules/cm3/s + + character*20 fname + + data ygrdum / 87.86379884, 85.09652699, 82.31291295, 79.52560657, & + 76.73689968, 73.94751515, 71.15775201, 68.36775611, & + 65.57760700, 62.78735180, 59.99702011, 57.20663153, & + 54.41619953, 51.62573360, 48.83524097, 46.04472663, & + 43.25419467, 40.46364818, 37.67308960, 34.88252099, & + 32.09194388, 29.30135962, 26.51076933, 23.72017390, & + 20.92957425, 18.13897099, 15.34836476, 12.55775612, & + 9.76714556, 6.97653355, 4.18592053, 1.39530/ + + + data area / 3.4123374E+09, 8.2558925E+09, 1.2956985E+10, & + 1.7624316E+10, 2.2249359E+10, 2.6821497E+10, & + 3.1329966E+10, 3.5764105E+10, 4.0113402E+10, & + 4.4367553E+10, 4.8516461E+10, 5.2550296E+10, & + 5.6459481E+10, 6.0234756E+10, 6.3867154E+10, & + 6.7348070E+10, 7.0669238E+10, 7.3822790E+10, & + 7.6801245E+10, 7.9597535E+10, 8.2205024E+10, & + 8.4617535E+10, 8.6829343E+10, 8.8835195E+10, & + 9.0630349E+10, 9.2210528E+10, 9.3572006E+10, & + 9.4711529E+10, 9.5626412E+10, 9.6314483E+10, & + 9.6774103E+10, 9.7004184E+10/ + + +! ---- Defines the ANCAT grid ---------------------------------------------- +! WARNING!!! This is not the correct t42 grid, but the aircraft +! emissions are defined in this grid +! +!-----Variable listing--------------- +! +!MAXLIMAX ==> Maximum no. of local points in longitude +!MAXLJMAX ==> Maximum no. of local points in latitude +!limax ==> Actual number of local points in longitude +!ljmax ==> Actual number of local points in latitude +!NPROC ==> Total no. of processors for parallel computation +!me ==> Address of processer, host=0 (numbering starts at 0 +! in south-west corner of ground level +!KCHEMTOP ==> Topmost level where chemistry is performed (k=2, chemistry is not done for k=1) +!KMAX_MID ==> Number of levels in vertical (=20) +!KMAX_BND ==> Number of levels in vertical + 1 (=KMAX_MID+1) +!current_date ==> derived type containing date info +!IO_AIRN ==> Input variable for Aircraft_nox emission from input emission file +!IO_LIGHT ==> Input variable for lightning emission from input emission file +!ios ==> I/O error status number +!open_file ==> Checks that file exists and opens if required +!gl ==> Geographical longitude of EMEP grid center +!gb ==> Geographical latitude of EMEP grid center +!GRIDWIDTH_M ==> Width of grid at 60N, in meters +!AVOG ==> Avogadro's No. +!z_bnd ==> Height of full layers +!GGL ==> No. of latitudes (=64 on T42 grid and =32 on T21 grid) +!IGL ==> No. of latitudes in NH (=32 for T42 and =16 for T21. Data read from N to S) +!ILON ==> No. of longitudes (=128 for T42 and =64 for T21) +!DLON ==> Delta longitude +!RLON0 ==> First longitude point +! + + + secmonth = 3600.*24.*31. + flux(:,:,:) = 0. + + + +! --- Open and read ancat data (originally from DLR, EU project POLINAT) +! --- Commercial aircraft emissions every season +! --- Military aircraft emission read in as annual data + + if(me == 0)then + + write(fname,fmt='(''ancat'',i2.2,''.dat'')') newseason + call open_file(IO_AIRN,"r",fname,needed=.true.,skip=1) + if (ios /= 0) WRITE(*,*) 'MPI_ABORT: ', "ioserror: ancat" + if (ios /= 0) call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + + end if ! me == 0 + + + if(me == 0)then + + read(IO_AIRN,'(3i4,2e22.13)') nlon,ngl,nlev,zrmin,zfak + if (MY_DEBUG)write(6,*) nlon,ngl,nlev,zrmin,zfak + do k = 0,NLEV-1 + read(IO_AIRN,'(i2)') level + read(IO_AIRN,'(12i6)') ((intnox(j,i),j=1,nlon),i=1,ngl) + do i = 1,ngl + do j = 1,nlon + flux(j,i,k)=(float(intnox(j,i))*zfak)+zrmin + end do + end do + end do + + close(IO_AIRN) + + call open_file(IO_AIRN,"r","ancatmil.dat",needed=.true.,skip=1) + if (ios /= 0) WRITE(*,*) 'MPI_ABORT: ', "ioserror: ancatmil" + if (ios /= 0) call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + + end if ! me == 0 + + + if(me == 0)then + read(IO_AIRN,'(3i4,2e22.13)') nlon,ngl,nlevb,zrmin,zfak + if (MY_DEBUG) write(6,*) nlon,ngl,nlevb,zrmin,zfak + do k = 1,nlevb + read(IO_AIRN,'(i2)') level + read(IO_AIRN,'(12i6)') ((intnox(j,i),j=1,nlon),i=1,ngl) + do i = 1,ngl + do j = 1,nlon + flux(j,i,k)=flux(j,i,k)+(float(intnox(j,i))*zfak)+zrmin + end do + end do + end do + + close(IO_AIRN) + + endif ! me == 0 + + call air_inter(ILON ,IGL ,GGL ,0 , & + flux ,airn , & + ygrdum ,ygrida ,DLON ,RLON0 , & + rlon ,area ,secmonth ) + + end subroutine aircraft_nox + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine lightning() + + integer, parameter :: ILON = 64, IGL = 16, GGL = 32 + real, parameter :: DLON = 8.4375 - 2.8125, RLON0 = -2.8125 + + integer i, j, k, nlon, ngl, nlev ,level + real zrmin, zfak, secmonth, sumnox + + + +! Definition of the ancat grid ~ t21 : +! Data read in from N --> S and from longitude 0 ( not from +-180 ) +! NB!! note the difference between lightning and aircraft emission grid + + + real, dimension(GGL) :: ygrida ! grid mid. pt. N-S + real, dimension(IGL) :: ygrdum & ! grid mid. pt. N-S + ,area ! grid area N-S + real, dimension(ILON+1) :: rlon ! + + integer, dimension(ILON,GGL) :: intnox ! global emission kg/month/cell + real, dimension(ILON,GGL,-1:ILEV) :: flux ! emission converted to flux + ! molecules/cm3/s + + + character*20 fname + + data ygrdum / 85.76058712, 80.26877907, 74.74454037, & + 69.21297617, 63.67863556, 58.14295405, & + 52.60652603, 47.06964206, 41.53246125, & + 35.99507841, 30.45755396, 24.91992863, & + 19.38223135, 13.84448373, 8.30670286, & + 2.76890301/ + + data area / 268516310010.37, 64778953547.94, 101133318591.76, & + 136519495343.02, 170627187541.37, 203140714921.94, & + 233757180440.66, 262190945894.60, 288176619318.18, & + 311471618334.64, 331858463070.53, 349146817322.73, & + 363175270173.37, 373812845114.06, 380960223957.41, & + 384550674664.23/ + +! ---- Defines the ANCAT grid ---------------------------------------------- + + + + secmonth = 1. + flux(:,:,:) = 0. + +! --- Read Emission data received from DLR + + if(me == 0)then + sumnox = 0. + write(fname,fmt='(''lightn'',i2.2,''.dat'')') & + current_date%month + +! - open and read 1 line of header + + call open_file(IO_LIGHT,"r",fname,needed=.true.,skip=1) + if (ios /= 0 ) WRITE(*,*) 'MPI_ABORT: ', "ioserror: lightning" + if (ios /= 0 ) call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + end if + + if(me == 0)then + read(IO_LIGHT,'(3i4,2e22.13)') nlon,ngl,nlev,zrmin,zfak + if (MY_DEBUG) write(6,*) nlon,ngl,nlev,zrmin,zfak + do k = 1,nlev + read(IO_LIGHT,'(i2)') level + read(IO_LIGHT,'(12i6)') ((intnox(j,i),j=1,nlon),i=1,ngl) + do i = 1,ngl + do j = 1,nlon + flux(j,i,k)=(float(intnox(j,i))*zfak)+zrmin + sumnox = sumnox + flux(j,i,k) + end do + end do + end do + + close(IO_LIGHT) + + write(6,*) 'lightning sum nox in AirEmis',sumnox + + endif + + call air_inter(ILON ,IGL ,GGL ,1 , & + flux ,airlig , & + ygrdum ,ygrida ,DLON ,RLON0 , & + rlon ,area ,secmonth) + + + end subroutine lightning + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine air_inter(ILON ,IGL ,GGL ,iktop , & + flux ,airem , & + ygrdum ,ygrida ,DLON ,RLON0 , & + rlon ,area ,secmonth ) + + + integer, parameter :: KMAX_BND_AIR = 21 + integer, intent(in) :: ILON,IGL,GGL,iktop + real, intent(in) :: area(IGL), ygrdum(IGL),DLON,RLON0,secmonth + + + real, intent(inout) :: flux(ILON,GGL,-1:ILEV) + + real, dimension(KCHEMTOP:KMAX_MID,MAXLIMAX,MAXLJMAX), intent(out) :: airem + real, intent(out) :: ygrida(GGL) + real, intent(out) :: rlon(ILON+1) + + ! local + integer info + integer lon,lat,i,j,ig,jg,kg,k, i_sh + integer la_tst1, la_tst2, lo_tst1, lo_tst2 ! test area for sums + real height, & ! height of the emission levels + atwno2, & ! atomic weight of NO2 + vol ! volume of model grid boxes + real frac, above, below, glij + real sum,sumnox,volcm,sum2 + integer, dimension(MAXLIMAX,MAXLJMAX) :: ixn & ! mapping of emission + ,jxn ! grid to model grid + integer, dimension(KMAX_MID) :: ilevel + real fraca(KMAX_MID), fracb(KMAX_MID) + + + height = 1.e5 + atwno2 = 46. + + ! print out values on a sub-domain for comparison with direct model input + ! NB! due to different resolution the subdomain will be different for + ! aircraft and lightning emissions + + la_tst1 = 7 + la_tst2 = 13 + lo_tst1 = 1 + lo_tst2 = 5 + + if(me == 0)then + sum = 0. + sumnox = 0. + + do k = iktop,ILEV + do lat = la_tst1,la_tst2 + do lon = lo_tst1,lo_tst2 + sum = sum + flux(lon,lat,k) + end do + end do + + do lat=1,GGL + if(lat<=IGL)then + volcm = area(lat)*1.e4*height + else + ! -- area not defined for Southern Hemisphere + volcm = area(GGL-lat+1)*1.e4*height + endif + + do lon=1,ILON + sumnox = sumnox + flux(lon,lat,k) + flux(lon,lat,k)=flux(lon,lat,k)*1.e3*AVOG & + /volcm/secmonth/atwno2 + end do !lon + end do !lat + end do !k + + write(6,*) 'SUMNOX, ANCAT:',sumnox + endif !me=0 + + + CALL MPI_BCAST(flux(1,1,iktop), 8*GGL*ILON*(ILEV+1-iktop), MPI_BYTE, 0,& + MPI_COMM_WORLD, INFO) + + ! -- N/S + ygrida(1) = 90. + ygrida(GGL) = -90. + + do i=2,IGL + i_sh = GGL + 1 - i + ygrida(i) = (ygrdum(i-1)+ygrdum(i))*0.5 + ygrida(i_sh) = - ygrida(i) + enddo + + ! - E/W + rlon(1) = RLON0 + + do i=2,ILON + rlon(i) = rlon(i-1) + DLON + end do + rlon(ILON+1) = rlon(1)+360. + + ! -- Assign gridpoints to the EMEP grid + + + jg = GGL-1 + do j = 1,ljmax + do i = 1,limax + if(abs(gb(i,j)-90.0)<0.001) then + ixn(i,j) = 1 + jxn(i,j) = 1 + else + + do while(gb(i,j)=ygrida(jg)) + jg = jg-1 + enddo + + jxn(i,j) = jg + glij = gl(i,j) + if(glij<=rlon(1)) glij = glij+360. + ig = int((glij-rlon(1))/DLON)+1 + if(ig>ILON) ig=ig-ILON + ixn(i,j) = ig + end if + end do !i + end do !j + + + do j = 1,ljmax + do i = 1,limax + + kg = 1 + above = 1.e3 + below = 0. + + do k = KMAX_MID,KCHEMTOP,-1 + + do while(z_bnd(i,j,k+1)>below+1.e3) + below = below+1.e3 + end do + + do while (z_bnd(i,j,k)>above) + kg = kg+1 + above = above+1.e3 + end do + + ilevel(k) = kg + fraca(k) = 1. + if(above-below>1.1e3) & + fraca(k) = (z_bnd(i,j,k)-(above-1.e3)) & + /(z_bnd(i,j,k) - z_bnd(i,j,k+1)) + fracb(k) = 0. + if(above-below>2.1e3) & + fracb(k) = (below+1.e3 - z_bnd(i,j,k+1)) & + /(z_bnd(i,j,k) - z_bnd(i,j,k+1)) + end do ! k + + lon = ixn(i,j) + lat = jxn(i,j) + + do k = KCHEMTOP,KMAX_MID + frac = 1. - fraca(k) - fracb(k) + kg = ilevel(k) + airem(k,i,j) = flux(lon,lat,kg)*fraca(k) & + + flux(lon,lat,kg-1)*frac & + + flux(lon,lat,kg-2)*fracb(k) + end do + + ! surface emissions + + if(iktop == 0) & + airem(KMAX_MID,i,j) = airem(KMAX_MID,i,j)+flux(lon,lat,0) + end do + end do + + + !! Print out on a limited part of the domain both raw data ( flux ) and + !! the re-gridded emissions ( airem ). Expect only an approximate match! + !! Summation of aircraft emission and lightning are on different grids + !! and hence for different domains. + + sum2 = 0. + do j = 1,ljmax + do i = 1,limax + + if(gl(i,j)>rlon(lo_tst1) .and. gl(i,j)ygrida(la_tst2+1)) then + do k=KCHEMTOP,KMAX_MID + vol = GRIDWIDTH_M*GRIDWIDTH_M & + *(z_bnd(i,j,k)-z_bnd(i,j,k+1))*1.e6 + sum2 = sum2 + airem(k,i,j)*atwno2/AVOG* & + vol*secmonth*1.e-3 + end do + end if + end do + end do + + MPIbuff=sum2 + CALL MPI_ALLREDUCE(MPIbuff,sum2, 1, & + MPI_DOUBLE_PRECISION, MPI_SUM, MPI_COMM_WORLD, INFO) + if(me == 0) write(6,*) 'ancat on limited area:',sum,sum2 + + end subroutine air_inter + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +end module AirEmis_ml + diff --git a/Ammonium_ml.f90 b/Ammonium_ml.f90 new file mode 100644 index 0000000..fcaca27 --- /dev/null +++ b/Ammonium_ml.f90 @@ -0,0 +1,273 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Ammonium_ml + !---------------------------------------------------------------------------- + ! Module to set up and process the NH4-NO3-SO4 reaction system + ! + ! Usage: + ! "call ammonium()" - from Runchem + ! - on the first call this runs the tabulation routines. On all calls + ! the equilibrium relationships are calculated and run to establish + ! new values of ammonium sulphate (AMSU), NH3, HNO3, SO4 and + ! ammonium nitrate (AMNI). + ! + ! Dec 2002 hf Routine change to treat SO4-NH3-HNO3-aNO3-aNH4 system instead + ! This makes code flexible with regards to which eq solver you choos: + ! Ammonium, MARS or EQSAM. + ! In principle, this is exactly the same as using the old indices, + ! however, SO4 which goes into the chemical solver is now the total sulphate, + ! whereas with the old indices it was only free sulphate. + !---------------------------------------------------------------------------- + ! + use ModelConstants_ml , only : CHEMTMIN, CHEMTMAX &! Temp. range + , PPB &! unit factors + , KCHEMTOP &! k=2 - top of chemistry + , KMAX_MID ! K=20 at ground + implicit none + private + + + !/- subroutines: + public :: ammonium ! Sets up most tables + + private :: tabulate ! Sets up most tables, and calls tab_rct_rates + private :: setup_ammonium ! setup data for 1d column calculation + private :: calc_ammonium ! Equilibrium distribution of NH4-SO4-NO3 + + !/Wanted? + !hf moved logical, public, parameter :: INORGANIC_AEROSOLS = .true. + + !/- Outputs: - updated xn_2d concentrations after equilibrium + + + !/-- Local: + + real, private, dimension(CHEMTMIN:CHEMTMAX), save :: & + tab_rhdel & ! RH of deliquescence for ammonium nitrate + ,tab_Kp_amni & ! Equil. constant, nh3 + hno3 <--> nh4no3 + ,tab_MozP1 & ! Mozurkewich P1 value for Kaq + ,tab_MozP2 & ! Mozurkewich P2 value for Kaq + ,tab_MozP3 ! & ! Mozurkewich P3 value for Kaq +! ,tab_vav_n2o5 ! avg. molecular speed N2O5 + ! Might move elsewhere + + logical, private, save :: my_first_call = .true. + + + contains + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine ammonium() + integer :: i,j ! for print-out only + + real, dimension(KCHEMTOP:KMAX_MID) :: rcnh4 ! equilib. value + !was : miscrc(ICRCNH3,k) + + if ( my_first_call ) then + call tabulate() + my_first_call = .false. + endif + + call setup_ammonium(rcnh4) + call calc_ammonium(rcnh4) + + + + end subroutine ammonium + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine tabulate() + ! + integer :: i + real, dimension(CHEMTMIN:CHEMTMAX) :: t ! temp.(K) for tabulations + + + !/-- current temperature range: from 148 K (-125C) ro 333K (+60C): + + t = (/ (real(i),i=CHEMTMIN,CHEMTMAX) /) + + + ! Tabulations tab_rhedl, tab_Kp_amni, tab_MozP.., tab_vav_n2o5 + !------------------------------------------------------------------- + ! relative humidity of deliquescence for ammonium nitrate + ! Ref: Mozurkewich (1993) - Journal??? + ! Units : fraction 0-1 + ! (MADE/MACHO notes : was miscrcit(ICRHD,it) + + tab_rhdel(:) = exp( 618.3/t(:) - 2.551 ) + + !------------------------------------------------------------------- + ! Equilibrium constant (Kp): NH3 + HNO3 <-------> NH4NO3 + ! Ref: Mozurkewich (1993) + ! Units : (molecule/cm3)^2 for Kp + ! (MADE/MACHO notes : was miscrcit(ICRS,it) + ! + ! lnKp = 118.87 - 24084.0/T - 6.025* ln(T) + ! + ! st: documentation has + 24084! + ! c.f. Seinfeld, eqn 9.91, p.532 - suggests minus, if it is relevant? + + tab_Kp_amni(:) = exp( 118.87 - 24084.0/t(:)-6.025*alog(t(:)) ) + + !------------------------------------------------------------------- + ! temp. dependant constrants for calcolating dissos. rate + ! for the formation of ammonium nitrate + ! Ref: Mozurkewich (1993) + ! (MADE/MACHO notes : was miscrcit(ICXK1,it)..miscrcit(ICXK_3,it) + ! n.b. EMEP report 2/98 had 2446 in P3, but 24.46 is correct + + tab_MozP1(:) = exp( -135.94 + 8763.0/t(:) + 19.12*alog( t(:) ) ) + tab_MozP2(:) = exp( -122.65 + 9969.0/t(:) + 16.22*alog( t(:) ) ) + tab_MozP3(:) = exp( -182.61 + 13875.0/t(:) + 24.46*alog( t(:) ) ) + + + !------------------------------------------------------------------- + end subroutine tabulate + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine setup_ammonium(rcnh4) + ! + ! Calculates the equilibrium constant for the ammonium-suphate + ! ammonium nitrate, Kp and Kaq (here denoted rcKaq). + ! Ref: EMEP Report 2/98, pages B:3, Mozurkewich (1993) + ! + ! Kpaq = [ P1 -P2(1-rh/100) + P3(1-rh/100)^2 ] .(1-rh/100)**1.75. Kp + ! + ! Units : Kp, Kaq : (molecules cm-3)^2 + ! rc ???? + ! MADE/MACHO notes.. ds- replaced xk by Kp, miscrc(ICRCNH3) by rc...?? + !-------------------------------------------------------------------------- + use Setup_1dfields_ml , only : rh, amk, itemp + + real, dimension(KCHEMTOP:KMAX_MID) :: rcnh4 ! equilib. value + real, dimension(KCHEMTOP:KMAX_MID) :: rhd, Kp ! deliq. rh, Kp + real, dimension(KCHEMTOP:KMAX_MID) :: & + roappm & ! density in ppm? + ,humd,humdsqrt,humdsqrt2 ! humd = 1-rh + !! rhd, Kp & ! deliq. rh, Kp + + rhd(:) = tab_rhdel( itemp(:) ) ! was: miscrcit(ICRHD,itk) + + Kp(:) = tab_Kp_amni( itemp(:) ) ! was: miscrcit(ICRS,itk) + +!hf Initialize rcnh4 to tab_Kp_amni,need roappm + roappm(:) = amk(:)*PPB + rcnh4(:) = tab_Kp_amni( itemp(:) )*roappm(:)* roappm(:) + +! The lines below are a CPU-efficient way of calculating the +! power of 1.75 for Mozurkewich Kp, suggested by su. + + where ( rh >= rhd ) ! old: if(rh(k) >= rhd) then + + humd = 1.0001 - rh ! ds why not 1.0? + humdsqrt = sqrt(humd) + humdsqrt2 = sqrt(humdsqrt)*humdsqrt + Kp = ( tab_MozP1(itemp) & + - tab_MozP2(itemp)*humd & + + tab_MozP3(itemp)*humd*humd ) *humd*humdsqrt2*Kp + + roappm = amk*PPB + rcnh4 = Kp * roappm * roappm ! old misrc(ICRCNH3,k) + +!hf BUG elsewhere + +!hf BUG rcnh4 = 0.0 + end where + + + end subroutine setup_ammonium + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine calc_ammonium(rcnh4) + !** DESCRIPTION + ! Calculates the distribution of NH3, (NH4)1.5SO4, NH4NO3 + ! - needs more text... + ! nov 2002 hf Changed from NH3-AMSU-AMNI-HNO3 + ! to NH3-aNH4-aNO3-HNO3 + ! in order to have same structure as with EQSAM and MARS + !------------------------------------------------------------------------- + + use GenSpec_tot_ml , only : SO4, aNH4,aNO3, NH3, HNO3 + use Setup_1dfields_ml , only : xn => xn_2d + + real, dimension(KCHEMTOP:KMAX_MID) :: rcnh4 ! equilib. value + real, dimension(KCHEMTOP:KMAX_MID) :: eqnh3, delteq !ds, delt + real, dimension(KCHEMTOP:KMAX_MID) :: freeSO4 + + freeSO4(:)=xn(SO4,:)-((xn(aNH4,:)-xn(aNO3,:))*2./3.) !hf Sulfate not in form + !of (NH4)1.5SO4 or NH4NO3 + freeSO4(:)=max(0.0,freeSO4(:)) + + + where ( 1.5*freeSO4(:) > xn(NH3,:) ) ! free SO4 (not in amsu form) in excess of NH3 + + + !hf amsu xn(AMSU,:) = xn(AMSU,:) + xn(NH3,:)*2./3. + + xn(aNH4,:) = xn(aNH4,:) + xn(NH3,:) !hf + + !hf amsu xn(SO4,:) = xn(SO4,:) - xn(NH3,:)*2./3. + + xn(NH3,:) = 0. + + elsewhere !NH3 in excess + + + !hf amsu xn(AMSU,:) = xn(AMSU,:) + xn(SO4,:) + + xn(aNH4,:) = xn(aNH4,:) + freeSO4(:)*1.5 !hf + + xn(NH3,:) = xn(NH3,:) - freeSO4(:)*1.5 + + !hf amsu xn(SO4,:) = 0. + + + ! The equilibrium concentration of NH3 is: + eqnh3 = (xn(NH3,:) - xn(HNO3,:))*0.5 & + + sqrt( 0.25*(xn(NH3,:) -xn(HNO3,:))**2 + rcnh4 )+1. + !ds - why +1 here? + !hf eqnh3 er i størrelsesorden 10^20. + + delteq = eqnh3 - xn(NH3,:) + !hf amsu delteq = min(delteq,xn(AMNI,:)) ! ds - used to have delt here + !hf amsu xn(AMNI,:) = xn(AMNI,:) - delteq + delteq = min(delteq,xn(aNO3,:)) + + xn(aNO3,:) = xn(aNO3,:) - delteq !hf + + xn(NH3,:) = xn(NH3,:) + delteq + xn(HNO3,:) = xn(HNO3,:) + delteq + + delteq = min(delteq,xn(aNH4,:))!in theory not necessary, + !but numerics make very small neg value possible + xn(aNH4,:) = xn(aNH4,:) - delteq !hf amsu + + end where + + end subroutine calc_ammonium + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +end module Ammonium_ml diff --git a/Aqueous_ml.f90 b/Aqueous_ml.f90 new file mode 100644 index 0000000..9d79b6e --- /dev/null +++ b/Aqueous_ml.f90 @@ -0,0 +1,559 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Aqueous_ml + +!----------------------------------------------------------------------- +! Aqueous scavenging routines. +! +! A "minimal" version of the aqueous reactions. +! 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. +! +! Usage: +! +! Uses My_WetDep_ml, where the scavenging coefficients, divided by +! relevant factors, are specified. +! +! Setup_Clouds(i,j) called from Runchem_ml +! WetDeposition(i,j) called from Runchem_ml if prec. clouds are present +! +! Refs: +! Berge, E., 1993, Coupling of wet scavenging of sulphur to clouds in a +! numerical weather prediction model, Tellus, 45B, 1-22 +! Berge, E. and Jakobsen, H.A., 1998, {A regional scale multi-layer model for +! the calculation of long-term transport and deposition of air pollution in +! Europe, Tellus, 50,205-223 +! Eliassen, A. and Saltbones, J., 1983, Modelling of long-range transport of +! sulphur over Europe: a two year model run and some experiments, Atmos. +! Environ., 17, 1457-1473 +! Seland, O. and T. Iversen (1999) A scheme for black carbon and +! sulphate aerosols tested in a hemispheric scale, Eulerian dispersion +! model. Atm. Env. Vol. 33, pp.2853-2879. +!----------------------------------------------------------------------- + + use My_WetDep_ml, only : WetDep, NWETDEP, WetDep_Budget, WDEP_PREC + use Derived_ml, only : IOU_INST & ! Index: instantaneous values + ,d_2d ! Contains Wet deposition fields + use GridValues_ml, only : gridwidth_m,xm2,xmd,carea + use ModelConstants_ml, only: & + CHEMTMIN, CHEMTMAX & ! -> range of temperature + ,KMAX_MID & ! -> ground, k=20 + ,KUPPER & ! -> top of cloud-chemistry, k=6 + ,KCHEMTOP & ! -> top of chemistry, now k=2 + ,dt => dt_advec & ! -> model timestep + ,PT, ATWAIR ! -> pressure at top, atw. air + use Met_ml, only : pr, roa, z_bnd, cc3d, ps, lwc + use Par_ml, only : me ! for DEBUG + use Setup_1dfields_ml, only : xn_2d, amk + + implicit none + private + +! Subroutines: + + 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 + + +! Variables used in module: + + logical, private, save :: DEBUG_AQ = .false. + + real, private, save, dimension(KUPPER:KMAX_MID) :: & + pr_acc ! Accumulated precipitation + + 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) + + real, private, save :: & ! Set in init below + INV_Hplus & ! = 1.0/Hplus (1/H+) + ,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 + +! 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 + +! Aqueous reaction rates for usage in gas-phase chemistry: + + 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, 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 + + 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) + + +! 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 +! 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, +! 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 +! return the user-defined array WetDep%W_sca, with W_Sca representing +! the value of f.W_Sca/Z_sca/rho_water + + +! Sub cloud scavenging: +!----------------------------------------------------------------------- +! The sub-cloud scavenging distinguishes between particulate and +! gas-phase components. The scavenging of gases is calculated as +! Q = vw * P, where P is the accumulated precipitation (pr_acc, m) +! 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 +! 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. + + +contains + +!----------------------------------------------------------------------- +subroutine Setup_Clouds(i,j) + +!----------------------------------------------------------------------- +! DESCRIPTION +! Define incloud and precipitating clouds. +! The layer must contain at least 1.e-7 kgwater/kg air to +! be considered a cloud. +! +! Also calculates +! pr_acc - the accumulated precipitation for each k +! b - fractional cloud cover for each k +!----------------------------------------------------------------------- + + integer, intent(in) :: i,j + + 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 + + integer :: k + +! Add up the precipitation in the column: + 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 + + prclouds_present = .false. + if ( pr_acc(KMAX_MID) > PR_LIMIT ) prclouds_present = .true. + ! --> precipitation at the surface + +! initialise with .false. and 0: + incloud(:) = .false. + cloudwater(:) = 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 + 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 + +! Define incloud part of the column requiring that both cloud water +! 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) + +! 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 +! (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_AQ ) write(6,"(a20,i3,2i4,3es12.4)") & + "ERROR prclouds sum_cw", & + me, 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) + + if ( DEBUG_AQ .and. i == 3 .and. j == 3 ) then + write(6,*) "DEBUG_AQ me presetn", me, prclouds_present + write(6,*) "(a15,i3,2i4,es14.4)", "DEBUG_AQ me ", me, & + kcloudtop, ksubcloud, pr_acc(KMAX_MID) + end if + +end subroutine Setup_Clouds + + +!----------------------------------------------------------------------- +subroutine init_aqueous() + +!----------------------------------------------------------------------- +! DESCRIPTION +! Calls initial tabulations, sets frac_aq to zero above cloud level, and +! sets constant rates. +! MTRLIM represents mass transport limitations between the clouds +! and the remainder of the grid-box volume. (so2 will be rapidly +! depleted within the clouds, and must be replenished from the +! surrounding cloudfree volume. +!----------------------------------------------------------------------- + + use PhysicalConstants_ml, only: AVOG ! Avogadro's No. + + real, parameter :: & + Hplus = 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 + +! tabulations +!======================== + call tabulate_aqueous() +!======================== + +! Constant rates: The rates given in Berge (1993) are in mol-1 l. +! These need to be multiplied by 1.0e3/AVOG/Vf,so we perform the +! 1.0e3/AVOG scaling here. + +! so2aq + h2o2 ---> so4, ref: Möller 1980 + aqrc(1) = 8.3e5 * 1.0e3/AVOG * MASSTRLIM + +! (so2aq + hso3-) + H+ + o3 ---> so4, ref: Martin & Damschen 1981 + aqrc(2) = 1.8e4 * 1.0e3/AVOG * MASSTRLIM + +! (so2aq + hso3-) + o2 ( + Fe ) --> so4, see documentation below + aqrc(3) = 3.3e-10 * MASSTRLIM + +! Regarding aqrc(3): +! catalytic oxidation with Fe. The assumption is that 2% of SIV +! is oxidised per hour inside the droplets, corresponding to a +! conversion rate of 5.6^-6 (units s^-1 -- Therfore no conversion +! from mol l^-1) + +! 5.6e-6 * 0.5e-6 (liquid water fraction) /8.5e-3 (fso2 at 10deg C) + +! 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+ ) +! 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 + + 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(:) ) + +! 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,:) + +end subroutine tabulate_aqueous + + +!----------------------------------------------------------------------- +subroutine setup_aqurates(b ,cloudwater,incloud) + +!----------------------------------------------------------------------- +! DESCRIPTION +! sets the rate-coefficients for thr aqueous-phase reactions +!----------------------------------------------------------------------- + + use Setup_1dfields_ml, only : & + itemp ! temperature (K) + + real, dimension(KUPPER:KMAX_MID) :: & + b & ! cloud-aread (fraction) + ,cloudwater ! cloud-water + logical, dimension(KUPPER:KMAX_MID) :: & + 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 ) + + integer k + + call get_frac(cloudwater,incloud) ! => frac_aq + +! initialize: + aqrck(:,:)=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 + + 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 + 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 + + use Setup_1dfields_ml, only : & + temp & ! temperature (K) + ,itemp ! temperature (K) + use PhysicalConstants_ml, only: RGAS_ATML ! Gas-constant + +! 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 + +! Make sure frac_aq is zero outside clouds: + frac_aq(:,:) = 0. + + do k = KUPPER, KMAX_MID + if ( incloud(k) ) then + + VfRT(k) = 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 + +end subroutine get_frac + + +!----------------------------------------------------------------------- +subroutine WetDeposition(i,j) + +!----------------------------------------------------------------------- +! DESCRIPTION +! Calculates wet deposition and changes in xn concentrations +! WetDeposition called from RunChem if precipitation reach the surface +!----------------------------------------------------------------------- + +! input + integer, intent(in) :: i,j + +! local + integer :: itot ! index in xn_2d arrays + integer :: spec ! species index from WetDep array + integer :: n,k + + real :: invgridarea ! xm2/(h*h) + real :: f_rho ! Factors in rho calculation + real :: rho(KUPPER:KMAX_MID) + real, dimension(KUPPER:KMAX_MID) :: vw ! Svavenging rates (tmp. array) + + real :: loss ! conc. loss due to scavenging + real,dimension(NWETDEP) :: sumloss ! sum conc. loss due to scavenging + +! Loop starting from above: + f_rho = xmd(i,j)*(ps(i,j,1) - PT)/ATWAIR + do k=kcloudtop, KMAX_MID ! No need to go above cloudtop + rho(k) = f_rho * carea(k) / amk(k) + end do + sumloss(:) = 0.0 + + invgridarea = xm2(i,j)/( gridwidth_m*gridwidth_m ) + +! calculate concentration after wet deposition and sum up the vertical +! column of the depositions for the fully soluble species. + + if ( DEBUG_AQ .and. i == 3 .and. j == 3 ) then + Write(6,*) "(a15,i3,2i4,es14.4)", "DEBUG_WDEP2", me, & + kcloudtop, ksubcloud, pr_acc(KMAX_MID) + end if ! DEBUG + + do spec = 1, NWETDEP + +! Put both in- and sub-cloud scavenging ratios in the array vw: + + vw(kcloudtop:ksubcloud-1) = WetDep(spec)%W_sca ! Scav. for incloud + vw(ksubcloud:KMAX_MID ) = WetDep(spec)%W_sub ! Scav. for subcloud + + if ( DEBUG_AQ .and. i == 3 .and. j == 3 ) then + Write(6,*) "(a15,i3,2es14.4)", "DEBUG_WDEP Sca", & + spec, WetDep(spec)%W_sca, WetDep(spec)%W_sub + end if ! DEBUG + + itot = WetDep(spec)%itot + + do k = kcloudtop, KMAX_MID + loss = xn_2d(itot,k) * ( 1.0 - exp( -vw(k)*pr_acc(k)*dt ) ) + xn_2d(itot,k) = xn_2d(itot,k) - loss + sumloss(spec) = sumloss(spec) + loss * rho(k) + + if ( DEBUG_AQ .and. i == 3 .and. j == 3 ) then + Write(6,*)"(a30,4i4)", "DEBUG_WDEP me, k, itot, spec", & + me, k, itot, spec + Write(6,*)"(a30,i4, 2es12.4, f8.2)", & + "DEBUG_WDEP me, vw, pr, dt ", me, & + vw(k), pr_acc(k), dt + Write(6,*)"(a30,3es12.4)", "DEBUG_WDEP loss, xn, sumloss", & + loss, xn_2d(itot,k), sumloss(spec) + end if ! DEBUG + end do ! k loop + end do ! spec 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,sumloss,invgridarea) ! Model-specific + +end subroutine WetDeposition + +!----------------------------------------------------------------------- +end module Aqueous_ml diff --git a/Biogenics_ml.f90 b/Biogenics_ml.f90 new file mode 100644 index 0000000..14a91f8 --- /dev/null +++ b/Biogenics_ml.f90 @@ -0,0 +1,174 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Biogenics_ml + !/-- Reads in BVOC emisions factors (for "standard" conditions, + ! 30 deg C and sunlit). + ! The effects of temperature and light on the biogenic stuff is calculated + ! in Setup_1d + !--------------------------------------------------------------------------- + use My_Emis_ml , only : NBVOC, BVOC_USED + + use CheckStop_ml, only: CheckStop + use GridValues_ml , only : xm2, gb, & + i_fdom,j_fdom,debug_proc,debug_li,debug_lj + use Io_ml , only : IO_FORES, open_file, ios, Read2DN + use KeyValue_ml, only : KeyVal,KeyValue + use ModelConstants_ml, only : NPROC + use Par_ml , only : me, MAXLIMAX,MAXLJMAX,MSG_READ1,li0,li1,lj0,lj1 + implicit none + private + + !/-- subroutines + public :: Init_BVOC + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + logical, private, parameter:: DEBUG = .false. + integer, public, save :: BIO_ISOP, BIO_TERP + + real, public, save, dimension(MAXLIMAX,MAXLJMAX,NBVOC) :: & + emforest & ! Gridded standard (30deg. C, full light) emissions + ,emnat ! Gridded std. emissions after scaling with density, etc. + + !/-- Canopy environmental correction factors----------------------------- + ! + ! - to correct for temperature and light of the canopy + ! - from Guenther's papers. (Limit to 0 +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +! ToDo: ???? +! Check all allocates ? +! Make one subroutine to do all stuff rtepeated for adv and bgn?? +! xn_Adv_changed doesn't include msic. Does this matter? +! Is 2nd call to Set_Misc... needed??? +! Answer: +! Since bc_bgn and bc_adv are initiated each month, +! the second call to Set_Misc is needed. This can be re written +! but it is safer as it is....and do not cost too much +!____________________________________________________________________________ +module BoundaryConditions_ml +!____________________________________________________________________________ +! This module is the main driver module for defining and setting boundary +! conditions (bcs) for the chemical species. +! +! The main code calls up these routines with just: +! +! call BoundaryConditions(month) !once per month, after say newmonth +! +! On first call, this routine runs some intialisation routines in related +! modules, reads the global data, and sets full 3-D concentration fields +! of the advected and background concentration fields (xn_adv, xn_bgn). +! On subsequent calls (my_first_call=.false.), the routine reads new +! global input data, and rsets the concentrations at the top level and +! lateral boundaries for advected species. For background species it reset +! full 3-D concentration fields. +! +! A bilinear interpolation routine is used to extrapolate from the coarser +! global data to the EMEP model arrays, from the module Interpolations_ml. +! Vertical interpolation is done on reading in the data. +! +! The main related bc modules are: +! +! 1. UiO_ml.f90 - sets indices of global model data, e.g. IBC_O3, as well +! as the number of global model fdata (NGLOB_BC). +! +! 2. My_bcmap_ml.f90 - assigns mappings, telling which EMEP species the +! global model fdata are assigned to (bc2xn_adv, bc2xn_bgn arrays). +! +! Language : F +! History : +! +! +!ds Summer 2003: Added Mace Head corrections. Corrected bugs in twopi_year +! and vertical scaling. +!ds January 2002: modified for case with no BCs to be set (num_changed). +! Re-formatted, replaced stop_test by mpi_abort +!hf september-01: 2-dim mask changed into a 3-dim mask, and new restrictions +! are made +! All adv species are only reset in top and edges, bgn species +! in 3d. +!hf october-01: Set_MiscBoundaryConditions renamed to MiscBoundaryConditions +! ds - December 2000-January 2001: added interpolations, removed txxlat, etc. +! (See !REM at end for removals). Reorganised to put UiO stuff in UiO_ml, +! "my" stuff (model-dependant) in My_BoundConditions_ml. +! jej - summer 2000 - original code called globinit.f +! +! ToDo: +! More flexible update times (update date array maybe?) ! (should make it +! Dates_ml....) +! Could restrict calculations of wt_00 etc. to limax, ljmax, but this was too +! complicated in F90 (due to problems with dummary arguments and non-fixed +! bounds)? To finish in January, I gave up! +!____________________________________________________________________________ +! IMPORTANT NOTES: +! 1. The routines given here are constructed around the global model +! fields from the University of Oslo (T21) global model. In order +! to use other models as bcs then usually these routines will have to be +! replaced by model-specific routines. The important thing is +! that the inputs and outputs from the routine are independant of the +! global module ufor one bc speciessed. +! 2. The routines make use of a "feature" of the model: that the concentration +! (xn) values along boundaries are not changed due to advection or chemistry. +! Thus, bc values only need to be set once per month, firstly for the whole 3-D +! domain, then monthly for the sides and top. +! Background species must be reset in 3-D each month. +!_____________________________________________________________________________ + use My_BoundConditions_ml, only: & + NTOT_BC & ! Total Number of species with bcs + ,My_bcmap &! set-up subroutine + ,bc2xn_adv, bc2xn_bgn ! mapping arrays + + use Chemfields_ml, only: xn_adv, xn_bgn ! emep model concs. + use GenSpec_adv_ml ! Lots, including NSPEC_ADV and IXADV_ + use GenSpec_bgn_ml, only :NSPEC_BGN + use GridValues_ml, only: gl, gb &! lat, long + ,i_fdom, j_fdom !u1 for testing + use ModelConstants_ml , only: KMAX_MID & ! Number of levels in vertical + ,NPROC & ! Number of processors + ,DEBUG_i, DEBUG_j + use Par_ml, only : & + MAXLIMAX, MAXLJMAX, limax, ljmax, me & + ,neighbor, NORTH, SOUTH, EAST, WEST & ! domain neighbours + ,NOPROC& + ,IRUNBEG,JRUNBEG,li1,li0,lj0,lj1 + use GlobalBCs_ml, only: & + NGLOB_BC & ! Number of species from global-model + ,GetGlobalData & ! Sub., reads global data+vert interp. + ,setgl_actarray + + use CheckStop_ml, only: CheckStop + implicit none + private + + + ! -- subroutines in this module: + + public :: BoundaryConditions ! call every month + + private :: Set_bcmap ! sets xn2adv_changed, etc. + private :: MiscBoundaryConditions ! misc bcs, not from global model. + private :: Set_BoundaryConditions ! assigns concentrations (xn) from bcs + + + !/-- Allow different behaviour on 1st call - full 3-D asimilation done + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + + logical, private, save :: my_first_call = .true. + + !/ - for debugging + real :: ppb = 1.0e-9 + logical, parameter, private :: DEBUG_BCS = .false. + + + ! Arrays for mapping from global bc to emep xn concentrations: + ! --------------------------------------------------------------------------- + + integer, private,save, dimension(NTOT_BC) :: & + bc_used &! set to 1 if bc used + ,bc_used_adv &! set to 1 if bc used + ,bc_used_bgn ! set to 1 if bc used + + integer, private, save :: & + num_adv_changed & !Num. adv. species that have bc's + ,num_used_adv !Max times a conc. from + !e.g CTM2 is used as bc + integer, private, save :: & + num_bgn_changed,num_used_bgn, & + num_changed !u1 - sum of adv and bgn + + !In general "changed" means "bc used for this species" + + logical, private, save, dimension(NSPEC_ADV) :: & + xn_adv_changed ! true if emep xn_adv changed by bcs + logical, private, save, dimension(NSPEC_BGN ) :: & + xn_bgn_changed ! true if emep xn_adv changed by bcs + + integer, private, save, dimension(NSPEC_ADV) :: & + spc_adv2changed !index of advected specie is converted to + !index in the row of advected species + !that have bc + integer, private, save, dimension(NSPEC_BGN) :: & + spc_bgn2changed ! + + integer, allocatable, dimension(:),save :: & + spc_changed2adv !index of adv. specie that have bc is + !converted to index in the row of + !advected species + integer, allocatable, dimension(:),save :: & + spc_changed2bgn + + integer, allocatable, dimension(:,:),save :: & + spc_used_adv !1.dimension(ibc) runs through bc adv.species + !2.dim.(i) through those who get same conc. + !from bc (eg i=1,2 for ibc=HNO3 when HNO3 + !from CTM2 is used as bc both for HNO3 and SO4) + !spc_used_adv gives the index in the row of + !advected species + integer, allocatable, dimension(:,:),save :: & + spc_used_bgn + + +contains + + !------- + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine BoundaryConditions(year,iyr_trend,month) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + !** DESCRIPTION + ! read in monthly-average global mixing ratios, and if found, collect the + ! data in bc_adv, bc_bgn arrays for later interpolations + ! (NB!! if mixing ratio by mass the scale by molcular weight) + ! ds- comment - so far no scaling is done, but this could be done + ! in Set_bcmap with atomic weights.... for the future.. + ! + ! On the first call, we also run the setup-subroutines + ! + !ds rv1.6.11 change: year is now obtained from the iyr_trend set in grun.pl + ! Allows say runs with BCs for 2100 and met of 1990. + !____________________________________________________________________________ + integer, intent(in) :: year ! "meteorology" year ds rv1.6.11 + integer, intent(in) :: iyr_trend ! "trend" year ds rv1.6.11 + 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 + + !/ data arrays for boundary data (bcs) - quite large, so NOT saved + integer alloc_err1,alloc_err2,alloc_err3 + + real, allocatable,dimension(:,:,:) :: bc_data ! for one bc species + real, allocatable,dimension(:,:,:,:) :: bc_adv + real, allocatable,dimension(:,:,:,:) :: bc_bgn + +! ( nb dimensions correspond to: +! IGLOB,JGLOB,KMAX_MID :: bc_data +! NSPEC_ADV,IGLOB,JGLOB,KMAX_MID :: bc_adv +! NSPEC_BGN,IGLOB,JGLOB,KMAX_MID :: bc_bgn ) + + integer :: iglobact,jglobact + integer :: errcode + integer, save :: idebug = 0, itest=1, i_test=0, j_test=0 + character(len=30) :: fname + + if ( my_first_call ) then + + if (DEBUG_BCS) write(*,*) "FIRST CALL TO BOUNDARY CONDITIONS, me :", me + if (DEBUG_BCS) write(*,*) "TREND YR, me ", iyr_trend, me + + 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(*,*) "BCs: num_adv_changed: ", num_adv_changed + if (DEBUG_BCS) write(*,*) "BCs: num_bgn_changed: ", num_bgn_changed + if (DEBUG_BCS) write(*,*) "BCs: num changed: ", num_changed + + end if ! first call + if (DEBUG_BCS) write(*,*) "CALL TO BOUNDARY CONDITIONS, me, month :", me, month + if (DEBUG_BCS) write(*,*) "TREND2 YR, me ", iyr_trend, me + + if ( num_changed == 0 ) then + write(*,*) "BCs: No species requested" + return + end if + +!MUST CONTAIN DECIDED DIMENSION FOR READ-IN DATA +! iglobac and jglobac are no the actual domains (the chosen domain) +! given in the same coord as the data we read - now 50*50 + call setgl_actarray(iglobact,jglobact) + + allocate(bc_data(iglobact,jglobact,KMAX_MID),stat=alloc_err1) + call CheckStop(alloc_err1, "alloc1 failed in BoundaryConditions_ml") + + ! - check if anything has changed before allocating: + + allocate(bc_adv(num_adv_changed,iglobact,jglobact,KMAX_MID), & + stat=alloc_err2) + call CheckStop(alloc_err2, "alloc2 failed in BoundaryConditions_ml") + bc_adv(:,:,:,:) = 0.0 + + allocate(bc_bgn(num_bgn_changed,iglobact,jglobact,KMAX_MID), & + stat=alloc_err3) + call CheckStop(alloc_err3, "alloc3 failed in BoundaryConditions_ml") + bc_bgn(:,:,:,:) = 0.0 + + + errcode = 0 + if ( DEBUG_BCS ) 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 + end if + end do + end do + end if + + + + !== BEGIN READ_IN OF GLOBAL DATA + + do ibc = 1, NGLOB_BC + + !================================================= + if(me == 0) call GetGlobalData(year,iyr_trend,month,ibc,bc_used(ibc) & + ,iglobact,jglobact,bc_data,io_num,errcode) + !================================================= + if ( DEBUG_BCS .and. me == 0 ) then + write(*,*)'Calls GetGlobalData: year,iyr_trend,ibc,month,bc_used=', & + year,iyr_trend,ibc,month,bc_used(ibc) + + end if + 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,:,:,:) + & + bc2xn_adv(ibc,iem) * bc_data(:,:,:) + end do + + ! 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,:,:,:) + & + bc2xn_bgn(ibc,iem) * bc_data(:,:,:) + end do + + endif ! bc_used + end do ! ibc + + if(me == 0) close(io_num) + + if ( my_first_call ) then + + idebug = 1 + if (DEBUG_BCS) print *, "RESET 3D BOUNDARY CONDITIONS", me + !=================================== + ! -> 3-D arrays of new BCs + call MiscBoundaryConditions(iglobact,jglobact,bc_adv,bc_bgn) + call Set_BoundaryConditions("3d",iglobact,jglobact & + ,bc_adv,bc_bgn) + !=================================== + + !=================================== + my_first_call = .false. + !=================================== + + else + idebug = idebug + 1 + !=================================== + + !ds - call to set misc conditions added here on 7/08/01. This uses + ! more CPU than needed since bc_adv is reset for the whole + ! domain, so in future a "3d"/"lateral" mask could be used + ! as for the normal boun. conds. + + ! -> 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 + + + if ( DEBUG_BCS .and. i_test > 0 ) then + write(6,"(a20,3i4,2f8.2)") "DEBUG BCS Rorvik", me, i,j,gl(i,j),gb(i,j) + write(6,"(a20,3i4)") "DEBUG BCS Rorvik DIMS", & + num_adv_changed,iglobact,jglobact + do k = 1, KMAX_MID + write(6,"(a20,i4,f8.2)") "DEBUG CO Rorvik", k, & + xn_adv(IXADV_CO,i_test,j_test,k)/ppb + end do + end if ! DEBUG + + if ( DEBUG_BCS .and. me == 0 ) then + itest = 1 + + write(6,*) "BoundaryConditions: No CALLS TO BOUND Cs", & + my_first_call, idebug + !/** the following uses hard-coded IXADV_ values for testing. + ! Remove later **/ + info = 1 ! index for ozone in bcs + write(6,*) "BCs: bc2xn(info,itest) : ", bc2xn_adv(info,itest) + write(6,*) "BCs: After Set_3d BOUND: me, itest: " , me, itest, & + bc_adv(spc_adv2changed(itest),1,1,1)/ppb + + info = 43 ! index for NO in bcs + write(6,*) "BCs: NSPECS: BC, ADV, BG, ", NTOT_BC, NSPEC_ADV, NSPEC_BGN + write(6,*) "BCs: Number of bc_used: ", sum(bc_used) + write(6,*) "BCs: limax, ljmax", limax, ljmax + + + ! Choose a point at mid-latitudes (j=24), around 0 long + do k = KMAX_MID, 1, -1 + write(6,"(a23,i3,e14.4)") "BCs at mid-lat (1,24):", k & + ,xn_bgn(itest,2,2,k)/PPB + end do + end if ! + + deallocate(bc_data,stat=alloc_err1) + call CheckStop(alloc_err1,"de-alloc1 failed in BoundaryConditions_ml") + + if ( num_adv_changed > 0 ) then + deallocate(bc_adv,stat=alloc_err2) + call CheckStop(alloc_err2,"de-alloc2 failed in BoundaryConditions_ml") + end if + + if ( num_bgn_changed > 0 ) then + deallocate(bc_bgn,stat=alloc_err3) + call CheckStop(alloc_err3,"de-alloc3 failed in BoundaryConditions_ml") + end if + + end subroutine BoundaryConditions + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine Set_bcmap() + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + !_______________________________________________________________________ + ! - returns some 1-D arrays which say if a bc is used or if an + ! emep xn_adv or xn_bgn is affected. This information is derived from + ! the mapping arrays bc2xn_adv and bc2xn_bgn, such that the emep species + ! are given along the x-dimension and the bc species along the y. + ! e.g., the statement + ! + ! bc2xn_adv(IBC_NOX,IXADV_NO2) = 0.55 + ! + ! would assign the BC concentration of NOX to the EMEP model concentration + ! of NO2 after multiplication with a factor 0.55. + ! + ! These arrays have been set in the My_BoundConditions_ml.f90 file. + !_______________________________________________________________________ + + integer :: ibc, iem ! local loop variables + integer :: i + + !-- bc_used set to one where a bc species is to be used. + + bc_used = 0 ! Initialise + bc_used_adv = 0 ! Initialise + bc_used_bgn = 0 ! Initialise + + do ibc = 1, NTOT_BC + if ( any( bc2xn_adv(ibc,:) > 0) .or. & + any( bc2xn_bgn (ibc,:) > 0) ) then + bc_used(ibc) = 1 + end if + do iem = 1, NSPEC_ADV + if(bc2xn_adv(ibc,iem) > 0)bc_used_adv(ibc) = bc_used_adv(ibc)+1 + enddo + do iem = 1, NSPEC_BGN + if(bc2xn_bgn(ibc,iem) > 0)bc_used_bgn(ibc) = bc_used_bgn(ibc)+1 + enddo + end do ! ibc + num_used_adv = maxval(bc_used_adv) + num_used_bgn = maxval(bc_used_bgn) + + xn_adv_changed = .false. ! Initialise + xn_bgn_changed = .false. ! Initialise + num_adv_changed = 0 + num_bgn_changed = 0 + + do iem = 1, NSPEC_ADV + if ( any( bc2xn_adv(:,iem) > 0) ) then + xn_adv_changed(iem) = .true. + num_adv_changed = num_adv_changed + 1 + end if + end do ! iem + + do iem = 1, NSPEC_BGN + if ( any( bc2xn_bgn(:,iem) > 0) ) then + xn_bgn_changed(iem) = .true. + num_bgn_changed = num_bgn_changed + 1 + end if + end do ! iem + + if ( DEBUG_BCS ) then + write(6,*) "TEST SET_BCMAP bc_used: " + write(6,"(10i5)") (bc_used(ibc),ibc=1, NTOT_BC) + end if + if (me==0) write(unit=6,fmt=*) "Finished Set_bcmap: Nbcused is ", sum(bc_used) + + allocate(spc_changed2adv(num_adv_changed)) + allocate(spc_changed2bgn(num_bgn_changed)) + i = 0 + spc_adv2changed = 0 + do iem = 1, NSPEC_ADV + if(xn_adv_changed(iem))then + i = i+1 + spc_changed2adv(i) = iem + spc_adv2changed(iem) = i + endif + enddo + i = 0 + spc_bgn2changed = 0 + do iem = 1, NSPEC_BGN + if(xn_bgn_changed(iem))then + i = i+1 + spc_changed2bgn(i) = iem + spc_bgn2changed(iem) = i + endif + enddo + allocate(spc_used_adv(NTOT_BC,num_used_adv)) + allocate(spc_used_bgn(NTOT_BC,num_used_bgn)) + + spc_used_adv = 0 + spc_used_bgn = 0 + + do ibc = 1, NTOT_BC + + if ( bc_used(ibc) > 0 ) then + + + ! - set bc_adv, - advected species + i = 0 + do iem = 1, NSPEC_ADV + if ( bc2xn_adv(ibc,iem) > 0.0 ) then + i = i+1 + spc_used_adv(ibc,i) = iem + end if + end do + + ! set bc_bgn, - background (prescribed) species + i = 0 + do iem = 1, NSPEC_BGN + if ( bc2xn_bgn(ibc,iem) > 0.0 ) then + i = i+1 + spc_used_bgn(ibc,i) = iem + end if + end do + + endif ! bc_used + end do ! ibc + + end subroutine Set_bcmap + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine MiscBoundaryConditions(iglobact,jglobact,bc_adv,bc_bgn) + + use GlobalBCs_ml, only: NGLOB_BC ! Number of species from global-model + + use My_BoundConditions_ml, only: & + bc2xn_adv, bc2xn_bgn, & ! mapping arrays + misc_bc ! species defined by user + use GenSpec_adv_ml + use Par_ml, only : me + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! - set bc_adv, bc_bgn,:::::::::::::::::::::::::::::::::::: + ! Note - this subroutine is a first draft and is only used for species + ! which have constant mixing ratios to start with - here CH4, H2. + ! I guess it should also work to set more complex variations (e.g. + ! vertical gradients) though - this would then be better off in + ! the module My_BoundaryConditions, but then we wouldn't have the + ! bc_adv, bc_bgn arrays available :-( + + + integer, intent(in) :: iglobact,jglobact + real, intent(inout), & + dimension(num_adv_changed,iglobact,jglobact,KMAX_MID) :: bc_adv + real, intent(inout), & + dimension(num_bgn_changed,iglobact,jglobact,KMAX_MID) :: bc_bgn + + integer :: itest ! Used to specify species index + integer :: ibc, iem,i,iem1,k ! local loop variables + + + 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) + 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) + enddo + enddo + enddo +endif + + itest = 1 + if (DEBUG_BCS) write(6,"(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 + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine Set_BoundaryConditions(mode,iglobact,jglobact & + ,bc_adv,bc_bgn) + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + ! Assign the global values to the interior model domain only first time + ! (mode=3d) or only the edge and top boundaries are reset for other + ! calls (mode=lateral). The emep model concentrations (xn) are only + ! changed for those species where bcs are available, as given in the + ! xn_adv_changed and xn_bgn_changed arrays. + ! + ! Programming note: we use F95 "forall" and logical masks to say which grid + ! squares are to be assigned. This is probably slower than the more-explicit + ! do-loops used previously, but is neater and shouldn't make too much + ! difference while this reset is done only once per month. + + character(len=*), intent(in) :: mode ! "3d" or "lateral" + integer, intent(in) :: iglobact,jglobact + real, intent(in), & + dimension(num_adv_changed,iglobact,jglobact,KMAX_MID) :: bc_adv + real, intent(in), & + dimension(num_bgn_changed,iglobact,jglobact,KMAX_MID) :: bc_bgn + integer, dimension(0:MAXLIMAX+1) :: & + i150 !EMEP 150*150 coord of emep point (i) + integer, dimension(0:MAXLJMAX+1) :: & + j150 !EMEP 150*150 coord of emep point (j) + logical, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: mask + integer :: i, j, k, n, ix, iy, ix1, iy1, itest + + + if ( mode == "3d" ) then + mask(:,:,:) = .true. ! We set everything + + else if ( mode == "lateral" ) then + mask(:,:,:) = .false. ! Initial + + +!chf Set edges (except on the top) +!pw if(neighbor(SOUTH) == NOPROC) mask(:,1,2:KMAX_MID) = .true. +!pw if(neighbor(NORTH) == NOPROC) mask(:,ljmax,2:KMAX_MID) = .true. +!pw if(neighbor(EAST) == NOPROC) mask(limax,:,2:KMAX_MID) = .true. +!pw if(neighbor(WEST) == NOPROC) mask(1,:,2:KMAX_MID) = .true. +!pw there may be no neighbor, but no external boundary (Poles in lat lon) + if(neighbor(SOUTH) == NOPROC) mask(:,1:(lj0-1),2:KMAX_MID) = .true. + if(neighbor(NORTH) == NOPROC) mask(:,(lj1+1):ljmax,2:KMAX_MID) = .true. + if(neighbor(EAST) == NOPROC) mask((li1+1):limax,:,2:KMAX_MID) = .true. + if(neighbor(WEST) == NOPROC) mask(1:(li0-1),:,2:KMAX_MID) = .true. + + mask(:,:,1) = .true. !Set top layer + else + call CheckStop("BCs:Illegal option failed in BoundaryConditions_ml") + endif + + !** Set concentrations (xn) from boundary conditions (bcs) + + ! Note on domains: although the geographical stuff has been specified + ! for the whole MAXLIMAX,MAXLJMAX grid, the interpolations take time + ! and are only needed for the sub-domain actually used, i.e. for + ! limax, ljmax. + + + !a) Advected species + + + do k = 1, KMAX_MID + do j = 1, ljmax + do i = 1,limax + if (mask(i,j,k)) then + do n = 1, num_adv_changed + xn_adv(spc_changed2adv(n),i,j,k) = & + bc_adv(n,(i_fdom(i)-IRUNBEG+1),(j_fdom(j)-JRUNBEG+1),k) + end do + endif + end do + end do + end do + + + + + !b) 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) + + end forall + + + end subroutine Set_BoundaryConditions ! call every 3-hours + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +end module BoundaryConditions_ml +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/CellMet_ml.f90 b/CellMet_ml.f90 new file mode 100644 index 0000000..19e46a3 --- /dev/null +++ b/CellMet_ml.f90 @@ -0,0 +1,154 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 CellMet_ml +!============================================================================= +!+ +! Description +! Module for setting some near-surface meteorology params +! ** calls SubMet_ml ** +! for calculating sub-grid meteorology for each land-use. +!============================================================================= + + +use CheckStop_ml, only : CheckStop +use Landuse_ml, only : LandCover ! Provides SGS, hveg, LAI .... +use LocalVariables_ml, only: Grid, Sub +use MicroMet_ml, only : PsiH, PsiM, AerRes !functions +use Met_ml, only: cc3dmax, nwp_sea, snow, surface_precip, ps,fh,fl,z_mid, z_bnd, & + q, roa, rho_surf, th, pzpbl, t2_nwp, ustar_nwp, u_ref, zen, coszen, Idirect, Idiffuse +use ModelConstants_ml, only : KMAX_MID, KMAX_BND +use PhysicalConstants_ml, only : PI, RGAS_KG, CP, GRAV, KARMAN, CHARNOCK, T0 +use SubMet_ml, only : Get_SubMet +use TimeDate_ml, only: current_date + +implicit none +private + +!Subroutines + +public :: Get_CellMet ! sets Grid-average (e.g. NWP) near-surface met, and + ! calls Get_Submet routines + +logical, private, parameter :: MY_DEBUG = .false. + +contains +!======================================================================= + + subroutine Get_CellMet(i,j,debug_flag) + integer, intent(in) :: i,j + logical, intent(in) :: debug_flag ! set true for wanted grid square + integer :: lu, ilu, nlu + +!--------------------------------------------------------------- + + + ! We assume that the area of grid which is wet is proportional to + ! cloud-cover. To avoid some compiler/numerical issues when + ! prec almost equal to zero, we allow a small build-up phase, with + ! linear increase from wetarea=0 to wetarea = cc3dmax for values of + ! prec between 1.0e-8 (near-zero!) to 0.01. + + if ( surface_precip(i,j) > 1.0d-2 ) then + Grid%is_wet = .true. + Grid%wetarea = cc3dmax(i,j,KMAX_MID) + else if ( surface_precip(i,j) > 1.0d-8 ) then + Grid%is_wet = .true. + Grid%wetarea = surface_precip(i,j)/1.0d-2 * cc3dmax(i,j,KMAX_MID) + else + Grid%is_wet = .false. + Grid%wetarea = 0.0 + end if + + + Grid%i = i + Grid%j = j + Grid%psurf = ps(i,j,1) ! Surface pressure, Pa + Grid%z_ref = z_mid(i,j,KMAX_MID) + Grid%DeltaZ = z_bnd(i,j,KMAX_BND-1) + Grid%u_ref = u_ref(i,j) + Grid%qw_ref = q(i,j,KMAX_MID,1) ! specific humidity + Grid%rho_ref = roa(i,j,KMAX_MID,1) + Grid%zen = zen(i,j) + Grid%coszen = coszen(i,j) + Grid%izen = max( 1, int ( Grid%zen + 0.5 ) )! 1 avoids zero in indices. + Grid%Idirect = Idirect(i,j) + Grid%Idiffuse = Idiffuse(i,j) + + !** prefer micromet signs and terminology here: + + Grid%Hd = -fh(i,j,1) ! Heat flux, *away from* surface + Grid%LE = -fl(i,j,1) ! Heat flux, *away from* surface + 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%rho_s = rho_surf(i,j) ! Should replace Met_ml calc. in future + + Grid%is_NWPsea = nwp_sea(i,j) + Grid%snow = snow(i,j) + + + Grid%invL = KARMAN * GRAV * -Grid%Hd & + / (CP*Grid%rho_s * Grid%ustar*Grid%ustar*Grid%ustar * Grid%t2 ) + + !.. we limit the range of 1/L to prevent numerical and printout problems + !.. and because we don't trust HIRLAM or other NWPs enough. + ! This range is very wide anyway. + + Grid%invL = max( -1.0, Grid%invL ) !! limit very unstable + Grid%invL = min( 1.0, Grid%invL ) !! limit very stable + + + ! wstar for particle deposition, based on Wesely + if(Grid%Hd < 0.0 ) then ! unstable stratification + Grid%wstar = (-GRAV * pzpbl(i,j) * Grid%Hd / & + (Grid%rho_ref * CP * th(i,j,KMAX_MID,1))) ** (1./3.) + else + Grid%wstar = 0. + end if + + nlu = LandCover(i,j)%ncodes + LULOOP: do ilu= 1, nlu + lu = LandCover(i,j)%codes(ilu) + + Sub(lu)%coverage = LandCover(i,j)%fraction(ilu) + Sub(lu)%LAI = LandCover(i,j)%LAI(ilu) + Sub(lu)%SAI = LandCover(i,j)%SAI(ilu) + Sub(lu)%hveg = LandCover(i,j)%hveg(ilu) + + !======================= + + call Get_SubMet(lu, debug_flag ) + + Sub(lu)%SWP = 0.0 ! Not yet implemented + !======================= + end do LULOOP + + end subroutine Get_CellMet + !======================================================================= + +end module CellMet_ml diff --git a/CheckStop_ml.f90 b/CheckStop_ml.f90 new file mode 100644 index 0000000..2d37c05 --- /dev/null +++ b/CheckStop_ml.f90 @@ -0,0 +1,147 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 CheckStop_ml + +! Provides routines to check for errors and if necessary close +! down the code neatly (** all processors **). + +! The generic routine CheckStopAll is defined, so that the code may be +! stopped if: +! (a) errmsg /= ok +! (b) int /= 0 (e.g. iostat index after read) +! (c) int1 /= int2 +! (d) string1 /= string2 +! (e) logical expression = true (e.g. lu < 0 for landuse index) + +! Dave Simpson, April-May 2007 +! + + implicit none + INCLUDE 'mpif.h' + INTEGER, private :: STATUS(MPI_STATUS_SIZE),INFO + + public :: StopAll + public :: CheckStop + private :: CheckStop_ok, CheckStop_okinfo, CheckStop_int1, CheckStop_int2, & + CheckStop_str2, CheckStop_TF + + interface CheckStop + module procedure CheckStop_ok + module procedure CheckStop_okinfo + module procedure CheckStop_int1 + module procedure CheckStop_int2 + module procedure CheckStop_str2 + module procedure CheckStop_TF + end interface CheckStop + + contains + + subroutine StopAll(errmsg) + character(len=*), intent(in) :: errmsg + + ! Stops all processors. + ! MPI_COMM_WORLD indicates all processors, in other programs you could have + ! different groups of processes. + ! INFO is the error message from MPI + + if ( errmsg /= "ok" ) then + write(*,*) "StopAll Called with", errmsg + write(*,*) "MPI_ABORT!!" + call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + end if + end subroutine StopAll + + + !---- Four variations on CheckStop: + + subroutine CheckStop_ok(errmsg) ! Test if errmsg /= "ok" + character(len=*), intent(in) :: errmsg + + if ( errmsg /= "ok" ) then + write(*,*) "CheckStop_ok Called with: errmsg ", errmsg + call StopAll(errmsg) + end if + end subroutine CheckStop_ok + + subroutine CheckStop_okinfo(errmsg,infomsg) ! Test if errmsg /= "ok" + character(len=*), intent(in) :: errmsg + character(len=*), intent(in) :: infomsg + + if ( errmsg /= "ok" ) then + write(*,*) "CheckStop_ok Called with: errmsg ", errmsg + write(*,*) " infomsg ", infomsg + call StopAll(errmsg) + end if + end subroutine CheckStop_okinfo + + subroutine CheckStop_int1(int1,infomsg) ! Test if int1 /= 0 + integer, intent(in) :: int1 + character(len=*), intent(in) :: infomsg + + if ( int1 /= 0 ) then + write(*,*) "CheckStopl_int1 Called with: int1 ", int1 + write(*,*) " infomsg ", infomsg + call StopAll(infomsg) + end if + end subroutine CheckStop_int1 + + subroutine CheckStop_int2(int1,int2, infomsg) ! Test if int1 /= int2 + integer, intent(in) :: int1, int2 + character(len=*), intent(in) :: infomsg + + if ( int1 /= int2 ) then + write(*,*) "CheckStopl_int2 Called with: int1 ", int1, " int2 ", int2 + write(*,*) " infomsg ", infomsg + call StopAll(infomsg) + end if + end subroutine CheckStop_int2 + + subroutine CheckStop_str2(str1,str2, infomsg) ! Test if str1 /= str2 + character(len=*), intent(in) :: str1, str2, infomsg + + if ( trim(str1) /= trim(str2) ) then + write(*,*) "CheckStopl_str2 Called with: str1 ", str1, " str2 ", str2 + write(*,*) " infomsg ", infomsg + call StopAll(infomsg) + end if + end subroutine CheckStop_str2 + + subroutine CheckStop_TF(is_error, infomsg) ! Test expression, e.g. lu<0 + logical, intent(in) :: is_error + character(len=*), intent(in) :: infomsg + + if ( is_error ) then + write(*,*) "CheckStopl_TF Called with: logical ", is_error + write(*,*) " infomsg ", infomsg + call StopAll(infomsg) + end if + end subroutine CheckStop_TF + +end module CheckStop_ml + diff --git a/Chem_ml.f90 b/Chem_ml.f90 new file mode 100644 index 0000000..f050e35 --- /dev/null +++ b/Chem_ml.f90 @@ -0,0 +1,65 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module Chemfields_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!_____________________________________________________________________________ +use Par_ml , only: MAXLIMAX,MAXLJMAX ! => x, y dimensions +use ModelConstants_ml , only: KMAX_MID ! => z dimension +use GenSpec_adv_ml, only: NSPEC_ADV ! => No. species +use GenSpec_shl_ml, only: NSPEC_SHL ! => No. species +use GenSpec_bgn_ml, only: NSPEC_BGN ! => No. species +implicit none +private + + !----------------- basic chemical fields ----------------------------------! + ! Here we declare and initialise to zero the chemical fields used in the ! + ! 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 & + ,PM_water (MAXLIMAX,MAXLJMAX,KMAX_MID) = 0.0 !water + + real, save, public :: & + cfac (NSPEC_ADV,MAXLIMAX,MAXLJMAX) = 1.0 + +!_____________________________________________________________________________ +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + end module Chemfields_ml +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!_____________________________________________________________________________ diff --git a/CoDep_ml.f90 b/CoDep_ml.f90 new file mode 100644 index 0000000..4675921 --- /dev/null +++ b/CoDep_ml.f90 @@ -0,0 +1,235 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 CoDep_ml + use CheckStop_ml, only : CheckStop + + ! In a future version, we might test for Ts_C > -2 instead of + ! Ts_C > 0 as we have now. + ! Also, F3 and F4 are defined here but not used. + + ! Still have RgsS_dry - in future rename to Rns_SO2_dry + + !--------------------------------------------------------------------------- + ! Calculates the acidity and humidity factors used in the EMEP model + ! deposition (for sulphur) and non-stomatal resistances Rns_SO2 and Rns_NH3. + !--------------------------------------------------------------------------- + ! For basic reference and methods, see + ! + ! Unidoc = + ! EMEP Report 1/2003, Part I. Unified EMEP Model Description. + ! + ! Also, + ! RIS: Smith, R.I., Fowler, D., Sutton, M.A., Flechard, C: and Coyle, M. + ! Atmos. Environ., 34, 3757-3777 + ! + Errata + pers. comm. with R.I.Smith + ! + ! and + ! Smith, Unpublished Note + ! Eiko Nemitz papers + !--------------------------------------------------------------------------- + + implicit none + + public :: CoDep_factors + private :: Tabulate ! pre-calculate many values to save CPU + + !/** Some parameters for the calculations + + integer, private, parameter :: TMIN = -40, TMAX = 40 ! Allowed temp. range + integer, private, parameter :: NTAB = 100 ! No. intervals used for tabulation + + real, private, save, dimension(0:100,2) :: tab_humidity_fac + real, private, save, dimension(0:100) :: tab_exp_rh ! For eqn (8.16) + real, private, save, dimension(0:NTAB) :: & + tab_acidity_fac, & + tab_F2,& ! For Unimod eqn (8.16) + tab_F4 ! equivalent for SO2 Rns_NH3 + + !/ Calculated values /outputs): + real, public, save :: & + RgsS_dry &! + ,RgsS_wet &! + ,humidity_fac &! to interpolate Gns across different RH + ,Rns_NH3 & ! Resistance for NH3 on ground (water) surface + ,Rns_SO2 ! Resistance for SO2 on ground (water) surface + +! Resistances for SO2 in low NH3 conditions + + real, private, parameter :: CEHd = 180.0, CEHw = 100.0 ! dry, wet, m/s + + logical, private, parameter :: MY_DEBUG = .false. + +contains +! ======================================================================= + + subroutine CoDep_factors( so2nh3ratio, Ts_C, frh, forest, debug_flag) +! ======================================================================= +! +! ======================================================================= + + +! Input: + + real, intent(in) :: so2nh3ratio ! so2/nh3 ratio + real, intent(in) :: Ts_C ! surface temp. (degrees C) + real, intent (in):: frh ! relative humidity (as a fraction) + logical, intent (in):: forest ! true if forest + logical, intent (in):: debug_flag ! true if forest + + + ! On first call we will tabulate Rns_NH3 + + logical, save :: my_first_call = .true. + + !local terms governing intermediary calculations in the evaluation of NH3_st: + + real, parameter :: BETA=1.0/22.0 ! Rns factors, see Unimod eqn (8.16) + real :: F1, F2 ! Rns factors, see Unimod eqn (8.16) + ! real :: F3, F4 ! (not used) + real :: a_SN ! so2/nh3 after correction with 0.6 + integer :: itemp ! integer Temp in deg.C + integer :: ia_SN ! 10*a_SN + integer :: IRH ! RH as percent + real :: acidity_fac ! to interpolate RgsS between high-low SO2/NH3 ratios + + if ( my_first_call ) then + + call Tabulate() + my_first_call = .false. + write(*,*) "First CoDep call, ", so2nh3ratio, Ts_C, frh, forest + + end if + + itemp = int( Ts_C + 0.5 ) + itemp = max(itemp, TMIN) ! For safety + itemp = min(itemp, TMAX) ! For safety + + a_SN = min(2.0,0.6*so2nh3ratio) ! NOTE: we multiply bu 0.6 to + ! correct for vertical grad error in local nh3 + ! Unidoc, eqn (8.15) + ia_SN = int( NTAB * a_SN/2.0 + 0.4999999 ) ! Spread values frm 0 to 2.0 + !ia_SN = min( 20, ia_SN) + IRH = max( 1, int( 100.0 * frh ) ) + if ( MY_DEBUG ) then + if ( IRH<1 .or. IRH>100 .or. ia_SN < 0 ) then + print *, "CODEP ERROR ", IRH, frh, ia_SN, a_SN + call CheckStop ( IRH<1 .or. IRH>100 , "CoDep IRH ERROR") + end if + end if + + !/ 1) Acidity factor & Rgs for sulphur: + + acidity_fac = tab_acidity_fac( ia_SN ) + + RgsS_dry = acidity_fac * CEHd + RgsS_wet = acidity_fac * CEHw + call CheckStop ( RgsS_dry<0.0 .or. RgsS_wet<0.0 , "CoDep NEG ERROR") + + !/ 2) Humidity factor: (F=forest, G=grass+other) + + if( forest ) then + humidity_fac = tab_humidity_fac(IRH,1) + else + humidity_fac = tab_humidity_fac(IRH,2) + end if + + + !/ 3) Rns_NH3 - see Unimod eqn (8.16) + ! =RIS eq. (24), modified by CEH Note + ! & Rns_SO2 - provisional !!! + + if (Ts_C >0 ) then ! Use "rh" - now in fraction 0..1.0 + + !F1 = 10.0 * log10(Ts_C+2.0) * exp(100.0*(1.0-frh)/7.0) + F1 = 10.0 * log10(Ts_C+2.0) * tab_exp_rh(IRH) + F2 = tab_F2( ia_SN ) + + Rns_NH3 = BETA * F1 * F2 + if(MY_DEBUG .and. debug_flag) then + write(*,*) "CODEP PRE ", IRH, frh, ia_SN, a_SN, F1, F2, Rns_NH3, BETA + end if + Rns_NH3 = min( 200.0, Rns_NH3) ! After discussion with Ron + Rns_NH3 = max( 10.0,Rns_NH3) + + !Ex F3 = 40.0 * log10(Ts_C+2.0) * exp(100.0*(1.0-frh)/25.0) + !Ex F4 = tab_F4( ia_SN ) + !Ex Rns_SO2 = F3 * F4 + Rns_SO2 = min( 200.0, Rns_SO2) ! After discussion with Ron + Rns_SO2 = max( 10.0,Rns_SO2) + + else if ( Ts_C > -5 ) then + + Rns_NH3=200.0 + Rns_SO2=200.0 + else + + Rns_NH3=1000.0 + Rns_SO2=1000.0 + end if !Ts_C + + + + end subroutine CoDep_factors + + !======================================================================= + + subroutine Tabulate() + !/** Tabulates humidity factors, + + real :: a_SN + integer :: IRH, rh_lim, veg, ia_SN + integer, parameter, dimension(2) :: & + Rhlim = (/ 85, 75 /) ! RH limits for F=forest, G=grass + + tab_humidity_fac(:,:) = 0.0 + + ! Acidity factor + do ia_SN = 1, NTAB + a_SN = ia_SN/real(NTAB) + tab_acidity_fac( ia_SN ) = exp( -(2.0- a_SN) ) + tab_F2 (ia_SN) = 10.0**( (-1.1099 * a_SN)+1.6769 ) + tab_F4 (ia_SN) = 10.0**( (0.55 * a_SN)-1.0 ) + end do + + do veg = 1, 2 + rh_lim = Rhlim(veg) + do IRH = rh_lim, 100 + tab_humidity_fac(IRH,veg) = ( (IRH-rh_lim)/(100-rh_lim) ) + end do + end do + + do IRH = 0, 100 + tab_exp_rh(IRH) = exp( (100.0-IRH)/7.0) + end do + + end subroutine Tabulate + !======================================================================= + +end module CoDep_ml + + diff --git a/Country_ml.f90 b/Country_ml.f90 new file mode 100644 index 0000000..f7b21e5 --- /dev/null +++ b/Country_ml.f90 @@ -0,0 +1,348 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Country_ml + + !+ Sets country index numbers (IC_xx), code, time-zones, and names + ! + ! Language : F + ! History : + ! 4th version: 06/03/2007 - jej/ds, sea areas split into flags etc, + ! 3rd version: 13/11/2003 - jej/ds, new countries, corrected 29 + ! 2nd version: 12/12/2001 - ds, added is_sea to country type + ! 1st version: 24/1/2001 - ds, using timezones from Vigdis. + ! + ! Notes: + ! Unfortunately doing the setting of the Country data needs the + ! subroutine Set_Countries, as doing this with a neat "parameter" + ! statement didn't work - there were too many continuation lines :-( + ! And I would have used the word countries instead of cc, but that made + ! the lines too long in Set-Countries.... + + ! Regions Atlantic (70) and Russia (71) outside EMEP defined separately, + ! as total emissions for Russia and the Atlantic often are reported for + ! EMEP domain only and then gridded according to this total. + + ! timefac_index under cc as defined below assigns timefactors to + ! country/region/emission_type. As an example defining Bavaria as + ! a separate region with timefactors as in Germany. + + implicit none + + public :: Country_Init ! sets country details + + integer, parameter, public :: NLAND = 349 + logical, parameter, private :: T = .true. ! shorthand + logical, parameter, private :: F = .false. ! shorthand + + !/ to be set in Country_Init: + + type, public :: cc + character(len=3) :: code ! up to 3 letter land code + integer :: index ! index number (corresponds to + ! numbering in emission files read inn + logical :: is_sea ! 1 for sea area, 0 otherwise + integer :: timefac_index ! see explanation above + integer :: timezone ! timezone, deviation from UTC time + character(len=30) :: name ! name of country/region/emission_type + end type cc + + type(cc), public, save, dimension(NLAND) :: Country + + integer, parameter, public :: IC_AL = 1 ! Albania + 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_DK = 6 ! Denmark + integer, parameter, public :: IC_FI = 7 ! Finland + integer, parameter, public :: IC_FR = 8 ! France + integer, parameter, public :: IC_GDR = 9 ! Former East Germany + integer, parameter, public :: IC_FRG = 10 ! Former West Germany + integer, parameter, public :: IC_GR = 11 ! Greece + integer, parameter, public :: IC_HU = 12 ! Hungary + integer, parameter, public :: IC_IS = 13 ! Iceland + integer, parameter, public :: IC_IE = 14 ! Ireland + integer, parameter, public :: IC_IT = 15 ! Italy + integer, parameter, public :: IC_LU = 16 ! Luxembourg + integer, parameter, public :: IC_NL = 17 ! Netherlands + integer, parameter, public :: IC_NO = 18 ! Norway + integer, parameter, public :: IC_PL = 19 ! Poland + integer, parameter, public :: IC_PT = 20 ! Portugal + integer, parameter, public :: IC_RO = 21 ! Romania + integer, parameter, public :: IC_ES = 22 ! Spain + integer, parameter, public :: IC_SE = 23 ! Sweden + integer, parameter, public :: IC_CH = 24 ! Switzerland + integer, parameter, public :: IC_TR = 25 ! Turkey + 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 + integer, parameter, public :: IC_BAS = 30 ! The Baltic Sea + integer, parameter, public :: IC_NOS = 31 ! The North Sea + integer, parameter, public :: IC_ATL = 32 ! Remaining NE Atlantic Ocean + integer, parameter, public :: IC_MED = 33 ! The Mediterranean Sea + integer, parameter, public :: IC_BLS = 34 ! The Black Sea + integer, parameter, public :: IC_NAT = 35 ! Natural marine sources + integer, parameter, public :: IC_RUO = 36 ! Kola/Karelia + integer, parameter, public :: IC_RUP = 37 ! St.Petersburg/Novgorod-Pskov + integer, parameter, public :: IC_RUA = 38 ! Kaliningrad + integer, parameter, public :: IC_BY = 39 ! Belarus + integer, parameter, public :: IC_UA = 40 ! Ukraine + integer, parameter, public :: IC_MD = 41 ! Moldova, + integer, parameter, public :: IC_RUR = 42 ! Rest + integer, parameter, public :: IC_EE = 43 ! Estonia + integer, parameter, public :: IC_LV = 44 ! Latvia + integer, parameter, public :: IC_LT = 45 ! Lithuania + integer, parameter, public :: IC_CZ = 46 ! Czech + integer, parameter, public :: IC_SK = 47 ! Slovakia + 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_MK = 52 ! Macedonia, + integer, parameter, public :: IC_KZ = 53 ! Kazakstan + integer, parameter, public :: IC_GE = 54 ! Georgia + integer, parameter, public :: IC_CY = 55 ! Cyprus + integer, parameter, public :: IC_AM = 56 ! Armenia + integer, parameter, public :: IC_MT = 57 ! Malta + integer, parameter, public :: IC_ASI = 58 ! Other Asian + integer, parameter, public :: IC_LI = 59 ! Lihtenstein + integer, parameter, public :: IC_DE = 60 ! Germany + integer, parameter, public :: IC_RU = 61 ! Russian + integer, parameter, public :: IC_MC = 62 ! Monaco + integer, parameter, public :: IC_NOA = 63 ! North Africa + integer, parameter, public :: IC_EU = 64 ! European + integer, parameter, public :: IC_US = 65 ! USA + integer, parameter, public :: IC_CA = 66 ! Canada + integer, parameter, public :: IC_DUMMY1 = 67 ! Not-defined + integer, parameter, public :: IC_KG = 68 ! Kyrgyzstan(outside dommain) + integer, parameter, public :: IC_AZ = 69 ! Azerbaijan + integer, parameter, public :: IC_ATX = 70 ! ATL outside emep + integer, parameter, public :: IC_RUX = 71 ! RU outside emep + integer, parameter, public :: IC_RS = 72 ! Serbia + integer, parameter, public :: IC_ME = 73 ! Montenegro + + + ! extra subdivisions: + ! Baltic Sea (30) + integer, parameter, public :: IC_BA2 = 302 + integer, parameter, public :: IC_BA3 = 303 + integer, parameter, public :: IC_BA4 = 304 + integer, parameter, public :: IC_BA5 = 305 + integer, parameter, public :: IC_BA6 = 306 + integer, parameter, public :: IC_BA7 = 307 + integer, parameter, public :: IC_BA8 = 308 + integer, parameter, public :: IC_BA9 = 309 + + ! North Sea (31) + integer, parameter, public :: IC_NS2 = 312 + integer, parameter, public :: IC_NS3 = 313 + integer, parameter, public :: IC_NS4 = 314 + integer, parameter, public :: IC_NS5 = 315 + integer, parameter, public :: IC_NS6 = 316 + integer, parameter, public :: IC_NS7 = 317 + integer, parameter, public :: IC_NS8 = 318 + integer, parameter, public :: IC_NS9 = 319 + + ! Remaining NE Atlantic (32) + integer, parameter, public :: IC_AT2 = 322 + integer, parameter, public :: IC_AT3 = 323 + integer, parameter, public :: IC_AT4 = 324 + integer, parameter, public :: IC_AT5 = 325 + integer, parameter, public :: IC_AT6 = 326 + integer, parameter, public :: IC_AT7 = 327 + integer, parameter, public :: IC_AT8 = 328 + integer, parameter, public :: IC_AT9 = 329 + + ! Mediterranean (33) + integer, parameter, public :: IC_ME2 = 332 + integer, parameter, public :: IC_ME3 = 333 + integer, parameter, public :: IC_ME4 = 334 + integer, parameter, public :: IC_ME5 = 335 + integer, parameter, public :: IC_ME6 = 336 + integer, parameter, public :: IC_ME7 = 337 + integer, parameter, public :: IC_ME8 = 338 + integer, parameter, public :: IC_ME9 = 339 + + ! Black Sea (34) + integer, parameter, public :: IC_BL2 = 342 + integer, parameter, public :: IC_BL3 = 343 + integer, parameter, public :: IC_BL4 = 344 + integer, parameter, public :: IC_BL5 = 345 + integer, parameter, public :: IC_BL6 = 346 + integer, parameter, public :: IC_BL7 = 347 + integer, parameter, public :: IC_BL8 = 348 + integer, parameter, public :: IC_BL9 = 349 + + + + + + contains + ! + subroutine Country_Init() + + ! Set the country details. Note that time-zones for some areas are either + ! difficult (Russia should be 3 to 12) or not relevant (sea areas, + ! volcanoes). This needs to be thought about in using these figures. + + integer :: iland + + ! first define all countries as undefined, just in case + do iland=1,NLAND + Country(iland) = cc( "N/A" , iland ,F, 17 , 0 , "Not_defined " ) + enddo + + !-------------- code index sea timefac_index timezone Name ------------! + +Country( IC_AL ) = cc( "AL " , 1 ,F, 1, 1 , "Albania " ) +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_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 " ) +Country( IC_GDR) = cc( "GDR" , 9 ,F, 9, 1 , "Former East Germany " ) +Country( IC_FRG) = cc( "FRG" , 10 ,F, 10, 1 , "Former Fed. Rep. of Germany " ) +Country( IC_GR ) = cc( "GR " , 11 ,F, 11, 2 , "Greece " ) +Country( IC_HU ) = cc( "HU " , 12 ,F, 12, 1 , "Hungary " ) +Country( IC_IS ) = cc( "IS " , 13 ,F, 13, 0 , "Iceland " ) +Country( IC_IE ) = cc( "IE " , 14 ,F, 14, 0 , "Ireland " ) +Country( IC_IT ) = cc( "IT " , 15 ,F, 15, 1 , "Italy " ) +Country( IC_LU ) = cc( "LU " , 16 ,F, 16, 1 , "Luxembourg " ) +Country( IC_NL ) = cc( "NL " , 17 ,F, 17, 1 , "Netherlands " ) +Country( IC_NO ) = cc( "NO " , 18 ,F, 18, 1 , "Norway " ) +Country( IC_PL ) = cc( "PL " , 19 ,F, 19, 1 , "Poland " ) +Country( IC_PT ) = cc( "PT " , 20 ,F, 20, 1 , "Portugal " ) +Country( IC_RO ) = cc( "RO " , 21 ,F, 21, 2 , "Romania " ) +Country( IC_ES ) = cc( "ES " , 22 ,F, 22, 1 , "Spain " ) +Country( IC_SE ) = cc( "SE " , 23 ,F, 23, 1 , "Sweden " ) +Country( IC_CH ) = cc( "CH " , 24 ,F, 24, 1 , "Switzerland " ) +Country( IC_TR ) = cc( "TR " , 25 ,F, 25, 2 , "Turkey " ) +Country( IC_SU ) = cc( "SU " , 26 ,F, 26, 3 , "Former USSR " ) +Country( IC_GB ) = cc( "GB " , 27 ,F, 27, 0 , "United Kingdom " ) +Country( IC_VUL) = cc( "VUL" , 28 ,F, 28, 1 , "Volcanoes " ) +Country( IC_REM) = cc( "REM" , 29 ,F, 29, 1 , "Remaining land areas " ) +Country( IC_BAS) = cc( "BAS" , 30 ,T, 30, 1 , "The Baltic Sea " ) +Country( IC_NOS) = cc( "NOS" , 31 ,T, 31, 1 , "The North Sea " ) +Country( IC_ATL) = cc( "ATL" , 32 ,T, 32, 1 , "Remaining NE Atlantic Ocean " ) +Country( IC_MED) = cc( "MED" , 33 ,T, 33, 1 , "The Mediterranean Sea " ) +Country( IC_BLS) = cc( "BLS" , 34 ,T, 34, 1 , "The Black Sea " ) +Country( IC_NAT) = cc( "NAT" , 35 ,F, 35, 1 , "Natural marine sources " ) +Country( IC_RUO) = cc( "RUO" , 36 ,F, 36, 3 , "Kola/Karelia " ) +Country( IC_RUP) = cc( "RUP" , 37 ,F, 37, 3 , "St.Petersburg/Novgorod-Pskov " ) +Country( IC_RUA) = cc( "RUA" , 38 ,F, 38, 3 , "Kaliningrad " ) +Country( IC_BY ) = cc( "BY " , 39 ,F, 39, 2 , "Belarus " ) +Country( IC_UA ) = cc( "UA " , 40 ,F, 40, 2 , "Ukraine " ) +Country( IC_MD ) = cc( "MD " , 41 ,F, 41, 2 , "Moldova, Republic of " ) +Country( IC_RUR) = cc( "RUR" , 42 ,F, 42, 4 , "Rest of Russia " ) +Country( IC_EE ) = cc( "EE " , 43 ,F, 43, 2 , "Estonia " ) +Country( IC_LV ) = cc( "LV " , 44 ,F, 44, 2 , "Latvia " ) +Country( IC_LT ) = cc( "LT " , 45 ,F, 45, 2 , "Lithuania " ) +Country( IC_CZ ) = cc( "CZ " , 46 ,F, 46, 1 , "Czech " ) +Country( IC_SK ) = cc( "SK " , 47 ,F, 47, 1 , "Slovakia " ) +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_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 " ) +Country( IC_CY ) = cc( "CY " , 55 ,F, 55, 2 , "Cyprus " ) +Country( IC_AM ) = cc( "AM " , 56 ,F, 56, 4 , "Armenia " ) +Country( IC_MT ) = cc( "MT " , 57 ,F, 57, 1 , "Malta " ) +Country( IC_ASI) = cc( "ASI" , 58 ,F, 58, 0 , "Other Asian areas " ) +Country( IC_LI ) = cc( "LI " , 59 ,F, 59, 1 , "Lichtenstein " ) +Country( IC_DE ) = cc( "DE " , 60 ,F, 60, 1 , "Germany " ) +Country( IC_RU ) = cc( "RU " , 61 ,F, 61, 3 , "Russian Federation " ) +Country( IC_MC ) = cc( "MC " , 62 ,F, 62, 1 , "Monaco " ) +Country( IC_NOA) = cc( "NOA" , 63 ,F, 63, 1 , "North Africa " ) +Country( IC_EU ) = cc( "EU " , 64 ,F, 64, 1 , "European Community " ) +Country( IC_US ) = cc( "US " , 65 ,F, 65, 1 , "USA " ) +Country( IC_CA ) = cc( "CA " , 66 ,F, 66, 1 , "Canada " ) +Country( IC_DUMMY1 ) & + = cc( "N/A" , 67 ,F, 67, 0 , "Not_defined " ) +Country( IC_KG ) = cc( "KG " , 68 ,F, 68, 6 , "Kyrgyzstan " ) +Country( IC_AZ ) = cc( "AZ " , 69 ,F, 69, 3 , "Azerbaijan " ) +Country( IC_ATX) = cc( "ATX" , 70 ,T, 32, 1 , "Atlantic outside. EMEP " ) +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 " ) + + +! Sea areas splitt according to innside/outside 12 nautical mile zone, +! ferries/cargo ships, registred inside/outside EU +Country( IC_BA2 ) = cc( "BA2" ,302 ,T, 30, 1 , "Baltic EU cargo outs.12 " ) +Country( IC_BA3 ) = cc( "BA3" ,303 ,T, 30, 1 , "Baltic ROW cargo outs. 12 " ) +Country( IC_BA4 ) = cc( "BA4" ,304 ,T, 30, 1 , "Baltic EU cargo ins. 12 " ) +Country( IC_BA5 ) = cc( "BA5" ,305 ,T, 30, 1 , "Baltic ROW cargo ins. 12 " ) +Country( IC_BA6 ) = cc( "BA6" ,306 ,T, 30, 1 , "Baltic EU ferries outs.12 " ) +Country( IC_BA7 ) = cc( "BA7" ,307 ,T, 30, 1 , "Baltic ROW ferries outs. 12 " ) +Country( IC_BA8 ) = cc( "BA8" ,308 ,T, 30, 1 , "Baltic EU ferries ins. 12 " ) +Country( IC_BA9 ) = cc( "BA9" ,309 ,T, 30, 1 , "Baltic ROW ferries ins. 12 " ) + +Country( IC_NS2 ) = cc( "NS2" ,312 ,T, 31, 1 , "N. Sea EU cargo outs.12 " ) +Country( IC_NS3 ) = cc( "NS3" ,313 ,T, 31, 1 , "N. Sea ROW cargo outs. 12 " ) +Country( IC_NS4 ) = cc( "NS4" ,314 ,T, 31, 1 , "N. Sea EU cargo ins. 12 " ) +Country( IC_NS5 ) = cc( "NS5" ,315 ,T, 31, 1 , "N. Sea ROW cargo ins. 12 " ) +Country( IC_NS6 ) = cc( "NS6" ,316 ,T, 31, 1 , "N. Sea EU ferries outs.12 " ) +Country( IC_NS7 ) = cc( "NS7" ,317 ,T, 31, 1 , "N. Sea ROW ferries outs. 12 " ) +Country( IC_NS8 ) = cc( "NS8" ,318 ,T, 31, 1 , "N. Sea EU ferries ins. 12 " ) +Country( IC_NS9 ) = cc( "NS9" ,319 ,T, 31, 1 , "N. Sea ROW ferries ins. 12 " ) + +Country( IC_AT2 ) = cc( "AT2" ,322 ,T, 32, 1 , "Atlant EU cargo outs.12 " ) +Country( IC_AT3 ) = cc( "AT3" ,323 ,T, 32, 1 , "Atlant ROW cargo outs. 12 " ) +Country( IC_AT4 ) = cc( "AT4" ,324 ,T, 32, 1 , "Atlant EU cargo ins. 12 " ) +Country( IC_AT5 ) = cc( "AT5" ,325 ,T, 32, 1 , "Atlant ROW cargo ins. 12 " ) +Country( IC_AT6 ) = cc( "AT6" ,326 ,T, 32, 1 , "Atlant EU ferries outs.12 " ) +Country( IC_AT7 ) = cc( "AT7" ,327 ,T, 32, 1 , "Atlant ROW ferries outs. 12 " ) +Country( IC_AT8 ) = cc( "AT8" ,328 ,T, 32, 1 , "Atlant EU ferries ins. 12 " ) +Country( IC_AT9 ) = cc( "AT9" ,329 ,T, 32, 1 , "Atlant ROW ferries ins. 12 " ) + +Country( IC_ME2 ) = cc( "ME2" ,332 ,T, 33, 1 , "Medite EU cargo outs.12 " ) +Country( IC_ME3 ) = cc( "ME3" ,333 ,T, 33, 1 , "Medite ROW cargo outs. 12 " ) +Country( IC_ME4 ) = cc( "ME4" ,334 ,T, 33, 1 , "Medite EU cargo ins. 12 " ) +Country( IC_ME5 ) = cc( "ME5" ,335 ,T, 33, 1 , "Medite ROW cargo ins. 12 " ) +Country( IC_ME6 ) = cc( "ME6" ,336 ,T, 33, 1 , "Medite EU ferries outs.12 " ) +Country( IC_ME7 ) = cc( "ME7" ,337 ,T, 33, 1 , "Medite ROW ferries outs. 12 " ) +Country( IC_ME8 ) = cc( "ME8" ,338 ,T, 33, 1 , "Medite EU ferries ins. 12 " ) +Country( IC_ME9 ) = cc( "ME9" ,339 ,T, 33, 1 , "Medite ROW ferries ins. 12 " ) + +Country( IC_BL2 ) = cc( "BL2" ,342 ,T, 34, 1 , "B. Sea EU cargo outs.12 " ) +Country( IC_BL3 ) = cc( "BL3" ,343 ,T, 34, 1 , "B. Sea ROW cargo outs. 12 " ) +Country( IC_BL4 ) = cc( "BL4" ,344 ,T, 34, 1 , "B. Sea EU cargo ins. 12 " ) +Country( IC_BL5 ) = cc( "BL5" ,345 ,T, 34, 1 , "B. Sea ROW cargo ins. 12 " ) +Country( IC_BL6 ) = cc( "BL6" ,346 ,T, 34, 1 , "B. Sea EU ferries outs.12 " ) +Country( IC_BL7 ) = cc( "BL7" ,347 ,T, 34, 1 , "B. Sea ROW ferries outs. 12 " ) +Country( IC_BL8 ) = cc( "BL8" ,348 ,T, 34, 1 , "B. Sea EU ferries ins. 12 " ) +Country( IC_BL9 ) = cc( "BL9" ,349 ,T, 34, 1 , "B. Sea ROW ferries ins. 12 " ) + + + end subroutine Country_Init +end module Country_ml diff --git a/DO3SE_ml.f90 b/DO3SE_ml.f90 new file mode 100644 index 0000000..7891174 --- /dev/null +++ b/DO3SE_ml.f90 @@ -0,0 +1,304 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 DO3SE_ml + + use CheckStop_ml, only : CheckStop + use LocalVariables_ml, only : L ! & +! t2C => L%t2c &! surface temp. at height 2m (deg. C) +! ,vpd => L%vpd &! vapour pressure deficit (kPa) +! ,SWP => L%SWP &! soil water potential (MPa) +! ,PARsun => L%PARsun &! photosynthetic active radn. for sun-leaves +! ,PARshade => L%PARshade &! " " for shade leaves +! ,LAIsunfrac => L%LAIsunfrac ! fraction of LAI in sun + + use ModelConstants_ml, only : NLANDUSE + + implicit none + private + +!============================================================================= +! Contains + + public :: Init_DO3SE ! Reads DOSEinputs.csv -> gmax + all f params + public :: g_stomatal ! produces g_sto and g_sun + public :: fPhenology ! -> f_phen + + ! Make public for output testing + real, public, save :: f_light, f_temp, f_vpd, f_swp, f_env + real, public, save :: f_phen = 888 ! But set elsewhere + +!----------------------------------------------------------------------------- +! Notes: Basis is Emberson et al, EMEP Report 6/2000 +! Numbers updated to Mapping Manual, 2004 and changes recommended +! in Tuovinen et al, 2004 +! + + ! 2 ) Phenology part + + !/***** Data to be read from Phenology_inputs.dat: + + type, public :: do3se_type + character(len=10) :: code + character(len=15) :: name + real:: g_max ! max. value conductance g_s + real:: f_min ! min. value Conductance, factor + real:: f_phen_a ! f_phen a (v. start of season + real:: f_phen_b ! f_phen b + real:: f_phen_c ! f_phen c + real:: f_phen_d ! f_phen d + real:: f_phen_Slen ! Length of Startup (days) = e + real:: f_phen_Elen ! Length of End period (days) = f + real:: Astart_rel ! + real:: Aend_rel ! + real:: f_light ! light coefficient + real:: T_min ! temperature when f_temp starts + real:: T_opt ! temperature when f_temp max. + real:: T_max ! temperature when f_temp stops + real:: RgsS ! ground surface resistance, Sulphur + real:: RgsO ! ground surface resistance, Ozone + real:: VPD_max ! threshold VPD when relative f = f_min + real:: VPD_min ! threshold VPD when relative f = 1 + real:: SWP_max ! threshold SWP when relative f = 1 + real:: PWP ! threshold SWP when relative f = f_min + ! and assumed equal to permanent wilting point + real:: rootdepth ! root depth (mm) + real:: Lw ! cros-wind leaf dimension (ony used for IAM) + end type do3se_type + + type(do3se_type), public, dimension(NLANDUSE) :: do3se + + logical, private, parameter :: MY_DEBUG = .false. + real, private, dimension(7) :: needed ! For debugging + + +contains +!======================================================================= + !======================================================================= + subroutine Init_DO3SE(io_num,fname,wanted_codes,io_msg) + !======================================================================= + integer, intent(in) :: io_num + character(len=*), intent(in) :: fname + character(len=*), dimension(:), intent(in) :: wanted_codes + character(len=*), intent(inout) :: io_msg + character(len=300) :: inputline + integer :: lu, ios + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Read data (still old-style reading, on all processors) + + open(unit=io_num,file=fname,status="old",& + action="read",position="rewind",iostat=ios) + call CheckStop(ios,"ERROR : Opening " // fname) + + + !------ Read in file. Lines beginning with "!" are taken as + ! comments and skipped + + lu = 1 + do + read(unit=io_num,fmt="(a200)",iostat=ios) inputline + + if ( ios /= 0 ) then !! End of File, hopefully + exit + end if + + if( inputline(1:1) == "!" ) then ! Is a comment + !print *, "COMMENT: ", trim(inputline) + cycle + end if + + read(unit=inputline,fmt=*) do3se(lu) + call CheckStop( wanted_codes(lu), do3se(lu)%code, "DO3SE MATCHING") + lu = lu + 1 + end do + close(unit=io_num) + + end subroutine Init_DO3SE + +!======================================================================= + + subroutine g_stomatal(lu) +!======================================================================= + +! Calculates stomatal conductance g_sto based upon methodology from +! EMEP MSC-W Note 6/00 and Mapping Manual (2004), and revisions (Simpson +! and Emberson, Chapter 5, EMEP Rep 1/2006, Mapping Manual revisions, 2007, +! and l. Emberson Notes from Forest group, Dec. 2007): +! +! g_sto = [g_max * f_pot * f_light * f_temp * f_vpd * f_swp ]/41000.0 +! + + integer, intent(in) :: lu + +! Outputs: +! L%g_sto, L%g_sun ! stomatal conductance for canopy and sun-leaves + + ! environmental f factors + + real :: f_sun ! light-factor for upper-canopy sun-leaves + real :: f_shade ! shade-leaf contribution to f_light + + real :: dg, dTs, bt ! for temperate calculations + real :: mmol2sm ! Units conversion, mmole/m2/s to s/m + + + +!..1 ) Calculate f_phen. Max value is 1.0. +!--------------------------------------- +! Not done here! - these calculations only needed once per day +!-------------------------------------------------------------------- + + +!..2 ) Calculate f_light +!--------------------------------------- +! Calculate f_light, using methodology as described in Emberson et +! al. (1998), eqns. 31-35, based upon sun/shade method of +! Norman (1979,1982) + + f_sun = (1.0 - exp (-do3se(lu)%f_light*L%PARsun ) ) + f_shade = (1.0 - exp (-do3se(lu)%f_light*L%PARshade) ) + + f_light = L%LAIsunfrac * f_sun + (1.0 - L%LAIsunfrac) * f_shade + +!-------------------------------------------------------------------- + + +!..3) Calculate f_temp +!--------------------------------------- +! Asymmetric function from Mapping Manual +! NB _ much more efficient to tabulate this - do later! + + dg = ( do3se(lu)%T_opt - do3se(lu)%T_min ) + bt = ( do3se(lu)%T_max - do3se(lu)%T_opt ) / dg + dTs = max( do3se(lu)%T_max - L%t2C, 0.0 ) !CHECK why max? + f_temp = dTs / ( do3se(lu)%T_max - do3se(lu)%T_opt ) + f_temp = ( L%t2C - do3se(lu)%T_min ) / dg * f_temp**bt + + f_temp = max( f_temp, 0.01 ) ! Revised usage of min value during 2007 + + +!..4) Calculate f_vpd +!--------------------------------------- + + f_vpd = do3se(lu)%f_min + & + (1.0-do3se(lu)%f_min) * (do3se(lu)%VPD_min - L%vpd )/ & + (do3se(lu)%VPD_min - do3se(lu)%VPD_max ) + f_vpd = min(f_vpd, 1.0) + f_vpd = max(f_vpd, do3se(lu)%f_min) + + +!..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. + + f_swp = do3se(lu)%f_min + & + (1-do3se(lu)%f_min)*(do3se(lu)%PWP-L%SWP)/ & + (do3se(lu)%PWP-do3se(lu)%SWP_max) + f_swp = min(1.0,f_swp) + + +!.. And finally, +!--------------------------------------- +! ( with revised usage of min value for f_temp during 2007) + + f_env = f_vpd * f_swp + f_env = max( f_env, do3se(lu)%f_min ) + f_env = max( f_temp, 0.01) * f_env + + f_env = f_phen * f_env * f_light ! Canopy average + +! From mmol O3/m2/s to s/m given in Jones, App. 3, gives 41000 for 20 deg.C ) +! (should we just use P=100 hPa?) + + mmol2sm = 8.3144e-8 * L%t2 ! 0.001 * RT/P + + L%g_sto = do3se(lu)%g_max * f_env * mmol2sm + + L%g_sun = L%g_sto * f_sun/f_light ! sunlit part + + + if ( MY_DEBUG ) then + needed = (/ L%t2C,L%t2,L%vpd ,L%SWP ,& + L%PARsun ,L%PARshade ,L%LAIsunfrac /) + if ( any( needed(:) < -998.0 )) then + print *, needed + call CheckStop("ERROR in g_stomatal, Missing data") + end if + ! debug_flag not implement yet. + !if ( debug_flag ) write(*,*) "G_STOMATAL f_temp, _vpd, _swp, _light", & + ! f_temp, f_vpd, f_swp, f_light + end if + + + end subroutine g_stomatal + +!=========================================================================== + + elemental function fPhenology(lu,code,jday,SGS,EGS,debug_flag) result (fphen) + real :: fphen + +! Input + integer, intent(in) :: lu + character(len=*), intent(in) :: code + integer, intent(in) :: jday + integer, intent(in):: SGS, EGS + logical, intent(in) :: debug_flag + real :: a,b,c,d,Slen,Elen,Astart, Aend + + a = do3se(lu)%f_phen_a + b = do3se(lu)%f_phen_b + c = do3se(lu)%f_phen_c + d = do3se(lu)%f_phen_d + Slen = do3se(lu)%f_phen_Slen ! e + Elen = do3se(lu)%f_phen_Elen ! f + + Astart = SGS + do3se(lu)%Astart_rel + Aend = EGS - do3se(lu)%Aend_rel + + + if ( jday < SGS ) then + fphen = 0.0 + else if ( jday <= Astart ) then + fphen = a + else if ( jday <= Astart+Slen ) then + fphen = b + (c-b) * ( jday-Astart)/real(Slen) + else if ( jday <= Aend-Elen ) then + fphen = c + else if ( jday < Aend ) then + fphen = d + (c-d) * ( Aend-jday)/real(Elen) + else if ( jday <= EGS ) then + fphen = d + else + fphen = 0.0 + end if + +end function fPhenology + + +end module DO3SE_ml diff --git a/DefPhotolysis_ml.f90 b/DefPhotolysis_ml.f90 new file mode 100644 index 0000000..50ae629 --- /dev/null +++ b/DefPhotolysis_ml.f90 @@ -0,0 +1,337 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! + +!+ Photolysis coefficients +!------------------------------------------------------------------------------- + + module DefPhotolysis_ml +!------------------------------------------------------------------------------- + +! Data needed for photolysis calculation. NPHODIS is the number of +! tabulated rates from the Phodis model. NRCPHOT (<=NPHODIS) is the +! number of photolysis rats needed by the model +! +! 10/10/01 - corrected and tidied up by jej. +! 11/10/01 - NDISS removed, minor F90 changes and docs +! added. NLAT and CLOUDTOP added. +!------------------------------------------------------------------------------- + + use CheckStop_ml, only: CheckStop + use GridValues_ml , only : gb + use Io_ml, only : IO_DJ, open_file, ios + use Met_ml , only : cc3d,cc3dmax,z_bnd + use ModelConstants_ml, only: KMAX_MID, KCHEMTOP, NPROC + use Par_ml , only : me,MAXLIMAX,MAXLJMAX + use LocalVariables_ml, only : Grid ! => izen + implicit none + private + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + integer, public, parameter :: & + NRCPHOT = 17 ! Number of photolytic reactions + + real, public, dimension(NRCPHOT,KCHEMTOP:KMAX_MID), & + save :: rcphot ! photolysis rates - main output + + real, public, save :: sum_rcphot ! was jej's sum1, for debug only + logical, public, parameter :: DEBUG_DJ = .false. + + integer, parameter, private :: & + HORIZON = 90 & ! Integer solar zenith angle at sunset + , CLOUDTOP = 6 ! k-value above which clear-sky dj assumed + ! (since..... Joffen?) + + integer, parameter, private :: & + NPHODIS = 17 & ! Max possible NRCPHOT + ,NLAT = 6 ! No. latitude outputs + + real, private, dimension(NPHODIS,KCHEMTOP:KMAX_MID,HORIZON,NLAT) :: dj + + real, private, dimension(NPHODIS,KCHEMTOP:KMAX_MID,HORIZON) :: & + djcl1 & + ,djcl3 + +! Indices of photolysis rates as available from Phodis files: + + integer, public, parameter :: & + IDAO3 = 1 , IDBO3 = 2 , IDNO2 = 3 , & + IDH2O2 = 4 , IDHNO3 = 5 , IDACH2O = 6 , & + IDBCH2O = 7 , IDCH3CHO = 8 , IDCH3COX = 9 , & + IDCH3COY = 10 , IDHCOHCO = 11 , IDRCOHCO = 12 , & + IDNO3 = 13 , IDN2O5 = 14 , IDCH3O2H = 15 , & + IDHO2NO2 = 16 , IDACETON = 17 + + !/ subroutines: + + public :: readdiss + public :: setup_phot + + contains + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine readdiss(newseason) + + integer :: newseason + + integer :: k & ! help index + ,izn & ! integer zenith angle + ,info & ! used for broadcast + ,nr & ! numbering of photolytic reactions + ,la ! counting every 10 deg. latitude + real myz + character*20 fname1, fname2, fname3 + + + + + +! Open, read and broadcast clear sky rates +!--------------- + + if(me == 0)then + write(fname1,fmt='(''jclear'',i2.2,''.dat'')') newseason + call open_file(IO_DJ,"r",fname1,needed=.true.) + call CheckStop(ios,"DefPhotolysis: ios error in jclear ") + endif + + +! Format of input data from Phodis - careful with "17" and NPHODIS +999 FORMAT(1x, f8.3, 17(1x, 1pe8.2)) + + + if(me == 0)then + + do la = 1,NLAT + do izn = 1,HORIZON + do k = 1,KCHEMTOP + read(IO_DJ,999) myz,(dj(nr,KCHEMTOP,izn,la),nr=1,NPHODIS) + end do + do k = KCHEMTOP+1,KMAX_MID + read(IO_DJ,999) myz,(dj(nr,k,izn,la),nr=1,NPHODIS) + end do ! k + end do ! izn + end do ! la + close(IO_DJ) + endif ! me = 0 + + CALL MPI_BCAST(dj ,8*NPHODIS*(KMAX_MID-KCHEMTOP+1)*HORIZON*NLAT,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + + + +! Open, read and broadcast light cloud rates +!--------------- + + if(me == 0)then + write(fname2,fmt='(''jcl1km'',i2.2,''.dat'')') newseason + call open_file(IO_DJ,"r",fname2,needed=.true.) + call CheckStop(ios,"DefPhotolysis: ios error in jcl1km ") + endif + + + if(me == 0)then + + do izn = 1,HORIZON + do k = 1,KCHEMTOP + read(IO_DJ,999) myz,(djcl1(nr,KCHEMTOP,izn),nr=1,NPHODIS) + end do + do k = KCHEMTOP+1,KMAX_MID + read(IO_DJ,999) myz,(djcl1(nr,k,izn),nr=1,NPHODIS) + end do + end do ! izn + + do izn = 1,HORIZON + do k = KCHEMTOP,KMAX_MID + do nr=1,NPHODIS + djcl1(nr,k,izn)=djcl1(nr,k,izn)/dj(nr,k,izn,3)-1.0 + enddo ! nr + end do ! k + end do ! izn + close(IO_DJ) + endif ! me = 0 + + CALL MPI_BCAST(djcl1 ,8*NPHODIS*(KMAX_MID-KCHEMTOP+1)*HORIZON,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + + + +! Open, read and broadcast dense cloud rates +!--------------- + + if(me == 0)then + write(fname3,fmt='(''jcl3km'',i2.2,''.dat'')') newseason + call open_file(IO_DJ,"r",fname3,needed=.true.) + call CheckStop(ios,"DefPhotolysis: ios error in jcl3km ") + endif + + + if(me == 0)then + + do izn = 1,HORIZON + do k = 1,KCHEMTOP + read(IO_DJ,999) myz,(djcl3(nr,KCHEMTOP,izn),nr=1,NPHODIS) + end do + do k = KCHEMTOP+1,KMAX_MID + read(IO_DJ,999) myz,(djcl3(nr,k,izn),nr=1,NPHODIS) + end do ! k + end do ! izn + close(IO_DJ) + do izn = 1,HORIZON + do k = KCHEMTOP,KMAX_MID + do nr=1,NPHODIS + djcl3(nr,k,izn)=djcl3(nr,k,izn)/dj(nr,k,izn,3)-1. + enddo ! nr + end do ! k + end do ! izn + endif ! me = 0 + + CALL MPI_BCAST(djcl3 ,8*NPHODIS*(KMAX_MID-KCHEMTOP+1)*HORIZON,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + +! if(me == 0) then +! do k=1,KMAX_MID +! write(6,*) 'jverdi i niv. k',k +! write(6,*) (dj(3,1,k,nr),nr=1,4) +! write(6,*) (djcl1(1,k,nr),nr=1,4) +! write(6,*) (djcl3(1,k,nr),nr=1,4) +! end do +! end if + + return + + end subroutine readdiss + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine setup_phot(i,j,errcode) + +! input + integer :: i,j + integer :: errcode + +! local + integer la & ! counting every 10 deg. latitude + ,n & ! help index + ,k & ! vertical index + ,base & ! cloud base + ,top & ! cloud top + ,iclcat ! cloud type + + real clear ! clear sky fraction + real sum1 + +!---- assign photolysis rates ------------------------------------------------ + + errcode = 0 + + + if ( Grid%izen > 90 ) then ! Photolysis rates zero when the sun is + ! below the horizon + rcphot(:,:) = 0.0 + + else !! (izen < 90) -- sun above horizon + + + !/ first find cloud base and cloud top + + iclcat = 0 + if(cc3dmax(i,j,KMAX_MID) > 1.e-4) then + + k = KMAX_MID + do while(cc3d(i,j,k) < 1.e-4 .and. k >= CLOUDTOP) + k = k-1 + end do + base = k+1 + + ! if all cc3d so far are <1.e-4 we are done + + if( base < CLOUDTOP ) then + + ! we have found a k>=CLOUDTOP with cc3d>=1.e-4, now search for top + + k = CLOUDTOP + do while(cc3d(i,j,k) < 1.0e-4) + k = k+1 + end do + top = k + + if(top >= base) then + print *,'top,base' + errcode = 17 + return + endif + iclcat = 1 + + if(z_bnd(i,j,top)-z_bnd(i,j,base) > 1.5e3) iclcat = 2 + + end if ! base +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Derived_ml + + !--------------------------------------------------------------------------- + ! DESCRIPTION + ! This module performs the calculations associated with "derived" 2D and 3D, + ! such as accumulated precipitation or sulphate, daily, monthly or yearly + ! averages, depositions. These fields are all typically output as netCDF + ! fields. + ! + ! This routine defines many possible derived outputs. + ! The names of the derived fields actualy required should have been specified + ! in the user-defined My_Derived_ml. + ! + + ! User-defined routines and treatments are often needed here. Here there is + ! added stuff for VOC, AOTs, accsu. In + ! general such code should be added in such a way that it isn't activated if + ! not needed. It then doesn't need to be commented out if not used. + !--------------------------------------------------------------------------- + +!current definitions: +!SOMO35: daily max is found over 00:00 to 24:00. (not emepday) +!SOMO35: accumulated over one year +!D2_MAXO3 : daily max is found over an EMEPDAY +!D2_MAXO3 : accumulated into yearly_output from April to September +!AOTXXc: accumulated into yearly_output from May to July +!AOTXXf: accumulated into yearly_output from April to September +!D2_EUAOTXXWH: accumulated into yearly_output from May to July +!D2_EUAOTXXDF: accumulated into yearly_output from April to September +!D2_UNAOTXXWH: accumulated into yearly_output from May to July +!D2_UNAOTXXDF: accumulated into yearly_output from April to September +!D2_MMAOTXXWH: accumulated into yearly_output over growing season +!D2_O3 is now yearly accumulated + +use My_Derived_ml, only : & + wanted_deriv2d, wanted_deriv3d &! names of wanted derived fields + ,Init_My_Deriv, My_DerivFunc + +use CheckStop_ml, only: CheckStop +use Chemfields_ml, only : xn_adv, xn_shl, cfac,xn_bgn, PM_water +use GenSpec_adv_ml ! Use NSPEC_ADV amd any of IXADV_ indices +use GenSpec_shl_ml +use GenSpec_tot_ml +use GenChemicals_ml, only : species +use GridValues_ml, only : debug_li, debug_lj, debug_proc +use Met_ml, only : roa,pzpbl,xksig,ps,th,zen +use ModelConstants_ml, & + only: KMAX_MID & ! => z dimension + , NPROC & ! No. processors + , atwS, atwN, ATWAIR & + , PPBINV & ! 1.0e9, for conversion of units + , PPTINV & ! 1.0e12, for conversion of units + , MFAC & ! converts roa (kg/m3 to M, molec/cm3) + , AOT_HORIZON&! limit of daylight for AOT calcs + ,DEBUG_i, DEBUG_j & + , SOURCE_RECEPTOR & + , NTDAY !Number of 2D O3 to be saved each day (for SOMO) +use Par_ml, only: MAXLIMAX,MAXLJMAX, & ! => max. x, y dimensions + me, & ! for print outs + gi0,gj0,IRUNBEG,JRUNBEG,&! for i_fdom, j_fdom + li0,lj0,limax, ljmax ! => used x, y area +use PhysicalConstants_ml, only : PI +use SmallUtils_ml, only: find_index, LenArray, NOT_SET_STRING +use TimeDate_ml, only : day_of_year,daynumber,current_date + +implicit none +private + + public :: Init_Derived ! + public :: ResetDerived ! Resets values to zero + public :: DerivedProds ! Calculates any production terms + private :: AddDef + private :: Define_Derived ! + private :: Setups + + public :: Derived ! Calculations of sums, avgs etc. + private :: Setup_VOC ! Defines VOC group + private :: voc_2dcalc ! Calculates sum of VOC for 2d fields + private :: voc_3dcalc ! Calculates sum of VOC for 3d fields + + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + + type, public:: Deriv + character(len=9) :: class ! Type of data, e.g. ADV or VOC + logical :: avg ! True => average data (divide by nav at end), + ! else accumulate over run period + integer :: index ! index in concentation array, or other + real :: scale ! Scaling factor + logical :: rho ! True when scale is ug (N or S) + logical :: inst ! True when instantaneous values needed + logical :: year ! True when yearly averages wanted + logical :: month ! True when monthly averages wanted + logical :: day ! True when daily averages wanted + character(len=15) :: name ! Name of the variable (for netCDF output) + character(len=10) :: unit ! Unit (writen in netCDF output) + end type Deriv + + logical, private, parameter :: T = .true., F = .false. ! shorthands only + + ! Tip. For unix users, do "grep AddDef | grep -v Is3D | wc" or similar + ! to help get the number of these: + integer, private, parameter :: & + MAXDEF_DERIV2D =100 & ! Max. No. 2D derived fields to be defined + ,MAXDEF_DERIV3D = 17 ! Max. No. 3D derived fields to be defined + + integer, public, save :: num_deriv2d, num_deriv3d + integer, private, save :: Nadded2d = 0, Nadded3d=0 ! No. defined derived + + ! We put definitions of **all** possible variables in def_2d, def_3d + ! and copy the needed ones into f_xx. The data will go into d_2d, d_3d + + type(Deriv),private, dimension(MAXDEF_DERIV2D), save :: def_2d + type(Deriv),private, dimension(MAXDEF_DERIV3D), save :: def_3d + + type(Deriv),public, allocatable, dimension(:), save :: f_2d + type(Deriv),public, allocatable, dimension(:), save :: f_3d + + + ! Define 4 output types corresponding to instantaneous,year,month,day + + integer, public, parameter :: & + IOU_INST=1, IOU_YEAR=2, IOU_MON=3, IOU_DAY=4, IOU_HOUR=5 + + ! The 2-d and 3-d fields use the above as a time-dimension. We define + ! LENOUTxD according to how fine resolution we want on output. For 2d + ! fields we use daily outputs. For the big 3d fields, monthly output + ! is sufficient. + + integer, public, parameter :: LENOUT2D = 4 ! Allows INST..DAY for 2d fields + integer, public, parameter :: LENOUT3D = 4 ! Allows INST..MON for 3d fields + + !e.g. d_2d( num_deriv2d,MAXLIMAX, MAXLJMAX, LENOUT2D) + ! & d_3d( num_deriv3d,MAXLIMAX, MAXLJMAX, KMAX_MID, LENOUT3D ) + real, save, public, allocatable, dimension(:,:,:,:) :: d_2d + real, save, public, allocatable, dimension(:,:,:,:,:) :: d_3d + + + ! 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. + + + ! Counters to keep track of averaging + ! Initialise to zero in Init. + + 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) + + integer, private, save :: nvoc ! No. VOCs + integer, private, dimension(NSPEC_ADV), save :: & + voc_index, & ! Index of VOC in xn_adv + voc_carbon ! Number of C atoms + + logical, private, parameter :: MY_DEBUG = .false. + logical, private, save :: debug_flag, Is3D + character(len=100), private :: errmsg + + integer, private :: i,j,k,n, ivoc, index ! Local loop variables + integer, public, parameter:: startmonth_forest=4,endmonth_forest=9& + ,startmonth_crops=5,endmonth_crops=7 + + contains + + !========================================================================= + subroutine Init_Derived() + + integer :: alloc_err + if(me==0 .and. MY_DEBUG) write(*,*) "INITIALISE 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) + + if ( num_deriv2d > 0 ) then + if(me==0 .and. MY_DEBUG) 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(me==0 .and. MY_DEBUG) 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 AddDef(class,avg,index,scale,rho,inst,year,month,day,& + name,unit,Is3D) + + character(len=*), intent(in) :: class ! Type of data, e.g. ADV or VOC + logical, intent(in) :: avg ! True => average data (divide by + ! nav at end), else accumulate over + ! run period + integer, intent(in) :: index ! index in e.g. concentration array + real, intent(in) :: scale ! Scaling factor + logical, intent(in) :: rho ! True when scale is ug (N or S) + logical, intent(in) :: inst ! True when instantaneous values needed + logical, intent(in) :: year ! True when yearly averages wanted + logical, intent(in) :: month ! True when monthly averages wanted + logical, intent(in) :: day ! True when daily averages wanted + character(len=*), intent(in):: name ! Name of the variable + ! (used in netCDF output) + character(len=*), intent(in) :: unit ! Unit (writen in netCDF output) + logical, intent(in), optional :: Is3D + + if ( present(Is3D) .and. Is3D ) then + Nadded3d = Nadded3d + 1 + N = Nadded3d + if ( me == 0 .and. MY_DEBUG ) write(*,*) "Define 3d deriv ", N, name + call CheckStop(N>MAXDEF_DERIV3D,"Nadded3d too big!") + def_3d(N) = Deriv(class,avg,index,scale,rho,inst,year,month,day,& + name,unit) + else + Nadded2d = Nadded2d + 1 + N = Nadded2d + if ( me == 0 .and. MY_DEBUG ) write(*,*) "Define 2d deriv ", N, name + call CheckStop(N>MAXDEF_DERIV2D,"Nadded2d too big!") + def_2d(N) = Deriv(class,avg,index,scale,rho,inst,year,month,day,& + name,unit) + end if + + end subroutine AddDef + !========================================================================= + subroutine Define_Derived() + + ! Set the parameters for the derived parameters, including the codes + ! used by DNMI/xfelt and scaling factors. (The scaling factors may + ! be changed later in Derived_ml. + ! And, Initialise the fields to zero. + + real, save :: ugS = atwS*PPBINV/ATWAIR + real, save :: ugN = atwN*PPBINV/ATWAIR + real, save :: ugSO4, ugHCHO, ugCH3CHO + real, save :: ugPMad, ugPMde, ugSS !advected and derived PM's & SeaS + + + ! - for debug - now not affecting ModelConstants version + integer, dimension(MAXLIMAX) :: i_fdom + integer, dimension(MAXLJMAX) :: j_fdom + integer :: ind + + + ! same mol.wt assumed for PPM25 and PPMco + + ugPMad = species(PM25)%molwt * PPBINV /ATWAIR + ugPMde = PPBINV /ATWAIR + ugSS = species( SSfi )%molwt * PPBINV /ATWAIR !SeaS + + ugSO4 = species( SO4 )%molwt * PPBINV /ATWAIR + ugHCHO = species ( HCHO )%molwt * PPBINV /ATWAIR + ugCH3CHO = species ( CH3CHO )%molwt * PPBINV /ATWAIR + +!-- Deposition fields. Define all possible fields and their xfelt codes here: + + !code class avg? ind scale rho Inst Yr Mn Day name unit + +Is3D = .false. +call AddDef( "PREC ", F, -1, 1.0, F , F ,T ,T ,T ,"WDEP_PREC","mm") +call AddDef( "WDEP ", F, -1, 1.0e6, F , F ,T ,T ,T ,"WDEP_SOX","mgS/m2") +call AddDef( "WDEP ", F, -1, 1.0e6, F , F ,T ,T ,T ,"WDEP_OXN","mgN/m2") +call AddDef( "WDEP ", F, -1, 1.0e6, F , F ,T ,T ,T ,"WDEP_RDN","mgN/m2") + + ! Dry dep. --includes fields for ecosystem specific--- + ! ecosystem codes: SW = sea/water, CF = conif forest, DF = decid forest, + ! SN = seminatural (grass/moorlande/tundra) + + !code class avg? ind scale rho Inst Yr Mn Day name unit + +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,T ,"DDEP_SOX","mgS/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,T ,"DDEP_OXN","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,T ,"DDEP_RDN","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXSSW","mgS/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXSCF","mgS/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXSDF","mgS/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXSCR","mgS/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXSSN","mgS/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXSWE","mgS/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXNSW","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXNCF","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXNDF","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXNCR","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXNSN","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_OXNWE","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_RDNSW","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_RDNCF","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_RDNDF","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_RDNCR","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_RDNSN","mgN/m2") +call AddDef( "DDEP ", F, -1, 1.0e6, F , F ,T ,T ,F ,"DDEP_RDNWE","mgN/m2") + +!-- 2-D fields - the complex ones +! (multiplied with roa in layers?? ==> rho "false" ) !ds - explain! + +! code class avg? ind scale rho Inst Yr Mn Day name unit + +call AddDef( "AOT ", F, 20, 1.0, F , F , T , T , F,"D2_AOT20","ppb h") +call AddDef( "AOT ", F, 30, 1.0, F , F , T , T , F,"D2_AOT30","ppb h") +call AddDef( "AOT ", F, 40, 1.0, F , F , T , T , F,"D2_AOT40","ppb h") +call AddDef( "AOT ", F, 60, 1.0, F , F , T , T , F,"D2_AOT60","ppb h") +call AddDef( "AOT ", F, 30, 1.0, F , F , T , F , F,"D2_AOT30f","ppb h") +call AddDef( "AOT ", F, 40, 1.0, F , F , T , F , F,"D2_AOT40f","ppb h") +call AddDef( "AOT ", F, 60, 1.0, F , F , T , F , F,"D2_AOT60f","ppb h") +call AddDef( "AOT ", F, 40, 1.0, F , F , T , F , F,"D2_AOT40c","ppb h") +! +! -- simple advected species. Note that some indices need to be set as dummys +! in ACID, e.g. IXADV_O3 +! +call AddDef( "ADV ", T, IXADV_SO2, ugS, T, F , T , T , T ,"D2_SO2","ugS/m3") +call AddDef( "ADV ", T, IXADV_SO4, ugS, T, F , T , T , T ,"D2_SO4","ugS/m3") +call AddDef( "ADV ", T, IXADV_HNO3,ugN, T, F , T , T , T ,"D2_HNO3","ugN/m3") +call AddDef( "ADV ", T, IXADV_PAN, ugN, T, F , T , T , T ,"D2_PAN","ugN/m3") +call AddDef( "ADV ", T, IXADV_NH3, ugN, T, F , T , T , T ,"D2_NH3","ugN/m3") +call AddDef( "ADV ", T, IXADV_NO , ugN, T, F , T , T , T ,"D2_NO","ugN/m3") +call AddDef( "ADV ", T, IXADV_NO2, ugN, T, F , T , T , T ,"D2_NO2","ugN/m3") +call AddDef( "ADV ", T,IXADV_aNH4, ugN, T, F , T , T , T ,"D2_aNH4","ugN/m3") +call AddDef( "ADV ",T,IXADV_O3 ,PPBINV, F, F , T, T , T ,"D2_O3","ppb") +call AddDef( "ADV ",T,IXADV_CO ,PPBINV, F, F , T, T , T ,"D2_CO","ppb") +call AddDef( "ADV ",T,IXADV_aNO3, ugN, T, F , T, T , T ,"D2_aNO3","ugN/m3") +call AddDef( "ADV ", T,IXADV_pNO3, ugN, T, F , T, T , T ,"D2_pNO3", "ugN/m3") +call AddDef( "NOX ", T, -1 ,ugN , T , F,T,T,T,"D2_NOX","ugN/m3") +call AddDef( "NOZ ", T, -1 ,ugN , T , F,T,T,T,"D2_NOZ","ugN/m3") +call AddDef( "OX ", T, -1 ,PPBINV , F , F,T,T,T,"D2_OX","ppb") +call AddDef( "ADV ",T,IXADV_PM25, ugPMad, T, F , T, T, T,"D2_PPM25","ug/m3") +call AddDef( "ADV ",T,IXADV_PMco, ugPMad, T, F , T, T, T,"D2_PPMco","ug/m3") +!Sea salt +call AddDef( "ADV ",T,IXADV_SSfi, ugSS, T, F , T, T, T,"D2_SSfi","ug/m3") +call AddDef( "ADV ",T,IXADV_SSco, ugSS, T, F , T, T, T,"D2_SSco","ug/m3") +call AddDef( "PS ",T, 0 , 1.0, F , T, T, T, T ,"PS","hPa") +call AddDef( "HMIX ",T, 0 , 1.0, T , F, T, T, T ,"D2_HMIX","m") +call AddDef( "HMIX00",T, 0 , 1.0, T , F, T, T, T ,"D2_HMIX00","m") +call AddDef( "HMIX12",T, 0 , 1.0, T , F, T, T, T ,"D2_HMIX12","m") +! +! drydep +! set as "external" parameters - ie set outside Derived subroutine +! code class avg? ind scale rho Inst Yr Mn Day name unit +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_AFSTDF0","mmol/m2") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_AFSTDF16","mmol/m2") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_AFSTBF0","mmol/m2") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_AFSTBF16","mmol/m2") +! +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_AFSTCR0","mmol/m2") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_AFSTCR3","mmol/m2") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_AFSTCR6","mmol/m2") +! +! code class avg? ind scale rho Inst Yr Mn Day name unit +call AddDef( "EXT ", T, -1, 1. , F, F,T ,T ,T ,"D2_O3DF ","ppb") +call AddDef( "EXT ", T, -1, 1. , F, F,T ,T ,T ,"D2_O3WH ","ppb") +! +! AOT30 and AOT40 for Wheat and Beech. May need daily here. +! Also, use field for EU definition (8-20 CET) and Mapping Manual/UNECE +! (daylight hours). +! All of these use O3 at crop height, in contrast to the older AOT30, AOT40 +! as defined above, and all allow daily output. +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_EUAOT30WH","ppb h") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_EUAOT40WH","ppb h") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_EUAOT30DF","ppb h") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_EUAOT40DF","ppb h") +! UNECE: +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_UNAOT30WH","ppb h") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_UNAOT40WH","ppb h") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_UNAOT30DF","ppb h") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_UNAOT40DF","ppb h") +!Mapping-Manual +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_MMAOT30WH","ppb h") +call AddDef( "EXT ", F, -1, 1. , F, F,T ,T ,T ,"D2_MMAOT40WH","ppb h") +! +! -- time-averages - here 8-16 +! +call AddDef( "TADV ", T,IXADV_HCHO ,ugHCHO, T, F, T, T, T,"D2T_HCHO","ug/m3") +call AddDef( "TADV ", T,IXADV_CH3CHO,ugCH3CHO,T, F, T, T,T,"D2T_CH3CHO","ug/m3") +call AddDef( "VOC ", T, -1 ,PPBINV, F, F, T, T, T,"D2_VOC","ppb") +! +! -- miscellaneous user-defined functions +! +! code class avg? ind scale rho Inst Yr Mn Day name unit +!! ,Deriv( "TSO4 ", T, -1 ,ugS , T , F,T,T,T,"D2_SOX","ugS/m3") +call AddDef( "TOXN ", T, -1 ,ugN , T , F,T,T,T,"D2_OXN","ugN/m3") +call AddDef( "TRDN ", T, -1 ,ugN , T , F,T,T,T,"D2_REDN","ugN/m3") +call AddDef( "FRNIT", T, -1 ,1.0 , F , F,T,T,T,"D2_FRNIT","(1)") +call AddDef( "MAXADV", F,IXADV_O3,PPBINV, F, F,T,T,T,"D2_MAXO3","ppb") +call AddDef( "MAXSHL", F,IXSHL_OH,1.0e13,F , F,T,F,T,"D2_MAXOH","?") +! +call AddDef( "tNO3 ", T, -1, ugN, T, F, T, T, T,"D2_tNO3", "ugN/m3") +call AddDef( "SIA ", T, -1, ugPMde, T, F, T, T, T,"D2_SIA" , "ug/m3") +call AddDef( "PMco ", T, -1, ugPMde, T, F, T, T, T,"D2_PMco", "ug/m3") +call AddDef( "PM25 ", T, -1, ugPMde, T, F, T, T, T,"D2_PM25", "ug/m3") +call AddDef( "PM10 ", T, -1, ugPMde, T, F, T, T, T,"D2_PM10", "ug/m3") +call AddDef( "H2O ", T, -1, 1.0 , T, F, T, T, T,"D2_PM25_H2O ", "ug/m3") +call AddDef( "SSalt", T, -1, ugSS, T, F, T, T, T,"D2_SS ", "ug/m3") +call AddDef( "SOM", F, 35, 1., F, F, T, T, F,"D2_SOMO35", "ppb day") +call AddDef( "SOM", F, 0, 1., F, F, T, T, F,"D2_SOMO0", "ppb day") + +!-- 3-D fields + +Is3D = .true. +call AddDef( "TH ",T, 0 , 1.0, F , T, T, T, F ,"D3_TH","m",Is3D) +call AddDef( "ADV ", T, IXADV_O3 , PPBINV, F, T, T, T, F ,"D3_O3","ppb",Is3D) +call AddDef( "ADV ", T, IXADV_SO2, PPBINV, F, T, T, T, F ,"D3_SO2","ppb",Is3D) +call AddDef( "ADV ", T, IXADV_PAN, PPBINV, F, T, T, T, F ,"D3_PAN","ppb",Is3D) +call AddDef( "ADV ", T, IXADV_HNO3,PPBINV, F, T, T, T, F ,"D3_HNO3","ppb",Is3D) +call AddDef( "ADV ", T, IXADV_aNO3,PPBINV, F, T, T, T, F ,"D3_aNO3","ppb",Is3D) +call AddDef( "ADV ", T, IXADV_NO2, PPBINV, F, T, T, T, F ,"D3_NO2","ppb",Is3D) +call AddDef( "VOC ", T, -1 , PPBINV, F, T, T, T, F ,"D3_VOC","ppb",Is3D) +call AddDef( "ADV ", T, IXADV_aNH4,PPBINV, F, T, T, T, F ,"D3_aNH4","ppb",Is3D) +call AddDef( "ADV ", T, IXADV_SO4, PPBINV, F, T, T, T, F ,"D3_SO4","ppb",Is3D) +call AddDef( "ADV ", T, IXADV_H2O2,PPBINV, F, T, T, T, F ,"D3_H2O2","ppb",Is3D) +! +! Set Year true to allow debug - change later +call AddDef( "SHL", T, IXSHL_OH, PPTINV, T, F, T, T, F ,"D3_OH","?",Is3D) +call AddDef( "ADV", T, IXADV_CH3COO2, & + PPTINV, F, F, T, T, F ,"D3_CH3COO2","?",Is3D) +call AddDef( "MAX3DSHL", T,IXSHL_OH,PPTINV, T, F, T, T, F ,"D3_MAXOH","?",Is3D) ! rho true for shl +call AddDef( "MAX3DADV", T, IXADV_CH3COO2,& + PPTINV, F, F, T, T, F ,"D3_MAXCH3COO2","?",Is3D) +call AddDef( "PHNO3 ", T, IXSHL_PHNO3,1.0e8, F, F, T, T, F ,"D3_PHNO3","?",Is3D) +call AddDef( "MAX3DADV", T, IXADV_O3,PPBINV,F, F, T, T, F ,"D3_MAXO3","?",Is3D) + + + if ( SOURCE_RECEPTOR .and. num_deriv2d>0 ) then ! We assume that no + ! daily outputs are wanted. + def_2d(:)%day = .false. + end if + + + ! Get indices of wanted fields in larger def_xx arrays: + + do i = 1, num_deriv2d + ind = find_index( wanted_deriv2d(i), def_2d(:)%name ) + f_2d(i) = def_2d(ind) + if ( me == 0 .and. MY_DEBUG) write(*,*) "Index f_2d ", i, " = def ", ind + end do + + do i = 1, num_deriv3d + ind = find_index( wanted_deriv3d(i), def_3d(:)%name ) + f_3d(i) = def_3d(ind) + if ( me == 0 .and. MY_DEBUG) write(*,*) "Index f_3d ", i, " = def ", ind + end do + + !Initialise to zero + + if ( num_deriv2d > 0 ) d_2d( :,:,:,:) = 0.0 + if ( num_deriv3d > 0 ) d_3d( :,:,:,:,:) = 0.0 + + debug_flag = ( MY_DEBUG .and. debug_proc ) + + end subroutine Define_Derived + !========================================================================= + subroutine Setups() + + !/** flexibility note. By making use of character-based tests such + ! as for "VOC" below, we achieve code which can stay for both ACID and + ! OZONE without having to define non-used indices. + ! Similarly, we avoid the previous "if NUM_ACCSU eq 1" type test, + ! since the appropriate code will now only activate + + !/ ** if voc wanted, set up voc_array. Works for all ozone chemistries + ! (and code not called for MADE-type). + + if ( any( f_2d(:)%class == "VOC" ) .or. & + any( f_3d(:)%class == "VOC" ) ) then + call Setup_VOC() + if (MY_DEBUG)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) + endif + end if + + + end subroutine Setups + !========================================================================= + + subroutine Derived(dt,End_of_Day) + + !/** DESCRIPTION + ! Integration and averaging of chemical fields. Intended to be + ! a more flexible version of the old chemint routine. + ! Includes AOT40, AOT60 if present + + real, intent(in) :: dt ! time-step used in intergrations + logical, intent(in) :: End_of_Day ! e.g. 6am for EMEP sites + + character(len=len(f_2d%class)) :: typ ! See defs of f_2d + real :: thour ! Time of day (GMT) + real :: timefrac ! dt as fraction of hour (3600/dt) + real :: dayfrac ! fraction of day elapsed (in middle of dt) + integer :: ntime ! 1...NTDAYS + integer :: nhour ! hours of day (GMT) + real, dimension(MAXLIMAX,MAXLJMAX) :: density ! roa (kgair m-3 when + ! scale in ug, else 1 + + 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 :: accumulate_2dyear !flag to know when to accumulate d_2d + ! (case "EXT") + + timefrac = dt/3600.0 + thour = current_date%hour+current_date%seconds/3600.0 + + daynumber=day_of_year(current_date%year,current_date%month,& + current_date%day) + + !/***** 2-D fields ************************** + + do n = 1, num_deriv2d + + accumulate_2dyear=.true. + typ = f_2d(n)%class + + + if ( f_2d(n)%rho ) then + forall ( i=1:limax, j=1:ljmax ) + density(i,j) = roa(i,j,KMAX_MID,1) + end forall + else + density(:,:) = 1.0 + end if + + !/** user-defined time-averaging. Here we have defined TADV and TVOC + ! so that 8-hour daytime averages will be calculated. + ! Just comment out if not wanted, or (better!) don't define any + ! f_2d as TADV or TVOC + + if ( typ == "TADV" .or. typ == "TVOC" ) then + if(thour <= 8.0 .or. thour > 16.0 ) cycle ! Start next species + end if + + ! hmix average at 00 and 12: + + if ( typ == "HMIX00" .or. typ == "XKSIG00" ) then + if(thour /= 0.0 ) cycle ! Start next species + end if + + if ( typ == "HMIX12" .or. typ == "XKSIG12" ) then + if(thour /= 12.0 ) cycle ! Start next species + end if + + index = f_2d(n)%index + !if ( My_DEBUG ) then + ! write(*,*) "DEBUG Derived 2d", n, f_2d(n)%name, index, typ + !end if + + select case ( typ ) + + case ( "PS" ) + + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = ps(i,j,1)*0.01 + end forall + + + case ( "HMIX", "HMIX00", "HMIX12" ) + + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = pzpbl(i,j) + end forall + + if ( debug_flag ) then + write(*,fmt="(a12,2i4,4f12.3)") "HMIX" , n , d_2d(n,debug_li,debug_lj,IOU_INST) + end if + + ! Simple advected species: + case ( "ADV", "TADV" ) + + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = xn_adv(index,i,j,KMAX_MID) & + * cfac(index,i,j) * density(i,j) + end forall + + if ( debug_flag ) then + write(*,fmt="(a12,2i4,4f12.3)") "JUST ADV" , n, index & + ,d_2d(n,debug_li,debug_lj,IOU_INST)*PPBINV & + ,xn_adv(index,debug_li,debug_lj,KMAX_MID)*PPBINV & + ,density(debug_li,debug_lj), cfac(index,debug_li,debug_lj) + end if + + case ( "H2O" ) !water + + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = PM_water(i,j,KMAX_MID) + end forall + + + case ( "MAXADV" ) + + + 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) * density(1:limax,1:ljmax)) + + + if ( debug_flag ) then + write(*,fmt="(a12,2i4,4f12.3)") "ADV MAX. ", n, index & + , d_2d(n,debug_li,debug_lj,IOU_DAY) * PPBINV & + , xn_adv(index,debug_li,debug_lj,KMAX_MID)* PPBINV & + , density(debug_li,debug_lj), cfac(index,debug_li,debug_lj) + + end if + + !Monthly and yearly ARE averaged over days + if(End_of_Day)then + d_2d(n,:,:,IOU_MON ) = d_2d(n,:,:,IOU_MON ) + d_2d(n,:,:,IOU_DAY) + nav_2d(n,IOU_MON) = nav_2d(n,IOU_MON) + 1 + if( current_date%month >= 4 & + .or.current_date%month <= 9 )then + d_2d(n,:,:,IOU_YEAR ) = d_2d(n,:,:,IOU_YEAR ) + d_2d(n,:,:,IOU_DAY) + nav_2d(n,IOU_YEAR) = nav_2d(n,IOU_YEAR) + 1 + endif + endif + + + case ( "MAXSHL" ) ! Daily maxima - short-lived + + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_DAY) = max( d_2d( n, i,j,IOU_DAY), & + xn_shl(index,i,j,KMAX_MID) & + / (density(i,j)*MFAC) ) + !u4 / (roa(:,:,KMAX_MID,1)*MFAC) ) + end forall + + + if ( debug_flag ) then + write(*, *) "SHL:MAX.,MFAC ", n, index , MFAC + write(*,fmt="(a12,2i4,4es12.3)") "SHL MAX. ", n, index & + , d_2d(n,debug_li,debug_lj,IOU_DAY) & + , xn_shl(index,debug_li,debug_lj,KMAX_MID) & + , density(debug_li,debug_lj), MFAC + end if + + !Monthly and yearly ARE averaged over days + if(End_of_Day)then + d_2d(n,:,:,IOU_MON ) = d_2d(n,:,:,IOU_MON ) + d_2d(n,:,:,IOU_DAY) + nav_2d(n,IOU_MON) = nav_2d(n,IOU_MON) + 1 + if( current_date%month >= 4 & + .or.current_date%month <= 9 )then + d_2d(n,:,:,IOU_YEAR ) = d_2d(n,:,:,IOU_YEAR ) + d_2d(n,:,:,IOU_DAY) + nav_2d(n,IOU_YEAR) = nav_2d(n,IOU_YEAR) + 1 + endif + endif + + case ( "VOC", "TVOC" ) + + call voc_2dcalc() + + case( "AOT" ) + + call aot_calc( n, timefrac ) + + if( debug_flag .and. i == debug_li .and. j == debug_lj ) then + write(*,*) "GROWINDERIV? ", n, f_2d(n)%name + end if + + if( current_date%monthendmonth_forest)then + if( f_2d(n)%name=="D2_AOT30f".or.& + f_2d(n)%name=="D2_AOT40f".or.& + f_2d(n)%name=="D2_AOT60f")then + accumulate_2dyear=.false. + endif + + endif + if( current_date%monthendmonth_crops)then + if( f_2d(n)%name=="D2_AOT30c".or.& + f_2d(n)%name=="D2_AOT40c".or.& + f_2d(n)%name=="D2_AOT60c")then + accumulate_2dyear=.false. + endif + endif + + case( "SOM" ) + + + !dt/7200: half a dt time step in hours + !dayfrac "points" to the middle of the integration step + dayfrac= (thour-(dt/7200.))/24. !must be < 1 + ntime=int(dayfrac*NTDAY )+1 !must be >=1 and <= NTDAY + if(dayfrac<0)ntime=NTDAY !midnight + + !last value (not averaged): + D2_O3_DAY( : , : , ntime) =& + xn_adv(IXADV_O3,:,:,KMAX_MID)*cfac(IXADV_O3,:,:)*PPBINV + + if(dayfrac<0)then !only at midnight: write on d_2d + + + call som_calc( n ) ! accumulate + 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 + d_2d(n,:,:,IOU_YEAR ) = d_2d(n,:,:,IOU_YEAR ) + d_2d(n,:,:,IOU_DAY) + !NB overwritten anyway D2_O3_DAY = 0. + endif + + + case ( "PREC", "WDEP", "DDEP" ) + if ( debug_flag ) write(*,"(a18,i4,a12,a4,es12.3)")"PR/DEP d_2d",& + n, f_2d(n)%name, " is ", d_2d(n,debug_li,debug_lj,IOU_INST) + + case ( "EXT" ) + + ! Externally set for IOU_INST (in other routines); so no new work + ! needed except decision to accumalate to yearly or not. + ! Used for e.g. AOT40s + call setaccumulate_2dyear(n,accumulate_2dyear) + if ( debug_flag ) write(*,"(a18,i4,a12,a4,es12.3)")"EXT d_2d",& + n, f_2d(n)%name, " is ", d_2d(n,debug_li,debug_lj,IOU_INST) + + case default + + if ( debug_flag ) then + write(*,*) "My_Deriv Defaults called for n=", n, "Type ",typ, "Name ", f_2d(n)%name + write(*,*) "My_Deriv index?, avg?, nav? length?, class? ", index,& + f_2d(n)%avg, nav_2d(n,IOU_INST), len(f_2d%class), f_2d(n)%class + end if + + call My_DerivFunc( d_2d(n,:,:,IOU_INST), n, typ, timefrac, density ) + + end select + + + !/** add to daily, monthly and yearly average, and increment counters + ! Note that the MAXADV and MAXSHL and SOM needn't be summed here, but + ! since the INST values are zero it doesn't harm, and the code is + ! shorter. These d_2d ( MAXADV, MAXSHL, SOM) are set elsewhere + + d_2d(n,:,:,IOU_DAY ) = d_2d(n,:,:,IOU_DAY ) + d_2d(n,:,:,IOU_INST) + if ( f_2d(n)%avg ) nav_2d(n,IOU_DAY) = nav_2d(n,IOU_DAY) + 1 + d_2d(n,:,:,IOU_MON ) = d_2d(n,:,:,IOU_MON ) + d_2d(n,:,:,IOU_INST) + if ( f_2d(n)%avg ) nav_2d(n,IOU_MON) = nav_2d(n,IOU_MON) + 1 + if(accumulate_2dyear)then + d_2d(n,:,:,IOU_YEAR ) = d_2d(n,:,:,IOU_YEAR ) + d_2d(n,:,:,IOU_INST) + if ( f_2d(n)%avg ) nav_2d(n,IOU_YEAR) = nav_2d(n,IOU_YEAR) + 1 + endif + + end do ! num_deriv2d + + !/***** 3-D fields ************************** + + if(debug_flag) then ! RUN through indices etc. + write(*, "(a12,2i4,f12.3)") "3D3D TIME ", me, num_deriv3d, & + (current_date%hour+current_date%seconds/3600.0) + end if + + + do n = 1, num_deriv3d + + index = f_3d(n)%index + + if ( f_3d(n)%rho ) then + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + inv_air_density3D(i,j,k) = 1.0/( roa(i,j,k,1) * MFAC ) + end forall + else + inv_air_density3D(:,:,:) = 1.0 + end if + + select case ( f_3d(n)%class ) + + ! Simple advected species: + case ( "ADV" ) + + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = xn_adv(index,i,j,k) + end forall + + case ( "BGN" ) + + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = xn_bgn(index,i,j,k) + end forall + + case ("XKSIG00", "XKSIG12" ) !hf hmix xksig + + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = xksig(i,j,k) + end forall + + case ("TH " ) !JEJ Pot. temp (needed for cross sections) + + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = th(i,j,k,1) + end forall + + case ( "PHNO3" ) !ds-hf rv1_9_28 + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = xn_shl(index,i,j,k) + end forall + + if(debug_flag) write(*,"(a12,i4,2es12.3)") "3D3D PHNO3", n, & + xn_shl(index,debug_li,debug_lj,KMAX_MID), & + d_3d(n,debug_li,debug_lj,KMAX_MID,IOU_INST) + + case ( "MAX3DSHL" ) + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID )! Daily maxima - short-lived + d_3d( n, i,j,k,IOU_INST) = max( d_3d( n, i,j,k,IOU_INST),& + xn_shl(index,i,j,k) & + * inv_air_density3D(i,j,k) ) + end forall + + if(debug_flag) write(*,"(a13,i4,f8.3,3es12.3)") "3D3D MAX3DSHL", n, thour, & + xn_shl(index,debug_li,debug_lj,KMAX_MID), & + 1.0/inv_air_density3D(debug_li,debug_lj,KMAX_MID), & + d_3d(n,debug_li,debug_lj,KMAX_MID,IOU_INST) + + case ( "MAX3DADV" ) + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = max( d_3d( n, i,j,k,IOU_INST),& + xn_adv(index,i,j,k) ) + end forall + + if(debug_flag) write(*,"(a12,i4,f8.3,4es12.3)") "SET MAX3DADV", n, thour, & + xn_adv(index,debug_li,debug_lj,KMAX_MID), & + d_3d(n,debug_li,debug_lj,KMAX_MID,IOU_INST) + + case ( "SHL" ) + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = xn_shl(index,i,j,k) * inv_air_density3D(i,j,k) + end forall + + + case ( "VOC" ) + + call voc_3dcalc() + + case default + + write(unit=errmsg,fmt=*) "Derived 3D class NOT FOUND", n, index, & + f_3d(n)%name,f_3d(n)%class + call CheckStop( errmsg ) + + + end select + + + !/** add to monthly and yearly average, and increment counters + ! ( no daily averaging done for 3-D fields so far). + + + ! For the MAX3D possibilities, we store maximum value of the + ! current day in the IOU_INST variables. + ! These are then added into IOU_MON **only** at the end of each day. + ! (NB there is an error made on 1st day used, since only 1st 6 hours + ! are checked. Still, not much happens on 1st Jan.... ;-) + + if ( (f_3d(n)%class == "MAX3DSHL") .or. & + (f_3d(n)%class == "MAX3DADV") )then + if (End_of_Day) then + d_3d(n,:,:,:,IOU_MON ) = d_3d(n,:,:,:,IOU_MON ) & + + d_3d(n,:,:,:,IOU_INST) + d_3d(n,:,:,:,IOU_YEAR) = d_3d(n,:,:,:,IOU_YEAR) & + + d_3d(n,:,:,:,IOU_INST) + if ( f_3d(n)%avg ) nav_3d(n,:) = nav_3d(n,:) + 1 !only collected for end_of_day + + if( debug_flag ) then + write(*,fmt="(a20,a9,i4,f8.3,2es12.3)") "END_OF_DAY MAX3D", & + f_3d(n)%class, n, thour, & + d_3d(n,debug_li,debug_lj,KMAX_MID,IOU_MON ),& + d_3d(n,debug_li,debug_lj,KMAX_MID,IOU_INST ) + write(*,"(a20,i4,2x,6i6)") "END_OF_DAY NAV ", & + n, (nav_3d(n,i), i=1,LENOUT3D) + end if + + d_3d(n,:,:,:,IOU_INST ) = 0.0 !! Reset d_3d + + endif ! End_of_Day + else + d_3d(n,:,:,:,IOU_DAY ) = d_3d(n,:,:,:,IOU_DAY ) & + + d_3d(n,:,:,:,IOU_INST) + d_3d(n,:,:,:,IOU_MON ) = d_3d(n,:,:,:,IOU_MON ) & + + d_3d(n,:,:,:,IOU_INST) + d_3d(n,:,:,:,IOU_YEAR) = d_3d(n,:,:,:,IOU_YEAR) & + + d_3d(n,:,:,:,IOU_INST) + if ( f_3d(n)%avg ) nav_3d(n,:) = nav_3d(n,:) + 1 + endif + + + +! !/** add to monthly and yearly average, and increment counters +! ! ( no daily averaging done for 3-D fields so far). +! +! d_3d(n,:,:,:,IOU_MON ) = d_3d(n,:,:,:,IOU_MON ) & +! + d_3d(n,:,:,:,IOU_INST) +! d_3d(n,:,:,:,IOU_YEAR) = d_3d(n,:,:,:,IOU_YEAR) & +! + d_3d(n,:,:,:,IOU_INST) +! +! if ( f_3d(n)%avg ) nav_3d(n,:) = nav_3d(n,:) + 1 + + end do + end subroutine Derived + !========================================================================= + + subroutine DerivedProds(text,dt) + + !/** DESCRIPTION + ! Calculates chemical changes by comparing values before and after + ! chemistry subroutine. Intended to be a more flexible version of the old + ! PRODO3 calculation + + character(len=*), intent(in) :: text ! "Before" or "After" + real, intent(in) :: dt ! timestep (s) + + real :: timefrac ! dt as fraction of hour (3600/dt) + + + + if (.not. any( f_3d%class == "PROD" ) ) return + + timefrac = dt/3600.0 + + !/***** 3-D fields ************************** + + do n = 1, num_deriv3d + + if ( f_3d(n)%class == "PROD " ) then + index = f_3d(n)%index + + select case ( text ) + + case ( "Before" ) !! Initialise to xn_adv + + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = xn_adv(index,i,j,k) + end forall + + case ( "After" ) !! Calculate change + + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = & + d_3d( n, i,j,k,IOU_INST) - xn_adv(index,i,j,k) + end forall + + end select + end if + end do + + end subroutine DerivedProds + !========================================================================= + + subroutine ResetDerived(period) + integer, intent(in) :: period ! Either IOU_DAY or IOU_MON + + if ( period <= LENOUT2D ) then + nav_2d (:,period) = 0.0 + d_2d(:,:,:,period) = 0.0 + end if + + + if ( period <= LENOUT3D ) then + nav_3d (:,period) = 0.0 + d_3d(:,:,:,:,period) = 0.0 + end if + + end subroutine ResetDerived + !========================================================================= + + subroutine Setup_VOC() + !-------------------------------------------------------- + ! Searches through the advected species and colects the + ! index and carbon content of nmhc/voc species, as they were + ! defined in GenOut_ml + ! + !-------------------------------------------------------- + integer :: n + + do n = 1, NSPEC_ADV + + if ( species( NSPEC_SHL+n )%carbons > 0 .and. & + species( NSPEC_SHL+n )%name /= "CO" .and. & + species( NSPEC_SHL+n )%name /= "CH4" ) then + + nvoc = nvoc + 1 + voc_index(nvoc) = n + voc_carbon(nvoc) = species( NSPEC_SHL+n )%carbons + end if + end do + end subroutine Setup_VOC + !========================================================================= + + subroutine voc_2dcalc() + + !/-- Sums up voc species using the indices defined earlier in Setup_VOCs + + ! We initialise d_2d first, the use a simple loop + ! over voc. Some CPU could be saved by initialising + ! with the 1st voc, then looping over 2, nvoc, but who cares... + + + d_2d( n, 1:limax,1:ljmax,IOU_INST) = 0.0 + + do ivoc = 1, nvoc + + index = voc_index(ivoc) ! Gives which IXADV_ to use. + forall ( i=1:limax, j=1:ljmax ) + d_2d( n, i,j,IOU_INST) = d_2d( n, i,j,IOU_INST) & + + xn_adv(index,i,j,KMAX_MID) & + * voc_carbon(ivoc) * cfac(index,i,j) + ! multiplied by nr. of C and "reduced to surface" + end forall + end do ! ivoc + end subroutine voc_2dcalc + + !========================================================================= + subroutine voc_3dcalc() + + !/-- as for voc_2dcalc + + d_3d( n, 1:limax,1:ljmax,1:KMAX_MID,IOU_INST) = 0.0 + + do ivoc = 1, nvoc + + index = voc_index(ivoc) + forall ( i=1:limax, j=1:ljmax, k=1:KMAX_MID ) + d_3d( n, i,j,k,IOU_INST) = d_3d( n, i,j,k,IOU_INST) + & + xn_adv(index,i,j,k)*voc_carbon(ivoc) + end forall + end do ! ivoc + + end subroutine voc_3dcalc + !========================================================================= + + subroutine aot_calc( n, timefrac ) + + !/-- Calcuates AOT values for input threshold. Daylight values calculated + ! only, for zenith < AOT_HORIZON ( e.g. 89 ) + ! Only relevant in ozone models, so far.... + + integer, intent(in) :: n ! index in Derived_ml::d_2d arrays + real, intent(in) :: timefrac ! Timestep as fraction of hour + + real :: threshold ! Threshold, e.g. 40 or 60 (ppb) + integer :: izen ! integer of zenith angle + real :: o3 ! Ozone (ppb) - needed if AOTs + + threshold = f_2d(n)%index + + do i=1,limax + do j=1,ljmax + + izen = max(1,int( zen(i,j) + 0.5)) + + if ( izen < AOT_HORIZON ) then + o3 = xn_adv(IXADV_O3,i,j,KMAX_MID) & + * cfac(IXADV_O3,i,j) * PPBINV + + o3 = max( o3 - threshold , 0.0 ) ! Definition of AOTs + + ! d_2d values will be accumulated in Derived_ml + + d_2d(n, i,j,IOU_INST ) = o3 * timefrac + + else + d_2d(n, i,j,IOU_INST ) = 0.0 + end if + end do + end do + end subroutine aot_calc + +!========================================================================= + + subroutine som_calc( n ) + + + !/-- Calculates SOM (8hours) values for input threshold. !pw rv2_1 + + implicit none + integer, intent(in) :: n ! index in Derived_ml::d_2d arrays + + real :: threshold ! Threshold, e.g. 35 (ppb) + real :: o3 ! Ozone (ppb) - needed if SOMs + real :: sum8h + integer, parameter :: N8h = (NTDAY*8)/24 !number of periods in 8 hours + real, parameter :: N8h_inv=1./N8h + integer :: nh + + + threshold = f_2d(n)%index + + do i=1,limax + do j=1,ljmax + + !find max running 8h sum O3 + sum8h=0. + do nh=1,N8h + sum8h = sum8h + D2_O3_DAY( i , j , nh) + enddo + o3=sum8h + do nh=N8h+1,NTDAY + sum8h =sum8h-D2_O3_DAY( i , j , nh-N8h)+D2_O3_DAY( i , j , nh) + o3=max(o3,sum8h) + if(n<0)write(*,*)o3 !pw fake for compiler!! + enddo + + !divide by N8h to find 8h mean + o3=o3*N8h_inv + + o3 = max( o3 - threshold , 0.0 ) ! Definition of SOMs + + ! d_2d values will be accumulated in Derived_ml + + d_2d(n, i,j,IOU_DAY ) = o3 + + end do + end do + end subroutine som_calc + + !========================================================================= + + subroutine setaccumulate_2dyear(n,accumulate_2dyear) + +! We don't want the yearly output to accumulate over the whole year + integer, intent(in) :: n + logical, intent(inout) :: accumulate_2dyear !flag to know when to + !accumulate d_2d (case "EXT") + + if( f_2d(n)%name=="D2_EUAOT30DF".or.& + f_2d(n)%name=="D2_EUAOT40DF".or.& + f_2d(n)%name=="D2_UNAOT30DF".or.& + f_2d(n)%name=="D2_UNAOT40DF" & + )then + if( current_date%monthendmonth_forest)then + accumulate_2dyear=.false. + endif + endif + + if(f_2d(n)%name=="D2_EUAOT30WH".or.& + f_2d(n)%name=="D2_EUAOT40WH".or.& + f_2d(n)%name=="D2_UNAOT30WH".or.& + f_2d(n)%name=="D2_UNAOT40WH" & + )then + if( current_date%monthendmonth_crops)then + accumulate_2dyear=.false. + + endif + endif + + end subroutine setaccumulate_2dyear + +end module Derived_ml diff --git a/DryDep_ml.f90 b/DryDep_ml.f90 new file mode 100644 index 0000000..6542e99 --- /dev/null +++ b/DryDep_ml.f90 @@ -0,0 +1,603 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 DryDep_ml + + ! Module started from the drag-coefficient based approach of BJ98: + ! Berge, E. and Jakobsen, H.A., A regional scale multi-layer model + ! for the calculation of long-term transport and deposition of air + ! pollution in Europe, Tellus B (1998), 50, 105-223. + + ! but has been extensively re-written since. See .... + ! Emberson, L.,Simpson, D.,Tuovinen, J.-P.,Ashmore, M.R., Cambridge, H.M.", + ! 2000, Towards a model of ozone deposition and stomatal uptake over + ! Europe, EMEP MSC-W Note 6/2000, + ! Simpson, D.,Tuovinen, J.-P.,Emberson, L.D.,Ashmore, M.R.,2001, + ! "Characteristics of an ozone deposition module",WASP:Focus,1,253-262 + ! Simpson, D.,Tuovinen, J.-P.,Emberson, L.D.,Ashmore, M.R.,2003, + ! "Characteristics of an ozone deposition module II: sensitivity analysis", + ! WASP, 143, 123-137 + ! Tuovinen, J.-P.,Ashmore, M.R.,Emberson, L.D.,Simpson, D., 2004, "Testing + ! and improving the EMEP ozone deposition module", Atmos.Env.,38,2373-2385 + + !-- model specific dry dep values are set in My_DryDep_ml + + use My_DryDep_ml, only : Init_DepMap, & ! Maps indices between + ! Vg-calculated (CDEP..) and advected (IXADV_..) + NDRYDEP_CALC, & ! No. Vd values calculated + NDRYDEP_ADV, & ! No. advected species affected + NDRYDEP_AER, & ! No. aerosol size modes for Vd + NDRYDEP_TOT, & ! Total No. of Vd values + DRYDEP_CALC, & ! Wesely Index Vd values calculated + CDEP_SET, & ! for so4 + CDEP_NO2,CDEP_O3, & ! for NO2 comp pt. approach + FLUX_CDEP, & ! index O3 in CALC array, for STO_FLUXES + FLUX_ADV , & ! index O3 in ADV array, for STO_FLUXES + DepLoss, Add_ddep, & + Dep ! Mapping (type = depmap) + + + use My_Derived_ml ! -> d_2d, IOU_INST, D2_VG etc... + + use Aero_DryDep_ml, only : Aero_Rb + use CheckStop_ml, only: CheckStop + use Chemfields_ml , only : cfac!,xn_adv + use DO3SE_ml, only : Init_DO3SE, do3se, f_phen + use GenSpec_adv_ml, only : NSPEC_ADV, IXADV_NO2, IXADV_SO2, IXADV_NH3 + use GenSpec_tot_ml, only : NSPEC_TOT + + use GridValues_ml , only : GRIDWIDTH_M,xmd,xm2,carea, gb, & + debug_proc, debug_li, debug_lj, i_fdom, j_fdom ! for testing + use Io_Nums_ml, only: IO_DO3SE + use Landuse_ml, only: Land_codes + use LocalVariables_ml, only : Grid, Sub, L, iL ! Grid and sub-scale Met/Veg data + use MassBudget_ml, only : totddep,DryDep_Budget + use MicroMet_ml, only : AerRes, Wind_at_h + use ModelConstants_ml, only : dt_advec,PT,KMAX_MID, KMAX_BND ,& + DEBUG_i, DEBUG_j, NPROC, & + ATWAIR, atwS, atwN, PPBINV,& + KUPPER, NLANDUSE + use Par_ml, only : me,li0,li1,lj0,lj1 + use PhysicalConstants_ml, only : PI, KARMAN, GRAV, RGAS_KG, CP, AVOG + + use Landuse_ml, only : SetLandUse & + ,NLUMAX & ! Max. no countries per grid + ,LandCover ! Provides codes, SGS, LAI, etc, + + use Rb_ml, only: Rb_gas + use Rsurface_ml + use SoilWater_ml, only : SWP ! = 0.0 always for now! + use Wesely_ml, only : Init_GasCoeff ! Wesely stuff, DRx, Rb_Cor, ... + use Setup_1dfields_ml, only : xn_2d,amk + use StoFlux_ml, only: STO_FLUXES, & ! true if fluxes wanted. + leaf_flux, &! = flag-leaf sto. flux per m2 + unit_flux, &! = sto. flux per m2 + lai_flux, &! = lai * unit_flux + luflux_wanted, & ! logical + c_hvegppb, & ! logical + Init_StoFlux, Setup_StoFlux, Calc_StoFlux ! subs + use GenSpec_shl_ml, only : NSPEC_SHL + use My_Aerosols_ml, only : NSIZE + use TimeDate_ml, only : daynumber, current_date + + implicit none + private + + public :: drydep, init_drydep + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + + logical, public, dimension(NDRYDEP_ADV), save :: vg_set + + logical, private, save :: my_first_call = .true. + logical, private, parameter :: MY_DEBUG = .false. + character(len=30),private, save :: errmsg = "ok" + + + contains + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine init_drydep + + + integer, save :: old_daynumber = -99 + integer ::nadv,n + + if ( my_first_call ) then + + call Init_DepMap() ! Maps CDEP to IXADV + call Init_GasCoeff() ! Sets Wesely coeffs. + +! 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) + call CheckStop(errmsg, "Reading DO3SE ") + call Init_StoFlux() + + nadv = 0 + do n = 1, NDRYDEP_ADV + nadv = max( Dep(n)%adv, nadv ) ! Looking for highest IXADV + vg_set(n) = ( Dep(n)%calc == CDEP_SET ) ! for set vg + !if ( MY_DEBUG .and. me == 0 ) write(*,*) "VGSET ", n, nadv, vg_set(n) + end do + + my_first_call = .false. + if(me==0 .and. MY_DEBUG) write(*,*) "INIT_DRYDEP day ", daynumber, old_daynumber + + end if ! my_first_call + + if ( old_daynumber /= daynumber ) then + + if(me==0.and. MY_DEBUG) write(*,*) "INIT_DRYDEP set ", daynumber, old_daynumber + call SetLandUse() ! Sets LandCover()%LAI, %hveg , etc + old_daynumber = daynumber + + end if + + end subroutine init_drydep + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine DryDep(i,j) + integer, intent(in):: i,j + + real, dimension(NDRYDEP_CALC) :: & + Rb & ! Quasi-boundary layer rsis. + ,Rsur_dry & ! Surface Resistance (s/m) over dry surface + ,Rsur_wet ! Surface Resistance (s/m) over wet surface + real, dimension(NDRYDEP_TOT) :: & + gradient_fac & ! Ratio of conc. at zref (ca. 50m) and 3m + ,vg_fac & ! Loss factor due to dry dep. + ,Vg_ref & ! Vg at ref ht. + ,Vg_3m & ! Vg at 3m + ,Grid_Vg_ref & ! Grid average of Vg at ref ht. (effective Vg for cell) + ,Grid_Vg_3m & ! Grid average Vg at 3m (or tree height) + ,Vg_ratio & ! Ratio Vg_ref/Vg_3m = ratio C(3m)/C(ref), over land + ,sea_ratio ! Ratio Vg_ref/Vg_3m = ratio C(3m)/C(ref), over sea + + integer n, iiL, nlu, ncalc, nadv, ispec, err,k ! help indexes + integer :: imm, idd, ihh, iss ! date + integer :: nadv2d !index of adv species in xn_2d array + + real :: no2fac ! Reduces Vg for NO2 in ration (NO2-4ppb)/NO2 + real :: RaVs ! Ra_ref *Vs for particles + + real convfac, & ! rescaling to different units + convfac2, & ! rescaling to different units + lossfrac, & ! If needed in My_DryDep - not used now. + dtz ! scaling factor for veff ( = dt/z, where dt=timestep and + ! z = height of layer) + + integer :: nae + real, dimension(NSIZE):: aeRb, aeRbw , Vs + real :: convec + + + real, save :: inv_gridarea ! inverse of grid area, m2 + + real :: Sumcover, Sumland ! Land-coverage + logical :: debug_flag ! set true when i,j match DEBUG_i, DEBUG_j + real :: Vg_scale + + ! Ecosystem specific deposition requires the fraction of dep in each + ! landuse, iL: + + real, dimension(NDRYDEP_TOT,NLUMAX):: Vg_ref_iL + real, dimension(NSPEC_ADV ,NLANDUSE):: fluxfrac_adv + integer :: iL_used(NLUMAX), nlu_used + real :: wet, dry ! Fractions + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Extra outputs sometime used. Important that this +!! line is kept at the end of the variable definitions and the start of real +!! code - allows both in .inc file +!! Uncomment and make .inc file as required + ! include 'EXTRA_LU_Setup.inc' +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +! first calculate the 3m deposition velocity following the same +! procedure as in the lagmod. second the flux and the accumulated +! deposition is calculated. +! +! effective dry deposition velocity applied to the model concentration +! at the top of the constant flux layer, zdep +! Dry deposion rates are specified in subroutine readpar +! + +! FOR DEBUGGING + imm = current_date%month ! for debugging + idd = current_date%day ! for debugging + ihh = current_date%hour ! for debugging + iss = current_date%seconds ! for debugging + + inv_gridarea = 1.0/(GRIDWIDTH_M*GRIDWIDTH_M) + + + ! - Set up debugging coordinates first. ---------------------------! + ! If location matches debug i,j value, set debug_flag. Also passed + ! to Rsurface_ml + + debug_flag= ( debug_proc .and. i == debug_li .and. j == debug_lj) + + + ! -----------------------------------------------------------------! + !.and conversion factor, convfac (( ps-pt)/grav... ) ===> + ! pressure in kg m-1 s-2 + + convfac = (Grid%psurf - PT)*carea(KMAX_MID)*xmd(i,j)/ATWAIR + ! -----------------------------------------------------------------! + +! !.and factor, kg_air_ij (( ps-pt)/grav... ) ===> +! ! pressure in kg m-1 s +! ! used for converting from mixing ratio to kg +! +! kg_air_ij = (ps(i,j,1) - PT)*carea(KMAX_MID) +! ! -----------------------------------------------------------------! +! + lossfrac = 1.0 ! Ratio of xn before and after deposition + + + dtz = dt_advec/Grid%DeltaZ + + if ( MY_DEBUG .and. debug_flag ) then + write(*,"(a26,4i4)") "UKDEP DryDep me, i,j ", me, i,j + write(*,"(a10,i4,3i3,i6,10f10.3)") "UKDEP SOL", & + daynumber, imm, idd, ihh, current_date%seconds, & + Grid%zen, Grid%coszen, Grid%wetarea, & + 1.0e-5*Grid%psurf, Grid%Idiffuse, Grid%Idirect + write(*,"(a10,i4,3i3,2f8.3,es12.4,f8.4)") "UKDEP NWP", & + daynumber, imm, idd, ihh, & + Grid%Hd, Grid%LE, Grid%invL, Grid%ustar + end if + + + !/ Initialise Grid-avg Vg for this grid square: + + Grid_Vg_ref(:) = 0.0 + Grid_Vg_3m(:) = 0.0 + Vg_ref_iL(:,:) = 0.0 + Vg_ratio(:) = 0.0 + Sumcover = 0.0 + Sumland = 0.0 + fluxfrac_adv (:,:) = 0.0 + + + !/ SO2/NH3 for Rsur calc + Grid%so2nh3ratio = & + xn_2d(NSPEC_SHL+IXADV_SO2,KMAX_MID) / & + max(1.0,xn_2d(NSPEC_SHL+IXADV_NH3,KMAX_MID)) + + + if ( STO_FLUXES ) call Setup_StoFlux(daynumber, & + xn_2d(NSPEC_SHL+FLUX_ADV,KMAX_MID),amk(KMAX_MID)) + + + !/ And start the sub-grid stuff over different landuse (iL) + + nlu = LandCover(i,j)%ncodes + LULOOP: do iiL= 1, nlu + iL = LandCover(i,j)%codes(iiL) + + iL_used (iiL) = iL ! for eco dep + + f_phen = LandCover(i,j)%fphen(iiL) + + + L = Sub(iL) ! ! Assign e.g. Sub(iL)ustar to ustar + L%SGS = LandCover(i,j)%SGS(iiL) !NOT NEEDED??? + L%EGS = LandCover(i,j)%EGS(iiL) + + + if ( MY_DEBUG .and. debug_flag ) then + write(6,"(a40,4i3,f6.1,2i4,3f7.3,2i4,2f6.2)") & + "DEBUG_veg: me,nlu,iiL,iL, lat, SGS, EGS ", & + me,nlu,iiL, iL, gb(i,j), L%SGS, L%EGS, & + L%coverage, L%LAI, L%hveg,daynumber, & + Grid%snow, SWP(daynumber),L%t2C + + write(6,"(a10,2i4,2f7.2,2es12.3,3f8.3)") "UKDEP SUB", me, & + iL, Grid%ustar, L%ustar, Grid%invL, & + L%invL, L%Ra_ref, L%Ra_3m,L%rh + + end if + + + call Rb_gas(L%is_water, L%ustar, L%z0, DRYDEP_CALC,Rb) + + call Rsurface(DRYDEP_CALC,Rsur_dry,Rsur_wet,errmsg,debug_flag) + + + !=================== + !// calculate dry deposition velocities for fine/coarse particles + + convec = Grid%wstar/L%ustar ! Convection velocity scale + convec = convec * convec + + call Aero_Rb ( L%ustar, convec, Grid%rho_ref & + , Grid%u_ref, iL, Grid%snow, Grid%wetarea, L%t2 & + , Vs, aeRb, aeRbw ) + !=================== + + + !/... add to grid-average Vg: + + + wet = Grid%wetarea + dry = 1.0 - wet + + do n = 1, NDRYDEP_TOT !stDep NDRYDEP_CALC + + if ( n > NDRYDEP_CALC) then ! particles + + nae = n - NDRYDEP_CALC + RaVs = L%Ra_ref * Vs(nae) + + Vg_ref(n) = Vs(nae) + & + dry / (L%Ra_ref + aeRb(nae) + RaVs *aeRb(nae) ) & + + wet / (L%Ra_ref + aeRbw(nae) + RaVs *aeRbw(nae) ) + + RaVs = L%Ra_3m * Vs(nae) + + Vg_3m(n) = Vs(nae) + & + dry / (L%Ra_3m + aeRb(nae) + RaVs *aeRb(nae) ) & + + wet / (L%Ra_3m + aeRbw(nae) + RaVs *aeRbw(nae) ) + + else ! gases + Vg_ref(n) = dry / ( L%Ra_ref + Rb(n) + Rsur_dry(n) ) & + + wet / ( L%Ra_ref + Rb(n) + Rsur_wet(n) ) + + Vg_3m (n) = dry / ( L%Ra_3m + Rb(n) + Rsur_dry(n) ) & + + wet / ( L%Ra_3m + Rb(n) + Rsur_wet(n) ) + + endif + + ! Surrogate for NO2 compensation point approach, + ! assuming c.p.=4 ppb (ca. 1.0e11 #/cm3): + ! Note, xn_2d has no2 in #/cm-3 + + if ( n == CDEP_NO2 ) then + + no2fac = xn_2d(NSPEC_SHL+IXADV_NO2,KMAX_MID) + no2fac = max(1.0, no2fac) + no2fac = max(0.00001, (no2fac-1.0e11)/no2fac) + + Vg_ref(CDEP_NO2) = Vg_ref(CDEP_NO2) * no2fac + Vg_3m (CDEP_NO2) = Vg_3m (CDEP_NO2) * no2fac + end if ! CDEP_NO2 + + Vg_ref_iL(n,iiL) = Vg_ref(n) + Grid_Vg_ref(n) = Grid_Vg_ref(n) + L%coverage * Vg_ref(n) + Grid_Vg_3m(n) = Grid_Vg_3m(n) + L%coverage * Vg_3m(n) + + end do + + + Sumcover = Sumcover + L%coverage + + + !/-- only grab gradients over land-areas + + if ( L%is_water ) then + do n = 1, NDRYDEP_TOT !stDep NDRYDEP_CALC + sea_ratio(n) = Vg_ref(n)/Vg_3m(n) + end do + else + Sumland = Sumland + L%coverage + do n = 1, NDRYDEP_TOT !stDep NDRYDEP_CALC + Vg_ratio(n) = Vg_ratio(n) + L%coverage * Vg_ref(n)/Vg_3m(n) + end do + end if + + + if ( MY_DEBUG .and. debug_flag ) then + do n = 1 , NDRYDEP_TOT + write(*,"(a14,2i4,f7.3,i3,2f10.2,es12.2,2f8.2,a5,f8.3,2es18.6)") & + "UKDEP EXT: ", iiL, iL, L%coverage, n,& + L%LAI,100.0*L%g_sto, & ! tmp, in cm/s + L%Ra_ref, Rb(n), min( 999.0,Rsur_dry(n) ), & + " Vg: ", 100.0*Vg_3m(n), 100.0*Vg_ref(n), Vg_ratio(n) + end do + + end if + + ! + + !======================= + + if ( STO_FLUXES .and. luflux_wanted(iL) ) then + call Calc_StoFlux(iL, Vg_ref(FLUX_CDEP), debug_flag ) + end if ! STO_FLUXES + + !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !! Extra outputs sometime used for Sweden/IVL/SEI/CEH + !! Uncomment and make .inc file as required + + ! include 'EXTRA_LU_Outputs.inc' + + + !======================= + end do LULOOP + !======================= + !======================= + + if ( MY_DEBUG .and. Sumland > 1.011 ) then + print *, "SUMLAND ", me, nlu, i,j,i_fdom(i), j_fdom(j), Sumland + call CheckStop( "SUMLAND TOO BUG") + end if + + + if ( Sumland > 0.01 ) then + gradient_fac(:) = Vg_ratio(:) / Sumland + else + gradient_fac(:) = sea_ratio(:) + end if + + if ( MY_DEBUG .and. debug_flag ) then + write(*, "(a14,i2,3i3,10f6.2)") "UKDEP VG_UKR", & + Grid%snow, imm, idd, ihh, & + (100.0*Grid_Vg_ref(n), n = 1, min(5,NDRYDEP_CALC)), & + (100.0*Grid_Vg_3m(n), n = 1, min(5,NDRYDEP_CALC)) + end if + + +!-- loop through all affected advected species to calculate changes in +! concentration (xn_adv), the conc. ratios (cfac), and deposition + + do ncalc = 1, NDRYDEP_TOT !stDep NDRYDEP_CALC + + vg_fac (ncalc) = 1.0 - exp ( -Grid_Vg_ref(ncalc) * dtz ) + + end do ! n + + do n = 1, NDRYDEP_ADV + nadv = Dep(n)%adv + nadv2d = NSPEC_SHL + Dep(n)%adv + + ncalc = Dep(n)%calc + + if ( vg_set(n) ) then + + DepLoss(nadv) = & ! Use directly set Vg + ( 1.0 - exp ( -Dep(n)%vg * dtz ) ) * xn_2d( nadv2d,KMAX_MID) + cfac(nadv, i,j) = 1.0 ! Crude, for now. + + else + DepLoss(nadv) = vg_fac( ncalc ) * xn_2d( nadv2d,KMAX_MID) + cfac(nadv, i,j) = gradient_fac( ncalc ) + end if + + if ( DepLoss(nadv) < 0.0 .or. & + DepLoss(nadv)>xn_2d(nadv2d,KMAX_MID) ) then + call CheckStop("NEGXN DEPLOSS" ) + end if + + + xn_2d( nadv2d,KMAX_MID) = & + xn_2d( nadv2d,KMAX_MID) - DepLoss(nadv) + + + + if ( STO_FLUXES .and. nadv == FLUX_ADV ) then + ! fraction by which xn is reduced - used in + ! safety measure: + + if( xn_2d( nadv2d,KMAX_MID) > 1.0e-30 ) then + lossfrac = ( 1.0 - DepLoss(nadv)/ & + (DepLoss(nadv)+xn_2d( nadv2d,KMAX_MID))) + end if + if ( MY_DEBUG .and. lossfrac < 0.1 ) then + call CheckStop( lossfrac < 0.1, "ERROR: LOSSFRAC " ) + !print *, "ERROR: LOSSFRAC ", lossfrac, nadv, nadv2d + end if + end if + + + !.. ecosystem specific deposition - translate from calc to adv + ! and normalise + + do iiL = 1, nlu + iL = iL_used(iiL) + + if ( vg_set(n) ) then + fluxfrac_adv(nadv,iL) = Sub(iL)%coverage ! Since all vg_set equal + else + Vg_scale = Vg_ref_iL(ncalc,iiL)/ Grid_Vg_ref(ncalc) + fluxfrac_adv(nadv,iL) = Sub(iL)%coverage*Vg_scale + end if + + + !======================= + ! The fraction going to the stomata = g_sto/g_sur = g_sto * R_sur. + ! Vg*nmole_o3 is the instantaneous deposition flux of ozone, and + ! the actual amount "deposited" is obtained from DepLoss(O3) using + ! fluxfrac as obtained above. + + ! Now, DepLoss is loss of molecules/cm3 over time-period dt_advec + ! and depth z_bnd over 1m2 of grid. For sto fluxes we need to + ! find values over 1m2 of vegeation (regardless of how much veg + ! is in grid, so we don't need cover. Instead: + + + if ( MY_DEBUG .and. debug_flag ) then + + if ( vg_set(n) ) then + write(6,"(a12,3i3,3f12.3)") "FLUXSET ", iiL, iL, nadv, & + 100.0*Dep(n)%vg, Sub(iL)%coverage, fluxfrac_adv(nadv,iL) + else + write(6,"(a12,3i3,f6.3,4f8.3)") "FLUXFRAC ", iiL, iL, nadv, & + Sub(iL)%coverage, & + 100.0*Grid_Vg_ref(ncalc), 100.0*Vg_ref_iL(ncalc,iiL), & + 100.0*Sub(iL)%coverage*Vg_ref_iL(ncalc,iiL), fluxfrac_adv(nadv,iL) + end if + end if + end do + + + + + !..accumulated dry deposition per grid square and summed over the whole + ! domain + +! totddep( nadv ) = totddep (nadv) + Deploss(nadv) * convfac + + + if ( MY_DEBUG .and. debug_flag ) then + if ( vg_set(n) ) then + write(*, "(a30,2i4,f8.3)") "DEBUG DryDep SET ", n,nadv, Dep(n)%vg + else + write(*, "(a30,3i4,f12.5)") & + "DEBUG DryDep n, adv, calc, fac ", n,nadv, ncalc, gradient_fac( ncalc) + write(*, "(a20,2e12.4)") & + "DEBUG xn, DepLoss ", xn_2d(nadv2d,KMAX_MID), DepLoss(nadv) + write(*, "(a20,2f8.4)") "DEBUG gv_fac( ncalc)", & + vg_fac(ncalc), 1.0-vg_fac(ncalc) + end if + !write(*,*) "XNSPEC DATES ", current_date + !do ispec = 1, NSPEC_TOT + ! write(*,"(a7,i3,es15.8)") "XNSPEC ", ispec, xn_2d(ispec,20) + !end do + end if + + end do ! n + + call DryDep_Budget(i,j,Deploss,convfac) + + ! inv_gridarea = xm2(i,j)/(GRIDWIDTH_M*GRIDWIDTH_M) + convfac2 = convfac * xm2(i,j) * inv_gridarea/amk(KMAX_MID) + + + !.. Add DepLoss to budgets if needed: + + call Add_ddep(debug_flag,dt_advec,i,j,convfac2,lossfrac,& + fluxfrac_adv,c_hvegppb) + + end subroutine drydep + +end module DryDep_ml diff --git a/EQSAM_ml.f90 b/EQSAM_ml.f90 new file mode 100644 index 0000000..29b6145 --- /dev/null +++ b/EQSAM_ml.f90 @@ -0,0 +1,654 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 EQSAM_v03d_ml + + implicit none + private + + + !/- subroutines: + public :: eqsam_v03d + + + contains + +!subroutine eqsam_v03c(yi,yo,nca,nco,iopt,loop,imax,ipunit,in) +! +!implicit none +!___________________________________________________________________________________________________________________________________ +! Written by Swen Metzger 3/11/99. Modified October 2002, March 2003. +! +! Department of Atmospheric Chemistry, Max-Planck-Institute for Chemistry. +! email: metzger@mpch-mainz.mpg.de +! +! COPYRIGHT 1999-2003 +! +! purpose +! ------- +! EQSAM is a new and Simplified Aerosol Model, which allows to calculate the gas/aerosol (EQuilibrium) +! partitioning, including the aerosol water and aerosol composition suffieciently fast and accurate for +! global modeling. EQSAM is based on a parameterization of activcity coefficients (AC), i.e. an AC-RH +! relationship, which holds for atmospheric aerosols in equilibrium with the ambient relative humidity (RH). +! Note that EQSAM should be regarded as a starting point for further development. Although not yet perfect, +! it compares rather well with more complex thermodynamic gas/aerosol equilibrium models (EQMs), such as +! ISORROPIA, or SCAPE. +! +! interface +! --------- +! call eqsam_v03b(yi,yo,nca,nco,iopt,loop,imax,ipunit,in) +! +! yi = input array (imax, nca) +! yo = output array (imax, nco) +! imax = max loop (e.g. time steps) +! nca >= 11 +! nc0 >= 35 +! iopt = 1 metastable +! iopt = 2 solids +! iopt = 3 hysteresis (metastable/solids) for online calculations +! iopt = 31 hysteresis lower branch +! iopt = 32 hysteresis upper branch +! ipunit = I/O unit (can be skipped) +! in = array (can be skipped) +! +! method +! ------ +! equilibrium / internal mixture assumption / aw=rh +! System: NH3,NH4+/H2SO4+,HSO4-,SO4--/HNO3,NO3-, HCl,Cl-/Na+, H2O +! (K+,Ca++,Mg++) +! external +! -------- +! program eqmd.f90 (driver) +! subroutine gribio.f90 (provides diagnostics output in grib/binary/ascii format) +! +! reference +! --------- +! Swen Metzger Ph.D Thesis, University Utrecht, 2000 +! http://www.mpch-mainz.mpg.de/~metzger +! +! Metzger, S. M., F. J. Dentener, J. Lelieveld, and S. N. Pandis, +! GAS/AEROSOL PARTITIONING I: A COMPUTATIONALLY EFFICIENT MODEL, +! JOURNAL OF GEOPHYSICAL RESEARCH, VOL. 107, NO. D16, 10.1029/2001JD001102, 2002 +! Metzger, S. M., F. J. Dentener, A. Jeuken, and M. Krol, J. Lelieveld, +! GAS/AEROSOL PARTITIONING II: GLOBAL MODELING RESULTS, +! JOURNAL OF GEOPHYSICAL RESEARCH, VOL. 107, NO. D16, 10.1029/2001JD001103, 2002. +!___________________________________________________________________________________________________________________________ + +!>-------------------------------------------------------------------------------< +subroutine eqsam_v03d (SO4in, HNO3in,NO3in,NH3in,NH4in,NAin,CLin, relh,temp,pa, & + aSO4out, aNO3out, aNH4out, aNaout, aClout, & + gSO4out, gNH3out, gNO3out, gClout, aH2Oout) +!>-------------------------------------------------------------------------------< + + use ModelConstants_ml, only : KMAX_MID, KCHEMTOP + +implicit none + real, intent(in):: temp(KCHEMTOP:KMAX_MID),relh(KCHEMTOP:KMAX_MID), & + pa(KCHEMTOP:KMAX_MID) + +!hf real :: c(nx,ny,nz,nspec), ah2o(nx,ny,nz) + real,intent(in):: & + SO4in(KCHEMTOP:KMAX_MID), & + NO3in(KCHEMTOP:KMAX_MID), & + NH4in(KCHEMTOP:KMAX_MID), & + NAin (KCHEMTOP:KMAX_MID), & + CLin (KCHEMTOP:KMAX_MID), & + HNO3in(KCHEMTOP:KMAX_MID), & + NH3in(KCHEMTOP:KMAX_MID) + + real,intent(out):: & + aSO4out(KCHEMTOP:KMAX_MID), & + aNO3out(KCHEMTOP:KMAX_MID), & + aNH4out(KCHEMTOP:KMAX_MID), & + aNAout (KCHEMTOP:KMAX_MID), & + aCLout (KCHEMTOP:KMAX_MID), & + gSO4out(KCHEMTOP:KMAX_MID), & + gNH3out(KCHEMTOP:KMAX_MID), & + gNO3out(KCHEMTOP:KMAX_MID), & + gCLout (KCHEMTOP:KMAX_MID), & + aH2Oout(KCHEMTOP:KMAX_MID) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!.. local .... + ! mean value for mixture of wet (2) and dry (1) gridboxes (needed for HYSTERESIS) +real,parameter :: RH_HIST_DW=1.50 +real,parameter :: T0=298.15, T1=298.0, & + AVO=6.03e23,R=82.0567e-6 ! in cu.m*atm/deg/mole +real,parameter :: RHMAX=0.99, RHMIN=0.0001 ! restrict to max / min RH +real,parameter :: MWNH4=18., MWSO4=96., & ! mole mass of species considered + MWNO3=62., MWCl=35.5, & + MWNa=23.0, MWH20=55.51*18.01 ! MWCa=40.1,MWN=14.0, MWS=32.1 +real,parameter :: ZERO=0.0 +real,parameter :: GF1=0.25,GF2=0.50,GF3=0.40,GF4=1.00 ! exponents of AC-RH functions +!______________________________________________ +integer,parameter :: NPAIR=10 +! +integer :: ii,il,IHYST, k, iopt +!integer,intent(in) :: nca,nco,imax,loop,ipunit +!integer,intent(inout) :: iopt +!______________________________________________ +!integer,dimension(6),intent(in) :: in +!______________________________________________ +real :: T0T,TT,RH,PX,RHD,KAN,KAC,ZIONIC,RH_HIST,GAMA,GG,GF,GFN +real :: X00,X01,X02,X03,X04,X05,X08,X09,X10,X11 +real :: X0,X1,X2,X3,X4,X5,X6,XK10,XK6 +real :: ZFLAG,ZKAN,ZKAC,PH,COEF,GAMAAN,HPLUS,AKW,XKW,MOLAL +real :: TNH4,TSO4,TNO3,TNa,TCl,TPo,TCa,TMg +real :: PNH4,PSO4,PNO3,PCl,PNa,GNO3,GNH3,GSO4,GHCl +real :: ASO4,ANO3,ANH4,ACl,ANa,SNH4,SSO4,SNO3,SCl,SNa +real :: WH2O,PM,PMs,PMt,RINC,DON,RATIONS,GR,NO3P,NH4P +!_______________________________________________ +!real,dimension(imax,nca),intent(in) :: yi +!real,dimension(imax,nco),intent(out) :: yo +real,dimension(8) :: w1,w2 +real,dimension(8) :: RHDA,RHDE,RHDX,RHDZ ! RHD/MRHD for different aerosol types +real,dimension(NPAIR) :: M0,MW,NW,ZW ! arrays of ion pairs +! +! salt solutes: +! 1 = NACl, 2 = (NA)2SO4, 3 = NANO3, 4 = (NH4)2SO4, 5 = NH4NO3, 6 = NH4CL, 7 = 2H-SO4 +! 8 = NH4HSO4, 9 = NAHSO4, 10 = (NH4)3H(SO4)2 +! +! mole mass of the salt solute +DATA MW(1:NPAIR) / 58.5, 142.0, 88.0, 132.0, 80.0, 53.5, 98.0, 115.0, 120.0, 247.0/ +! square of max. dissocation number (not consistent) +DATA NW(1:NPAIR) / 2.0, 2.5, 2.5, 2.5, 3.5, 1.0, 4.5, 2.0, 2.0, 2.5/ +! exponents of water activity functions +DATA ZW(1:NPAIR) / 0.67, 1.0, 1.0, 1.0, 1.0, 1.0, 0.5, 1.0, 1.0, 1.0/ +! RHD / MRHD values as of ISORROPIA / SCAPE (T=298.15K) +DATA RHDA(1:8) / 0.32840, 0.4906, 0.6183, 0.7997, 0.67500, 0.5000, 0.4000, 0.0000/ +! Temp. coeff. +DATA RHDE(1:8) / -1860.0, -431.0, 852.00, 80.000, 262.000, 3951.0, 384.00, 0.0000/ +!_____________________________________________________________________________________ + IOPT = 1 ! METASTABLE aerosols + +IHYST=2 +IF(IOPT.EQ.31) THEN ! SOLID HYSTORY + IHYST=1 + IOPT=3 +ELSEIF(IOPT.EQ.32) THEN ! WET HISTORY + IHYST=2 + IOPT=3 +ENDIF + +w1=0.;w2=0. ! init/reset +!______________________________________________________________________________________ + + do k=KCHEMTOP,KMAX_MID +! get old relative humidity to calculate aerosol hysteresis (online only) + + RH_HIST = 2. ! WET HISTORY (DEFAULT) + IF(IHYST.EQ.1.OR.IOPT.EQ.2) RH_HIST = 1. ! SET TO SOLIDS + +! meteorology + TT = temp(k) ! yi(il,1) ! T [K] + RH = relh(k) ! yi(il,2) ! RH [0-1] + PX = pa(k) ! yi(il,11) ! p [hPa] +! +! gas+aerosol: + w1(1) = NAin(k) !yi(il,6) ! Na+ (ss + xsod) (a) [umol/m^3] + w1(2) = SO4in(k) !yi(il,4) ! H2SO4 + SO4-- (p) [umol/m^3] + w1(3) = NH3in(k)+NH4in(k) !yi(il,3) ! NH3 (g) + NH4+ (p) [umol/m^3] + w1(4) = HNO3in(k)+NO3in(k) !yi(il,5) ! HNO3 (g) + NO3- (p) [umol/m^3] + w1(5) = CLin(k) !yi(il,7) ! HCl (g) + Cl- (p) [umol/m^3] + w1(6) = 0. !yi(il, 8) ! K+ (p) from Dust [umol/m^3] + w1(7) = 0. !yi(il, 9) ! Ca++ (p) from Dust [umol/m^3] + w1(8) = 0. !yi(il,10) ! Mg++ (p) from Dust [umol/m^3] +!______________________________________________ + + zflag=1. + + w1=w1*1.0e-6 ! [mol/m^3 air] + + TNa = w1(1) ! total input sodium (g+p) + TSO4 = w1(2) ! total input sulfate (g+p) + TNH4 = w1(3) ! total input ammonium (g+p) + TNO3 = w1(4) ! total input nitrate (g+p) + TCl = w1(5) ! total input chloride (g+p) + TPo = w1(6) ! total input potasium (g+p) + TCa = w1(7) ! total input calcium (g+p) + TMg = w1(8) ! total input magnesium(g+p) + +! SULFATE RICH + + if((TNa + TNH4 + TPo +2.*(TCa + TMg)) .le. (2.*TSO4)) then + zflag=3. + endif + +! SULFATE VERY RICH CASE if (NH4+Na+K+2(Ca+Mg))/SO4 < 1 + + if((TNa + TNH4 + TPo +2.*(TCa + TMg)) .le. TSO4) then + zflag=4. + endif + +! SULFATE NEUTRAL CASE + + if((TNa + TNH4 + TPo +2.*(TCa + TMg)) .gt. (2.*TSO4)) then + zflag=2. + endif + +! SULFATE POOR AND CATION POOR CASE + + if((TNa + TPo +2.*(TCa + TMg)) .gt. (2.*TSO4)) then + zflag=1. + endif + + IF ( RH .LT. RHMIN ) RH=RHMIN + IF ( RH .GT. RHMAX ) RH=RHMAX + +! CALCULATE TEMPERATURE DEPENDENCY FOR SOME RHDs + + RHDX(:)=RHDA(:)*exp(RHDE(:)*(1./TT-1./T0)) + RHDZ(:)=RHDX(:) + +! ACCOUNT FOR VARIOUS AMMOMIUM/SODIUM SULFATE SALTS ACCORDING TO MEAN VALUE AS OF ISORROPIA + GG=2.0 ! (Na)2SO4/(NH4)2SO4 is PREFFERED SPECIES FOR SULFATE DEFICIENT CASES + IF(ZFLAG.EQ.3.) THEN + IF(RH.LE.RHDZ(7)) THEN ! MIXTURE OF (NH4)2SO4(s) & NH4HSO4(s) & (NH4)3H(SO4)2(s) + GG=1.677 ! (Na)2SO4 & NaHSO4 +! GG=1.5 + ELSEIF(RH.GT.RHDZ(7).AND.RH.LE.RHDZ(5)) THEN ! MAINLY (Na)2SO4/(NH4)2SO4(s) & (NH4)3H(SO4)2(s) + GG=1.75 +! GG=1.5 + ELSEIF(RH.GE.RHDZ(5)) THEN ! (NH4)2SO4(S) & NH4HSO4(S) & SO4-- & HSO4- + GG=1.5 ! (Na)2SO4 & NaHSO4 + ENDIF + ENDIF + IF(ZFLAG.EQ.4.) GG=1.0 ! IF SO4 NEUTRALIZED, THEN ONLY AS NaHSO4/NH4HSO4(S) + !OR HSO4- / H2SO4 + RHD=RH + IF(IOPT.EQ.2.OR.RH_HIST.LT.RH_HIST_DW) THEN ! GET RHD FOR SOLIDS / HYSTERESIS +! +! GET LOWEST DELIQUESCENCE RELATIVE HUMIDITIES ACCORDING TO THE CONCENTRATION DOMAIN +! (APROXIMATION BASED ON RHD / MRHD ISORROPIA/SCAPE +! + w2(:)=1. + do ii=1,8 + if(w1(ii).le.1.e-12) w2(ii)=0. ! skip compound in RHD calculation if + enddo ! concentration is zero or rather small + +! GET LOWEST RHD ACCORDING TO THE CONCENTRATION DOMAIN + +! zflag=1. (cation rich) ... +! 1. sea salt aerosol : RHDX(1)=MgCl2 +! 2. mineral dust aerosol : RHDX(2)=Ca(NO3)2 +! +! zflag=2. (sulfate neutral) ... +! 3. ammonium + nitrate : RHDX(3)= NH4NO3 +! 4. ammonium + sulfate : RHDX(4)=(NH4)2SO4 +! 5. ammonium + sulfate mixed salt : RHDX(5)=(NH4)3H(SO4)2, (NH4)2SO4 +! 6. ammonium + nitrate + sulfate : RHDX(6)=(NH4)2SO4, NH4NO3, NA2SO4, NH4CL +! +! zflag=3. (sulfate poor) ... +! 7. ammonium + sulfate (1:1,1.5) : RHDX(7)= NH4HSO4 +! +! zflag=4. (sulfate very poor) ... +! 8. sulfuric acid : RHDX(8)= H2SO4 + + IF(ZFLAG.EQ.1.)THEN + + RHD=W2(1)+W2(5) ! Na+ dependency + IF(RHD.EQ.0.) RHDX(1)=1. + RHD=W2(6)+W2(7)+W2(8) ! K+/Ca++/Mg++ dependency (incl. ss) + IF(RHD.EQ.0.) RHDX(2)=1. + + RHD=MINVAL(RHDX(1:2)) + + ELSEIF(ZFLAG.EQ.2.)THEN + + RHD=W2(3)*W2(4) ! NH4+ & NO3- dependency + IF(RHD.EQ.0.) RHDX(3)=1. + RHD=W2(2)+W2(3) ! NH4+ & SO4-- dependency + IF(GG.NE.2.) RHD=0. ! account only for pure (NH4)2SO4 + IF(RHD.EQ.0.) RHDX(4)=1. + RHD=W2(2)+W2(3) ! NH4+ & SO4-- dependency + IF(RHD.EQ.0.) RHDX(5)=1. + RHD=W2(2)+W2(3)+W2(4)+W2(5) ! (NH4)2SO4, NH4NO3, NA2SO4, NH4CL dependency + IF(RHD.EQ.0.) RHDX(6)=1. + +! RHD=MINVAL(RHDX(3:4)) + RHD=MINVAL(RHDX(3:6)) + + ELSEIF(ZFLAG.EQ.3.)THEN + + RHD=W2(2)+W2(3) ! NH4+ & SO4-- dependency + IF(RHD.EQ.0.) RHDX(7)=1. + RHD=RHDX(7) + + ELSEIF(ZFLAG.EQ.4.)THEN + + RHD=W2(2) ! H2SO4 dependency (assume no dry aerosol) + IF(RHD.EQ.0.) RHDX(8)=1. + + RHD=RHDX(8) + + ENDIF ! ZFLAG + ENDIF ! SOLIDS + + +! GET WATER ACTIVITIES ACCORDING TO METZGER, 2000. +! FUNCTION DERIVED FROM ZSR RELATIONSHIP DATA (AS USED IN ISORROPIA) + + M0(:) = ((NW(:)*MWH20/MW(:)*(1./RH-1.)))**ZW(:) + +! CALCULATE TEMPERATURE DEPENDENT EQUILIBRIUM CONSTANTS + + T0T=T0/TT + COEF=1.0+LOG(T0T)-T0T + +! EQUILIBRIUM CONSTANT NH4NO3(s) <==> NH3(g) + HNO3(g)[atm^2] (ISORROPIA) + + XK10 = 5.746e-17 + XK10= XK10 * EXP(-74.38*(T0T-1.0) + 6.120*COEF) + KAN = XK10/(R*TT)/(R*TT) + +! EQUILIBRIUM CONSTANT NH4CL(s) <==> NH3(g) + HCL(g) [atm^2] (ISORROPIA) + + XK6 = 1.086e-16 + XK6 = XK6 * EXP(-71.00*(T0T-1.0) + 2.400*COEF) + KAC = XK6/(R*TT)/(R*TT) + +! CALCULATE AUTODISSOCIATION CONSTANT (KW) FOR WATER H2O <==> H(aq) + OH(aq) [mol^2/kg^2] (ISORROPIA) + + XKW = 1.010e-14 + XKW = XKW *EXP(-22.52*(T0T-1.0) + 26.920*COEF) + +! GET MEAN MOLAL IONIC ACTIVITY COEFF ACCORDING TO METZGER, 2002. + + GAMA=0.0 + IF(RH.GE.RHD) GAMA=(RH**ZFLAG/(1000./ZFLAG*(1.-RH)+ZFLAG)) + GAMA = GAMA**GF1 ! ONLY GAMA TYPE OF NH4NO3, NaCl, etc. NEEDED SO FAR + + GAMA=0.0 + GFN=K*K ! K=2, i.e. condensation of 2 water molecules per 1 mole ion pair + GF=GFN*GF1 ! = GFN[=Nw=4] * GF1[=(1*1^1+1*1^1)/2/Nw=1/4] = 1 + ! ONLY GAMA TYPE OF NH4NO3, NH4Cl, etc. needed so far + + IF(RH.GE.RHD) GAMA=RH**GF/((GFN*MWH20*(1./RH-1.)))**GF1 + + GAMA = min(GAMA,1.0) ! FOCUS ON 0-1 SCALE + GAMA = max(GAMA,0.0) + GAMA = (1.-GAMA)**K ! transplate into aqueous phase equillibrium and account for + ! enhanced uptake of aerosol precursor gases with increasing RH + ! (to match the results of ISORROPIA) + + +! CALCULATE RHD DEPENDENT EQ: IF RH < RHD => NH4NO3(s) <==> NH3 (g) + HNO3(g) (ISORROPIA) +! IF RH >> RHD => HNO3 (g) -> NO3 (aq) + + X00 = MAX(ZERO,MIN(TNa,GG*TSO4)) ! MAX SODIUM SULFATE + X0 = MAX(ZERO,MIN(TNH4,GG*TSO4-X00)) ! MAX AMMOMIUM SULFATE + X01 = MAX(ZERO,MIN(TNa-X00, TNO3)) ! MAX SODIUM NITRATE + X1 = MAX(ZERO,MIN(TNH4-X0,TNO3-X01)) ! MAX AMMOMIUM NITRATE +! + X02 = MAX(ZERO,MIN(TNa-X01-X00,TCl)) ! MAX SODIUM CHLORIDE + X03 = MAX(ZERO,MIN(TNH4-X0-X1,TCl-X02))! MAX AMMOMIUM CHLORIDE + + X2 = MAX(TNH4-X1-X0-X03,ZERO) ! INTERIM RESIDUAL NH3 + X3 = MAX(TNO3-X1-X01,ZERO) ! INTERIM RESIDUAL HNO3 + X04 = MAX(TSO4-(X0+X00)/GG,ZERO) ! INTERIM RESIDUAL H2SO4 + X05 = MAX(TCl-X03-X02,ZERO) ! INTERIM RESIDUAL HCl +! X06 = MAX(TNa-X02-X01-X00,ZERO) ! INTERIM RESIDUAL Na (should be zero for electro-neutrality in input data) +! + + ZKAN=2. + IF(RH.GE.RHD) ZKAN=ZKAN*GAMA + + X4 = X2 + X3 +!corrected SM X5 = SQRT(X4*X4+KAN*ZKAN) + X5 = SQRT(X4*X4+KAN*ZKAN*ZKAN) + X6 = 0.5*(-X4+X5) + X6 = MIN(X1,X6) + + GHCl = X05 ! INTERIM RESIDUAl HCl + GNH3 = X2 + X6 ! INTERIM RESIDUAl NH3 + GNO3 = X3 + X6 ! RESIDUAl HNO3 + GSO4 = X04 ! RESIDUAl H2SO4 + PNa = X02 + X01 + X00 ! RESIDUAl Na (neutralized) + + ZKAC=2. + IF(RH.GE.RHD) ZKAC=ZKAC*GAMA + + X08 = GNH3 + GHCl + X09 = SQRT(X08*X08+KAC*ZKAC*ZKAC) + X10 = 0.5*(-X08+X09) + X11 = MIN(X03,X10) + + GHCl = GHCl + X11 ! RESIDUAL HCl + GNH3 = GNH3 + X11 ! RESIDUAL NH3 + +! GO SAVE ... + + IF(GHCl.LT.0.) GHCl=0. + IF(GSO4.LT.0.) GSO4=0. + IF(GNH3.LT.0.) GNH3=0. + IF(GNO3.LT.0.) GNO3=0. + IF(PNa.LT.0.) PNa=0. + IF(GSO4.GT.TSO4) GSO4=TSO4 + IF(GNH3.GT.TNH4) GNH3=TNH4 + IF(GNO3.GT.TNO3) GNO3=TNO3 + IF(GHCl.GT.TCl) GHCl=TCl + IF(PNa.GT.TNa) PNa=TNa +! IF(PNa.LT.TNa) print*,il,' PNa.LT.TNa => no electro-neutrality in input data! ',PNa,TNa + + +! DEFINE AQUEOUSE PHASE (NO SOLID NH4NO3 IF NO3/SO4>1, TEN BRINK, ET AL., 1996, ATMOS ENV, 24, 4251-4261) + +! IF(TSO4.EQ.ZERO.AND.TNO3.GT.ZERO.OR.TNO3/TSO4.GE.1.) RHD=RH + +! IF(IOPT.EQ.2.AND.RH.LT.RHD.OR.IOPT.EQ.2.AND.RH_HIST.LT.RH_HIST_DW) THEN ! SOLIDS / HYSTERESIS + IF(RH_HIST.EQ.1.AND.RH.LT.RHD) THEN ! SOLIDS / HYSTERESIS + + ! EVERYTHING DRY, ONLY H2SO4 (GSO4) REMAINS IN THE AQUEOUSE PHASE + + ANH4 = 0. + ASO4 = 0. + ANO3 = 0. + ACl = 0. + ANa = 0. + + ELSE ! SUPERSATURATED SOLUTIONS NO SOLID FORMATION + + ASO4 = TSO4 - GSO4 + ANH4 = TNH4 - GNH3 + ANO3 = TNO3 - GNO3 + ACl = TCl - GHCl + ANa = PNa + + ENDIF ! SOLIDS / HYSTERESIS + +! CALCULATE AEROSOL WATER [kg/m^3(air)] +! +! salt solutes: +! 1 = NACl, 2 = (NA)2SO4, 3 = NANO3, 4 = (NH4)2SO4, 5 = NH4NO3, 6 = NH4CL, 7 = 2H-SO4 +! 8 = NH4HSO4, 9 = NAHSO4, 10 = (NH4)3H(SO4)2 +! + IF(ZFLAG.EQ.1.) WH2O = ASO4/M0( 2) + ANO3/M0(3) + ACl/M0(6) + IF(ZFLAG.EQ.2.) WH2O = ASO4/M0( 4) + ANO3/M0(5) + ACl/M0(6) + IF(ZFLAG.EQ.3.) WH2O = ASO4/M0( 8) + ANO3/M0(5) + ACl/M0(6) + IF(ZFLAG.EQ.4.) WH2O = ASO4/M0( 8) + GSO4/M0(7) + + +! CALCULATE AQUEOUS PHASE PROPERTIES + +! PH = 9999. + PH = 7. + MOLAL = 0. + HPLUS = 0. + ZIONIC= 0. + +!hf&pw IF(WH2O.GT.0.) THEN + IF(WH2O.GT.1.0e-2) THEN + + ! CALCULATE AUTODISSOCIATION CONSTANT (KW) FOR WATER + + AKW=XKW*RH*WH2O*WH2O ! H2O <==> H+ + OH- with kw [mol^2/kg^2] + AKW=AKW**0.5 ! [OH-] = [H+] [mol] + + ! Calculate hydrogen molality [mol/kg], i.e. H+ of the ions: + ! Na+, NH4+, NO3-, Cl-, SO4--, HH-SO4- [mol/kg(water)] + ! with [OH-] = kw/[H+] + + HPLUS = (-ANa/WH2O-ANH4/WH2O+ANO3/WH2O+ACl/WH2O+GG*ASO4/WH2O+GG*GSO4/WH2O+ & + SQRT(( ANa/WH2O+ANH4/WH2O-ANO3/WH2O-ACl/WH2O-GG*ASO4/WH2O-GG*GSO4/WH2O)**2+XKW/AKW*WH2O))/2. + + ! Calculate pH + + PH=-ALOG10(HPLUS) ! aerosol pH + + ! Calculate ionic strength [mol/kg] + + ZIONIC=0.5*(ANa+ANH4+ANO3+ACl+ASO4*GG*GG+GSO4*GG*GG+XKW/AKW*WH2O*WH2O) + ZIONIC=ZIONIC/WH2O ! ionic strength [mol/kg] +! ZIONIC=min(ZIONIC,200.0) ! limit for output +! ZIONIC=max(ZIONIC,0.0) + + ENDIF ! AQUEOUS PHASE + +! +!------------------------------------------------------- +! calculate diagnostic output consistent with other EQMs ... +! + ASO4 = ASO4 + GSO4 ! assuming H2SO4 remains aqueous + + TNa = TNa * 1.e6 ! total input sodium (g+p) [umol/m^3] + TSO4 = TSO4 * 1.e6 ! total input sulfate (g+p) [umol/m^3] + TNH4 = TNH4 * 1.e6 ! total input ammonium (g+p) [umol/m^3] + TNO3 = TNO3 * 1.e6 ! total input nitrate (g+p) [umol/m^3] + TCl = TCl * 1.e6 ! total input chloride (g+p) [umol/m^3] + TPo = TPo * 1.e6 ! total input potasium (g+p) [umol/m^3] + TCa = TCa * 1.e6 ! total input calcium (g+p) [umol/m^3] + TMg = TMg * 1.e6 ! total input magnesium(g+p) [umol/m^3] +! +! residual gas: + GNH3 = GNH3 * 1.e6 ! residual NH3 + GSO4 = GSO4 * 1.e6 ! residual H2SO4 + GNO3 = GNO3 * 1.e6 ! residual HNO3 + GHCl = GHCl * 1.e6 ! residual HCl + +! total particulate matter (neutralized) + PNH4=TNH4-GNH3 ! particulate ammonium [umol/m^3] + PNO3=TNO3-GNO3 ! particulate nitrate [umol/m^3] + PCl =TCl -GHCl ! particulate chloride [umol/m^3] + PNa =TNa ! particulate sodium [umol/m^3] + PSO4=TSO4 ! particulate sulfate [umol/m^3] + +! liquid matter + ANH4 = ANH4 * 1.e6 ! aqueous phase ammonium [umol/m^3] + ANO3 = ANO3 * 1.e6 ! aqueous phase nitrate [umol/m^3] + ACl = ACl * 1.e6 ! aqueous phase chloride [umol/m^3] + ANa = ANa * 1.e6 ! aqueous phase sodium [umol/m^3] + ASO4 = ASO4 * 1.e6 ! aqueous phase sulfate [umol/m^3] + +! solid matter + SNH4=PNH4-ANH4 ! solid phase ammonium [umol/m^3] + SSO4=PSO4-ASO4 ! solid phase sulfate [umol/m^3] + SNO3=PNO3-ANO3 ! solid phase nitrate [umol/m^3] + SCl =PCl -ACl ! solid phase chloride [umol/m^3] + SNa =PNa -ANa ! solid phase sodium [umol/m^3] + +! GO SAVE ... + + IF(SNH4.LT.0.) SNH4=0. + IF(SSO4.LT.0.) SSO4=0. + IF(SNO3.LT.0.) SNO3=0. + IF(SCl.LT.0.) SCl=0. + IF(SNa.LT.0.) SNa=0. + + ! PM=SNH4+SSO4+SNO3+SNH4+SCl+SNa+ANH4+ASO4+ANO3+ACl+ANa ! total PM [umol/m^3] + ! PMs=SNH4*MWNH4+SSO4*MWSO4+SNO3*MWNO3+SCl*MWCl+SNa*MWNa ! dry PM [ug/m^3] + ! PMt=PMs+ANH4*MWNH4+ASO4*MWSO4+ANO3*MWNO3+ACl*MWCl+ ANa*MWNa ! dry+wet PM, excl.H20[ug/m^3] + + WH2O = WH2O * 1.e9 ! convert aerosol water from [kg/m^3] to [ug/m^3] + IF(WH2O.LT.1.e-3) WH2O=0. + +! UPDATE HISTORY RH FOR HYSTERESIS (ONLINE CALCULATIONS ONLY) + +!st RH_HIST=2. ! wet +!st IF(WH2O.EQ.0.) RH_HIST=1. ! dry + +! Approximate the pH (for test purposes only) +!st PH = 7. +!st HPLUS = 0. +!st IF(WH2O.GT.0.) HPLUS=(2.*TSO4+ANO3+ACl-ANH4-ANa)/WH2O*1000. ! hydrogen ion concentration [mol/l] +!st IF(HPLUS.GT.0.) PH=-ALOG10(HPLUS) ! aerosol pH + +!st ZIONIC=0. +!st IF(WH2O.GT.0.) ZIONIC=0.5*(ANa+ANH4+ANO3+ACl+ASO4*4.) ! ionic strength [moles/kg] +!st ZIONIC=ZIONIC*1.e3/WH2O +!st ZIONIC=min(ZIONIC,200.0) ! limit for output +!st ZIONIC=max(ZIONIC,0.0) + +!st GAMAAN=0.0 +!st IF(WH2O.GT.0.) GAMAAN = GAMA**GF1 ! activity coefficient (NH4NO3) +!st GAMAAN=min(GAMAAN,1.0) ! focus on 0-1 scale +!st GAMAAN=max(GAMAAN,0.0) + +!st RINC = 1. +!st IF(PMt.GT.0.) RINC = (WH2O/PMt+1)**(1./3.) ! radius increase due to water uptake +!st IF(RINC.EQ.0.) RINC = 1. + +!st RATIONS = 0. +!st IF(PSO4.GT.0.) RATIONS = PNO3/PSO4 ! nitrate / sulfate mol ratio + +!st GR = 0. +!st IF(GNO3.GT.0.) GR = GNH3/GNO3 ! gas ratio = residual NH3 / residual HNO3 [-] + +!st DON = 0. +!st IF((PNO3+2.*PSO4).GT.0.) DON = 100.*PNH4/(PNO3+2.*PSO4)! degree of neutralization by ammonia : + ! ammonium / total nitrate + sulfate [%] +!st NO3P = 0. +!st IF(TNO3.GT.0.) NO3P = 100.*PNO3/TNO3 ! nitrate partitioning = nitrate/total nitrate[%] + +!st NH4P = 0. +!st IF(TNH4.GT.0.) NH4P = 100.*PNH4/TNH4 ! ammonium partitioning = ammonium/total ammonium[%] + +! KAN = rks5/(r*temp)**2 ! Keq of NH3(g)+HNO3(g)---> NH4NO3 (s) + ! [mol^2/kg]/(R[m^3*atm/deg/mole]*T[K])**2 = [m^3*atm/kg] +! +! store aerosol species for diagnostic output: +!______________________________________________________________ + +! Output values: +!//.. aerosols + aSO4out(k) = PSO4 ! particulate sulfate (p=a+s) [umol/m^3] + aNO3out(k) = PNO3 ! particulate nitrate (p=a+s) [umol/m^3] + aNH4out(k) = PNH4 ! particulate ammonium (p=a+s) [umol/m^3] + aNAout(k) = PNa ! particulate sodium (p=a+s) [umol/m^3] + aClout(k) = PCl ! particulate chloride (p=a+s) [umol/m^3] +!//.. gases + gSO4out(k) = GSO4 ! residual H2SO4 (aq) [umol/m^3] + gNO3out(k) = GNO3 ! residual HNO3 (g) [umol/m^3] + gNH3out(k) = GNH3 ! residual NH3 (g) [umol/m^3] + gCLout(k) = GHCL ! residual HCl (g) [umol/m^3] + +!//.. aerosol water + aH2Oout(k) = WH2O ! aerosol Water (aq) [ug/m^3] + + enddo +! + end subroutine eqsam_v03d + +end module EQSAM_v03d_ml diff --git a/EmisDef_ml.f90 b/EmisDef_ml.f90 new file mode 100644 index 0000000..6838b09 --- /dev/null +++ b/EmisDef_ml.f90 @@ -0,0 +1,179 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module EmisDef_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!_____________________________________________________________________________ +implicit none +public :: EmisDef_Init ! sets names and conv. factors of allowed emissions +public :: EmisDef_Index ! function to find index of given pollutant name + + !----------------- basic emissions file definitions --------------------! + ! Here we define the parameters *not* likely to change often ! + ! between different model versions - e.g. the size and characteristics! + ! of emission files and sector splits. ! + !-----------------------------------------------------------------------! + ! What is "Flat emissions": ! + ! Most emission sources will have a seasonal, weekly, daily cycle. For ! + ! some sources there is no cycle, or the emission cycle is not known. ! + ! For these source emissions will be constant (or flat) throughout the ! + ! year. ! + !-----------------------------------------------------------------------! + + + ! Note on SNAP sectors: + ! ---------------------- + ! SNAP1 = public power stations,150m nat gas + ! SNAP2 = Comm./inst. combustion + ! SNAP3 = Industrial combustion !60m nat gas + ! SNAP4 = Production processes + ! SNAP5 = Extracton fossil fuels + ! SNAP6 = Solvents + ! SNAP7 = Road traffic + ! SNAP8 = Other mobile (trains+planes, ...) + ! SNAP9 = Waste! .. ds + some ground level + ! SNAP10 = Agriculture + ! SNAP11 = Nature + + + + !/.. First, define here the characteristics of the EMEP/CORINAIR + ! SNAP sector emissions data-bases: + + + + integer, public, parameter :: NCMAX = 11 ! Max. No. countries per grid +!hf + integer, public, parameter :: FNCMAX = 10 ! Max. No. countries (with + ! flat emissions) per grid + + + !/.. List of possible emissions, and their initial conversion factors: + + type, public :: emislist + character(len=6) :: name + real :: conv ! conv. emis file units to required units + end type emislist + + integer, public, parameter :: NEMIS_DEF=8 ! No of emitted species + ! ( before splitting ) + type(emislist), public, save, dimension(NEMIS_DEF) :: & + EmisDef = emislist("notdef", -1.0) + + + !/.. Sector specific information + + integer, public, parameter :: & + NSECTORS = 11 ! Number of SNAP-sectors in emissions +!hf +!hf SECENARIO + integer, public, parameter :: & + ANTROP_SECTORS=10 ! Non-natural sectors + + integer, public, parameter :: & + ISNAP_NAT = 11,& ! SNAP index for volcanoe emissions + ISNAP_SHIP = 8 ! SNAP index for flat emissions,e.g ship + ! Note that flat emissions do NOT necessarily + ! belong to the same SNAP sector + +! New vertical allocation from SNAP sectors. +! - allocations are guesswork - should be investigated + + 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.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 + /), & + (/NEMISLAYERS,NSECTORS /) )!hf stakheigth + + + +contains + +subroutine EmisDef_Init() + + ! Here we define the allowed emissions and their standard conversion + ! factors. Any emissions used must be in this list, but not all of + ! the following are required. E.g. MADE might just use sox, nox and nh3. + ! This will be checked in the Emissions_ml + + EmisDef(1) = emislist( "sox ", 0.5 ) ! tonne SO2 -> tonne S + EmisDef(2) = emislist( "nox ", 14.0/46.0 ) ! tonne NO2 -> tonne N + EmisDef(3) = emislist( "co ", 1.0 ) ! tonne CO -> tonne CO + EmisDef(4) = emislist( "nh3 ", 14.0/17.0 ) ! tonne NH3 -> tonne N + EmisDef(5) = emislist( "voc ", 1.0 ) ! tonne VOC -> tonne VOC + EmisDef(6) = emislist( "pm25 ", 1.0 ) ! tonne pm -> tonne pm + EmisDef(7) = emislist( "pm10 ", 1.0 ) ! tonne pm -> tonne pm + EmisDef(8) = emislist( "pmco ", 1.0 ) ! tonne pm -> tonne pm + +end subroutine EmisDef_Init +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +function EmisDef_Index(name) result(index) + + ! Here we find the index in EmisDef which corresponds to the pollutant name + ! passed as an argument. If no match is found index is returned as -1. + !--------------------------------------------------------------------------- + character(len=*), intent(in) :: name + integer :: index, i + + index = -1 + do i = 1, NEMIS_DEF + if ( name == EmisDef(i)%name ) then + index = i + exit + end if + end do + +end function EmisDef_Index + +!_____________________________________________________________________________ +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + end module EmisDef_ml +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!_____________________________________________________________________________ diff --git a/EmisGet_ml.f90 b/EmisGet_ml.f90 new file mode 100644 index 0000000..3288d1a --- /dev/null +++ b/EmisGet_ml.f90 @@ -0,0 +1,598 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module EmisGet_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + + use CheckStop_ml, only: CheckStop + use Country_ml, only: NLAND, IC_NAT, IC_VUL, Country + use EmisDef_ml, only: NSECTORS, ANTROP_SECTORS, NCMAX, FNCMAX, & + ISNAP_SHIP, ISNAP_NAT + use GridAllocate_ml, only: GridAllocate + use Io_ml, only: open_file, NO_FILE, ios, IO_EMIS + use ModelConstants_ml, only: NPROC + use My_Emis_ml, only: NEMIS, NRCSPLIT, EMIS_NAME, SPLIT_NAME, & + NEMIS_PLAIN, NEMIS_SPLIT, EMIS_NSPLIT + use Par_ml, only: me + use SmallUtils_ml, only: wordsplit + use Volcanos_ml + + implicit none + private + + !/* subroutines: + + public :: EmisGet ! Collects emissions of each pollutant + public :: EmisSplit ! => emisfrac, Speciation of voc, pm25, etc. + private :: femis ! Sets emissions control factors + + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + logical, private, save :: my_first_call = .true. + + logical, private, parameter :: DEBUG = .false. + + + ! 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) :: e_fact + + !/* emisfrac is used at each time-step of the model run to split + ! emissions such as VOC; PM into species. + + real, public, dimension(NRCSPLIT,NSECTORS,NLAND), save :: emisfrac + + !/ some common variables + character(len=40), private :: fname ! File name + character(len=80), private :: errmsg + + contains + + +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine EmisGet(iemis,emisname,IRUNBEG,JRUNBEG,GIMAX,GJMAX, & + globemis,globnland,globland,sumemis, & + globemis_flat,flat_globnland,flat_globland) + +!....................................................................... +!** DESCRIPTION: +! Reads in emissions 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(:,:,:,:):: globemis ! Emission values + real, intent(out), dimension(:,:,:) :: globemis_flat ! Flat emissions + ! (e.g. shipping) + integer, intent(inout), dimension(:,:,:):: & + globland, & ! Codes of countries-emitters + flat_globland ! Flat emis.codes (shipping) + integer, intent(inout), dimension(:,:) :: & + globnland, & ! No. emitions in grid + flat_globnland ! No. flat emitions in grid + real, intent(inout), dimension(:,:) :: sumemis ! Emission sums per + ! country(after e_fact) + + !--local + integer :: flat_iland, flat_nc, & + i, j, isec, iland, k, nc, & ! loop variables + iic,ic ! country code (read from file) + real :: duml,dumh ! dummy variables, low/high emis. + real, dimension(NSECTORS) :: tmpsec ! array for reading emission files + integer, save :: ncmaxfound = 0 ! Max no. countries found in grid + integer, save :: flat_ncmaxfound = 0 ! Max no. countries found in grid + ! including flat emissions + + !>============================ + + if ( my_first_call ) then + sumemis(:,:) = 0.0 ! Initialise sums + ios = 0 + call femis() ! emission factors (femis.dat file). + if ( ios /= 0 )return + my_first_call = .false. + endif + !>============================ + + + globemis (:,:,:,:) = 0.0 + globemis_flat(:,:,:) = 0.0 + + if (DEBUG) write(unit=6,fmt=*) "Called EmisGet with index, name", iemis, emisname + fname = "emislist." // emisname + call open_file(IO_EMIS,"r",fname,needed=.true.) + call CheckStop(ios,"EmisGet: ios error in emission file") + +READEMIS: do ! ************* Loop over emislist files ******************* + + read(unit=IO_EMIS,fmt=*,iostat=ios) iic,i,j, duml,dumh, & + (tmpsec(isec),isec=1,NSECTORS) + + if ( ios < 0 ) exit READEMIS ! End of file + call CheckStop(ios > 0,"EmisGet: ios error 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 543 + enddo + write(unit=errmsg,fmt=*) & + "COUNTRY CODE NOT RECOGNIZED OR UNDEFINED ", iic + call CheckStop(errmsg) + ic=0 +543 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 .or. & + ic == IC_NAT ) & ! Excludes DMS + cycle READEMIS + + !/* Ship emissions + + if ( Country(ic)%is_sea ) then ! ship emissions + + ! .......................................................... + ! Generate new land allocation in 50 km grid for FLAT + ! EMISSIONS (ships). First, we check if country "ic" + ! has already been found within that grid. If not, then ic is + ! added to flat_landcode and flat_nlandcode increased by one. + + !/** Test that ship emissions are only in sector ISNAP_SHIP + do isec=1,(ISNAP_SHIP-1) + call CheckStop(tmpsec(isec) /= 0, & + "EmisGet: NOT FLAT EMISSIONS") + enddo + do isec=ISNAP_SHIP+1,NSECTORS + call CheckStop(tmpsec(isec) /= 0, & + "EmisGet: NOT FLAT EMISSIONS") + enddo + !/** end test + + call GridAllocate("FLat",i,j,ic,FNCMAX, flat_iland, & + flat_ncmaxfound,flat_globland,flat_globnland) + ! ................................................... + ! Assign e_fact corrected emissions to global FLAT + ! emission matrices. + ! ................................................... + + globemis_flat(i,j,flat_iland) = globemis_flat(i,j,flat_iland) & + + e_fact(ISNAP_SHIP,ic,iemis) * tmpsec(ISNAP_SHIP) + + !...................................................... + !.. Sum over all sectors, store as Ktonne: + !...................................................... + + sumemis(ic,iemis) = sumemis(ic,iemis) & + + 0.001 * globemis_flat(i,j,flat_iland) + + cycle READEMIS + endif !ship emissions + + + !....................................................... + !/** Volcanos + !....................................................... + + if ( trim ( emisname ) == "sox" ) then + if (ic == IC_VUL) then + volc_no=volc_no+1 + if (DEBUG) write(*,*)'Volcano no. ',volc_no + i_volc(volc_no)=i + j_volc(volc_no)=j + + emis_volc(volc_no) = tmpsec(ISNAP_NAT) * & + e_fact(ISNAP_NAT,IC_VUL,iemis) + nvolc=volc_no + + call CheckStop(nvolc>NMAX_VOLC,"EMISGET, nvolc>NMAX_VULC") + + write(*,*)'Found ',nvolc,' volcanoes on sox file' + + sumemis(IC_VUL,iemis) = sumemis(IC_VUL,iemis) & + + 0.001 * emis_volc(volc_no) + cycle READEMIS ! do not want to count volcano "landcode" + endif ! ic + endif ! so2 + + !.............................................................. + !/** end Volcanoes + !.............................................................. + + + ! For VOC natural and agricultur emissions (managed forests) + ! set to zero + + if ( trim ( emisname ) == "voc" ) tmpsec(11:11) = 0.0 + + ! .......................................................... + ! 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("SNAP"// trim ( emisname ),i,j,ic,NCMAX, & + iland,ncmaxfound,globland,globnland) + + ! ................................................... + ! ................................................... + + globemis(:,i,j,iland) = globemis(:,i,j,iland) & + + e_fact(:,ic,iemis) * tmpsec(:) + + + !.. Sum over all sectors, store as Ktonne: + + sumemis(ic,iemis) = sumemis(ic,iemis) & + + 0.001 * sum (globemis (:,i,j,iland)) + + end do READEMIS + ! + close(IO_EMIS) + ios = 0 + end subroutine EmisGet + + +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine femis() +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!------------------------------------------------------------------------- +! Read emission control factors for the emissions from (optional) file femis. +! Emission factors are applied EITHER to specified country and/or +! emission sector, e.g. the femis file with input: +! Code 5 co sox nox nh3 voc +! 27 6 1.0 0.5 1.0 1.0 1.0 +! will reduce SO2 emissions from sector 6 by a factor 0.5 for the UK +! (country 27); +! OR to all countries/sectors: a zero for country or sector means to +! apply factors to all countries and/or sectors. +! The number following the first text on line 1 (number 5 above) gives +! the number of pollutants treated in the file (ncols below). +! Note: ncols can be greater than the number of emitted species we actually +! have, and the species can be specified in any order, as given on the +! top line. +!------------------------------------------------------------------------- + + !/** local variables **/ + integer :: ie, iq, ic, iland1, iland2 & ! loop variables + ,inland & ! Country read from femis + ,isec, isec1 , isec2 & ! loop vars: emis sectors + ,ncols, n, oldn ! No. cols. in "femis" + integer, parameter :: NCOLS_MAX = 12 ! Max. no. cols. in "femis" + integer, dimension(NEMIS) :: qc ! index for sorting femis columns + real, dimension(NCOLS_MAX):: e_f ! factors read from femis + character(len=80) :: txt ! For read-in + character(len=5), dimension(NCOLS_MAX):: polltxt! to read line 1 + !-------------------------------------------------------- + + + e_fact(:,:,:) = 1.0 !/*** default value = 1 ***/ + + + call open_file(IO_EMIS,"r","femis.dat",needed=.false.) + + if ( ios == NO_FILE ) then + ios = 0 + return !/** if no femis file, e_fact=1 as default **/ + endif + call CheckStop( ios < 0 ,"EmisGet:ios error in femis.dat") + + + !/** Reads in the header line, e.g. name sec sox nox voc. + ! Pollutant names wil be checked against those defined in My_Emis_ml **/ + + read(unit=IO_EMIS,fmt="(a80)") txt + + call wordsplit(txt,NCOLS_MAX,polltxt,ncols,ios) + if(ios>0)return + write(unit=6,fmt=*) "In femis, header is: ", txt + write(unit=6,fmt=*) "In femis, file has ", ncols, " columns (-2)" + + !/** we allow the femis file to give factors in any order, and + ! for pollutants not needed, so we need to work out the indices + ! for each column. Remember also that ncols includes the 1st + ! 2 columns (country_code and sector), which are not e_factors + + ncols = ncols - 2 + call CheckStop( ncols > NCOLS_MAX , "EmisGet:femisncols ncols > NCOLS_MAX" ) + call CheckStop( ncols < 1 , "EmisGet:femisncols ncols < 1" ) + + n = 0 + COLS: do ic=1,ncols + oldn = n + EMLOOP: do ie=1, NEMIS + if ( polltxt(ic+2) == trim ( EMIS_NAME(ie) ) ) then + qc(ie) = ic + n = n + 1 + write(unit=6,fmt=*) "In femis: ", polltxt(ic+2), & + " assigned to ", ie, EMIS_NAME(ie) + exit EMLOOP + end if + end do EMLOOP ! ie + if (oldn == n) & + write(unit=6,fmt=*) "femis: ",polltxt(ic+2)," NOT assigned" + end do COLS ! ic + + call CheckStop( n < NEMIS , "EmisGet: too few femis items" ) + + + n = 0 + + READFILE: do ! ************ read lines of femis *************** + + read(unit=IO_EMIS,fmt=*,iostat=ios) inland, isec, (e_f(ic),ic=1,ncols) + + if ( ios < 0 ) exit READFILE ! End of file + call CheckStop( ios > 0 , "EmisGet: read error in femis" ) + + n = n + 1 + write(unit=6,fmt=*) "FEMIS READ", inland, isec, (e_f(ic),ic=1,ncols) + + if (inland == 0 ) then ! Apply factors to all countries + iland1 = 1 + iland2 = NLAND + else ! Apply factors to country "inland" + +!.. find country number corresponding to index as written in emisfile + do iland1=1,NLAND + if(Country(iland1)%index==inland) goto 544 + enddo + + if(me==0) write(*,*)'COUNTRY CODE NOT RECOGNIZED',inland + + iland1 = 0 + iland2 =-1 +544 continue + if(iland1/=0) iland2 = iland1 + end if + + if (isec == 0 ) then ! All sectors + isec1 = 1 + isec2 = NSECTORS + elseif (isec==100) then ! Anthropogenic scenario + isec1 = 1 + isec2 = ANTROP_SECTORS + else ! one sector: isec + isec1 = isec + isec2 = isec + end if + + + do ie = 1,NEMIS + + do iq = iland1, iland2 + do isec = isec1, isec2 + e_fact(isec,iq,ie) = e_fact(isec,iq,ie) * e_f( qc(ie) ) + end do !isec + end do !iq + + if (DEBUG ) then + write(unit=6,fmt=*) "IN NEMIS LOOP WE HAVE : ", ie, & + qc(ie), e_f( qc(ie) ) + write(unit=6,fmt=*) "loops over ", isec1, isec2, iland1, iland2 + end if ! DEBUG + end do !ie + + enddo READFILE ! Loop over femis + + close(IO_EMIS) + + write(unit=6,fmt=*) "In femis, read ", n, "records from femis." + if ( DEBUG ) then ! Extra checks + write(unit=6,fmt=*) " For UK this gives: " + write(unit=6,fmt="(6x, 10a12)") (EMIS_NAME(ie), ie=1,NEMIS) + do isec = 1, 11 + write(unit=6,fmt="(i6, 10f12.6)") isec,(e_fact(isec,27,ie),ie=1,NEMIS) + end do + end if ! DEBUG + ios = 0 + end subroutine femis + +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine EmisSplit() +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!------------------------------------------------------------------------- +!** DESCRIPTION: +! Sets speciation for emissions to be splitted as defined in My_Emissions, +! e.g. VOC, PM, NOx, per source category for each country from input files. +! Done for species where NEMISFRAC > 1 +! +! Input files: +! xxxsplit.defaults (e.g. vocsplit.defaults, pm25split.defaults) +! xxxsplit.special +! where xxx can be voc or pm or whatever has NEMISFRAC > 1 +! +! Output: (module public variable) +! real emisfrac(NRCSPLIT,NSECTORS,NLAND) +! +!------------------------------------------------------------------------- + + !-- local + integer :: ie ! emission index in EMIS_NAME (1..NEMIS) + integer :: isp ! emission index in 1..NEMIS_SPLIT + integer :: ifr0, ifr ! index of split compound in emisfrac + + integer, parameter :: NONREACTIVE = 1 ! No.columns of non-reactive species + ! enforced for read-ins. + + !-- for read-ins, dimension for max possible number of columns: + character(len=12), dimension(0:1, NRCSPLIT + NONREACTIVE ) :: intext + real , dimension (NRCSPLIT + NONREACTIVE ) :: tmp + real :: sumtmp + integer :: nsplit & ! No.columns data to be read + ,iland,isec,i,n,nn + integer :: idef ! Set to 0 for defaults, 1 for specials + integer :: iland1, iland2 ! loop variables over countries + logical :: defaults ! Set to true for defaults, false for specials +!----------------------------------------------- + + if ( NEMIS_SPLIT == 0 ) return !/** for safety **/ + + + ifr0 = 1 ! Starting index in emisfrac array + + do isp = 1, NEMIS_SPLIT + ie = NEMIS_PLAIN + isp ! Split species, index in 1..NEMIS + + nsplit = EMIS_NSPLIT(isp) + NONREACTIVE + + if (isp > 1) ifr0 = ifr0 + EMIS_NSPLIT(isp-1) !start index of next species + + !/ Just in case .... + call CheckStop( EMIS_NAME(ie) /= SPLIT_NAME(isp) , & + "EmisGet: Mis-matchSPLIT" ) + + IDEF_LOOP: do idef = 0, 1 + + defaults = (idef == 0) + + !** Check if *.split.defaults file for the component exists + if ( defaults ) then + + fname = trim( EMIS_NAME(ie) ) // "split.defaults" + call open_file(IO_EMIS,"r",fname,needed=.true.) + + call CheckStop( ios, "EmisGet: ioserror:split.defaults " ) + + else + !** If specials exists, they will overwrite the defaults + + fname = trim( EMIS_NAME(ie) ) // "split.special" + call open_file(IO_EMIS,"r",fname,needed=.false.) + + if ( ios == NO_FILE ) then + write(unit=6,fmt=*) "emis_split: no specials for",EMIS_NAME(ie) + ios = 0 + exit IDEF_LOOP + endif + end if + + if (DEBUG) write(unit=6,fmt=*) "TTT split defaults=", defaults, fname + + !/ Read text line and speciation: + ! the following lines expect one line of a header text with the + ! species names, followed by lines of the following format: + ! iland, isec, tmp1, tmp2.... tmpN+1, where the N+1'th column + ! is for non-reactive species. These non-reactives are not used in + ! the rest of the program, but are required to check mass-balance. + + read (unit=IO_EMIS,fmt=*,iostat=ios) & + iland, isec ,(intext(idef,i), i=1, nsplit) + + call CheckStop( ios , "EmisGet: Read error on header, emis_split " ) + + write(unit=6,fmt="(a25,i3,/,(12a7))") "SPLIT species for idef=", & + idef, (intext(idef,i), i=1, nsplit) + write(unit=6,fmt=*) "Will try to split ", EMIS_NSPLIT(isp) , " times" + + n = 0 + + READ_DATA: do + read (unit=IO_EMIS,fmt=*,iostat=ios) & + iland, isec, (tmp(i),i=1, nsplit) + + if ( ios < 0 ) exit READ_DATA ! End of file + call CheckStop( ios > 0 , "EmisGet: Readerror on emis_split " ) + + n = n + 1 + + !/... some checks: + sumtmp = sum( tmp(1:nsplit) ) + if ( ( sumtmp > 100.01 .or. sumtmp < 99.99 ) .or. & + ( defaults .and. iland /= 0 ) .or. & + ( defaults .and. isec /= n ) & + ) then + write(unit=errmsg,fmt=*) "ERROR: emisfrac:", idef, & + iland, isec, sumtmp + call CheckStop( errmsg ) + end if + if ( .not. defaults ) then + do nn=1,nsplit + call CheckStop( intext(1,nn) /= intext(0,nn), & + "EmisGet: ERROR intext(1,nn) /= intext(0,nn) ") + enddo + end if + + if ( defaults .or. iland == 0 ) then + iland1 = 1 + iland2 = NLAND + else ! specials for one country + iland1 = iland + iland2 = iland + end if + + do iland = iland1, iland2 + do i = 1, EMIS_NSPLIT(isp) + ifr = ifr0 + i - 1 ! => index in emisfrac array + + !/** assign and convert from percent to fractions: **/ + + emisfrac(ifr,isec,iland) = 0.01 * tmp(i) + + ! just a check + if ( DEBUG .and. iland == 27 ) then + write(*,"(a15,3i3,f10.4)") "TTT splitdef UK", isec, & + ifr0, ifr, emisfrac(ifr,isec,iland) + endif + enddo ! i + enddo ! iland + + enddo READ_DATA + close(IO_EMIS) + + call CheckStop( defaults .and. n /= NSECTORS, & + "ERROR: EmisGet: defaults .and. n /= NSECTORS" ) + write(unit=6,fmt=*) "Read ", n, " records from ",fname + + end do IDEF_LOOP + end do ! ie + ios = 0 + + end subroutine EmisSplit + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end module EmisGet_ml diff --git a/Emissions_ml.f90 b/Emissions_ml.f90 new file mode 100644 index 0000000..52077a5 --- /dev/null +++ b/Emissions_ml.f90 @@ -0,0 +1,963 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module Emissions_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!+ Calls up emission read/set routines +! This routine interfaces the stand-alone emission-file reading routines +! with the 3D model. +!_____________________________________________________________________________ + use My_Emis_ml, only : & + NEMIS, & ! No. emission files + EMIS_NAME, & ! Names of species ("sox ",...) + NEMIS_PLAIN, & ! No. emission files for non-speciated emissions + EMIS_NSPLIT, & ! No. emission files to be speciated + NEMIS_SPLIT, & ! No. emission files for speciated emissions + NRCSPLIT, & ! No. emis species from split emissions species + NRCEMIS, & ! Total No. emission species after speciation + set_molwts, & ! subroutine to set molwt + molwt, & ! Mol. wts + NBVOC, & ! > 0 if forest voc wanted + QRCVOL, & ! For volcanoes + VOLCANOES ! + use My_MassBudget_ml, only : set_mass_eqvs ! Some equivalences bewteen + ! indices + + use Biogenics_ml, only: first_dms_read,IQ_DMS,emnat,emforest + use CheckStop_ml,only : CheckStop + use Country_ml, only : NLAND,Country_Init,Country + use EmisDef_ml, only : NSECTORS, & ! No. sectors + NEMISLAYERS,& ! No. vertical layers for emission + NCMAX,& ! Max. No. countries per grid + FNCMAX,& ! Max. No. countries (with flat + ! emissions) per grid + EmisDef_Init &! Sub to define conversion factors + ,EmisDef_Index &! Sub to get index of emis name + ,EmisDef & ! Superset of names/factors + ,ISNAP_SHIP & ! snap index for ship emissions + ,ISNAP_NAT & ! snap index for nat. (dms) emissions + ,VERTFAC ! vertical emission split + use EmisGet_ml, only : EmisGet, EmisSplit, emisfrac ! speciation routines and array + use GridValues_ml, only: GRIDWIDTH_M & ! size of grid (m) + ,xm2 & ! map factor squared + ,debug_proc,debug_li,debug_lj & + ,sigma_bnd, xmd, gl + use Io_Nums_ml, only : IO_LOG, IO_DMS + use Io_Progs_ml, only : ios, open_file + use Met_ml, only : ps, roa ! ps in Pa, roa in kg/m3 + use ModelConstants_ml, only : KMAX_MID, KMAX_BND, PT ,dt_advec, & + NPROC, IIFULLDOM,JJFULLDOM + use Par_ml, only : MAXLIMAX,MAXLJMAX,me,gi0,gi1,gj0,gj1, & + GIMAX, GJMAX, IRUNBEG, JRUNBEG, & + limax,ljmax,li0,lj0,li1,lj1, & + MSG_READ1,MSG_READ7 + use PhysicalConstants_ml, only : GRAV, AVOG + use ReadField_ml, only : ReadField ! Reads ascii fields + use TimeDate_ml,only : nydays, date, current_date ! No. days per year, date-type + 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 + use Volcanos_ml + + + implicit none + private + + + !/* subroutines: + + public :: Emissions ! Main emissions module + public :: newmonth + public :: EmisSet ! Sets emission rates every hour/time-step + + !/* The main code does not need to know about the following */ + private :: consistency_check ! Safety-checks + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + + logical, private, parameter :: DEBUG = .false. + logical, private, parameter :: MY_DEBUG = .false. + + !** 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 +! 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 + ! + ! The output emission matrix for the 11-SNAP data is snapemis: + ! + + real, private, dimension(NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,NEMIS) & + , save :: snapemis !/* main emission arrays, in kg/m2/s + + real, private, dimension(MAXLIMAX,MAXLJMAX,FNCMAX,NEMIS) & + , save :: snapemis_flat !/* main emission arrays, in kg/m2/s + + !/-- emissions for input to chemistry routines + + ! KEMISTOP added to avoid hard-coded KMAX_MID-3: + + integer, public, parameter :: KEMISTOP = KMAX_MID - NEMISLAYERS + 1 + real, public, save, dimension(NRCEMIS,KEMISTOP:KMAX_MID,MAXLIMAX,MAXLJMAX) :: & + gridrcemis ! varies every time-step (as ps changes) + real, private, save, dimension(NRCEMIS,KEMISTOP:KMAX_MID,MAXLIMAX,MAXLJMAX) :: & + gridrcemis0 ! varies every hour + + !/-- and for budgets (not yet used - not changed dimension) + + real, public, save, dimension(NRCEMIS) :: totemadd + + + +contains + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine Emissions(year) + + + !+ calls main emission reading routines + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + !*********************************************************************** + !** DESCRIPTION: + ! 0) call set_molwts and set_emisconv_and_iq, followed by + ! consistency check + ! 1) Calls 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) Reads 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) + ! + !** REVISION HISTORY: + ! Original from MADE, adapted to MACHO j.e.jonson + ! Call to femis added, j.e. jonson + ! 1-2/99 Rearranged d. simpson, for 11-sector input. Condensed. + ! Monthly and daily input read in in subroutine timefactors: + ! efac_mm (monthly) and efac_dd (daily) + ! added . Note that emissions are no longer multiplied by + ! monthly factors here - this is done in subroutine emission where + ! also daily and hourly factors are applied. + ! 4/2/99 - checked/corrected and re-arranged by s. unger. + ! 8/2/99 - timezone and eulxxxx.inc method added by ds + ! + !********************************************************************** + + !--arguments + integer, intent(in) :: year ! Year ( 4-digit) + + !-- local variables + integer, dimension(NEMIS) :: eindex ! Index of emissions in EmisDef + real :: conv ! Conversion factor + integer :: iqrc, k, kused ! index over emitted species, QRCSO2.. + integer :: i, j, n ! Loop variables + integer :: i_l,j_l ! Local i,j + real :: tonne_to_kgm2s ! Converts tonnes/grid to kg/m2/s + real :: ccsum ! Sum of emissions for one country !ds, rv1_9_3 + + ! 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) + + + !/** emission sums (after e_fact adjustments): + real, dimension(NEMIS) :: emsum ! Sum emis over all countries + real, dimension(NLAND,NEMIS) :: sumemis ! Sum of emissions per country + + if (me ==0) write(6,*) "Emissions called with me, year", me, year + + ! ** 0) set molwts, conversion factors (e.g. tonne NO2 -> tonne N), and + ! emission indices (IQSO2=.., ) + + !========================= + call EmisDef_Init() ! In EmisDef_ml + call set_molwts() ! In My_Emis_ml + call set_mass_eqvs() ! In My_MassBudget_ml + call Country_Init() ! In Country_ml, => NLAND, country codes and + ! names, timezone + !========================= + + do i = 1, NEMIS + eindex(i) = EmisDef_Index( EMIS_NAME(i) ) + end do + + !========================= + ! Check that all is well! + call consistency_check(eindex) ! Below + !========================= + ios = 0 + + if( me == 0) then !::::::: ALL READ-INS DONE IN HOST PROCESSOR :::: + + ! ** 1) + !========================= + call timefactors(year) ! => fac_emm, fac_edd, day_factor + !========================= + + + !** 2) + !========================= + if ( NEMIS_SPLIT > 0 ) call EmisSplit() ! In EmisGet_ml, => emisfrac + !========================= + + + endif !(me=0) + + call CheckStop(ios, "ioserror: EmisSplit") + + + ! ################################# + ! *** Broadcast monthly and Daily factors **** + CALL MPI_BCAST( emisfrac ,8*NRCSPLIT*NSECTORS*NLAND,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST( fac_emm ,8*NLAND*12*NSECTORS*NEMIS,MPI_BYTE, 0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST( fac_edd ,8*NLAND*7*NSECTORS*NEMIS,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. + + + first_dms_read = .true. + + !** 4) Read emission files *************** + ! ****************************************************************** + + !uni allocate for me=0 only: + err1 = 0 + if ( me == 0 ) then + + if (DEBUG) write(unit=6,fmt=*) "TTT me ", me , "pre-allocate" + allocate(globnland(GIMAX,GJMAX),stat=err1) + allocate(globland(GIMAX,GJMAX,NCMAX),stat=err2) + allocate(globemis(NSECTORS,GIMAX,GJMAX,NCMAX),stat=err3) +! + allocate(flat_globnland(GIMAX,GJMAX),stat=err4) + allocate(flat_globland(GIMAX,GJMAX,FNCMAX),stat=err5) + allocate(globemis_flat(GIMAX,GJMAX,FNCMAX),stat=err6) + + call CheckStop(err1, "Allocation error 1 - globland") + call CheckStop(err2, "Allocation error 2 - globland") + call CheckStop(err3, "Allocation error 3 - globland") + call CheckStop(err4, "Allocation error 4 - globland") + call CheckStop(err5, "Allocation error 5 - globland") + call CheckStop(err6, "Allocation error 6 - globland") + + + !/** and initialise **/ + globnland(:,:) = 0 ! csu initialise globnland with 0 + flat_globnland(:,:)=0 !hf + globland(:,:,:) = 0 !hk + globemis(:,:,:,:) = 0 !hk + flat_globland(:,:,:)=0 !hk + globemis_flat(:,:,:) =0!hk + + end if + + do iem = 1, NEMIS + ! now again test for me=0 + if ( me == 0 ) 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 ! me==0 + + call CheckStop(ios, "ios error: EmisGet") + + !CC** 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, & + 1,GIMAX,GJMAX,FNCMAX,1,1) + + end do ! iem = 1, NEMIS-loop + + + if ( me == 0 ) then + write(unit=6,fmt=*) "Country totals" + write(unit=IO_LOG,fmt=*) "Country totals" + write(unit=6,fmt="(2a4,3x,10a12)") " N "," CC ",(EMIS_NAME(iem),iem=1,NEMIS) + write(unit=IO_LOG,fmt="(2a4,3x,10a12)") " N "," CC ",(EMIS_NAME(iem),iem=1,NEMIS) + + do ic = 1, NLAND + ccsum = sum( sumemis(ic,:) ) + if ( ccsum > 0.0 ) then + write(unit=6,fmt="(i3,1x,a4,3x,8f12.2)") & + ic, Country(ic)%code, (sumemis(ic,i),i=1,NEMIS) + write(unit=IO_LOG,fmt="(i3,1x,a4,3x,8f12.2)")& + ic, Country(ic)%code, (sumemis(ic,i),i=1,NEMIS) + end if + end do + 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) + + + +! 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 +! + if ( DEBUG) print *, "CONV:me, nydays, gridwidth = ",me,nydays,GRIDWIDTH_M + + tonne_to_kgm2s = 1.0e3 / (nydays * 24.0 * 3600.0 * GRIDWIDTH_M * GRIDWIDTH_M) + + if ( DEBUG .and. me == 0 ) then + 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:" + write(unit=6,fmt=*) (EMIS_NAME(iem),iem=1,NEMIS) + write(unit=6,fmt=*) (emsum(iem),iem=1,NEMIS) + endif + + + do iem = 1, NEMIS + conv = tonne_to_kgm2s * EmisDef( eindex(iem) )%conv + + forall (ic=1:NCMAX, j=lj0:lj1, i=li0:li1, isec=1:NSECTORS) + snapemis (isec,i,j,ic,iem) = & + snapemis (isec,i,j,ic,iem) * conv * xm2(i,j) + end forall + + forall (fic=1:FNCMAX, j=lj0:lj1, i=li0:li1) + snapemis_flat(i,j,fic,iem) = & + snapemis_flat(i,j,fic,iem) * conv * xm2(i,j) + end forall + enddo !iem + + if ( VOLCANOES ) then + + conv = tonne_to_kgm2s * EmisDef( eindex(QRCVOL) )%conv + + do volc_no=1,nvolc + i=i_volc(volc_no) + j=j_volc(volc_no) + !Find global<->local coordinates for xm2 + if ((i >= gi0).and.(i<=gi1).and.(j>= gj0).and.& + (j<= gj1))then !on the correct processor + if ( DEBUG ) write(*,*)'i,j for volcanoe is',i,j + if ( DEBUG ) write(*,*)'EMIS_VOLC is',emis_volc(volc_no) + i_l = i -gi0 +1 + j_l = j- gj0 +1 + if ( MY_DEBUG ) write(*,*)'Local coord is',i_l,j_l,gi0,gj0 + emis_volc(volc_no) = emis_volc(volc_no)* conv * xm2(i_l,j_l) + endif + enddo !volc_no + + !/** Read Volcano.dat to get volcano height + if (me==0)then + call VolcGet(height_volc) + if (MY_DEBUG) write(*,*)'Volcano heights',height_volc + endif + + !/** broadcast volcano heights + CALL MPI_BCAST(height_volc,4*NMAX_VOLC,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + endif ! VOLCANOES + + err1 = 0 + if ( me == 0 ) then + deallocate(globnland,stat=err1) + deallocate(globland ,stat=err2) + deallocate(globemis ,stat=err3) + + deallocate(flat_globnland,stat=err4) + deallocate(flat_globland,stat=err5) + deallocate(globemis_flat,stat=err6) + + 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") + + end if + + end subroutine Emissions + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine consistency_check(eindex) + !------------------------------------------------------------------! + ! checks that all the values given so far are consistent ! + !------------------------------------------------------------------! + integer, dimension(NEMIS), intent(in) :: eindex + character(len=30) :: errormsg + integer :: i + + errormsg = "ok" + do i = 1, NEMIS + if ( eindex(i) < 0 ) then + print *, "EmisIndex: Mis-match for ", i, eindex(i) + errormsg = "EmisIndex: Mismatch" + end if + end do + if ( NRCEMIS < NEMIS ) errormsg = " NRCEMIS < NEMIS" + if ( size(EMIS_NAME) /= NEMIS ) errormsg = " size EMISNAME wrong " + if ( NEMIS_PLAIN+sum(EMIS_NSPLIT) /= NRCEMIS ) errormsg = "sum ne NRCEMIS" + if ( any( molwt < 1.0 ) ) errormsg = " Mol. wt not assigned " + + call CheckStop(errormsg,"Failed consistency check") + + end subroutine consistency_check + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + + + !***************************************************************** + + subroutine EmisSet(indate) ! emission re-set every time-step/hour + + ! + !*********************************************************************** + !** DESCRIPTION: + ! calculates the emmision-tendencies and the local (instantaneous) dry + ! deposition in the emission squares. + ! emis set once per hour to allow for day/night variation (and voc + ! speciation) (based on local time) for each snap sector. + ! gridrcemis0 calculated every time-step to allow for ps changes. + ! inputs from Emissions in EMISSIONS_ML: + ! country and snap-specific array : + ! snapemis (NSECTORS,MAXLIMAX,MAXLJMAX,NCMAX,NEMIS) + ! + !*** Units: + ! snapemis has units of kg/m2/s, SO2 as S, NO2 as N, NH3 as N. + ! Map factor (xm2) already accounted for. + ! + ! Data on how many countries contribute per grid square is stored in + ! nlandcode(MAXLIMAX,MAXLJMAX) , with the country-codes given by + ! landcode(MAXLIMAX,MAXLJMAX,NCMAX). + ! + ! Monthly and weekday factors are pre-multiplied and stored in: + ! real timefac(NLAND,NSECTORS,NEMIS) + ! And day-night factors are applied here: + ! day_factor(11,0:1) ! 0=night, 1=day + ! .......................................................................... + ! + !** REVISION HISTORY: + ! Revised , 30/5/01, jej/st found problem on gridur - split NEMIS loop + ! into separate NEMIS_PLAIN and NEMIS_SPLIT loops. + ! Revised, ds, Feb. 2001 for unified model. Use of date%seconds replaces + ! thourloc. + ! Revised : d. simpson 4/2/98 to act as common subrouinte + ! between 3-D models, and to avoid hard-coded emissions + ! !uni - revised to F90 and for more flexible handling of emissions + ! fraction through NEMIS_FRAC + ! Originally emission.f from MADE and MACHO. + ! + ! 25/3-2002, pw changed test for hour and day change (Now the first day + ! does not need to start at 0 hours) + ! + ! 11/2005,pw if timezone=-100 use timezone based on longitude + ! + !************************************************************************* + + implicit none + type(date), intent(in) :: indate ! Gives year..seconds + integer :: i, j, n, k, f ! cooridnates, loop variables + integer :: icc, ncc ! No. of countries in grid. +! + integer :: ficc,fncc ! No. of countries with + integer :: iqrc, ifrac ! emis indices + integer :: isec ! loop variables: emission sectors + integer :: iem ! loop variable over pollutants (1..NEMIS) +! + integer :: i_l,j_l ! Local i,j + !uni - save daytime value between calls, intiialise to zero + integer, save, dimension(NLAND) :: daytime = 0 ! 0=night, 1=day + integer :: hourloc ! local hour + logical :: hourchange ! " " + real, dimension(NRCEMIS) :: emis ! local array for emissions + + real :: deploc,ehlpcom,ehlpcom0(KEMISTOP:KMAX_MID) + real :: tfac, dtgrid ! time-factor (tmp variable); dt*h*h for scaling + real :: s ! source term (emis) before splitting + integer :: iland, iland_timefac ! country codes, and codes for timefac + + real :: ftfac ! time-factor for flat emissions + real :: sf ! source term (emis) before splitting (for flat emissions) + integer :: flat_iland ! country codes (countries with flat emissions) + + integer, save :: oldday = -1, oldhour = -1 + +! If timezone=-100, calculate daytime based on longitude rather than timezone + integer :: daytime_longitude,daytime_iland + +! Initialize + ehlpcom0(:)=0.0 + + do k=KEMISTOP,KMAX_MID + ehlpcom0(k) = GRAV* 0.001*AVOG/ (sigma_bnd(k+1) - sigma_bnd(k)) + enddo + + !/** scaling for totemadd: + dtgrid = dt_advec * GRIDWIDTH_M * GRIDWIDTH_M + + + !/** The emis array only needs to be updated either 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 + ! at midnight every day. + + hourchange = .false. + if ( indate%hour /= oldhour .or. indate%day /= oldday ) then + + hourchange = .true. + oldhour = indate%hour + + if ( indate%day /= oldday )then + + !========================== + call NewDayFactors(indate) + !========================== + + oldday = indate%day + endif + end if + + + !.......................................... + ! Look for day-night changes, after local time correction + ! (daytime(iland) not used if LONGITUDE_TIME=true) + + do iland = 1, NLAND + + daytime(iland) = 0 + hourloc = indate%hour + Country(iland)%timezone + + if ( hourloc >= 7 .and. hourloc <= 18 ) daytime(iland)=1 + + end do ! iland + + + if ( hourchange ) then + + totemadd(:) = 0. + gridrcemis0(:,:,:,:) = 0.0 + + + !.......................................... + ! Process each grid: + + do j = lj0,lj1 + do i = li0,li1 + + ncc = nlandcode(i,j) ! No. of countries in grid + +! find the approximate local time: + hourloc= mod(nint(indate%hour+24*(1+gl(i,j)/360.0)),24) + daytime_longitude=0 + if( hourloc>=7.and.hourloc<= 18) daytime_longitude=1 + + + !************************************************* + ! First loop over non-flat(one sector) emissions + !************************************************* + + emis(:)=0. + do icc = 1, ncc + iland = landcode(i,j,icc) ! 1=Albania, etc. + iland_timefac = Country(iland)%timefac_index + + if(Country(iland)%timezone==-100)then + daytime_iland=daytime_longitude + else + daytime_iland=daytime(iland) + endif + + ! As each emission sector has a different diurnal profile + ! and possibly speciation, we loop over each sector, adding + ! the found emission rates to gridrcemis as we go. + ! ================================================== + + + do isec = 1, NSECTORS ! Loop over snap codes + + + !-- Calculate emission rates from snapemis, time-factors, + ! and if appropriate any speciation fraction (NEMIS_FRAC) + + iqrc = 0 ! index over emis + ifrac = 0 ! index over emisfrac + + !/.. First, the simple emissions + do iem = 1, NEMIS_PLAIN + + tfac = timefac(iland_timefac,isec,iem) * & + day_factor(isec,daytime_iland) + + iqrc = iqrc + 1 + emis(iqrc) = snapemis(isec,i,j,icc,iem) * tfac + end do ! iem=1,NEMIS_PLAIN + + !/.. Then , the split (speciated) emissions if NEMIS_SPLIT>0 + + do iem = 1, NEMIS_SPLIT + + tfac = timefac(iland_timefac,isec,iem+NEMIS_PLAIN ) * & + day_factor(isec,daytime_iland) + + s = tfac * snapemis(isec,i,j,icc,iem+NEMIS_PLAIN) + + do f = 1, EMIS_NSPLIT( iem ) + ifrac = ifrac + 1 + iqrc = iqrc + 1 + emis(iqrc) = s * emisfrac(ifrac,isec,iland) + end do ! f + + end do ! iem=1,NEMIS_SPLIT + + !-- Add up emissions in ktonne ...... + + do iqrc = 1, NRCEMIS + totemadd(iqrc) = totemadd(iqrc) + & + emis(iqrc) * dtgrid * xmd(i,j) + end do + + !.. Assign to height levels 1-4 + + do k=KEMISTOP,KMAX_MID + do iqrc =1, NRCEMIS + gridrcemis0(iqrc,k,i,j) = & + gridrcemis0(iqrc,k,i,j) + emis(iqrc)* & + ehlpcom0(k)*VERTFAC(KMAX_BND-k,isec) /molwt(iqrc) + end do ! iem + end do ! k + + enddo ! isec +! ================================================== + + end do ! icc + + !************************************ + ! Then loop over flat emissions + !************************************ + emis(:)=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. + + if ( Country(flat_iland)%is_sea ) then ! - saves if statements below + isec = ISNAP_SHIP + else + isec = ISNAP_NAT + end if + + ! As each emission sector has a different diurnal profile + ! and possibly speciation, we loop over each sector, adding + ! the found emission rates to gridrcemis as we go. + ! ================================================== + + + !-- Calculate emission rates from snapemis, time-factors, + ! and if appropriate any speciation fraction (NEMIS_FRAC) + + iqrc = 0 ! index over emis + ifrac = 0 ! index over emisfrac + + !/.. First, plain emissions + + do iem = 1, NEMIS_PLAIN + iqrc = iqrc + 1 + + emis(iqrc) = snapemis_flat(i,j,ficc,iem) + + end do ! iem=1,NEMIS_PLAIN + + !/.. Then , the split (speciated) emissions if NEMIS_SPLIT>0 + + do iem = 1, NEMIS_SPLIT + + sf = snapemis_flat(i,j,ficc,iem+NEMIS_PLAIN) + + + do f = 1, EMIS_NSPLIT( iem ) + ifrac = ifrac + 1 + iqrc = iqrc + 1 + + emis(iqrc) = sf * emisfrac(ifrac,isec,flat_iland) + + end do ! f + + end do ! iem=1,NEMIS_SPLIT + + !-- Add flat emissions in ktonne (to non-flat emissions)...... + + do iqrc = 1, NRCEMIS + + totemadd(iqrc) = totemadd(iqrc) + & + emis(iqrc) * dtgrid * xmd(i,j) + end do + + + !.. Assign flat emissions to height levels 1-4 + !.. Note, no VERTFAC + + do iqrc =1, NRCEMIS + + gridrcemis0(iqrc,KMAX_MID,i,j) = & + gridrcemis0(iqrc,KMAX_MID,i,j) + emis(iqrc)*& + ehlpcom0(KMAX_MID)/molwt(iqrc) + end do ! iem + +! ================================================== + end do !ficc + end do ! i + end do ! j + + if ( VOLCANOES ) 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 + + ehlpcom= roa(i,j,k,1)/(ps(i,j,1)-PT) + do iqrc =1, NRCEMIS + gridrcemis(iqrc,k,i,j) = & + gridrcemis0(iqrc,k,i,j)* ehlpcom + enddo ! iqrc + end do ! i + end do ! j + end do ! k + + !/** Scale volc emissions to get emissions in molecules/cm3/s (rcemis_volc) + if ( VOLCANOES ) call Scale_Volc + + if( NBVOC > 0 )then + + do j = lj0,lj1 + do i = li0,li1 + + ehlpcom = ehlpcom0(KMAX_MID) * roa(i,j,KMAX_MID,1)/(ps(i,j,1)-PT) + + emnat(i,j,1:NBVOC) = emforest(i,j,1:NBVOC)*ehlpcom + + end do ! i + end do ! j + + if ( DEBUG .and. debug_proc ) then + !print "(a12,2i4,/,(g12.3))", "bio-setemis",li0,lj0, & + ! (gridrcemis(i,KMAX_MID,2,2),i=1, NRCEMIS), + write(*,"(a12,2g12.3,3x,2g12.3)") "bio-setemis", & + ( emforest(debug_li,debug_li,i), i = 1, NBVOC),& + ( emnat(debug_li,debug_li,i), i = 1, NBVOC) + end if + + endif ! NBVOC + + end subroutine EmisSet + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine newmonth + +!..................................................................... +!** DESCRIPTION: +! Reads in natural DMS emissions at start of each month. Update +! landcode and nlandcode arrays as needed. + +! Reads in snow cover at start of each month. + +!** REVISION HISTORY: +! Original from MADE + +!........................................................................... + + + integer i, j + integer ijin(2) + integer n, flat_ncmaxfound ! Max. no. countries w/flat emissions + real :: rdemis(MAXLIMAX,MAXLJMAX) ! Emissions read from file + character*20 fname + real ktonne_to_kgm2s ! Units conversion + integer :: IQSO2 ! Index of sox in EMIS_NAME + integer errcode + +!*** Units: +! Input files seem to be in ktonne PER YEAR. We convert here to kg/m2/s +! to save CPU in setemis.f. +! The conversion factor from 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+6. +! the conversion factor (ktonne_to_kgm2s) then equals 1.27e-8 +! NB: a new file is read every month; this means that total emissions +! are NOT the sum of the 12 files emissions (but about 12 times less than the sum). +! More precisely: year_emis=sum_months(emis_month*nmdays/nydays) + + ktonne_to_kgm2s = 1.0e6 / & + (nydays*24.*60.*60.*GRIDWIDTH_M*GRIDWIDTH_M) + + if ( me == 0 .and. MY_DEBUG) then + write(6,*) 'Enters newmonth, mm, ktonne_to_kgm2s = ', & + current_date%month,ktonne_to_kgm2s + write(6,*) ' first_dms_read = ', first_dms_read + end if ! me +!........................................................................... + +!........................................................................... +! DMS Input - land 35 - SNAP sector 11 +!........................................................................... + flat_ncmaxfound = 0 ! Max. no. countries(w/flat emissions) per grid +! natural so2 emissions + + IQSO2 = 0 + do i = 1, NEMIS + if ( trim( EMIS_NAME(i) ) == "sox" ) IQSO2 = i + end do + + if ( IQSO2 < 1 ) then + write(*,*) " No SO2 emissions - need to skip DMS also" + return ! No need to read DMS fields ... + + else + !/--- we have so2 emission so need DMS also + + if ( me == 0 ) then + + write(fname,fmt='(''natso2'',i2.2,''.dat'')') & + current_date%month + write(6,*) 'filename for nat-so2',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 + + end if ! IQSO2>0 + + end subroutine newmonth + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end module Emissions_ml diff --git a/Functions_ml.f90 b/Functions_ml.f90 new file mode 100644 index 0000000..adbb346 --- /dev/null +++ b/Functions_ml.f90 @@ -0,0 +1,471 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Functions_ml +!____________________________________________________________________ +! Miscellaneous collection of "standard" (or guessed ) functions +! Including Troe, sine and cosine curves, +! bilinear-interpolation routines, +! and Standard Atmosphere p -> H conversion +!____________________________________________________________________ +! +!** includes +! troe - standrad chemical function +! bilin_interpolate - generic, elemental - guessed bilinera method +! +! Depends on: none - self-contained. +! Language: F +! History: +! ds - 2000-Jan. 2001 +!____________________________________________________________________ + use PhysicalConstants_ml, only : KAPPA, PI + implicit none + private + + public :: troe + public :: Daily_cosine ! Generates daily values of a variable + ! specified as a cosine curve over the year. + public :: Daily_sine ! Generates daily values of a variable + ! specified as a sine curve over the year. + public :: Daily_halfsine ! Similar, but only half-sine curve (0..pi) + ! used. (E.g. for H2O2 in ACID versions) + + public :: StandardAtmos_kPa_2_km ! US Standard Atmosphere conversion + + + !/- Exner subroutines: ------------------------------------------------------ + + public :: Exner_nd ! (p/P0)**KAPPA + public :: Tpot_2_T ! Same as Exner_nd - but easier to remember + public :: T_2_Tpot ! Inverse as Exner_nd + public :: Exner_tab ! Tabulation. Must be called first + + + !/- Interpolation constants + + real, private, parameter :: & + PINC=1000.0 & + ,P0 =1.0e5 & ! Standard pressure + ,PBAS=-PINC + + real, save, private, dimension(131) :: tab_exf ! Tabulated Exner + + + !/-- interpolation stuff + public :: bilin_interpolate ! "Generic" subroutine + private :: bilin_interp_elem + private :: bilin_interp_array + + real, public, dimension(0:1,0:1) :: wt ! weighting factors, array version + + interface bilin_interpolate + module procedure bilin_interp_array + module procedure bilin_interp_elem + end interface + + + + !======================================== + contains + !======================================== + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + elemental function troe(k0,kinf,Fc,M) result (rctroe) + + !+ Calculates Troe expression + ! ----------------------------------------------------------- + ! ds note - this isn't checked or optimised yet. Taken from + ! Seinfeld+Pandis, 1998, pp 283, eqn. 5.98. + + ! Input arguments are intended to represent: + ! M may be O2+N2 or just N2 or just O2. + + real, intent(in) :: k0,kinf,Fc,M + real :: rctroe + + !-- local + real :: x,y, K0M ! temp variable + + k0M = k0 * M + + + !- use the power function replacament, m**n == exp(n*log m) + !-k0M = a*(T/300.0)**(-2.3) * M + !-kinf = p*(T/300.0)**(-1.4) + + ! k0M = a * exp( b*log(t/300.0) ) * M + ! kinf = p * exp( q*log(t/300.0) ) + + ! factors for Fc: + y = k0M/kinf ! used also below + x = log10(y) + x = 1.0/( 1.0 + x*x ) + + !- F**x == exp(x*logF) + +! give Fc already as log(Fc) + +! rctroe = k0M / ( 1.0 + k0M/kinf) * exp(x*log(Fc)) + rctroe = k0M / ( 1.0 + y) * exp(x*Fc) + + end function troe + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + function Daily_cosine(mean, amp, dmax, ndays) result (daily) + !+ + ! Specifies cosine curve for a variable over a year + + real, intent(in) :: mean, amp ! Annual mean and amplitude of sine + integer, intent(in) :: dmax ! Day where maximum occurs + integer, intent(in) :: ndays ! No. days per year (365/366) + + real, dimension(ndays) :: daily + integer :: d + real, save :: twopi ! Could use PhysiclConstants_ml + twopi = 8.0 * atan(1.0) ! but I prefer to keep Functions_ml + ! standalone + + do d = 1, ndays + daily(d) = mean + amp * cos ( twopi * (d - dmax)/ ndays ) + end do + + end function Daily_cosine + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + function Daily_sine(mean, amp, dmax, ndays) result (daily) + !+ + ! Specifies sine curve for a variable over a year + ! 25/9/2002, ds, dmax redifined to be true dmax. Before it was + ! 80 and actually the day when the mean ocrrurred (spotted by hf) + + real, intent(in) :: mean, amp ! Annual mean and amplitude of sine + integer, intent(in) :: dmax ! Day where maximum occurs + 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 + ! when d = dmax + real, save :: twopi ! Could use PhysiclConstants_ml + twopi = 8.0 * atan(1.0) ! but I prefer to keep Functions_ml + ! standalone + shift = ndays/4.0 + + do d = 1, ndays + daily(d) = mean + amp * sin ( twopi * (d + shift - dmax)/ ndays ) + end do + + end function Daily_sine + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + function Daily_halfsine(base, amp, ndays) result (daily) + !+ + ! Specifies half-sine curve for a variable over a year, with + ! values 1.0 at start and end, and max in mid-summer. + + real, intent(in) :: base, amp ! Annual base and amplitude of sine + integer, intent(in) :: ndays ! No. days per year (365/366) + + real, dimension(ndays) :: daily + integer :: d + real, save :: pi ! Could use PhysiclConstants_ml + pi = 4.0 * atan(1.0) ! but I prefer to keep Functions_ml + ! standalone + + do d = 1, ndays + daily(d) = base + amp * sin ( pi * (ndays - d )/ ndays ) + end do + + end function Daily_halfsine + + !___________________________________________________________________________ + !+ subroutines which can be used in 2-D interpolation + ! - includes "generic" subroutine bilin_interpolate + !___________________________________________________________________________ + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine bilin_interp_array(xp,yp,ixp,iyp) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + real, intent(in) :: xp, yp ! coordinates of point P (see fig.) + integer, intent(out) :: ixp, iyp ! integer coords P + + !/ Output: + ! real, intent(out), dimension(0:1,0:1) :: wt ! weights (see below) + !----------------------------------------------------------------------------- + ! This subroutine uses a bilinear interpolation method which suuplies the + ! weighting factors needed to estimate the value of a field at a point P + ! (input coords xp, yp) from the values at the nearest 4 grid points. + ! + ! This routine assumes that P is given in the coordinates of the field + ! which is being interpolated. If we define ixp = int(xp),iyp=int(yp), + ! dx = xp - ixp, dy = yp - iyp, we obtain a system: + ! + ! y' + ! ^ + ! | + ! 0,1--------------------------1,1 + ! | | + ! | | + ! | | + ! p1 *P(dx,dy) p2 + ! | | + ! | | + ! | | + ! | | + ! | | + ! | | + ! | | + ! | | + ! 0,0 -------------------------1,0----------> x' + ! + ! This subroutine outputs the weight to be given to the four corners + ! using the array wt(0:1,0:1). + ! + ! For the bilinear interpolation we first calculate the weights associated + ! with points p1,p2 along the y-axis, then interpolate these to P along the + ! x-axis + ! + ! C(0,p1) = (1-dy) * C(0,0) + dy * C(0,1) + ! C(1,p2) = (1-dy) * C(1,0) + dy * C(1,1) + ! C(dx,dy) = (1-dx) * C(0,p1) + dx * C(1,p2) + ! = (1-dx) * (1-dy) * C(0,0) +(1-dx) * dy * C(0,1) + ! + dx * (1-dy) * C(1,0) + dx * dy * C(1,1) + ! i.e. Cp + ! = (1-dx-dy+dx.dy) * C(0,0) + ! +(dy -dx.dy) * C(0,1) + ! +(dx -dx.dy) * C(1,0) + ! +(dx.dy) * C(1,1) + ! The "wt" array consists of the 4 coefficients of the C terms + ! + ! Notes: + ! - robust against P lying on either or both axis - no special cases are + ! needed. + ! - assumes that field values exist at all corners. This is fine as long + ! as we are using the method to interpolate from global fields. + !----------------------------------------------------------------------------- + real :: dx, dy, dxdy ! local variables + + ixp = int(xp) + iyp = int(yp) + + dx = xp - ixp + dy = yp - iyp + dxdy =dx * dy + + wt(0,0) = 1.0 - dx - dy + dxdy + wt(0,1) = dy - dxdy + wt(1,0) = dx - dxdy + wt(1,1) = dxdy + + end subroutine bilin_interp_array + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + elemental subroutine bilin_interp_elem(xp,yp,ixp,iyp,wt_00,wt_01,wt_10,wt_11) + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + real, intent(in) :: xp, yp ! coordinates of point P (see fig.) + integer, intent(out) :: ixp, iyp ! integer coords P + real, intent(out) :: wt_00, wt_01, wt_10, wt_11 ! weights, see below + + !----------------------------------------------------------------------------- + ! method as for subroutine bilin_interp_array, but now we return scalar + ! arguments so that the routine can be elemental. Not quite so elegant + ! maybe, but elemental is nice. + ! Now we have wt_00 = wt(0,0), wt_01 = wt(0,1), etc. + ! Note the potential for error if the arguments are not called in the correct + ! order! + !----------------------------------------------------------------------------- + real :: dx, dy, dxdy ! local variables + + ixp = int(xp) + iyp = int(yp) + + dx = xp - ixp + dy = yp - iyp + dxdy = dx * dy + + wt_00 = 1.0 - dx - dy + dxdy + wt_01 = dy - dxdy + wt_10 = dx - dxdy + wt_11 = dxdy + + end subroutine bilin_interp_elem + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + + !======================================================================= + elemental function StandardAtmos_kPa_2_km(p_kPa) result (h_km) + !======================================================================= + implicit none + + !+ Converts pressure (kPa) to height (km) for a US standard Atmosphere + ! Valid up to 20 km + ! + ! ds 27/7/2003 + + real, intent(in) :: p_kPa + real :: h_km + real :: t ! Temperature (K) + + if( p_kPa > 22.632 ) then ! = 11 km height + ! t = 288.15/(p_kPa/101.325)**(-1.0/5.255876) + !- use the power function replacament, m**n == exp(n*log m) + + t = 288.15/exp(-1.0/5.255876*log(p_kPa/101.325)) + h_km = (288.15-t)/6.5 + else + h_km = 11.0 + log( p_kPa/22.632)/(-0.1576884) + end if + + end function StandardAtmos_kPa_2_km + + !======================================================================= + + !+ + ! Exner functions + ! + ! Defined here as (p/P0)**KAPPA + + ! Where KAPPA = R/CP = 0.286 + ! P0 = 1.0e5 Pa + + ! CAREFUL: The term Exner function can also be used for CP * (p/P0)**KAPPA + ! Hence notation Exner_nd - non dimensional version + ! + ! Tabulate : + ! defines the exner-function for every 1000 pa from zero to 1.3e+5 pa + ! in a table for efficient interpolation (same procedure as used in + ! the nwp-model, see mb1e.f) + ! + ! Exner_nd returns the non-dimesnional excner function (p/p0)**R/CP + ! + ! Added 7/4/2005, Dave, based upon tpi code from tiphys + ! Test prog at end along with results. + !---------------------------------------------------------------------------- + + + + !------------------------------------------------------------------- + subroutine Exner_tab() + ! + real :: p + integer :: i + + do i = 1,131 + p = PBAS + i*PINC + ! tpi(i) = CP*(p/1.0e+5)**KAPPA ! With CP!!!! + tab_exf(i) = (p/1.0e+5)**KAPPA ! Without CP + enddo + + end subroutine Exner_tab + !------------------------------------------------------------------- + + elemental function Exner_nd(p) result(exf) + + real, intent(in) :: p ! Pressure, p + real :: exf, x1 + integer :: ix1 + + x1 = (p-PBAS)/PINC + ix1 = x1 + exf = tab_exf(ix1) + (x1-ix1)*(tab_exf(ix1+1) - tab_exf(ix1)) + + end function Exner_nd + !------------------------------------------------------------------- + + elemental function Tpot_2_T(p) result(fTpot) + ! Identical to Exner_nd + ! Usage: T = Tpot * Tpot_2_T(p) + + real, intent(in) :: p ! Pressure, p + real :: fTpot, x1 + integer :: ix1 + + x1 = (p-PBAS)/PINC + ix1 = x1 + fTpot = tab_exf(ix1) + (x1-ix1)*(tab_exf(ix1+1) - tab_exf(ix1)) + + end function Tpot_2_T + !------------------------------------------------------------------- + elemental function T_2_Tpot(p) result(fT) + ! Iinvese of Exner_nd + ! Usage: Tpot = T * T_2_Tpot(p) + + real, intent(in) :: p ! Pressure, p + real :: fT, exf, x1 + integer :: ix1 + + x1 = (p-PBAS)/PINC + ix1 = x1 + exf = tab_exf(ix1) + (x1-ix1)*(tab_exf(ix1+1) - tab_exf(ix1)) + fT = 1.0/exf + + end function T_2_Tpot + !------------------------------------------------------------------- + +!program Test_exn +! use Exner_ml +! use PhysicalConstants_ml, only : KAPPA +! implicit none +! +! real :: p, exf1, exf2 +! integer :: i +! +! call Exner_tab() +! +! do i = 1, 20 +! p = 0.05 * i * 1.0e5 +! exf1 = Exner_nd(p) +! exf2 = (p*1.0e-5)**KAPPA +! 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 +! 100.000 0.51778 0.51778 0.51778 1.93133 +! 150.000 0.58141 0.58141 0.58141 1.71997 +! 200.000 0.63124 0.63124 0.63124 1.58418 +! 250.000 0.67282 0.67282 0.67282 1.48629 +! 300.000 0.70881 0.70881 0.70881 1.41081 +! 350.000 0.74075 0.74075 0.74075 1.34999 +! 400.000 0.76957 0.76957 0.76957 1.29943 +! 450.000 0.79592 0.79592 0.79592 1.25641 +! 500.000 0.82025 0.82025 0.82025 1.21913 +! 550.000 0.84291 0.84291 0.84291 1.18637 +! 600.000 0.86414 0.86414 0.86414 1.15722 +! 650.000 0.88414 0.88414 0.88414 1.13105 +! 700.000 0.90307 0.90307 0.90307 1.10734 +! 750.000 0.92105 0.92105 0.92105 1.08571 +! 800.000 0.93820 0.93820 0.93820 1.06587 +! 850.000 0.95461 0.95461 0.95461 1.04755 +! 900.000 0.97033 0.97033 0.97033 1.03058 +! 950.000 0.98544 0.98544 0.98544 1.01477 +!1000.000 1.00000 1.00000 1.00000 1.00000 +end module Functions_ml diff --git a/GlobalBCs_ml.f90 b/GlobalBCs_ml.f90 new file mode 100644 index 0000000..58fb80d --- /dev/null +++ b/GlobalBCs_ml.f90 @@ -0,0 +1,808 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 GlobalBCs_ml +! +!+ DATA/SUBROUTINES FOR USING Logan climatology for BOUNDARY +! CONDITIONS (bcs) +! From Hilde's uni.2_Logan_O3 but: +! module name changed to GlobalBCs_ml, so that both UiO_ml and +! public subroutine names changed back: +! GelLoganData -> GetGlobalData : UiO and Logan modules +! (no L suffix now). +! +! Time-of-year, height, and latitude functions applied to non-oozne BCs +! Comments: +! In using these functions I have had to accept some known problems, +! for example that the seasonal variation is often weaker at higher +! altitude. The "vmin" minimum concentration can correct for some +! of this, but for now (this week) this simplification might be ok. +! It is after all (I hope) the near-surface BCs which matter most. +! In principal we could specify al concentrations as complex 3-D fieldds +! here, but that can wait for the new setup! +! +! (the private routines, e.g. emeplat2Logan are left as they +! are since these names are not seen outside this module. +! -- for use with BoundConditions_ml and My_BoundConditions_ml -- +!____________________________________________________________________________ + use My_Derived_ml,only: model + + use CheckStop_ml, only: CheckStop + use GridValues_ml, only: gbacmax,gbacmin,glacmax,glacmin& + ,gl,gb_glob,GlobalPosition & + ,i_fdom,j_fdom & + ,sigma_mid ! for use in Hz scaling + use Functions_ml, only: StandardAtmos_kPa_2_km ! for use in Hz scaling + use GridValues_ml, only: lb2ij, xp, yp, AN, fi, gb_glob, gl_glob + use Io_ml, only : IO_GLOBBC, ios, open_file + use ModelConstants_ml, only: PPB, PPT,PPBINV & + ,KMAX_MID, PT & + ,IIFULLDOM,JJFULLDOM + use NetCDF_ml,only :GetCDF + use Par_ml, only:GIMAX,GJMAX,IRUNBEG,JRUNBEG, me + use PhysicalConstants_ml, only: PI + use TimeDate_ml, only : daynumber + + + implicit none + private + !/-- subroutines + + public :: GetGlobalData ! Opens, reads bc_data, closes global data + public :: setgl_actarray + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + + logical, parameter, private :: DEBUG_GLOBBC= .false. + logical, parameter, private :: DEBUG_Logan = .false. + logical, parameter, private :: DEBUG_HZ = .false. + + ! A. Define parameters and indices of global-model species + ! ========================================================================== + !-- definitions in Jostein's grid. Generally, these will be from + ! a Txx model, where xx is currently 21. + + integer, parameter, public :: & + !IGLOB = 57 , & ! number of emep 150*150 grids, longitude + !JGLOB = 45 ! number of emep 150*150 grids, latitude + ! IGLOB = 170, & ! number of emep 50*50 grids, longitude + ! JGLOB = 133 ! number of emep 50*50 grids, latitude + ! 15/3-2005 We 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 + ! ** usually only changed when global-model output changes ** + + integer, public, parameter :: NGLOB_BC = 18 ! No. species setup here + integer, public, parameter :: & + IBC_O3 = 1 & + ,IBC_NO = 2 & + ,IBC_NO2 = 3 & + ,IBC_PAN = 4 & + ,IBC_HNO3 = 5 & ! used for nitrate too + ,IBC_SO2 = 6 & + ,IBC_SO4 = 7 & + ,IBC_CO = 8 & + ,IBC_C2H6 = 9 & + ,IBC_C4H10 = 10 & + ,IBC_HCHO = 11 & + ,IBC_CH3CHO = 12 & + ,IBC_H2O2 = 13 & + ,IBC_aNH4 = 14 & + ,IBC_aNO3 = 15 & + ,IBC_pNO3 = 16 & + ,IBC_CH3COO2 = 17 & + ,IBC_OH = 18 + + + ! we define some concentrations in terms of sine curves and other + ! simple data: + + type, private :: sineconc + real :: surf ! Mean surface conc. (ppb) + integer :: dmax ! Day when concentrations peak + real :: amp ! amplitude of surface conc. (ppb) + real :: hz ! Scale-height (km) - height to drop 1/e concentration + real :: vmin ! background , minimum conc., in vertical direction + real :: hmin ! background , minimum conc., in horiz direction + real :: conv_fac ! factor to convert input data to mixing ratio + end type sineconc + type(sineconc), private, save, dimension(NGLOB_BC) :: SpecBC + + +! the actual values - do not use IGLOB,JGLOB, but the actual one's + integer, save, private :: iglbeg,iglend + integer, save, private :: jglbeg,jglend + + ! ========================================================================== + +contains + + + subroutine setgl_actarray(iglobact,jglobact) + !set actual domain in 150*150 emep coord + + integer i1 + real hel1,hel2 + integer,intent(out) :: iglobact,jglobact + hel1 = IRUNBEG + hel2 = IRUNBEG+GIMAX-1 + iglbeg = nint(hel1) ! global i emep coord of start of domain + iglend = nint(hel2) + iglobact = GIMAX + + hel1 = JRUNBEG + hel2 = JRUNBEG+GJMAX-1 + jglbeg = nint(hel1) + jglend = nint(hel2) + jglobact = GJMAX + + + end subroutine setgl_actarray + !------- + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine GetGlobalData(year,iyr_trend,month,ibc,used & + ,iglobact,jglobact,bc_data,io_num,errcode) + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + !== HANDLES READ_IN OF GLOBAL DATA. We read in the raw data from the + ! global model, and do the vertical interpolation to EMEP k values + ! here if the species is to be used. + integer, intent(in) :: year !for Mace Head correction + integer, intent(in) :: iyr_trend !Allows future/past years + integer, intent(in) :: month + integer, intent(in) :: ibc ! Index of BC, u3 + integer, intent(in) :: used ! set to 1 if species wanted + integer, intent(in) :: iglobact,jglobact !u3 intent added + real, dimension(iglobact,jglobact,KMAX_MID), & + intent(out) :: bc_data ! Data from Logan model + integer, intent(out) :: io_num ! i/o number + integer, intent(inout) :: errcode ! i/o number + logical, save :: my_first_call = .true. ! u3 + + real, dimension(IGLOB,JGLOB,KMAX_MID) :: bc_rawdata ! Data (was rtcdmp) + + +! Now we want fake data on EMEP 50*50 grid.... + real:: USso2trend,USnoxtrend,USnh4trend + + integer, dimension(IGLOB,JGLOB), save :: lat5 !u3 for latfunc below + + real, dimension(NGLOB_BC,6:14), save :: latfunc !u3 lat. function + real, save :: twopi_yr, cosfac ! for time-variations !u3 + real, dimension(12) :: macehead_O3 + real :: O3fix + integer :: i, j , k,i1,j1,icount + real ::val + character(len=30) :: fname ! input filename + character(len=99) :: errmsg ! For error messages + character(len=30) :: BCpoll ! pollutant name + integer, save :: oldmonth = -1 + real :: trend_o3, trend_co, trend_voc + !Use of standard atmosphere + real, dimension(KMAX_MID), save :: p_kPa, h_km + real :: scale_old, scale_new,iMH,jMH + logical :: notfound !set true if NetCDF BIC are not found + real, parameter :: macehead_lat = 53.3 !latitude of Macehead station + real, parameter :: macehead_lon = -9.9 !longitude of Macehead station + real, dimension(1,1) :: buf_lon,buf_lat,bufi,bufj + logical,parameter :: MACEHEADFIX=.true. + + io_num = IO_GLOBBC ! for closure in BoundCOnditions_ml + +!================================================================== +!Trends 1980-2003 derived from EPA emissions of so2,nox. nh4 derived from +!2/3so3+1/3nox +!1920-1970 BCs derived from: +!NH4: nh3 emissions +!SOx: winter ice cores, Col du dome +!NOx: winter ice cores +!1890-1920: trender fra utslipp for SOx,NOx, NH3, Aardenne USA + +if (iyr_trend == 1890) then + USso2trend=0.12 + USnoxtrend=0.15 + USnh4trend=0.44 +elseif (iyr_trend == 1900) then + USso2trend=0.18 + USnoxtrend=0.20 + USnh4trend=0.48 +elseif (iyr_trend == 1910) then + USso2trend=0.27 + USnoxtrend=0.27 + USnh4trend=0.52 +elseif (iyr_trend == 1920) then + USso2trend=0.32 + USnoxtrend=0.33 + USnh4trend=0.59 +elseif(iyr_trend == 1930)then + USso2trend=0.35 + USnoxtrend=0.33 + USnh4trend=0.55 +elseif(iyr_trend == 1940)then + USso2trend=0.46 + USnoxtrend=0.25 + USnh4trend=0.59 +elseif(iyr_trend == 1950)then + USso2trend=0.59 + USnoxtrend=0.33 + USnh4trend=0.69 +elseif(iyr_trend == 1960)then + USso2trend=0.76 + USnoxtrend=0.5 + USnh4trend=0.76 +elseif(iyr_trend == 1970)then + USso2trend=0.95 + USnoxtrend=0.75 + USnh4trend=0.90 +elseif(iyr_trend == 1980)then + USso2trend=1. + USnoxtrend=1. + USnh4trend=1. +else if( iyr_trend == 1985) then + USso2trend=0.91 + USnoxtrend=0.95 + USnh4trend=0.94 +else if( iyr_trend == 1990) then + USso2trend=0.89 + USnoxtrend=0.94 + USnh4trend=0.93 +else if( iyr_trend == 1995) then + USso2trend=0.72 + USnoxtrend=0.92 + USnh4trend=0.88 +else if( iyr_trend == 1996) then + USso2trend=0.71 + USnoxtrend=0.92 + USnh4trend=0.88 +else if( iyr_trend == 1997) then + USso2trend=0.73 + USnoxtrend=0.91 + USnh4trend=0.88 +else if( iyr_trend == 1998) then + USso2trend=0.73 + USnoxtrend=0.90 + USnh4trend=0.87 +else if( iyr_trend == 1999) then + USso2trend=0.68 + USnoxtrend=0.84 + USnh4trend=0.81 +else if( iyr_trend == 2000) then + USso2trend=0.63 + USnoxtrend=0.83 + USnh4trend=0.80 +else if( iyr_trend == 2001) then + USso2trend=0.62 + USnoxtrend=0.80 + USnh4trend=0.76 +else if( iyr_trend == 2002) then + USso2trend=0.59 + USnoxtrend=0.78 + USnh4trend=0.74 +else if( iyr_trend >= 2003) then + USso2trend=0.62 + USnoxtrend=0.77 + USnh4trend=0.74 +else + write(unit=errmsg,fmt=*) "Unspecified trend BCs for this year:", ibc, year + call CheckStop(errmsg) + +endif + + +!================================================================== +! Trends - derived from EMEP report 3/97 +! adjustment for years outside the range 1990-2000. + + + if ( iyr_trend >= 1990 ) then + trend_o3 = 1.0 + trend_co = 1.0 + trend_voc= 1.0 + else + trend_o3 = exp(-0.01*1.0 *(1990-iyr_trend)) + trend_co = exp(-0.01*0.85*(1990-iyr_trend)) ! Zander:CO + trend_voc= exp(-0.01*0.85*(1990-iyr_trend)) ! Zander,1975-1990 + end if + if (me == 0 .and. my_first_call) write(6,"(a20,i5)") "GLOBAL TREND YEAR ", iyr_trend + if (me == 0 .and. my_first_call) write(6,"(a20,3f8.3)") "TRENDS O3,CO,VOC ", trend_o3, trend_co, trend_voc + +!================================================================== +!=========== BCs Generated from Mace Head Data ======================= +! +! Mace Head ozone concentrations for backgroudn sectors +! from Fig 5., Derwent et al., 1998, AE Vol. 32, No. 2, pp 145-157 +! +! Here we use the meteorology year to get a reaslistic O3. +! Later we use iyr_trend to adjust for otyer years, say for 2050. + +! For 2010, 2020 "trend" runs - use 10 yr average as base-O3 +! then later scale by trend_o3: + + if ( iyr_trend /= year ) then ! For trends, use defaults from 1990-2000 average + macehead_O3 = (/ 37.6, 40.0, 42.9, 43.2, 41.9, 33.9, & + 29.4, 30.1, 33.3, 36.5, 35.1, 37.8 /) + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + if ( iyr_trend == 2010 ) then + macehead_O3 = macehead_O3 + 3.0 !ASSUMPTION FOR IIASA SR runs + elseif ( iyr_trend > 2010 )then + macehead_O3 = macehead_O3 + 4.5 !ASSUMPTION FOR JUN06 SR runs + endif + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + else if( year == 1990) then + macehead_O3 = (/ 35.3, 36.3, 38.4, 43.0, 41.2, 33.4 & + , 35.1, 27.8, 33.7, 36.2, 28.4, 37.7/) + else if( year == 1991) then + macehead_O3 = (/ 36.1, 38.7, 37.7, 45.8, 38.8, 36.3 & + , 29.6, 33.1, 33.4, 35.7, 37.3, 36.7/) + else if( year == 1992) then + macehead_O3 = (/ 36.1, 37.3, 41.8, 39.6, 41.2, 31.5 & + , 28.3, 30.3, 31.3, 34.2, 36.1, 34.9/) + else if( year == 1993) then + 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/) + else if( year == 1994) then + 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/) + else if( year == 1995) then + macehead_O3 = (/ 37.5, 37.1, 41.6, 42.4, 41.1, 33.1 & + , 29.1, 28.7, 33.7, 34.8, 35.0, 36.0/) + else if( year == 1996) then + macehead_O3 = (/ 37.0, 40.1, 42.9, 44.6, 41.3, 38.3 & + , 29.3, 29.4, 35.6, 38.4, 37.8, 38.4/) + else if( year == 1997) then + macehead_O3 = (/ 36.2, 41.9, 41.8, 40.4, 40.6, 34.4 & + , 26.2, 29.3, 31.3, 35.2, 25.7, 39.5/) + else if( year == 1998) then + macehead_O3 = (/ 38.6, 42.0, 44.6, 45.1, 44.2, 33.0 & + , 29.7, 32.9, 35.7, 38.8, 39.7, 40.4/) + else if( year == 1999) then + macehead_O3 = (/ 39.9, 44.5, 49.4, 45.0, 42.8, 34.3 & + , 29.0, 30.0, 31.8, 36.9, 39.6, 39.2/) + else if( year == 2000) then + macehead_O3 = (/ 39.5, 42.1, 41.8, 43.8, 43.4, 34.5 & + , 28.0, 27.3, 33.6, 37.4, 35.6, 35.8/) + else if( year == 2001) then + macehead_O3 = (/ 37.3, 38.0, 42.2, 44.8, 42.6, 34.9 & + , 28.9, 29.4, 29.9, 35.3, 37.3, 37.5/) +!--------------------------------------------------------------------------- +! Preliminary BCs generated using Mace Head CFC and other greenhouse gases +! data to define clean air masses. Data cover all of 2002 and 9 months +! of 2003. What to do for Oct-Dec 2003? +! Could use (1) 2002 data or (2) 10-year average? +! Simmonds paper would support (1), simplicity (2). +! After seeing earlier 2003 plots, chose (2). +! +elseif ( year == 2002 ) then + macehead_O3 = (/ 42.4 , 44.4 , 45.5 , 45.0 , 45.9 , 39.8 & + , 32.5 , 28.7 , 37.7 , 39.3 , 40.5 , 42.3 /) + +elseif ( year == 2003 ) then + macehead_O3 = (/ 39.8 , 40.1 , 44.7 , 45.4 , 45.7 , 41.7 & + , 33.3 , 31.0 , 35.7, 37.9 , 40.9 , 38.1 /) + +elseif( year == 2004) then + macehead_O3 = (/ 40.8, 42.0, 48.3, 46.6, 39.9, 31.9 & + , 32.4, 32.1, 33.9, 36.7, 40.2, 39.8/) + +elseif( year == 2005) then + macehead_O3 = (/ 40.9, 41.4, 44.1, 45.6, 42.7, 32.9 & + , 26.7, 30.0, 33.2, 37.7, 39.5, 38.0/) +!--------------------------------------------------------------------------- +elseif ( year > 2005 ) then + write(unit=errmsg,fmt=*) & + "ERROR: No Mace Head correction for this year yet! ", year + call CheckStop(errmsg) + else ! Defaults, from 1990-2000 average ! + macehead_O3 = (/ 37.6, 40.0, 42.9, 43.2, 41.9, 33.9, & + 29.4, 30.1, 33.3, 36.5, 35.1, 37.8 /) + end if +!=========== Generated from Mace Head Data ======================= + + errcode = 0 + errmsg = "ok" + + if ( DEBUG_Logan ) write(*,*) "DEBUG_LOgan ibc, mm", ibc, month + + ! ========= first call ========================================= + if ( my_first_call ) then + ! Set up arrays to contain Logan's grid as lat/long + !/ COnversions derived from emeplat2Logan etc.: + + twopi_yr = 2.0 * PI / 365.25 + + call GlobalPosition !get gb for global domaib + do i = 1, IGLOB + do j = 1, JGLOB ! Don't bother with south pole complications + + lat5(i,j) = gb_glob(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 + end do + end do + + ! Define concs where a simple specification based on lat/mm + ! etc. will be given + ! surf dmax amp hz vmin hmin conv_fac!ref + ! ppb ppb km hmin,vmin:same units as input data=conv_fac + + SpecBC(IBC_SO2 ) = sineconc( 0.15 , 15.0, 0.05, 999.9, 0.03 , 0.03,PPB) !W99, bcKz vmin + SpecBC(IBC_SO4 ) = sineconc( 0.15 ,180.0, 0.00, 1.6, 0.05 , 0.03,PPB) !W99 + SpecBC(IBC_NO ) = sineconc( 0.1 , 15.0, 0.03, 4.0 , 0.03, 0.02,PPB) + 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) !bcKz change vmin + SpecBC(IBC_CO ) = sineconc( 125.0, 75.0, 35.0,25.0 , 70.0, 30.0,PPB )!JEJ-W + SpecBC(IBC_C2H6 ) = sineconc( 2.0 , 75.0, 1.0 , 10.0 , 0.05, 0.05,PPB ) + SpecBC(IBC_C4H10) = sineconc( 2.0 , 45.0, 1.0 , 6.0 , 0.05, 0.05,PPB ) + SpecBC(IBC_HCHO ) = sineconc( 0.7 ,180.0, 0.3 , 6.0 , 0.05, 0.05,PPB ) + SpecBC(IBC_CH3CHO) = sineconc(2.0 ,180.0, 0.5 , 6.0 , 0.05, 0.05,PPB ) +! SpecBC(IBC_HNO3 ) = sineconc( 0.1 , 15.0, 0.03, 999.9, 0.05, 0.05,PPB )!M, bcKz vmin + SpecBC(IBC_HNO3 ) = sineconc( 0.07 , 180.0, 0.03, 999.9, 0.025, 0.03 ,PPB)!changed to be approx eq to NO3, + !but with opposite seasonal var. + SpecBC(IBC_aNO3 )= sineconc( 0.07 , 15.0, 0.03, 1.6, 0.025 , 0.02,PPB) !ACE-2 + SpecBC(IBC_pNO3 )= sineconc( 0.07 , 15.0, 0.00, 1.6, 0.025 , 0.02,PPB) !ACE-2 + SpecBC(IBC_aNH4 ) = sineconc( 0.15 , 180.0, 0.00, 1.6, 0.05 , 0.03,PPB) !ACE-2(SO4/NH4=1) + + ! all BCs read in are in mix. ratio, thus hmin,vmin needs to be in mix. ratio for those + SpecBC(IBC_O3 ) = sineconc(-99.9 ,-99.9,-99.9,-99.9 ,-99.9,10.0*PPB,1.)!N1 + SpecBC(IBC_H2O2 ) = sineconc(-99.9 ,-99.9,-99.9,-99.9 ,-99.9,0.01*PPB,1.) + SpecBC(IBC_OH ) = sineconc(-99.9 ,-99.9,-99.9,-99.9 ,-99.9,1.0e-7*PPB,1.) + SpecBC(IBC_CH3COO2)=sineconc(-99.9 ,-99.9,-99.9,-99.9 ,-99.9,1.0e-7*PPB,1.) + + ! Consistency check: + + if (DEBUG_GLOBBC) print *, "SPECBC NGLB ", NGLOB_BC + do i = 1, NGLOB_BC + if (DEBUG_GLOBBC) print *, "SPECBC i, hmin ", i, SpecBC(i)%surf, SpecBC(i)%hmin + + if( SpecBC(i)%hmin*SpecBC(i)%conv_fac < 1.0e-17) then + + write(unit=errmsg,fmt=*) "PECBC: Error: No SpecBC set for species", i + call CheckStop(errmsg) + end if + end do + + + !refs: + ! N1 - for ozone we read Logan's data, so the only paramater specified + ! is a min value of 10 ppb. I hope this doesn't come into effect in + ! Europe as presumably any such min values are in the S. hemisphere. + ! Still, giving O3 such a value let's us use the same code for + ! all species. + ! W99: Warneck, Chemistry of the Natural Atmosphere, 2nd edition, 1999 + ! Academic Press. Fig 10-6 for SO2, SO4. + ! JEJ - Joffen's suggestions from Mace/Head, UiO and other data.. + ! with scale height estimated large from W99, Isaksen+Hov (1987) + ! M -Mozart-obs comparison + ! ACE-2 Lots of conflicting measurements exist, from NH4/SO4=2 to NH4/SO4=0.5 + ! A 'mean' value of NH4/SO4=1 is therefore selected. Otherwise NH4 is assumed to + ! act as SO4 + ! aNO3 is assumed to act as SO4, but with 1/2 concentrations and seasonal var. + ! pNO3 is assumed to act like seasalt, with decreasing conc with height, with + ! approx same conc. as fine nitrate. + ! The seasonal var of HNO3 is now assumed to be opposite of aNO3. + + ! Latitude functions taken from Lagrangian model, see Simpson (1992) + latfunc(:,6:14) = 1.0 ! default + ! 30 40 50 60 70 degN + latfunc(IBC_SO2,6:14) = (/ 0.05,0.15,0.3 ,0.8 ,1.0 ,0.6 ,0.2 ,0.12,0.05/) + latfunc(IBC_HNO3,6:14)= (/ 1.00,1.00,1.00,0.85,0.7 ,0.55,0.4 ,0.3 ,0.2 /) + latfunc(IBC_PAN,6:14) = (/ 0.15,0.33,0.5 ,0.8 ,1.0 ,0.75,0.5 ,0.3 ,0.1 /) + latfunc(IBC_CO ,6:14) = (/ 0.6 ,0.7 ,0.8 ,0.9 ,1.0 ,1.0 ,0.95,0.85,0.8 /) + + latfunc(IBC_SO4,:) = latfunc(IBC_SO2,:) + latfunc(IBC_NO ,:) = latfunc(IBC_SO2,:) + latfunc(IBC_NO2,:) = latfunc(IBC_SO2,:) + latfunc(IBC_HCHO,:) = latfunc(IBC_HNO3,:) + latfunc(IBC_CH3CHO,:) = latfunc(IBC_HNO3,:) + latfunc(IBC_aNH4,:) = latfunc(IBC_SO2,:) + latfunc(IBC_aNO3,:) = latfunc(IBC_SO2,:) + latfunc(IBC_pNO3,:) = latfunc(IBC_SO2,:) + + + + !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) + + my_first_call = .false. + + end if ! my_first_call + ! ========= end of first call =================================== + + + !+ + ! Specifies concentrations for a fake set of Logan data. + + !/-- tmp and crude - we associate 1 km of scaleht with 1 Logan level + ! - okayish for 1st 5-6 km in any case...... + + fname = "none" ! dummy for printout + + + select case ( ibc ) + + case ( IBC_OH) + write(unit=fname,fmt="(a6,i2.2)") "D3_OH.",month + + BCpoll='D3_OH' + call ReadBC_CDF(BCpoll,month,bc_rawdata,IGLOB,JGLOB,KMAX_MID,notfound) + if(notfound)then + call open_file(IO_GLOBBC,"r",fname,needed=.true.,skip=1) + if ( ios /= 0 ) errmsg = "BC Error H2O2" + read(IO_GLOBBC,*) bc_rawdata + close(IO_GLOBBC) + endif + + case ( IBC_CH3COO2) + write(unit=fname,fmt="(a11,i2.2)") "D3_CH3COO2.",month + + BCpoll='D3_CH3COO2' + call ReadBC_CDF(BCpoll,month,bc_rawdata,IGLOB,JGLOB,KMAX_MID,notfound) + if(notfound)then + call open_file(IO_GLOBBC,"r",fname,needed=.true.,skip=1) + if ( ios /= 0 ) errmsg = "BC Error H2O2" + read(IO_GLOBBC,*) bc_rawdata + close(IO_GLOBBC) + endif + + + case ( IBC_H2O2 ) + + write(unit=fname,fmt="(a8,i2.2)") "D3_H2O2.",month + + BCpoll='D3_H2O2' + call ReadBC_CDF(BCpoll,month,bc_rawdata,IGLOB,JGLOB,KMAX_MID,notfound) + if(notfound)then + call open_file(IO_GLOBBC,"r",fname,needed=.true.,skip=1) + if ( ios /= 0 ) errmsg = "BC Error H2O2" + read(IO_GLOBBC,*) bc_rawdata + close(IO_GLOBBC) + endif + + + case ( IBC_O3 ) + + write(unit=fname,fmt="(a6,i2.2)") "D3_O3.",month + + BCpoll='D3_O3_Logan' + call ReadBC_CDF(BCpoll,month,bc_rawdata,IGLOB,JGLOB,KMAX_MID,notfound) + + if(notfound)then + call open_file(IO_GLOBBC,"r",fname,needed=.true.,skip=1) + if ( ios /= 0 ) errmsg = "BC Error O3" + read(IO_GLOBBC,*) bc_rawdata + close(IO_GLOBBC) + endif + + write(*,*) "dsOH READ OZONE3 ", fname, ": ", bc_rawdata(IGLOB/2,JGLOB/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 + if( gb_glob(i,j)macehead_lat-25.0 & + .and.gl_glob(i,j)macehead_lon-40.0)then + O3fix=O3fix+bc_rawdata(i,j,20) + icount=icount+1 + endif + enddo + enddo + +! grid coordinates of Mace Head + + call lb2ij(macehead_lon,macehead_lat, iMH,jMH) + + if(icount>=1) O3fix = O3fix/(icount) - macehead_O3(month)*PPB + + write(6,"(a10,2f7.2,i4,i6,3f8.3)") "O3FIXes ",iMH,jMH, & + month,icount,bc_rawdata(nint(iMH),nint(jMH),20)/PPB,& + macehead_O3(month),O3fix/PPB + endif + + if (model=='ZD_ACID') then + + bc_rawdata=max(15.*PPB,bc_rawdata) + + elseif (model=='ZD_OZONE') then + bc_rawdata=max(15.0*PPB,bc_rawdata-O3fix) + else + call CheckStop("Problem with Mace Head Correction in GlobalBCs_ml") + endif + + bc_rawdata=trend_o3 * bc_rawdata + + + case ( IBC_NO, IBC_NO2, IBC_HNO3, IBC_CO, & + IBC_C2H6, IBC_C4H10, IBC_PAN, IBC_pNO3 ) + + ! NB since we only call once per month we add 15 days to + ! day-number to get a mid-month value + + cosfac = cos( twopi_yr * (daynumber+15.0-SpecBC(ibc)%dmax)) + + bc_rawdata(:,:,KMAX_MID) = SpecBC(ibc)%surf + & + ( SpecBC(ibc)%amp * cosfac) + + !/ - correct for other heights + do k = 1, KMAX_MID-1 + + scale_new = exp( -h_km(k)/SpecBC(ibc)%hz ) + + bc_rawdata(:,:,k) = & + bc_rawdata(:,:,KMAX_MID)* scale_new + + if (DEBUG_HZ) then + scale_old = exp( -(KMAX_MID-k)/SpecBC(ibc)%hz ) + write(6,"(a8,2i3,2f8.3,i4,f8.2,f8.3,2f8.3)") "SCALE-HZ ", month, ibc, & + SpecBC(ibc)%surf, SpecBC(ibc)%hz, k, & + h_km(k), p_kPa(k), scale_old, scale_new + end if ! DEBUG_HZ + end do + + bc_rawdata = max( bc_rawdata, SpecBC(ibc)%vmin ) + + + !/ - correct for latitude functions -------------------------- + + do i = 1, IGLOB + do j = 1, JGLOB + bc_rawdata(i,j,:) = bc_rawdata(i,j,:) * latfunc(ibc,lat5(i,j)) + enddo + end do + !/ - end of correction for latitude functions --------------- + + !/ trend adjustments: + if( ibc == IBC_C4H10 .or. ibc == IBC_C2H6 )then + bc_rawdata = trend_voc * bc_rawdata + else if( ibc == IBC_CO )then + bc_rawdata = trend_co * bc_rawdata + end if + + case ( IBC_SO2, IBC_SO4, IBC_HCHO, IBC_CH3CHO, IBC_aNH4, IBC_aNO3 ) + + ! (No vertical variation for S in marine atmosphere, see W99) + ! aNO3 and NH4 assumed to act as SO4 + ! and PAN is just temporary, with some guessing that + ! since sources decrease with altitude, but lifetime + ! increases the concs don't change much. + + cosfac = cos( twopi_yr * (daynumber+15.0-SpecBC(ibc)%dmax)) + + bc_rawdata(:,:,:) = SpecBC(ibc)%surf + & + ( SpecBC(ibc)%amp * cosfac) + + !/ - correct for latitude functions -------------------------- + if ( DEBUG_Logan ) write(*,*) "LOGAN HORIZ", & + ibc, SpecBC(ibc)%surf, cosfac + do i = 1, IGLOB + do j = 1, JGLOB + + bc_rawdata(i,j,:) = bc_rawdata(i,j,:) * latfunc(ibc,lat5(i,j)) + + if ( DEBUG_Logan ) then + write(6,"(2i4,f8.2,f15.4)")j, lat5(i,j), & + latfunc(ibc,lat5(i,j)), bc_rawdata(36,j,1) + end if + enddo + end do + + !/ - end of correction for latitude functions ---------------- + + case default + print *,"Error with specified BCs:", ibc + errmsg = "BC Error UNSPEC" + end select + !================== end select ================================== + if (DEBUG_GLOBBC) write(*,*) "dsOH FACTOR ", ibc, fname + + call CheckStop(errmsg) + if( DEBUG_Logan )then + + write(*,"(a15,3i4,f8.3)") "DEBUG:LOGAN: ",ibc, used, month, cosfac + write(*,*) "LOGAN BC MAX ", maxval ( bc_rawdata ), & + " MIN ", minval ( bc_rawdata ) + do k = KMAX_MID, 1, -1 ! print out for equator, mid-lat + write(*, "(i4,f12.3)") k, bc_rawdata(15,15,k) + end do + end if ! DEBUG + + + !/ - correction for latitude functions ----------------------- + bc_rawdata = max( bc_rawdata, SpecBC(ibc)%hmin ) + + +! ========================================= + !trend data + select case ( ibc ) + case(IBC_SO2, IBC_SO4) + bc_rawdata=bc_rawdata*USso2trend + case(IBC_aNH4) + bc_rawdata=bc_rawdata*USnh4trend + case(IBC_aNO3, IBC_pNO3, IBC_HNO3, IBC_NO2, IBC_NO, IBC_PAN) + bc_rawdata=bc_rawdata*USnoxtrend + end select +! ========================================= + + + if( DEBUG_Logan ) write(*,*) "LOGAN NEW MIN", minval ( bc_rawdata ) + + + if ( used == 1 ) then + + bc_rawdata(:,:,:)=bc_rawdata(:,:,:) * SpecBC(ibc)%conv_fac !Convert to mixing ratio + + j1 = 1 + do j = jglbeg,jglend + i1 = 1 + do i = iglbeg,iglend + + bc_data(i1,j1,:) = bc_rawdata(i,j,:) + i1 = i1+1 + enddo + j1 = j1+1 + enddo + + + end if + + end subroutine GetGlobalData + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine ReadBC_CDF(varname,month,bc_rawdata,varGIMAX,varGJMAX,varKMAX,notfound) + + logical, intent(out) :: notfound + integer, intent(in) :: month + integer, intent(in) :: varGIMAX,varGJMAX,varKMAX!dimensions of bc_rawdata + real, dimension(*), intent(inout) :: bc_rawdata !NB written as one-dimensional + character (len = *),intent(in) ::varname + + + integer :: nstart,nfetch + character (len = 100)::filename + nstart=month + nfetch=1 + fileName='Boundary_and_Initial_Conditions.nc' + call GetCDF(varname,fileName,bc_rawdata,varGIMAX,varGJMAX,varKMAX,nstart,nfetch,needed=.false.) + notfound=.false. + if(nfetch==0)notfound=.true. + + + end subroutine ReadBC_CDF +end module GlobalBCs_ml + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ diff --git a/GridAllocate_ml.f90 b/GridAllocate_ml.f90 new file mode 100644 index 0000000..d6162ad --- /dev/null +++ b/GridAllocate_ml.f90 @@ -0,0 +1,267 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 GridAllocate_ml +!____________________________________________________________________ +! + ! GridAllocate subroutines: GridAllocate_ij, GridAllocate_rarray + ! + Self_Test + ! + ! Some gridded arrays have several data values for the same i,j coordinate + ! associated with dfferent land or emission codes, e.g. + ! + ! e.g. i=2, j=2, code = 4, data = 1.2 + ! i=2, j=2, code = 12, data = 2.3 + ! i=2, j=2, code = 87, data = 0.3 + + ! Or, for each i,j, we may have row inputs for lots of possible codes, + ! e.g. for landuse types with say 17 possibilities + ! + ! It would be wasteful to assign arrays with code-dimension 87 or 17 to + ! collect this data, when only a few data points might be needed for this i,j. + ! + ! This routine "compresses" the data for grid i,j into two arrays, + ! such that: + ! ngridc(i,j) = 3 ! Number of data points in coord i,j + ! gridc(i,j,1) = 4 + ! gridc(i,j,2) = 12 + ! gridc(i,j,3) = 87 + ! + !-- Checks if a country "code" (or landuse type, lu) whose data has just + ! been read in has already been found within the given grid square. + ! If not, the array "ngridc" is incremented by one and the + ! country (or landuse) index added to "gridc". + ! + ! These routines are used for emissions and landuse +!____________________________________________________________________ +! +!** includes +! +! Depends on: CheckStop - stops code if needed (MPI-enabled) +! Language: F +! History: +! ds - 2000-Jan. 2001, some re-writing + Self_Test added, May 2007 +!____________________________________________________________________ + use CheckStop_ml, only : CheckStop + use Par_ml, only : me ! TESTS + use GridValues_ml, only : i_fdom, j_fdom + implicit none + private + + !/-- subroutines + + public :: GridAllocate + public :: Self_Test + + private :: GridAllocate_ij, GridAllocate_rarray + + interface GridAllocate + module procedure GridAllocate_ij ! Call for one i,j value + module procedure GridAllocate_rarray ! Call with full real arrays + end interface GridAllocate + + + + !======================================== + contains + !======================================== + + subroutine GridAllocate_ij(label,i,j,code,ncmax,ic,& + ncmaxfound,gridc,ngridc) + + character(len=*), intent(in) :: label ! Type of data + integer, intent(in) :: i,j + integer, intent(in) :: code ! Full code (e.g. country code) + integer, intent(in) :: ncmax ! Max. no countries (lu) allowed + + integer, intent(out) :: ic ! Index in compressed array + integer, intent(inout) :: ncmaxfound ! No. countries found so far + integer, dimension(:,:,:), intent(inout) :: gridc ! Land-codes + integer, dimension(:,:), intent(inout) ::ngridc ! No. countries + + integer :: nc, icc ! local variables + character(len=100) :: errmsg + + nc=ngridc(i,j) ! nc = no. countries known so far + + do icc = 1,nc + if( gridc(i,j,icc) == code ) then + !write(unit=*,fmt="(a8,a20,i3,3i6,4i4)") trim(label), & + ! " ::Already listed ", me, i,j, nc , icc, code + ic = icc + return + endif + enddo + + ic = nc + 1 + if ( ic > ncmax ) then + do icc = 1, ic + write(unit=*,fmt=*) "XXX GridAlloc_ij:"//label , icc,ic, code + end do + + write(unit=errmsg,fmt=*) "me", me, " i ", i, " j ", j, " iglob ", i_fdom(i), j_fdom(j) + call CheckStop( "GridAlloc ncmax ERROR" // label // errmsg ) + + end if + + + ngridc(i,j) = ngridc(i,j) + 1 ! country is a new one + gridc(i,j,ic) = code + + if( ic > ncmaxfound) then + ncmaxfound = ic + + end if + + end subroutine GridAllocate_ij + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine GridAllocate_rarray(label,ncmax,ncmaxfound,& + fulldata,data,gridc,ngridc) + + ! See comments above for explanation. This routine was designed for + ! the full array as input, e.g. landuse(:,:,17) + + character(len=*), intent(in) :: label ! Type of data + integer, intent(in) :: ncmax ! Max. no countries (lu) allowed + integer, intent(out) :: ncmaxfound ! No. countries found + + real, dimension(:,:,:), intent(in) :: fulldata ! Full data-set + real, dimension(:,:,:), intent(out) :: data ! Reduced data-set + integer, dimension(:,:,:), intent(out) :: gridc ! Land-codes + integer, dimension(:,:), intent(out) ::ngridc ! No. countries + + integer :: i,j, nc, ic, icc, code ! local variables + real :: dat + + ncmaxfound = 0 + data(:,:,:) = 0.0 + ngridc(:,:) = 0 + gridc(:,:,:) = 0 + + do i = 1, size(fulldata, 1) + do j = 1, size(fulldata, 2) + + GRIDLOOP: do code = 1, size(fulldata, 3) ! e.g. 1 .. 17 for landuse + + dat = fulldata(i,j,code) + if ( dat == 0.0 ) then + cycle GRIDLOOP + end if + + ! First, check if country is already in list: + nc= ngridc(i,j) ! nc = no. countries/landuse known so far + do icc = 1, nc + if( gridc(i,j,icc) == code ) then + data(i,j,icc) = data(i,j,icc) + dat + cycle GRIDLOOP ! Yep, go onto to next k + endif + enddo + + ! Nope, must be new. Add to ngridc and gridc: + ngridc(i,j) = ngridc(i,j) + 1 + ic = nc + 1 + + call CheckStop( ic > ncmax , "GridAlloc ncmax ERROR" // label ) + + gridc(i,j,ic) = code + data(i,j,ic) = dat + + + if( ic > ncmaxfound) then + ncmaxfound = ic + write(unit=*,fmt=*) "GridAlloc ", label, & + " increased ncmaxfound:", i,j,ic + write(unit=*,fmt=*) "GridAlloc gridc: ", & + (gridc(i,j,icc),icc=1,ncmaxfound) + write(unit=*,fmt=*) "GridAlloc Data: ", & + (data(i,j,icc),icc=1,ncmaxfound) + endif + end do GRIDLOOP + end do ! j + end do ! i + + end subroutine GridAllocate_rarray + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine Self_Test() + !+ Tests this module + + integer, parameter :: NCMAX=3 ! Max. no codes allowed + integer :: i=2,j=1 + integer :: ic, icc, iland ! Indices + integer :: ncmaxfound ! No. countries found so far + integer, dimension(2,2,NCMAX) :: land ! Land-codes + integer, dimension(2,2) ::nland ! No. countries + real, dimension(2,2,10) :: cover ! some landuse data, perhaps + real, dimension(2,2,NCMAX):: ccover ! compressed array from cover + + print *, "============================================================" + print *, "Test 1 GridAllocate integers with up to ncmax", ncmax + print *, "Should print 3 lines: " + print *, " " + + land = 0 + nland = 0 + do icc = 1, 4 ! e.g. country or vegetation code + ic = icc + if( icc == 4 ) ic = 2 ! test of repeated code + print *, "Starting ic ", ic + call GridAllocate("TEST-ij",i,j,ic,ncmax,iland,& + ncmaxfound,land,nland) + end do + print *, "Self_Test 1 found ncmax = ", ncmax + print *, " " + print *, "============================================================" + print *, "Test 2 Array input" + + land = 0 + nland = 0 + cover = 0.0 + cover(1,1,1) = 10.0 + cover(1,1,4) = 3.0 + cover(1,1,10) = 6.0 + + call GridAllocate("TEST-array",ncmax, ncmaxfound,& + cover, ccover, land,nland) + print *, "Self_Test 2 found ncmax = ", ncmax + print *, " " + print *, "============================================================" + print *, "Test 3 Array input SHOULD MPI_ABORT WITH nc > ncmax" + print *, " " + + land = 0 + nland = 0 + cover(1,1,2) = 10.0 !! Add some more data - too much + cover(1,1,3) = 3.0 + + call GridAllocate("TEST-array",ncmax, ncmaxfound,& + cover, ccover, land,nland) + print *, "ERROR IN Self_Test 3 SHOULD NOT GET HERE" + + end subroutine Self_Test + +end module GridAllocate_ml + diff --git a/GridValues_ml.f90 b/GridValues_ml.f90 new file mode 100644 index 0000000..789ea73 --- /dev/null +++ b/GridValues_ml.f90 @@ -0,0 +1,671 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 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. I have 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 ModelConstants_ml, only : KMAX_BND, KMAX_MID &! vertical extent + ,DEBUG_i, DEBUG_j & ! full-domain coordinate of debug-site + ,NPROC, IIFULLDOM,JJFULLDOM + 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 !pw grid to longitude latitude + Public :: lb2ijm !pw longitude latitude to grid + Public :: ij2ijm !pw grid1 to grid2 + Public :: lb2ij !pw longitude latitude to grid + + Public :: GlobalPosition ! => + private :: Position ! => lat(gb), long (gl) + + + !** 1) Public (saved) Variables from module: + 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) + + !/ 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 + + ! and reverse: + integer, public, save, dimension(IIFULLDOM) :: i_local !local coordinates + integer, public, save, dimension(JJFULLDOM) :: j_local !of full-domain i,j + + + real, public, save, dimension(KMAX_BND) :: & + sigma_bnd ! sigma, layer boundary + + real, public, save, dimension(KMAX_MID) :: & + sigma_mid ! sigma layer midpoint + + real, public, save, dimension(KMAX_MID) :: carea ! for budgets ??? + + real, public, save, dimension(MAXLIMAX,MAXLJMAX) :: & + gl & !longitude of EMEP grid center + ,gb !latitude of EMEP grid center + + real, public, save, dimension(IIFULLDOM,JJFULLDOM) :: & + gb_glob, & !longitude of EMEP grid center + gl_glob !longitude of EMEP grid center + + + real, public, save :: gbacmax,gbacmin,glacmax,glacmin + +! 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 + + !/** 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 + + integer, public, save :: & + debug_li, debug_lj ! 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 + +contains + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine DefGrid() + !-------------------------------------------------------------------! + ! 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 ) + real, dimension(0:MAXLIMAX+1,0:MAXLJMAX+1) :: & + xm ! map-factor + + ! Earth radius = 6.37e6 m, gives gridwidth: + +! 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 + + !/ 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 + + 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 + + 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 + + rpol2 = (x*x + y)/an2 + rpol2_i = (x*x + y_i)/an2 + rpol2_j = (x_j*x_j + y)/an2 + +! rpol2 = (x*x + y)/an2 + 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) + + + 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 + +! 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. + + ! + ! 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 + end do + + ! set latitude, longitude + + !!! projection='Stereographic' + call Position() + + if ( DEBUG_GRID ) 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",& + " gb(1,1)"," gb(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) + + write(*,806) "GRIDLL ",me, minval(gl), maxval(gl), minval(gb), & + maxval(gb), gb(1,1), gb(MAXLIMAX,MAXLJMAX) + end if + 800 format(a10,20a4) + 802 format(a10,a4,10a12) + 804 format(a10,20i4) + 806 format(a10,i4,10f12.4) + + end subroutine DefGrid + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + 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 + + real :: glmin, glmax, om, om2, dy, dy2,rp,rb, rl, dx, dr !,fi read in Met_ml + integer :: i, j, info + + !su xp,yp read in infield + !su xp = 43. + !su yp = 121. + +! fi = -32.0 !read in Met_ml + 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 + + + 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 + gl(i,j)=rl ! longitude + gb(i,j)=rb ! latitude + + end do ! i + end do ! j + endif + + ! test to find full-domain min and max lat/long values + + gbacmax = maxval(gb(:,:)) + gbacmin = minval(gb(:,:)) + glacmax = maxval(gl(:,:)) + glacmin = minval(gl(:,:)) + MPIbuff= gbacmax + CALL MPI_ALLREDUCE(MPIbuff, gbacmax, 1,MPI_DOUBLE_PRECISION, & + MPI_MAX, MPI_COMM_WORLD, INFO) + MPIbuff= gbacmin + CALL MPI_ALLREDUCE(MPIbuff, gbacmin , 1, & + MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, INFO) + MPIbuff= glacmax + CALL MPI_ALLREDUCE(MPIbuff, glacmax, 1,MPI_DOUBLE_PRECISION, & + MPI_MAX, MPI_COMM_WORLD, INFO) + MPIbuff= glacmin + CALL MPI_ALLREDUCE(MPIbuff, glacmin , 1, & + MPI_DOUBLE_PRECISION, MPI_MIN, MPI_COMM_WORLD, INFO) + + if(me==0) write(unit=6,fmt="(a30,4f9.4)") "GridValues: max/min for gb,gl", & + gbacmax,gbacmin,glacmax,glacmin + + if ( DEBUG_GRID ) 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,gl,gb,rp: ", & + me, i,j, i_fdom(i), j_fdom(j), gl(i,j), gb(i,j),rp + end if + end do + end do + end if + + end subroutine Position + ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine GlobalPosition + + integer i,j + real :: dr,om,om2,rb,rl,rp,dx,dy,dy2,glmax,glmin + + 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 (om=Norwegian omvendt?) + 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 + gl_glob(i,j)=rl ! longitude + gb_glob(i,j)=rb ! latitude + + end do ! i + end do ! j + endif + +end subroutine GlobalPosition + + + subroutine lb2ijm(imax,jmax,gl,gb,ir2,jr2,fi2,an2,xp2,yp2) + !-------------------------------------------------------------------! + ! calculates coordinates ir2, jr2 (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 + !-------------------------------------------------------------------! + + + integer :: imax,jmax,i1, j1 + real :: fi2,an2,xp2,yp2 + real :: gl(imax,jmax),gb(imax,jmax) + real :: ir2(imax,jmax),jr2(imax,jmax) + + 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 + + ir2(i1,j1)=xp2+an2*tan(PId4-gb(i1,j1)*dr2)*sin(dr*(gl(i1,j1)-fi2)) + jr2(i1,j1)=yp2-an2*tan(PId4-gb(i1,j1)*dr2)*cos(dr*(gl(i1,j1)-fi2)) + + end do ! i + end do ! j + + end subroutine lb2ijm + + subroutine lb2ij(gl2,gb2,ir2,jr2,fi2,an2,xp2,yp2) + +!Note: this routine is not supposed to be CPU optimized + !-------------------------------------------------------------------! + ! calculates coordinates ir2, jr2 (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 + !-------------------------------------------------------------------! + + real, intent(in) :: gl2,gb2 + real, intent(out) :: ir2,jr2 + 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 + + + PId4 = PI/4. + dr2 = PI/180.0/2. ! degrees to radians /2 + dr = PI/180.0 ! degrees to radians + + if(projection=='Stereographic')then + 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 + + ir2=xp_loc+an_loc*tan(PId4-gb2*dr2)*sin(dr*(gl2-fi_loc)) + jr2=yp_loc-an_loc*tan(PId4-gb2*dr2)*cos(dr*(gl2-fi_loc)) + else!ASSUMES lon-lat grid + ir2=(gl2-gl_glob(1,1))/(gl_glob(2,1)-gl_glob(1,1))+1 + if(ir2<0.5)ir2=ir2+360.0/(gl_glob(2,1)-gl_glob(1,1)) + jr2=(gb2-gb_glob(1,1))/(gb_glob(1,2)-gb_glob(1,1))+1 + endif + + return + end subroutine lb2ij + + subroutine ij2lbm(imax,jmax,gl,gb,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. + !-------------------------------------------------------------------! + + integer :: i, j, imax, jmax + real :: gl(imax,jmax),gb(imax,jmax) + real :: fi, an, xp, yp + real :: om, om2, glmin, glmax,dy, dy2,rp,rb, rl, dx, dr + real, parameter :: PI=3.14159265358979323 + + +! fi = -32.0 + 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 + gl(i,j)=rl ! longitude + gb(i,j)=rb ! latitude +! write(*,*)i,j,gl(i,j),gb(i,j) + end do ! i + end do ! j + + end subroutine ij2lbm + + subroutine ij2ijm(in_field,imaxin,jmaxin,out_field,imaxout,jmaxout, & + 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 + + + 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,gb,gl + integer alloc_err,i,j,i2,j2 + logical :: interpolate + real :: f11,f12,f21,f22 + + interpolate = .true. +! interpolate = .false. + + allocate(x(imaxout,jmaxout), stat=alloc_err) + allocate(y(imaxout,jmaxout), stat=alloc_err) + allocate(gb(imaxout,jmaxout), stat=alloc_err) + allocate(gl(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 + call ij2lbm(imaxout,jmaxout,gl,gb,fiout,anout,xpout,ypout) + +! find corresponding coordinates (i,j) in in_field coordinates + call lb2ijm(imaxout,jmaxout,gl,gb,x,y,fiin,anin,xpin,ypin) + + + ! check if the corners of the domain are inside the area covered by the + ! in_grid: (In principle we should test for all i,j , but test the corners + ! 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) + endif + + + +! 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) + + 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))) + enddo + enddo + + endif + + deallocate(x,stat=alloc_err) + deallocate(y,stat=alloc_err) + deallocate(gb,stat=alloc_err) + deallocate(gl,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 + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end module GridValues_ml +!============================================================================== diff --git a/Io_Nums_ml.f90 b/Io_Nums_ml.f90 new file mode 100644 index 0000000..45d78e6 --- /dev/null +++ b/Io_Nums_ml.f90 @@ -0,0 +1,80 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Io_Nums_ml + +!_____________________________________________________________________________ +! The idea is to keep all unit numbers used for input and output +! stored here. So that programmers can quickly see which numbers are +! in use or not. (Warning - some of the routines mentioned are outdated) +! +! Assign unit number, e.g. io_xxx, here, and use read(io_xxx,*) in +! main program. +! +! (c) - file opened AND closed in subroutine +! (o) - file remains open in subroutine +!_____________________________________________________________________________ +implicit none + + + integer, parameter, public :: & + IO_LOG = 7 &! General output log (o) + ,IO_SITES = 8 &! sites module, first for input(c) + ,IO_MYTIM = 20 &! Unimod.f90(c)-output mytim.out + ,IO_RES = 25 &! o3mod,massbud(o) + ,IO_TMP = 27 ! General IO number (files *must* be type (c)) + + + integer, parameter, public :: & + IO_SONDES = 30 &! siteswrt_ml(o) for output of sonde data + ,IO_WRTCHEM = 118 &! Used in Wrtchem (c) for AOT and BCs + ,IO_HOURLY = 119 ! hourly_out(o) + + !(some subroutine names are a bit outdated:) + integer, parameter, public :: & + IO_FORES = 49 &! rforest.f(c)-read land use % + ,IO_AIRN = 49 &! airnox.f(c) - read aircr. em. + ,IO_LIGHT = 49 &! lightning.f(c) - read lightning. emiss. + ,IO_JOST = 49 &! newjostinit(c) - read global mixing ratios + ,IO_GLOBBC = 49 &! read global mixing ratios e.g. Logan + ,IO_GLOBBC2 = 91 &! read global mixing ratios e.g. h2o2 + ,IO_INFIELD = 50 &! infield.F(c) -reads fil000xx + ,IO_DO3SE = 51 &! for DO3SE inputs(c) + ,IO_ROUGH = 52 &! inpar.f -reads roughn. class + ,IO_SNOW = 53 &! newmonth(c): for snow + ,IO_VOLC = 54 & + ,IO_DJ = 55 &! readdiss.f(c) - inp. solar r. + ,IO_AIRCR = 66 &! phyche.f(c) - write aircraft conc. + ,IO_OUT = 80 &! (c)write outday etc. + ,IO_UKDEP = 81 &! (o)write fluxes, etc. + ,IO_STAB = 82 &! (o)write fluxes, etc. + ,IO_EMIS = 84 &! Used for femis , emis_split(c) + ,IO_TIMEFACS = 85 &! Used for monthly + ,IO_NEST = 88 &! + ,IO_DMS = 90 ! Emissions(c): for DMS + +end module Io_Nums_ml diff --git a/Io_Progs_ml.f90 b/Io_Progs_ml.f90 new file mode 100644 index 0000000..f2338f9 --- /dev/null +++ b/Io_Progs_ml.f90 @@ -0,0 +1,611 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Io_Progs_ml +!_____________________________________________________________________________ +! -- routines to check and open files. Also, the routine Read_Headers +! is designed for EMEP format input files, using specific headers. +! Read_Headers can also be used to check that all required columns +! are available, or to read files with columns in arbitray positions. +! +! Language: F-compliant, except system calls in Self_Test +! (Can be run with F is test-input file created manually +! and system calls commented out, as here) +! Dave Simpson, 1999-2007 +!_____________________________________________________________________________ +!_____________________________________________________________________________ + + use CheckStop_ml, only: CheckStop + use GridValues_ml, only : i_local, j_local + use Io_Nums_ml, only: IO_TMP + use ModelConstants_ml, only : DEBUG_i, DEBUG_j, DomainName + use KeyValue_ml, only: KeyVal, KeyValue, LENKEYVAL + use Par_ml, only: me, li0, li1, lj0, lj1 + use SmallUtils_ml, only : wordsplit, WriteArray + implicit none + + INCLUDE 'mpif.h' !MPI needed + + + ! -- subroutines in this module: + + public :: read_line ! Reads one line of input on host, broadcasts to other + ! (done as text for flexibility) + public :: check_file ! checks that file exists and stops if required + public :: open_file ! checks that file exists and opens if required + public :: Read_Headers ! Reads header information from input files + public :: Read2D ! Reads x,y,z data for simple case + public :: Read2DN ! Reads x,y,z1...z2 data for simple case + public :: Self_Test + + logical, public :: fexist ! true if file exists + integer, public, parameter :: NO_FILE = 777 ! code for non-existing file + integer, public, save :: ios ! i/o error status number + + integer, private, parameter :: MAXLINELEN = 9000 ! Max length of ascii inputs + integer, private, parameter :: MAXHEADERS = 900 ! Max No. headers + logical, private, parameter :: MY_DEBUG = .false. + + +contains + + !======================================================================= + subroutine read_line(io_in,txt,status) + !======================================================================= + ! Reads one line of input on host (me==0), broadcasts to other processors + ! This is done as text for flexibility, with the inten + ! + ! Instead of e.g. + ! if ( me == 0 ) then + ! read(unit=IO,fmt=*) i,j, data(:) on a serial code, or + ! end if + ! call MPI_BROADCAST(....) + ! + ! We use call read_line(IO,txtinput) + ! read(unit=txtinput,fmt=*) i,j, data(:) + ! + ! Why? To let read_line hide the sending of data across processors + ! in the MPI framework. Above, txtinput is made available to all + ! processors. + + integer, intent(in) :: io_in + character(len=*), intent(inout) :: txt + character(len=len(txt)+30) :: errmsg + integer, intent(out) :: status + integer :: INFO + + if ( me == 0 ) then + txt = "" + read(unit=io_in,fmt="(a)",iostat=status) txt + + if ( len_trim(txt) > 0.9*MAXLINELEN ) then ! line too long for comfort + write(unit=errmsg,fmt=*) "ERROR? Increase MAXLINELEN for IO", & + io_in, len_trim(txt), "txt = " + call CheckStop ( errmsg // txt ) + end if + + if ( MY_DEBUG ) then + write(unit=*,fmt=*) "READTXT" // trim(txt) + write(unit=*,fmt=*) "READLEN", len_trim(txt), MAXLINELEN + write(unit=*,fmt=*) "READ_LINE ", " STATUS ", status , trim(txt) + end if + end if + + call MPI_BCAST( txt, len(txt), MPI_CHARACTER, 0, MPI_COMM_WORLD,INFO) + call MPI_BCAST( status, 1, MPI_INTEGER, 0, MPI_COMM_WORLD,INFO) + if ( MY_DEBUG ) then + write(unit=errmsg,fmt=*) "me ", me, " BCAST_LINE:" // trim(txt) + write(unit=*,fmt=*) trim(errmsg) + end if + CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) + + end subroutine read_line + + !======================================================================= + subroutine check_file(fname,fexist,needed,errmsg) + !======================================================================= + ! Checks for the existence of a file. If the file is + ! specified as "needed", and missing, an error message is + ! printed and the run is stopped. + + character (len=*), intent(in) :: fname ! file name + logical, intent(in) :: needed ! see below + logical, intent(out) :: fexist ! file exists + character (len=*), intent(inout):: errmsg + + errmsg = "ok" + inquire(file=fname,exist=fexist) + + write(unit=6,fmt=*) "check_file::: ", fname + if ( .not. fexist .and. .not. needed ) then + write(unit=6,fmt=*) "not needed, skipping....." + ios = 0 + + else if ( .not. fexist .and. needed ) then + ios = -1 + print *, "ERROR: Missing!!! in check-file" + + else + write(unit=6,fmt=*) "ok. File exists" + end if + end subroutine check_file + + !======================================================================= + subroutine open_file(io_num,mode,fname,needed,skip) + !======================================================================= + + ! 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. + + integer, intent(in) :: io_num ! i/o number + character (len=*), intent(in) :: mode ! "r" for read, "w" for write + 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 :: i ! local loop counter + + ios = 0 ! Start with assumed ok status + + inquire(file=fname,exist=fexist) + select case (mode) + case ("r") + + if ( .not. fexist ) then + + call CheckStop( needed, "OPEN_FILE ::: missing file is :: "// fname ) + ios = NO_FILE + else + open(unit=io_num,file=fname,status="old",action="read",iostat=ios) + write(unit=6,fmt=*) "File opened: ", fname, ios + ! *** skip header lines if requested **** + if ( present( skip ) ) then ! Read (skip) some lines at start of file + do i = 1, skip + read(unit=io_num,fmt=*) + end do + end if ! skip + end if + + case ("w") + if ( .not. fexist ) then ! Super-fussy coding! + open(unit=io_num,file=fname,status="new",& + action="write",iostat=ios) + else + open(unit=io_num,file=fname,status="replace",& + position="rewind", & + action="write",iostat=ios) + end if + write(unit=6,fmt=*) "File created: ", fname + case default + print *, "OPEN FILE: Incorrect mode: ", mode + ios = -1 + end select + + end subroutine open_file + + !======================================================================= + subroutine Read_Headers(io_num,io_msg,NHeaders,NKeys,Headers,Keyvalues,& + CheckValues, required_fields, alternate_fields ) !<= Optional + !======================================================================= + ! Reads the header lines of an EMEP format input file, and extracts + ! any key-value pairs, as well as the column headers. See Self_Test + ! routine at end for example + ! + + integer, intent(in) :: io_num + character(len=*), intent(inout) :: io_msg + integer, intent(out) :: NHeaders, NKeys + character(len=*),dimension(:), intent(out) :: Headers + type(KeyVal), dimension(:), intent(out) :: KeyValues + type(KeyVal), dimension(:), intent(in), optional :: & + CheckValues ! Sets of key-values which must be present. + + character(len=*),dimension(:), intent(in), optional :: required_fields + character(len=*),dimension(:), intent(in), optional :: alternate_fields + + character(len=LENKEYVAL),dimension(size(Headers)) :: xHeaders + character(len=LENKEYVAL) :: key, value + character(len=5) :: marker ! e.g. !> or !# + character(len=MAXLINELEN) :: inputline + integer :: i, NxHeaders, ncheck + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + + !------ Read in file. Lines beginning with "!#" are taken as + ! comments and skipped + + NKeys = 0 + NHeaders = 0 + Headers = "" + xHeaders = "" + io_msg = "ok" + + do + + inputline="" + call read_line(io_num,inputline,ios) + if (MY_DEBUG .and. me == 0 ) write(*,*) "IN ", io_num, me, ios, & + len_trim(inputline) ,trim(inputline) + if ( ios /= 0 ) then ! End of file + exit + end if + + if ( inputline(1:2) == ": " ) then ! Key-values + + read(unit=inputline,fmt=*,iostat=ios) marker, key, value + call CheckStop(ios, "KeyValue Input error" // trim(inputline) ) + NKeys = NKeys + 1 + KeyValues(NKeys)%key = key + KeyValues(NKeys)%value = value + if ( me == 0 ) then + if (MY_DEBUG) write(unit=*,fmt=*) "KEYS FULL =", trim(inputline) + if (MY_DEBUG) write(unit=*,fmt=*) "KEYS LINE NKeys=", & + NKeys, trim(key), " : ", trim(value) + end if + cycle + + else if ( index(inputline,"#HEADER") > 0 ) then ! Header lines + + + call wordsplit(inputline,MAXHEADERS,xHeaders,NxHeaders,ios) + + call CheckStop(ios, "Header wordsplit error" // trim(inputline) ) + + do i = 1, NxHeaders + if ( xHeaders(i)(1:1) /= "#" .and. & + len_trim(xHeaders(i)) > 0 ) then + Nheaders = Nheaders + 1 + Headers(i) = xHeaders(i) + end if + + end do + do i = Nheaders+1, size(Headers) + Headers(i) = "" ! Remove trailing txt + end do + + cycle + + else if ( inputline(1:3) == ":: " ) then ! WILL DO LATER + cycle ! Maybe keys with multiple values? + + else if ( inputline(1:5) == "#DATA" ) then ! End of headers. + ! Data follows. + + if ( present(CheckValues) ) then + !Check that the values specified in CheckValues are the same + !as those found in input file's KeyValues: + ncheck = size(CheckValues) + do i = 1, ncheck + call CheckStop( KeyValue(KeyValues,CheckValues(i)%key),& + CheckValues(i)%value ,& + "Comparing Values: " // CheckValues(i)%key ) + end do + end if + + if ( me == 0 .and. MY_DEBUG ) then + write(unit=*,fmt=*) "DATA LINE" // trim(inputline) + end if + + return + + else if ( index(inputline,"#SKIP") > 0 ) then ! Comments + + cycle + + else if ( inputline(1:1) == "#" ) then ! Comments + + if ( MY_DEBUG ) write(unit=*,fmt=*) & + "COMMENTS LINE" // trim(inputline) + cycle + + end if + + end do + + io_msg = "GOT TO END - NO #DATA STATEMENT MAYBE?" + + end subroutine Read_Headers + !======================================================================= + subroutine Read2D(fname,data2d,idata2d) + + character(len=*), intent(in) :: fname + real, dimension(:,:), intent(out), optional :: data2d + integer, dimension(:,:), intent(out), optional :: idata2d + + integer :: i_fdom, j_fdom, i,j + real :: tmp + character(len=20), dimension(3) :: Headers + character(len=200) :: txtinput ! Big enough to contain one full input record + type(KeyVal), dimension(20) :: KeyValues ! Info on units, coords, etc. + character(len=50) :: errmsg + + integer :: NHeaders, NKeys, Nlines + logical :: debug_flag + + + Nlines = 0 + + if (present(idata2d) ) idata2d (:,:) = 0 !/** initialise **/ + if (present(data2d) ) data2d (:,:) = 0.0 !/** initialise **/ + + if ( me == 0 ) then + call open_file(IO_TMP,"r",fname,needed=.true.) + call CheckStop(ios,"open_file error on " // fname ) + end if + + + call Read_Headers(IO_TMP,errmsg,NHeaders,NKeys,Headers,Keyvalues) + + call CheckStop( errmsg , "Read2D: Read_Headers" // fname ) + call CheckStop( Headers(1), "ix" , "HeaderIX not found" // fname) + call CheckStop( Headers(2), "iy" , "HeaderIY not found" // fname) + call CheckStop( KeyValue(KeyValues,"Coords"),"ModelCoords" ,"Landuse: Coords??") + call CheckStop( KeyValue(KeyValues,"Domain"),DomainName ,& + "Domain Name - matched to ModelConstants") + + ! The first two columns are assumed for now to be ix,iy, hence: + + Headers(1) = Headers(3) + if ( MY_DEBUG .and. me == 0 ) then + write(*,*) "Read2D Headers" // fname, Nheaders, Headers(1) +! call WriteArray(Headers,NHeaders,"Read2D Headers") + end if + + do + call read_line(IO_TMP,txtinput,ios) + if ( ios /= 0 ) exit ! likely end of file + read(unit=txtinput,fmt=*,iostat=ios) i_fdom,j_fdom,tmp + call CheckStop ( ios, "Read2D txt error:" // trim(txtinput) ) + Nlines = Nlines + 1 + + 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 ( MY_DEBUG ) debug_flag = ( i_fdom == DEBUG_i & + .and. j_fdom == DEBUG_j ) + + if ( debug_flag ) then + write(*,*) "READ TXTINPUT", me, i_fdom, j_fdom, " => ", i,j,tmp + endif + if (present(idata2d)) then + idata2d(i,j) = nint(tmp) + else + data2d(i,j) = tmp + end if + + end if ! i,j + end do + + if ( me == 0 ) close(IO_TMP) + if ( me == 0 ) write(6,*) fname // "Read2D: me, Nlines = ", me, Nlines + + end subroutine Read2D + + !------------------------------------------------------------------------- + + subroutine Read2DN(fname,Ndata,data2d,CheckValues,HeadersRead) + + character(len=*), intent(in) :: fname + integer, intent(in) :: Ndata ! Number of data columns + real, dimension(:,:,:), intent(out) :: data2d + type(KeyVal), dimension(:), intent(in), optional :: & + CheckValues ! Sets of key-values which must be present. + logical, intent(in), optional :: HeadersRead + + integer, parameter :: NCOORDS = 2 ! for ix, iy - "simple" + + integer :: i_fdom, j_fdom, i,j,kk + real, dimension(Ndata+NCOORDS) :: tmp + character(len=20), dimension(Ndata+10) :: Headers + character(len=(Ndata+10)*20) :: txtinput ! Big enough to contain one full input record + type(KeyVal), dimension(20) :: KeyValues ! Info on units, coords, etc. + character(len=50) :: errmsg + + integer :: NHeaders, NKeys, Nlines, ncheck + logical :: debug_flag, Start_Needed + + if ( MY_DEBUG .and. me == 0 ) write(*,*) " Starting Read2DN, me ",me + + Nlines = 0 + + data2d (:,:,:) = 0.0 !/** initialise **/ + + Start_Needed = .true. + if ( present(HeadersRead) ) then ! Headers have already been read + Start_Needed = .false. + end if + + !====================================================================== + if ( Start_Needed ) then + !====================================================================== + if ( me == 0 ) then + call open_file(IO_TMP,"r",fname,needed=.true.) + call CheckStop(ios,"ios error on Inputs.landuse") + end if + + + call Read_Headers(IO_TMP,errmsg,NHeaders,NKeys,Headers,Keyvalues) + + call CheckStop( errmsg , "Read2D: Read_Headers" // fname ) + call CheckStop( Headers(1), "ix" , "HeaderIX not found" // fname) + call CheckStop( Headers(2), "iy" , "HeaderIY not found" // fname) + call CheckStop( KeyValue(KeyValues,"Coords"),"ModelCoords" ,"Landuse: Coords??") + + if ( present(CheckValues) ) then + !Check that the values specified in CheckValues are the same as those + !found in input file's KeyValues: + ncheck = size(CheckValues) + do i = 1, ncheck + call CheckStop( KeyValue(KeyValues,CheckValues(i)%key),& + CheckValues(i)%value ,"Comparing Values: " // CheckValues(i)%key ) + end do + end if + + ! The first two columns are assumed for now to be ix,iy, hence: + + Headers(1:Ndata) = Headers(3:Ndata+2) + NHeaders = NHeaders -2 + + end if ! Start_Needed + !====================================================================== + if ( MY_DEBUG .and. me == 0 ) then + write(*,*) "Read2DN for ", fname, "Start_Needed ", Start_Needed + do i = 1, NHeaders + write(*,*) "Read2D Headers" // fname, i, Nheaders, Headers(i) + end do + !call WriteArray(Headers,NHeaders,"Read2D Headers") + end if + + do + call read_line(IO_TMP,txtinput,ios) + if ( ios /= 0 ) exit ! likely end of file + read(unit=txtinput,fmt=*,iostat=ios) i_fdom,j_fdom,& + ( tmp(kk), kk=1,Ndata) + + call CheckStop ( ios, "Read2D txt error:" // trim(txtinput) ) + Nlines = Nlines + 1 + + i = i_local(i_fdom) ! Convert to local coordinates + j = j_local(j_fdom) + + !SAFER? if ( i >= li0 .and. i <= li1 .and. j >= lj0 .and. j <= lj1 ) then + if ( i >= 1 .and. i <= li1 .and. j >=1 .and. j <= lj1 ) then + + if ( MY_DEBUG .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) + + end if ! i,j + end do + + if ( me == 0 ) close(IO_TMP) + if ( me == 0 ) write(6,*) fname // "Read2DN: me, Nlines = ", me, Nlines + + end subroutine Read2DN + + !------------------------------------------------------------------------- + subroutine Self_Test() + use ModelConstants_ml, only: NPROC + use Par_ml, only: me + integer :: NHeaders, NKeyValues, i, ios + character(len=10), dimension(10) :: Headers + character(len=10) :: msg = "ok" + character(len=100) :: inputline + integer :: yy, mm, dd + real, dimension(2) :: test_data + type(KeyVal), dimension(10) :: KeyValues + integer, parameter :: IO_IN=88 + + +!---------------------------------------------------------------------------- +! The input files are designed to read nicely in gnumeric and other spread- +! sheets (excel, oocalc), and can be either space of comma separated. +! +! Lines starting with : are for key-value pairs, e.g. : year 2002 +! The line following #HEADERS should contain the headings of each column +! IMPORTANT: One line of column headers *must* be provided, and the +! number of headers must match the number of data items. +! (And second lines, e.g. for units, must be commented out) +! +! All lines starting "# " are ignored, but text will show up nicest in +! spread sheets if enlcosed in quotation marks +! + if ( me == 0 ) then + + print "(/,a)", "Self-test - Io_Progs_ml ===========================" + + print *, "PROCESSOR ", me, "CREATES FILE for TEST READS " + print *, "NPROC ", NPROC + call open_file(IO_IN,"w","Self_Test_INPUT.csv") + + write(unit=IO_IN,fmt="((a))") & + "# ""Example of EMEP Input file""", & + ": Key1 Value1", & + ": year 2007", & + ": version rv2_9_8" , & + " mm yy dd v1 v2 #Total #HEADERS", & + " - - - m/s m/s - #SKIP ", & + "#DATA:", & + " 02,07, 28,1.2 ,2.3, 3.5", & + " 02, 07, 29,2.4 ,1.2, 3.6", & + " 02,07, 30,12.2,6.7, 18.9" + + close(IO_IN) + + print *, "PROCESSOR ", me, "OPENS FILE for TEST READS " + call open_file(IO_IN,"r","Self_Test_INPUT.csv",needed=.true.) + end if ! me = 0 + + print "(/,a)", "Self-test - Read_Headers ==========================" + + call Read_Headers(IO_IN,msg,Nheaders,NKeyValues, Headers, KeyValues) + + if ( me == NPROC-1 ) then + print *, "Checking data on processor me = ", me + do i = 1, NKeyValues + print *, "me ", me, "Keys ", i, & + trim(KeyValues(i)%key), " => ", trim(KeyValues(i)%value) + end do + + print *, "NHead ", NHeaders + do i = 1, NHeaders + print *, "Headers ", i, trim(Headers(i)) + end do + end if ! me + + + print "(/,a,/,a,/)", "Self-test - Now read data =========================",& + " REMINDER - WAS: mm yy dd v1 v2 #Total #HEADERS" + + do + call read_line(IO_IN,inputline,ios) + if ( ios /= 0 ) then + exit + end if + if(me==0) then + print *, "DATA: read_line -> ", trim(inputline) + end if + read(unit=inputline,fmt=*,iostat=ios) yy,mm,dd,test_data(1:2) + if ( ios == 0 ) then + if ( me == NPROC-1 ) then + print *, "TEST DATA SPLIT INTO: ", yy, mm, dd, & + test_data(1), test_data(2) + end if + else + print *, "Read failed. Maybe wrong dimensions?" + end if + end do + + + end subroutine Self_Test + + end module Io_Progs_ml diff --git a/Io_ml.f90 b/Io_ml.f90 new file mode 100644 index 0000000..2a52f0b --- /dev/null +++ b/Io_ml.f90 @@ -0,0 +1,31 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Io_ml + use Io_Nums_ml + use Io_Progs_ml +end module Io_ml diff --git a/KeyValue_ml.f90 b/KeyValue_ml.f90 new file mode 100644 index 0000000..8406dc5 --- /dev/null +++ b/KeyValue_ml.f90 @@ -0,0 +1,86 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 KeyValue_ml + +! ========================================================= +! Routines for dealing with a fortran equivalent +! of a key-value pair - a crude attempt to redproduce +! some of the nice features of perl's hashes or python's dictionary +! +! Language : F-complaint +! History: Created May 2007, Dave +! ========================================================= + +implicit none + + public :: KeyValue ! returns value for given key + public :: Self_Test + + + !-- for Read_Headers we use a key-value pair, inspired by perl's hash arrays + + integer, public, parameter :: LENKEYVAL = 30 ! max length of key or value + + type, public :: KeyVal + character(len=LENKEYVAL) :: key + character(len=LENKEYVAL) :: value + end type KeyVal + + logical, private, parameter :: MY_DEBUG = .false. + + +contains + + !======================================================================= + function KeyValue(KV,txt) result(val) + type(KeyVal), dimension(:), intent(in) :: KV + character(len=*), intent(in) :: txt + character(len=LENKEYVAL) :: val + integer :: i + + val = "" + do i = 1, size(KV) + if( KV(i)%key == trim(txt) ) then + val = KV(i)%value + return + end if + end do + + end function KeyValue + !======================================================================= + subroutine Self_Test() + type(KeyVal), dimension(3) :: KeyValues = (/ & + KeyVal("Units","ppb"), & + KeyVal("Coords","longlat"), & + KeyVal("Version","2007may") /) + + print *, "Self_Test, First key: ", KeyValues(1)%key + print *, "Self_Test, First value: ", KeyValues(1)%value + print *, "Self_Test, using function ", KeyValue(KeyValues,"Units") + end subroutine Self_Test +end module KeyValue_ml diff --git a/LandDefs_ml.f90 b/LandDefs_ml.f90 new file mode 100644 index 0000000..70f07ac --- /dev/null +++ b/LandDefs_ml.f90 @@ -0,0 +1,200 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 LandDefs_ml + use CheckStop_ml, only : CheckStop + use Io_ml, only : IO_TMP, open_file, ios, Read_Headers, read_line + use KeyValue_ml, only : KeyVal + use ModelConstants_ml, only : NLANDUSE + use Par_ml, only : me + implicit none + private + +!============================================================================= +! This module reads inthe basics landuse data features, e.g. defaults +! for heights, LAI, growinf-season, etc. +! The list given below can be changed, extended or reduced, but then other +! input data files and codimg are needed. + +!----------------------------------------------------------------------------- +! Notes: Basis was Emberson et al, EMEP Report 6/2000 +! +! flux_wheat is an artificial species with constant LAI, SAI, h throughout year, +! to allow Fst calculations without knowing details of growing season. + + + ! 2 ) Phenology part + !/*** DESCRIPTION********************************************************** + !/ reads in or sets phenology data used for the default deposition module + !/ Users with own phenology data can simply provide their own subroutines + !/ (replacing Init_phenology and Phenology) + !/************************************************************************* + + public :: Init_LandDefs ! Sets table for LAI, SAI, hveg + public :: Growing_season + + real, public, parameter :: STUBBLE = 0.01 ! Veg. ht. out of season + + !/***** Data to be read from Phenology_inputs.dat: + + type, public :: land_input + character(len=15) :: name + character(len=9) :: code + character(len=3) :: type ! Ecocystem type, see headers + real :: hveg_max + real :: Albedo + integer :: eNH4 ! Possible source of NHx + integer :: SGS50 ! Start of grow season at 50 deg. N + real :: DSGS ! Increase in SGS per degree N + integer :: EGS50 ! End of grow season at 50 deg. N + real :: DEGS ! Increase in EGS per degree N + real :: LAImin ! Min value of LAI + real :: LAImax ! Max value of LAI + integer :: SLAIlen ! Length of LAI growth periods + integer :: ELAIlen ! Length of LAI decline periods + end type land_input + !############## + type(land_input), public, dimension(NLANDUSE) :: LandDefs + !############## + type(land_input), private :: LandInput + + type, public :: land_type + logical :: is_forest + logical :: is_conif + logical :: is_decid + logical :: is_crop + logical :: is_seminat + logical :: is_water + logical :: is_ice + logical :: is_veg + logical :: is_bulk ! Bulk-surface resistance used + logical :: is_iam ! Fake species for IAM outputs + end type land_type + !############## + type(land_type), public, dimension(NLANDUSE) :: LandType + !############## + + + logical, private, parameter :: MY_DEBUG = .false. ! helps with extra printouts + + +contains +!======================================================================= + subroutine Growing_season(lu,lat,SGS,EGS) +!======================================================================= + +! calculates the start and end of growing season for land-use +! class "lu" and latitude "lat". + + integer, intent(in) :: lu ! Land-use index + real, intent(in) :: lat ! Latitude + integer, intent(out) :: SGS, EGS ! start and end of growing season + + if ( LandDefs(lu)%DSGS > 0 ) then ! calculate + + SGS = int ( 0.5 + LandDefs(lu)%SGS50 + LandDefs(lu)%DSGS * (lat-50.0) ) + EGS = int ( 0.5 + LandDefs(lu)%EGS50 + LandDefs(lu)%DEGS * (lat-50.0) ) + else + SGS = LandDefs(lu)%SGS50 + EGS = LandDefs(lu)%EGS50 + end if + + EGS = min(EGS, 366 ) ! Keeps EGS to 366 to allow for leap year + ! (and ignore diff 365/366 otherwise) + + end subroutine Growing_season + + !======================================================================= + subroutine Init_LandDefs(wanted_codes) + !======================================================================= + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + character(len=*), dimension(:) :: wanted_codes ! From Inputs-Landuse + character(len=20), dimension(14) :: Headers + character(len=200) :: txtinput ! Big enough to contain one input record + type(KeyVal), dimension(2) :: KeyValues ! Info on units, coords, etc. + character(len=50) :: errmsg, fname + integer :: iL, n, NHeaders, NKeys + + + ! Read data + + + fname = "Inputs_LandDefs.csv" + if ( me == 0 ) then + call open_file(IO_TMP,"r",fname,needed=.true.) + call CheckStop(ios,"open_file error on " // fname ) + end if + + call Read_Headers(IO_TMP,errmsg,NHeaders,NKeys,Headers,Keyvalues) + + call CheckStop( errmsg , "Read LandDefs Headers" ) + + + !------ Read in file. Lines beginning with "!" are taken as + ! comments and skipped + + n = 0 + do + call read_line(IO_TMP,txtinput,ios) + if ( ios /= 0 ) exit ! likely end of file + if ( txtinput(1:1) == "#" ) cycle + read(unit=txtinput,fmt=*,iostat=ios) LandInput + call CheckStop ( ios, fname // " txt error:" // trim(txtinput) ) + n = n + 1 + !############################ + LandDefs(n) = LandInput + !############################ + + !/ Set any input negative values to physical ones (some were set as -1) + + LandDefs(n)%hveg_max = max( LandDefs(n)%hveg_max, 0.0) + LandDefs(n)%LAImax = max( LandDefs(n)%LAImax, 0.0) + + + if ( MY_DEBUG .and. me == 0 ) write(*,*) "LANDPHEN match? ", n, & + LandInput%name, LandInput%code, wanted_codes(n) + call CheckStop( LandInput%code, wanted_codes(n), "MATCHING CODES in LandDefs") + + LandType(n)%is_water = LandInput%code == "W" + LandType(n)%is_ice = LandInput%code == "ICE" + LandType(n)%is_iam = LandInput%code(1:4) == "IAM_" + + LandType(n)%is_forest = & + ( LandInput%type == "ECF" .or. LandInput%type == "EDF" ) + LandType(n)%is_conif = ( LandInput%type == "ECF" ) + LandType(n)%is_decid = ( LandInput%type == "EDF" ) + LandType(n)%is_crop = ( LandInput%type == "ECR" ) + LandType(n)%is_seminat = ( LandInput%type == "SNL" ) + LandType(n)%is_bulk = LandInput%type == "BLK" + LandType(n)%is_veg = LandInput%type /= "U" .and. & + LandInput%hveg_max > 0.01 ! Excludes water, ice, desert + end do + if ( me == 0 ) close(unit=IO_TMP) + + end subroutine Init_LandDefs + +end module LandDefs_ml diff --git a/Landuse_ml.f90 b/Landuse_ml.f90 new file mode 100644 index 0000000..5bedf35 --- /dev/null +++ b/Landuse_ml.f90 @@ -0,0 +1,476 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Landuse_ml + +use CheckStop_ml, only: CheckStop +use KeyValue_ml, only: KeyVal,KeyValue, LENKEYVAL +use DO3SE_ml, only : fPhenology +use GridAllocate_ml,only: GridAllocate +use GridValues_ml, only: gb_glob, gb, i_fdom, j_fdom, & ! latitude, coordinates + i_local, j_local, & + debug_proc, debug_li, debug_lj +use Io_ml, only: open_file, ios, Read_Headers, Read2DN, IO_TMP +use KeyValue_ml, only: KeyVal,KeyValue +use LandDefs_ml, only: Init_LandDefs, LandType, LandDefs, STUBBLE, Growing_Season +use ModelConstants_ml, only : DEBUG_i, DEBUG_j, NLANDUSE, & + NPROC, IIFULLDOM, JJFULLDOM, & + DomainName +use Par_ml, only: li0, lj0, li1, lj1, MAXLIMAX, MAXLJMAX, & + limax, ljmax, me +use SmallUtils_ml, only: find_index, NOT_FOUND, WriteArray +use TimeDate_ml, only: daynumber, nydays, current_date +implicit none +private + + +!/- subroutines: + + public :: InitLanduse + public :: ReadLanduse + public :: SetLanduse + private :: Polygon ! Used for LAI + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + + integer, public, parameter :: NLUMAX = 17 ! max no. landuse per grid + +! The headers read from Inputs.Landuse define the "master-list" of +! codes for landuse. Each code must be present in the subsequent +! data files for phenology and DO3SE. + + character(len=6), dimension(NLANDUSE), public, save :: Land_codes ! As used + + !============================================= + type, public :: LandCov + integer :: ncodes ! Number of codes in grid + integer,dimension(NLUMAX) :: & + codes &! landcover codes + ,SGS &! Start of growing season (days) + ,EGS &! End of growing season (days) + ,Astart &! Start photosyntgetic activity, for DO3SE + ,Aend ! + real, dimension(NLUMAX) :: & + fraction &! (coverage) + ,LAI &! Leaf-area-index (m2/m2) + ,SAI &! Surface-area-index (m2/m2) (leaves+bark, etc.) + ,hveg &! Max. height of veg. + ,fphen &! Potential (age) factor for Jarvis-calc + ,SumVPD &! For critical VPD calcs, reset each day + ,old_gsun ! also for flux + end type LandCov + !============================================= + type(LandCov), public, save, dimension(MAXLIMAX,MAXLJMAX) :: LandCover + !============================================= + + + integer, public,save,dimension(MAXLIMAX,MAXLJMAX) :: & + WheatGrowingSeason ! Growing season (days), IAM_WHEAT =1 for true + + ! For some flux work, experimental XXXXXXXx + + real,public,save,dimension(MAXLIMAX,MAXLJMAX) :: water_fraction, ice_fraction + + logical, private, parameter :: DEBUG_LU = .false. + character(len=80), private :: errmsg + + +contains + + !========================================================================== + subroutine InitLanduse() + + !===================================== + call ReadLandUse() ! => Land_codes, Percentage cover per grid + + call Init_LandDefs(Land_codes) ! => LandType, LandDefs + !===================================== + + + end subroutine InitLanduse + !========================================================================== + subroutine ReadLanduse() + + integer :: i,j,lu, index_lu, maxlufound + real, dimension(NLANDUSE) :: tmp + character(len=20), dimension(NLANDUSE+10) :: Headers + character(len=(NLANDUSE+10)*20) :: txtinput ! Big enough to contain one full input record + type(KeyVal), dimension(10) :: KeyValues ! Info on units, coords, etc. + real, dimension(NLANDUSE+1) :: tmpmay + character(len=50) :: fname + integer :: iL, n, NHeaders, NKeys, Nlines + logical :: debug_flag + real :: sumfrac + + ! Specify the assumed coords and units - Read2DN will check that the data + ! conform to these. + type(keyval), dimension(2) :: CheckValues = (/ keyval("Units","PercentGrid"), & + keyval("Coords","ModelCoords") /) + + ! temporary arrays used. Will re-write one day.... + real, dimension(MAXLIMAX,MAXLJMAX,NLANDUSE):: landuse_in ! 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_LU .and. me == 0 ) write(*,*) "LANDUSE: Starting ReadLandUse, me ",me + + maxlufound = 0 + Nlines = 0 + + landuse_ncodes(:,:) = 0 !/** initialise **/ + landuse_codes(:,:,:) = 0 !/** initialise **/ + landuse_data (:,:,:) = 0.0 !/** initialise **/ + +!------------------------------------------------------------------------------ + + ! Read Header info - this will define landuse classes for model + + fname = "Inputs.Landuse" + if ( me == 0 ) then + call open_file(IO_TMP,"r",fname,needed=.true.) + call CheckStop(ios,"open_file error on " // fname ) + end if + + + call Read_Headers(IO_TMP,errmsg,NHeaders,NKeys,Headers,Keyvalues,CheckValues) + + call CheckStop( errmsg , "Read Headers" // fname ) + + + ! The first two columns are assumed for now to be ix,iy, hence: + + NHeaders = NHeaders -2 + call CheckStop( NHeaders /= NLANDUSE, "Inputs.Landuse not consisternt with NLANDUSE") + + ! **** HERE we set the Landuse_codes ***************** + + do i = 1, NLANDUSE + Land_codes(i) = trim ( Headers(i+2) ) + end do + + ! Then data: + + call Read2DN("Inputs.Landuse",NLANDUSE,landuse_in,HeadersRead=.true.) + +!------------------------------------------------------------------------------ + + + if ( DEBUG_LU .and. me == 0 ) then + write(*,*) "NOW LAND_CODES ARE ", NHeaders + call WriteArray(Land_codes,NLANDUSE,"Land_Codes") + end if + + do i = li0, li1 + do j = lj0, lj1 + debug_flag = ( debug_proc .and. i == debug_li .and. j == debug_lj ) + do lu = 1, NLANDUSE + 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) + 0.01 * landuse_in(i,j,lu) + end if + if ( DEBUG_LU .and. debug_flag ) & + write(*,"(a15,i3,f8.4,a10,i3,f8.4)") "DEBUG Landuse ",& + lu, landuse_in(i,j,lu), & + "index_lu ", index_lu, landuse_data(i,j,index_lu) + 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, li0, li1, lj0, lj1, & + i_fdom(li0), j_fdom(lj0), i_fdom(li1), j_fdom(lj1) + call CheckStop(errmsg) + end if + + end do !j + end do !i + + if (DEBUG_LU) write(6,*) "Landuse_ml: me, Nlines, maxlufound = ", me, Nlines, maxlufound + + end subroutine ReadLanduse + + !========================================================================= + subroutine SetLandUse() + integer :: i,j,ilu,lu, nlu, n ! indices + logical, save :: my_first_call = .true. + logical :: debug_flag = .false. + real :: hveg, lat_factor + integer :: effectivdaynumber !6 months shift in Southern hemisphere. + real :: xSAIadd + logical :: iam_wheat + +! Treatment of growing seasons in the southern hemisphere: +! all the static definitions (SGS,EGS...) refer to northern hemisphere, but the actual +! simulation dates are shifted by 6 monthes in the southern hemisphere by using +! uses effectivdaynumber and mod(current_date%month+5,12)+1 in southern hemis + + + if ( DEBUG_LU .and. debug_proc ) write(*,*) "UKDEP SetLandUse, me, day ", me, daynumber, debug_proc + if ( DEBUG_LU .and. debug_proc ) write(*,*) "DEBUG_LU SetLandUse, me, day ", me, daynumber + + if ( my_first_call ) then + if ( DEBUG_LU .and. debug_proc ) write(*,*) "UKDEP FIrst Start SetLandUse, me ", me + + ! 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 !ds Pb210 + ice_fraction(:,:) = 0.0 !ds 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 > NLANDUSE , & + "SetLandUse out of range" ) + + if ( LandDefs(lu)%SGS50 > 0 ) then ! need to set growing seasons + + call Growing_season( lu,abs(gb(i,j)),& + LandCover(i,j)%SGS(ilu),LandCover(i,j)%EGS(ilu) ) + if ( DEBUG_LU .and. debug_flag ) write(*,*)"LU_SETGS", lu, 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 + if ( DEBUG_LU .and. debug_flag ) write(*,*)"LU_FIXGS", lu, LandCover(i,j)%SGS(ilu),LandCover(i,j)%EGS(ilu) + end if + + + !/ 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_fraction(i,j) = LandCover(i,j)%fraction(ilu) + + if ( DEBUG_LU .and. debug_flag ) then + write(*,"(a,2i4,2f12.4)") "DEBUG_LU WATER ", ilu, lu, & + water_fraction(i,j), ice_fraction(i,j) + end if + + end do ! ilu + end do ! j + end do ! i + + my_first_call = .false. + !====================================================================== + end if ! my_first_call + !====================================================================== + + + do i = li0, li1 + do j = lj0, lj1 + + effectivdaynumber=daynumber + ! effectiv daynumber to shift 6 months when in southern hemisphere + if(gb(i,j)<0.0)effectivdaynumber=mod(daynumber+182,nydays)+1 + + debug_flag = ( debug_proc .and. i == debug_li .and. j == debug_lj ) + if ( DEBUG_LU .and. debug_flag ) then + write(*,"(a12,i3,i4)") "LANDUSE N Day? ", LandCover(i,j)%ncodes, daynumber + end if + do ilu= 1, LandCover(i,j)%ncodes + lu = LandCover(i,j)%codes(ilu) + + if ( LandType(lu)%is_bulk ) cycle !else Growing veg present: + + LandCover(i,j)%LAI(ilu) = Polygon(effectivdaynumber, & + 0.0, LandDefs(lu)%LAImin, LandDefs(lu)%LAImax,& + LandCover(i,j)%SGS(ilu), LandDefs(lu)%SLAIlen, & + LandCover(i,j)%EGS(ilu), LandDefs(lu)%ELAIlen) + + LandCover(i,j)%fphen(ilu) = fPhenology( lu, LandDefs(lu)%code,effectivdaynumber & + ,LandCover(i,j)%SGS(ilu), LandCover(i,j)%EGS(ilu) & + ,debug_flag ) + + + + hveg = LandDefs(lu)%hveg_max ! defaults + xSAIadd = 0.0 + + + iam_wheat = .false. + if ( LandType(lu)%is_crop ) then + + if ( LandType(lu)%is_iam ) then ! IAM wheat + iam_wheat = .true. + if ( effectivdaynumber >= LandCover(i,j)%SGS(ilu) .and. & + effectivdaynumber <= LandCover(i,j)%EGS(ilu) ) then + WheatGrowingSeason(i,j) = 1 + else + WheatGrowingSeason(i,j) = 0 + end if + end if + + if ( effectivdaynumber < LandCover(i,j)%SGS(ilu) .or. & + effectivdaynumber > LandCover(i,j)%EGS(ilu) ) then + hveg = STUBBLE + xSAIadd = 0.0 + else if ( effectivdaynumber < & + (LandCover(i,j)%SGS(ilu) + LandDefs(lu)%SLAIlen) ) then + hveg= LandDefs(lu)%hveg_max * & + LandCover(i,j)%LAI(ilu) / LandDefs(lu)%LAImax + xSAIadd = ( 5.0/3.5 - 1.0) * LandCover(i,j)%LAI(ilu) + else if ( effectivdaynumber < LandCover(i,j)%EGS(ilu) ) then + hveg = LandDefs(lu)%hveg_max ! not needed? + xSAIadd = 1.5 ! Sensescent + end if + LandCover(i,j)%SAI(ilu) = LandCover(i,j)%LAI(ilu) + xSAIadd + + !! end if ! crops + + + ! Just used reduced LAI for high latitudes for now, because of tests + ! which suggest that the big-leaf model as coded will overestimate + ! Gsto if we allow higher LAI in central Europe. + + else if( LandType(lu)%is_forest ) then + if ( gb(i,j) >= 60.0 ) then + lat_factor = max(0.3, ( 1.0 - 0.05* (gb(i,j)-60.0)) ) + hveg = hveg * lat_factor + LandCover(i,j)%LAI(ilu) = LandCover(i,j)%LAI(ilu) * lat_factor + end if + LandCover(i,j)%SAI(ilu) = LandCover(i,j)%LAI(ilu) + 1.0 + else + LandCover(i,j)%SAI(ilu) = LandCover(i,j)%LAI(ilu) !defaults + end if + + LandCover(i,j)%hveg(ilu) = hveg + + if ( DEBUG_LU .and. debug_flag ) then + write(*,"(a12,i3,a16,i4,f7.2,2f8.3,4i4)") "LANDPhen ", lu, trim(LandDefs(lu)%name), daynumber, & + LandCover(i,j)%hveg(ilu), LandCover(i,j)%LAI(ilu), LandCover(i,j)%fphen(ilu), & + LandCover(i,j)%SGS(ilu), LandCover(i,j)%EGS(ilu) + end if + + + end do ! lu + end do ! j + end do ! i + if ( DEBUG_LU .and. me==0 ) write(*,*)"UKDEP Finishing SetLandUse " + if(debug_proc .and. DEBUG_LU) write(*,*) "LAST GROWSEASON ", effectivdaynumber, WheatGrowingSeason(debug_li,debug_lj) + + end subroutine SetLandUse +! ===================================================================== + +!======================================================================= +function Polygon(jdayin,Ymin,Ystart,Ymax,Sday,LenS,Eday,LenE) & +result (Poly) +!======================================================================= + +! Calculates the value of a parameter Y with a polygon +! distribution - currently LAI and g_pot + +! _____________ <- Ymax +! / \ +! / \ +! / \ +! / \ +! | | <- Ystart +! | | +! | | +! ----------------------------- <- Ymin +! S S1 E1 E +! +!1.4 The following has been simplified + + +! Inputs + integer, intent(in) :: jdayin !day of year +!d1.4 integer, intent(in) :: yydays !no. days in year (365 or 366) + real, intent(in) :: Ymin !minimum value of Y + real, intent(in) :: Ystart !value Y at start of growing season + real, intent(in) :: Ymax !maximum value of Y + integer, intent(in) :: Sday !start day (e.g. of growing season) + integer, intent(in) :: LenS !length of Start period (S..S1 above) + integer, intent(in) :: Eday !end day (e.g. of growing season) + integer, intent(in) :: LenE !length of end period (E..E1 above) + +! Output: + real :: Poly ! value at day jday + +! Local + integer :: jday ! day of year, after any co-ordinate change + integer :: S ! start day + integer :: E ! end day + + + jday = jdayin + E = Eday + S = Sday + + ! Here we removed a lot of code associated with the leaf-age + ! version of g_pot. + + if ( jday < S .or. jday > E ) then + Poly = Ymin + return + end if + + !d1.3 - slightly re-written tests: + + if (jday <= S+LenS .and. LenS > 0 ) then + + Poly = (Ymax-Ystart) * (jday-S)/LenS + Ystart + + else if ( jday >= E-LenE .and. LenE > 0.0 ) then !d1.1 test for LenE + + Poly = (Ymax-Ystart) * (E-jday)/LenE + Ystart + + else + + Poly =Ymax + end if + + + end function Polygon + + !======================================================================= +end module Landuse_ml diff --git a/LocalVariables_ml.f90 b/LocalVariables_ml.f90 new file mode 100644 index 0000000..fc2ad0b --- /dev/null +++ b/LocalVariables_ml.f90 @@ -0,0 +1,186 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!ALBEDO? +!SNOW? +!ALSO CHECK/CHANGE lu==1 test in fphen, DO3SE_ml +!NNLAND vs NLAND??? +!! PARsun, shade is set by Rsurace + +module LocalVariables_ml + use ModelConstants_ml, only : NLANDUSE + implicit none + private + + ! public :: set_local ! Copies Sub(lu)%xxx to xxx + +! Near-surface meteorology and other variables for local area, +! e.g. for a measurement site or for a specific landuse within a grid square + + real, private, parameter :: NOT_SET = -999.999 ! Fake value to check for + integer, private, parameter :: INOT_SET = -999 ! Fake value to check for + ! variables being set + + integer, public, save :: iL = INOT_SET ! Landuse index + + ! 1) Grid data which should be okay for local ====================== + + type, public :: GridDat + real :: latitude ! deg N + real :: longitude ! deg E + integer :: i ! index + integer :: j ! index + logical :: is_wet ! true if precip > 0 + logical :: is_NWPsea ! NWP model defines this square as sea + real :: precip ! Precip at surface + real :: wetarea ! Fraction of grid which is wet + real :: cloud ! Cloud-cover (fraction) + integer :: snow ! 1=snow present, 0 = no snow + real :: psurf ! Surface pressure (Pa) + real :: z_ref ! Height of grid centre (m) + real :: DeltaZ ! Depth of grid centre (m) + real :: qw_ref ! Specific humidity + real :: rho_ref ! Air density (kg/m3) + ! the following are likely used in Sub below also + real :: t2C ! Surface (2m) temperature in degrees C + real :: t2 ! Surface (2m) temperature in degrees K + real :: rh ! Relative humidity, fraction (0-1) + real :: rho_s ! Air density (kg/m3) at surface, here 2m + real :: vpd ! Vapour pressure deficit (kPa) ! CHECK UNITS + real :: SWP ! SWP ! CHECK UNITS + real :: ustar ! friction velocity, m/s + real :: wstar ! convective velocity scale, m/s + real :: invL ! 1/L, where L is Obukhiov length (1/m) + real :: Hd ! Sensible Heat flux, *away from* surface + real :: LE ! Latent Heat flux, *away from* surface + real :: theta_ref ! Pot. temp at grid center + real :: Ra_ref ! + real :: u_ref ! wind speed at ref. height + real :: Ra_2m ! + real :: Ra_3m ! + real :: so2nh3ratio ! for CEH deposition scheme + real :: & !Not quite sure how many of these we need. + solar = NOT_SET & ! => irradiance (W/m^2) + ,Idirectn = NOT_SET & ! => irradiance (W/m^2), normal to beam + ,Idiffuse = NOT_SET & ! => diffuse solar radiation (W/m^2) + ,Idirect = NOT_SET & ! => total direct solar radiation (W/m^2) + ,zen = NOT_SET & ! Zenith angle (degrees) + ,coszen = NOT_SET ! = cos(zen) + ! (= sinB, where B is elevation angle) + integer :: izen = INOT_SET ! int(zen) +! +! real, dimension(NDRYDEP_TOT) :: & +! Vg_ref &! Grid average of Vg at ref ht. (effective Vg for cell) +! ,Vg_3m ! and at 3m + end type GridDat + + type(GridDat), public, save :: Grid + + ! 2) Near-surface Data - Sub-grid ==================== + ! + Sub-grid Veg/landcover data ==================================== + + + type, public :: SubDat + !* + integer :: & + iL = INOT_SET & ! Landcover index + ,SGS = INOT_SET & ! Start, growing seasons (day num) + ,EGS = INOT_SET ! End, growing seasons (day num) + !* + logical :: & + is_forest, is_water + !* + real :: & + t2C = NOT_SET &! Surface (2m) temperature in degrees C + ,t2 = NOT_SET &! Surface (2m) temperature in degrees K + ,rh = NOT_SET &! Relative humidity, fraction (0-1) + ,rho_s = NOT_SET &! Air density (kg/m3) at surface, here 2m + ,vpd = NOT_SET &! Vapour pressure deficit (kPa) ! CHECK UNITS + ,SWP = NOT_SET &! SWP ! CHECK UNITS + ,ustar = NOT_SET &! friction velocity, m/s + ,wstar = NOT_SET &! convective velocity scale, m/s + ,invL = NOT_SET &! 1/L, where L is Obukhiov length (1/m) + ,Hd = NOT_SET &! Sensible Heat flux, *away from* surface + ,LE = NOT_SET &! Latent Heat flux, *away from* surface + ,Ra_ref = NOT_SET &! + ,Ra_2m = NOT_SET &! + ,Ra_3m = NOT_SET &! + ,RgsO = NOT_SET &! ground-surface resistances - set in DO3SE + ,RgsS = NOT_SET &! ground-surface resistances - set in DO3SE + ! + ,coverage = NOT_SET &! Area covered (fraction) + ,LAI = NOT_SET &! Leaf area index (m2/m2) + ,SAI = NOT_SET &! Surface area index (m2/m2) + ,hveg = NOT_SET &! Height of veg. (m) + ,d = NOT_SET &! displacement height (m) + ,z_refd = NOT_SET &! z_ref - d (m) + ,z0 = NOT_SET &! roughness length (m) + ! + ! Canopy-Associated Radiation + ,PARsun = NOT_SET &! photosynthetic active radn. for sun-leaves + ,PARshade = NOT_SET &! " " for shade leaves + ,LAIsunfrac= NOT_SET &! fraction of LAI in sun + ! outputs from Rsurface will include: + ,g_sto = NOT_SET &! stomatal conductance (m/s) + ,g_sun = NOT_SET ! g_sto for sunlit upper-canopy (flag) leaves + + !,ObsRad = NOT_SET &! Used for box-model, for observed values + !,snow = NOT_SET &! Usually from Grid + !,wetarea = NOT_SET &! Usually from Grid + !,psurf = NOT_SET &! Surface Pressure (Pa), Usually from Grid + !,soil = NOT_SET ! Not used yet. + !,b_inc = NOT_SET &! in-canopy factor (Erisman-type) + ! + end type SubDat + + type(SubDat), public, dimension(NLANDUSE), save :: Sub + type(SubDat), public, save :: L ! For just one land-class + + + +!contains +! subroutine set_local(lu) +! integer, intent(in) :: lu +! +! iL = lu ! Is this sensible/needed?! +! t2C = Sub(lu)%t2C +! LAI = Sub(lu)%LAI +! SAI = Sub(lu)%SAI !! SAIadded???? +! rh = Sub(lu)%rh !! SAIadded???? +! ustar = Sub(lu)%ustar !! SAIadded???? +! hveg = Sub(lu)%hveg !! SAIadded???? +! PARsun = Sub(lu)%PARsun +! PARshade = Sub(lu)%PARshade +! LAIsunfrac = Sub(lu)%LAIsunfrac +! +! snow = Grid%snow +! wetarea = Grid%wetarea +! so2nh3ratio = Grid%so2nh3ratio !! SAIadded???? +! +! end subroutine set_local +! +end module LocalVariables_ml diff --git a/MARS_ml.f90 b/MARS_ml.f90 new file mode 100644 index 0000000..ea8760e --- /dev/null +++ b/MARS_ml.f90 @@ -0,0 +1,1237 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 MARS_ml + + use Io_ml, only : ios + use Aero_water_ml, only: Awater + use ModelConstants_ml, only : NPROC + use Par_ml, only : me + implicit none + private + + real, parameter :: FLOOR = 1.0E-30 ! minimum concentration + + + !/- subroutines: + public :: rpmares, & + cubic, & + actcof + + contains + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine rpmares ( SO4, HNO3, NO3, NH3, NH4, RH, TEMP, & + ASO4, ANO3, AH2O, ANH4, GNH3, GNO3, & + ERRMARK,deb) + +!----------------------------------------------------------------------- +!C +!C Description: +!C +!C ARES calculates the chemical composition of a sulfate/nitrate/ +!C ammonium/water aerosol based on equilibrium thermodynamics. +!C +!C This code considers two regimes depending upon the molar ratio +!C of ammonium to sulfate. +!C +!C For values of this ratio less than 2,the code solves a cubic for +!C hydrogen ion molality, HPLUS, and if enough ammonium and liquid +!C water are present calculates the dissolved nitric acid. For molal +!C ionic strengths greater than 50, nitrate is assumed not to be present. +!C +!C For values of the molar ratio of 2 or greater, all sulfate is assumed +!C to be ammonium sulfate and a calculation is made for the presence of +!C ammonium nitrate. +!C +!C The Pitzer multicomponent approach is used in subroutine ACTCOF to +!C obtain the activity coefficients. Abandoned -7/30/97 FSB + +!c The Bromley method of calculating the activity coefficients is s used +!c in this version + +!c The calculation of liquid water +!C is done in subroutine water. Details for both calculations are given +!C in the respective subroutines. +!C +!C Based upon MARS due to +!C P. Saxena, A.B. Hudischewskyj, C. Seigneur, and J.H. Seinfeld, +!C Atmos. Environ., vol. 20, Number 7, Pages 1471-1483, 1986. +!C +!C and SCAPE due to +!C Kim, Seinfeld, and Saxeena, Aerosol Ceience and Technology, +!C Vol 19, number 2, pages 157-181 and pages 182-198, 1993. +!C +!C NOTE: All concentrations supplied to this subroutine are TOTAL +!C over gas and aerosol phases +!C +!C Parameters: +!C +!C SO4 : Total sulfate in MICROGRAMS/M**3 as sulfate (IN) +!C HNO3 : Nitric Acid in MICROGRAMS/M**3 as nitric acid (IN) +!C NO3 : Total nitrate in MICROGRAMS/M**3 as nitric acid (IN) +!C NH3 : Total ammonia in MICROGRAMS/M**3 as ammonia (IN) +!C NH4 : Ammonium in MICROGRAMS/M**3 as ammonium (IN) +!C RH : Fractional relative humidity (IN) +!C TEMP : Temperature in Kelvin (IN) +!C GNO3 : Gas phase nitric acid in MICROGRAMS/M**3 (OUT) +!C GNH3 : Gas phase ammonia in MICROGRAMS/M**3 (OUT) +!C ASO4 : Aerosol phase sulfate in MICROGRAMS/M**3 (OUT) +!C ANO3 : Aerosol phase nitrate in MICROGRAMS/M**3 (OUT) +!C ANH4 : Aerosol phase ammonium in MICROGRAMS/M**3 (OUT) +!C AH2O : Aerosol phase water in MICROGRAMS/M**3 (OUT) +!C NITR : Number of iterations for obtaining activity coefficients (OUT) +!C NR : Number of real roots to the cubic in the low ammonia case (OUT) +!C +!C Revision History: +!C Who When Detailed description of changes +!C --------- -------- ------------------------------------------- +!C S.Roselle 11/10/87 Received the first version of the MARS code +!C S.Roselle 12/30/87 Restructured code +!C S.Roselle 2/12/88 Made correction to compute liquid-phase +!C concentration of H2O2. +!C S.Roselle 5/26/88 Made correction as advised by SAI, for +!C computing H+ concentration. +!C S.Roselle 3/1/89 Modified to operate with EM2 +!C S.Roselle 5/19/89 Changed the maximum ionic strength from +!C 100 to 20, for numerical stability. +!C F.Binkowski 3/3/91 Incorporate new method for ammonia rich case +!C using equations for nitrate budget. +!C F.Binkowski 6/18/91 New ammonia poor case which +!C omits letovicite. +!C F.Binkowski 7/25/91 Rearranged entire code, restructured +!C ammonia poor case. +!C F.Binkowski 9/9/91 Reconciled all cases of ASO4 to be output +!C as SO4-- +!C F.Binkowski 12/6/91 Changed the ammonia defficient case so that +!C there is only neutralized sulfate (ammonium +!C sulfate) and sulfuric acid. +!C F.Binkowski 3/5/92 Set RH bound on AWAS to 37 % to be in agreement +!C with the Cohen et al. (1987) maximum molality +!C of 36.2 in Table III.( J. Phys Chem (91) page +!C 4569, and Table IV p 4587.) +!C F.Binkowski 3/9/92 Redid logic for ammonia defficient case to remove +!C possibility for denomenator becoming zero; +!C this involved solving for HPLUS first. +!C Note that for a relative humidity +!C less than 50%, the model assumes that there is no +!C aerosol nitrate. +!C F.Binkowski 4/17/95 Code renamed ARES (AeRosol Equilibrium System) +!C Redid logic as follows +!C 1. Water algorithm now follows Spann & Richardson +!C 2. Pitzer Multicomponent method used +!C 3. Multicomponent practical osmotic coefficient +!C use to close iterations. +!C 4. The model now assumes that for a water +!C mass fraction WFRAC less than 50% there is +!C no aerosol nitrate. +!C F.Binkowski 7/20/95 Changed how nitrate is calculated in ammonia poor +!C case, and changed the WFRAC criterion to 40%. +!C For ammonium to sulfate ratio less than 1.0 +!C all ammonium is aerosol and no nitrate aerosol +!C exists. +!C F.Binkowski 7/21/95 Changed ammonia-ammonium in ammonia poor case to +!C allow gas-phase ammonia to exist. +!C F.Binkowski 7/26/95 Changed equilibrium constants to values from +!C Kim et al. (1993) +!C F.Binkowski 6/27/96 Changed to new water format +!c F.Binkowski 7/30/97 Changed to Bromley method for multicomponent +!c activity coefficients. The binary activity coefficients +!c are the same as the previous version +!c F.Binkowski 8/1/97 Chenged minimum sulfate from 0.0 to 1.0e-6 i.e. +!c 1 picogram per cubic meter +!C I.Ackermann 2/23/98 modification for solving precision problems +!C on workstations +!C I.Ackermann 2/25/99 changed logic as follows: +!c If iterations fail, initial values of nitrate +!c are retained. +!c Total mass budgets are changed to account for gas +!c phase returned. (incorporated from FZB's models3 +!c framework) +!C eliminated ratio=5 !! for low to zero sulfate +!C I.Ackermann 3/17/99 modified ratio = 5 treatment see RB3,p.125 +!C +!C----------------------------------------------------------------------- + + +!...........ARGUMENTS and their descriptions + + real, intent(in) :: SO4 & ! Total sulfate in micrograms / m**3 + ,HNO3 & ! Total nitric acid in micrograms / m**3 + ,NO3 & ! Total nitrate in micrograms / m**3 + ,NH3 & ! Total ammonia in micrograms / m**3 + ,NH4 & ! Total ammonium in micrograms / m**3 + ,RH & ! Fractional relative humidity + ,TEMP ! Temperature in Kelvin + + real, intent(out):: ASO4 & ! Aerosol sulfate in micrograms / m**3 + ,ANO3 & ! Aerosol nitrate in micrograms / m**3 + ,AH2O & ! Aerosol liquid water content water in micrograms / m**3 + ,ANH4 & ! Aerosol ammonium in micrograms / m**3 + ,GNO3 & ! Gas-phase nitric acid in micrograms / m**3 + ,GNH3 ! Gas-phase ammonia in micrograms / m**3 + + logical, intent(in) :: deb + +!C...........INCLUDES and their descriptions +!! INCLUDE SUBST_CONST ! constants + +!...........PARAMETERS and their descriptions: + + 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 ) + + real MWORG ! molecular weight for Organic Species + parameter ( MWORG = 16.0 ) + + real MWCL ! molecular weight for Chloride + parameter ( MWCL = 35.453 ) + + real MWAIR ! molecular weight for AIR + parameter ( MWAIR = 28.964 ) + + real MWLCT ! molecular weight for Letovicite + parameter ( MWLCT = 3.0 * MWNH4 + 2.0 * MWSO4 + 1.0080 ) + + real MWAS ! molecular weight for Ammonium Sulfate + parameter ( MWAS = 2.0 * MWNH4 + MWSO4 ) + + real MWABS ! molecular weight for Ammonium Bisulfate + parameter ( MWABS = MWNH4 + MWSO4 + 1.0080 ) + + +!...........SCRATCH LOCAL VARIABLES and their descriptions: + + REAL irh ! 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 + INTEGER ERRMARK + + real A0 ! Coefficients and roots of + real A1 ! Coefficients and roots of + real A2 ! Coefficients and roots of + real AA ! Coefficients and discriminant for quadratic equation for ammonium nitrate + real BAL ! internal variables ( high ammonia case) + real BB ! Coefficients and discriminant for quadratic equation for ammonium nitrate + real BHAT ! Variables used for ammonia solubility + real CC ! Coefficients and discriminant for quadratic equation for ammonium nitrate + real CONVT ! Factor for conversion of units + real DD ! Coefficients and discriminant for quadratic equation for ammonium nitrate + real DISC ! Coefficients and discriminant for quadratic equation for ammonium nitrate + real EROR ! Relative error used for convergence test + real FNH3 ! "Free ammonia concentration", that which exceeds TWOSO4 + real GAMAAB ! Activity Coefficient for (NH4+, HSO4-)GAMS( 2,3 ) + real GAMAAN ! Activity coefficient for (NH4+, NO3-) GAMS( 2,2 ) + real GAMAHAT ! Variables used for ammonia solubility + real GAMANA ! Activity coefficient for (H+ ,NO3-) GAMS( 1,2 ) + real GAMAS1 ! Activity coefficient for (2H+, SO4--) GAMS( 1,1 ) + real GAMAS2 ! Activity coefficient for (H+, HSO4-) GAMS( 1,3 ) + real GAMOLD ! used for convergence of iteration + real GASQD ! internal variables ( high ammonia case) + real HPLUS ! Hydrogen ion (low ammonia case) (moles / kg water) + real K1A ! Equilibrium constant for ammoniua to ammonium + real K2SA ! Equilibrium constant for sulfate-bisulfate (aqueous) + real K3 ! Dissociation constant for ammonium nitrate + real KAN ! Equilibrium constant for ammonium nitrate (aqueous) + real KHAT ! Variables used for ammonia solubility + real KNA ! Equilibrium constant for nitric acid (aqueous) + real KPH ! Henry's Law Constant for ammonia + real KW ! Equilibrium constant for water dissociation + real KW2 ! Internal variable using KAN + real MAN ! Nitrate (high ammonia case) (moles / kg water) + real MAS ! Sulfate (high ammonia case) (moles / kg water) + real MHSO4 ! Bisulfate (low ammonia case) (moles / kg water) + real MNA ! Nitrate (low ammonia case) (moles / kg water) + real MNH4 ! Ammonium (moles / kg water) + real MOLNU ! Total number of moles of all ions + real MSO4 ! Sulfate (low ammonia case) (moles / kg water) + real PHIBAR ! Practical osmotic coefficient + real PHIOLD ! Previous value of practical osmotic coefficient used for convergence of iteration + real RATIO ! Molar ratio of ammonium to sulfate + real RK2SA ! Internal variable using K2SA + real RKNA ! Internal variables using KNA + real RKNWET ! Internal variables using KNA + real RR1 + real RR2 + real STION ! Ionic strength + real T1 ! Internal variables for temperature corrections + real T2 ! Internal variables for temperature corrections + real T21 ! Internal variables of convenience (low ammonia case) + real T221 ! Internal variables of convenience (low ammonia case) + real T3 ! Internal variables for temperature corrections + real T4 ! Internal variables for temperature corrections + real T6 ! Internal variables for temperature corrections + real TNH4 ! Total ammonia and ammonium in micromoles / meter ** 3 + real TNO3 ! Total nitrate in micromoles / meter ** 3 + real TOLER1 ! Tolerances for convergence test + real TOLER2 ! Tolerances for convergence test + real TSO4 ! Total sulfate in micromoles / meter ** 3 + real TWOSO4 ! 2.0 * TSO4 (high ammonia case) (moles / kg water) + real WFRAC ! Water mass fraction + real WH2O ! Aerosol liquid water content (internally) + ! micrograms / meter **3 on output + ! internally it is 10 ** (-6) kg (water) / meter ** 3 + ! the conversion factor (1000 g = 1 kg) is applied + ! for AH2O output + real WSQD ! internal variables ( high ammonia case) + real XNO3 ! Nitrate aerosol concentration in micromoles / meter ** 3 + real XXQ ! Variable used in quadratic solution + real YNH4 ! Ammonium aerosol concentration in micromoles / meter** 3 + real ZH2O ! Water variable saved in case ionic strength too high. + real ZSO4 ! Total sulfate molality - mso4 + mhso4 (low ammonia case) (moles / kg water) + + real CAT( 2 ) ! Array for cations (1, H+); (2, NH4+) (moles / kg water) + real AN ( 3 ) ! Array for anions (1, SO4--); (2, NO3-); (3, HSO4-) (moles / kg water) + real CRUTES( 3 ) ! Coefficients and roots of + real GAMS( 2, 3 ) ! Array of activity coefficients + real MINSO4 ! Minimum value of sulfate laerosol concentration + 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 +!2/25/99 IJA +! FSB New variables Total ammonia and nitrate mass concentrations + real TMASSNH3 ! Total ammonia (gas and particle) + ! as ammonia gas [ug /m**3] + real TMASSHNO3 ! Total nitrate (vapor and particle) as + ! nitric acid vapor [ug /m**3] + +!----------------------------------------------------------------------- +! begin body of subroutine RPMARES + +!...convert into micromoles/m**3 + +!..iamodels3 merge NH3/NH4 , HNO3,NO3 here + TSO4 = MAX( 0.0, SO4 / MWSO4 ) + TNO3 = MAX( 0.0, (NO3 / MWNO3 + HNO3 / MWHNO3) ) + TNH4 = MAX( 0.0, (NH3 / MWNH3 + NH4 / MWNH4) ) + +!2/25/99 IJA +! TMASSNH3 = MAX(0.0, NH3 + (MWNH3 / MWNH4) * NH4 ) +! TMASSHNO3 = MAX(0.0, NO3 + (MWHNO3 / MWNO3) * NO3 ) + + TMASSNH3 = MAX(0.0, NH3 + NH4 ) + TMASSHNO3 = MAX(0.0, HNO3 + NO3 ) + +!...now set humidity index IRH as a percent + +!st IRH = NINT( 100.0 * RH ) + irh = RH +!...Check for valid IRH + + irh = MAX( 0.01, IRH ) + irh = MIN( 0.99, IRH ) + +!...Specify the equilibrium constants at correct +!... temperature. Also change units from ATM to MICROMOLE/M**3 (for KAN, +!... KPH, and K3 ) +!... Values from Kim et al. (1993) except as noted. + + CONVT = 1.0 / ( 0.082 * TEMP ) + T6 = 0.082E-9 * TEMP + T1 = 298.0 / TEMP + T2 = ALOG( T1 ) + T3 = T1 - 1.0 + T4 = 1.0 + T2 - T1 + KNA = 2.511E+06 * EXP( 29.17 * T3 + 16.83 * T4 ) * T6 + K1A = 1.805E-05 * EXP( -1.50 * T3 + 26.92 * T4 ) + K2SA = 1.015E-02 * EXP( 8.85 * T3 + 25.14 * T4 ) + KW = 1.010E-14 * EXP( -22.52 * T3 + 26.92 * T4 ) + KPH = 57.639 * EXP( 13.79 * T3 - 5.39 * T4 ) * T6 +!!! K3 = 5.746E-17 * EXP( -74.38 * T3 + 6.12 * T4 ) * T6 * T6 + KHAT = KPH * K1A / KW + KAN = KNA * KHAT + +!...Compute temperature dependent equilibrium constant for NH4NO3 +!... ( from Mozurkewich, 1993) + + K3 = EXP( 118.87 - 24084.0 / TEMP - 6.025 * ALOG( TEMP ) ) + +!...Convert to (micromoles/m**3) **2 + + K3 = K3 * CONVT * CONVT + + WH2O = 0.0 + STION = 0.0 + AH2O = 0.0 + MAS = 0.0 + MAN = 0.0 + HPLUS = 0.0 + TOLER1 = 0.00001 + TOLER2 = 0.001 + NITR = 0 + NR = 0 + RATIO = 0.0 + GAMAAN = 1.0 + GAMOLD = 1.0 + +!...set the ratio according to the amount of sulfate and nitrate + + IF ( TSO4 > MINSO4 ) THEN + RATIO = TNH4 / TSO4 + +!...If there is no sulfate and no nitrate, there can be no ammonium +!... under the current paradigm. Organics are ignored in this version. + + ELSE + + IF ( TNO3 <= MINNO3 ) THEN + +! *** 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 ) + WH2O = 0.0 + AH2O = 0.0 + GNH3 = MAX(FLOOR,GNH3) + GNO3 = MAX(FLOOR,GNO3) + RETURN + END IF + +!...For the case of no sulfate and nonzero nitrate, set ratio to 5 +!... to send the code to the high ammonia case if there is more +!... ammonia than sulfate, otherwise send to low ammonia case. + + IF (TNH4 > TSO4) THEN + RATIO = 5.0 !this is a high ammonia case with low sulfur + ELSE + RATIO = 1. !this is a low ammonia case with low sulfur + END IF + + END IF + +!.................................... +!......... High Ammonia Case ........ +!.................................... + + IF ( RATIO > 2.0 ) THEN + GAMAAN = 0.1 + +!...Set up twice the sulfate for future use. + + TWOSO4 = 2.0 * TSO4 + XNO3 = 0.0 + YNH4 = TWOSO4 + +!...Treat different regimes of relative humidity + +!...ZSR relationship is used to set water levels. Units are +!... 10**(-6) kg water/ (cubic meter of air) +!... start with ammomium sulfate solution without nitrate + + CALL awater(IRH,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 ( WFRAC == 0.0 ) RETURN ! No water + IF ( WFRAC < 0.2 ) THEN + +!..."dry" ammonium sulfate and ammonium nitrate +!... compute free ammonia + + FNH3 = TNH4 - TWOSO4 + CC = TNO3 * FNH3 - K3 + +!...check for not enough to support aerosol + + IF ( CC <= 0.0 ) THEN + XNO3 = 0.0 + ELSE + AA = 1.0 + BB = -( TNO3 + FNH3 ) + DISC = BB * BB - 4.0 * CC + +!...Check for complex roots of the quadratic +!... set nitrate to zero and RETURN if complex roots are found +!2/25/99 IJA + + IF ( DISC < 0.0 ) THEN + XNO3 = 0.0 + AH2O = 1000.0 * WH2O + YNH4 = TWOSO4 + GNO3 = HNO3 + ASO4 = TSO4 * MWSO4 + ANO3 = NO3 + ANH4 = YNH4 * MWNH4 + GNH3 = TMASSNH3 - ANH4 + RETURN + END IF + +!...to get here, BB .lt. 0.0, CC .gt. 0.0 always + + DD = SQRT( DISC ) + XXQ = -0.5 * ( BB + SIGN ( 1.0, BB ) * DD ) + +!...Since both roots are positive, select smaller root. + + XNO3 = MIN( XXQ / AA, CC / XXQ ) + + END IF +!2/25/99 IJA + AH2O = 1000.0 * WH2O + YNH4 = TWOSO4 + XNO3 + ASO4 = TSO4 * MWSO4 + ANO3 = XNO3 * MWNO3 + ANH4 = YNH4 * MWNH4 + GNH3 = TMASSNH3 - ANH4 + GNO3 = TMASSHNO3 - ANO3 + RETURN + + END IF + +!...liquid phase containing completely neutralized sulfate and +!... some nitrate. Solve for composition and quantity. + + MAS = TSO4 / WH2O + MAN = 0.0 + XNO3 = 0.0 + YNH4 = TWOSO4 + PHIOLD = 1.0 + +!...Start loop for iteration + +!...The assumption here is that all sulfate is ammonium sulfate, +!... and is supersaturated at lower relative humidities. + + DO 1501 NNN = 1, 150 + NITR = NNN + GASQD = GAMAAN * GAMAAN + WSQD = WH2O * WH2O + KW2 = KAN * WSQD / GASQD + AA = 1.0 - KW2 + BB = TWOSO4 + KW2 * ( TNO3 + TNH4 - TWOSO4 ) + CC = -KW2 * TNO3 * ( TNH4 - TWOSO4 ) + +!...This is a quadratic for XNO3 [MICROMOLES / M**3] of nitrate in solution. + + DISC = BB * BB - 4.0 * AA * CC + +!...Check for complex roots, retain inital values and RETURN +!2/25/99 IJA + + IF ( DISC < 0.0 ) THEN + XNO3 = 0.0 + AH2O = 1000.0 * WH2O + YNH4 = TWOSO4 + GNO3 = HNO3 + ASO4 = TSO4 * MWSO4 + ANO3 = NO3 + ANH4 = YNH4 * MWNH4 + GNH3 = TMASSNH3 - ANH4 + +!!! 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 + ELSE + XNO3 = - CC / BB + END IF + + XNO3 = MIN( XNO3, TNO3 ) + +!...This version assumes no solid sulfate forms (supersaturated ) +!... Now update water + + CALL AWATER ( IRH, TSO4, YNH4, XNO3, AH2O) + +!...ZSR relationship is used to set water levels. Units are +!... 10**(-6) kg water/ (cubic meter of air) +!... The conversion from micromoles to moles is done by the units of WH2O. + + WH2O = 1.0E-3 * AH2O + +!...Ionic balance determines the ammonium in solution. + + MAN = XNO3 / WH2O + MAS = TSO4 / WH2O + MNH4 = 2.0 * MAS + MAN + YNH4 = MNH4 * WH2O + + !st ... FIXING + if(MNH4<0. .or. MAS<0. .or. MAN<0.) then + MNH4 = 1.e-30 + MAS = 1.e-30 + MAN = 1.e-30 + endif + +!...MAS, MAN and MNH4 are the aqueous concentrations of sulfate, nitrate, +!... and ammonium in molal units (moles/(kg water) ). + + STION = 3.0 * MAS + MAN + CAT( 1 ) = 0.0 + CAT( 2 ) = MNH4 + AN ( 1 ) = MAS + AN ( 2 ) = MAN + AN ( 3 ) = 0.0 + CALL ACTCOF ( CAT, AN, GAMS, MOLNU, PHIBAR , ERRMARK,1,deb) + GAMAAN = GAMS( 2, 2 ) + +!...Use GAMAAN for convergence control + + EROR = ABS( GAMOLD - GAMAAN ) / GAMOLD + GAMOLD = GAMAAN + +!...Check to see if we have a solution + + IF ( EROR <= TOLER1 ) THEN +!!! WRITE( 11, * ) RH, STION, GAMS( 1, 1 ),GAMS( 1, 2 ), GAMS( 1, 3 ), +!!! & GAMS( 2, 1 ), GAMS( 2, 2 ), GAMS( 2, 3 ), PHIBAR +! 2/25/99 IJA + ASO4 = TSO4 * MWSO4 + ANO3 = XNO3 * MWNO3 + ANH4 = YNH4 * MWNH4 + GNO3 = TMASSHNO3 - ANO3 + GNH3 = TMASSNH3 - ANH4 + AH2O = 1000.0 * WH2O + RETURN + END IF + +1501 CONTINUE + +!...If after NITR iterations no solution is found, then: +! FSB retain the initial values of nitrate particle and vapor +! 2/25/99 IJA + ASO4 = TSO4 * MWSO4 + ANO3 = NO3 + XNO3 = NO3 / MWNO3 + YNH4 = TWOSO4 + ANH4 = YNH4 * MWNH4 + CALL AWATER ( IRH, TSO4, YNH4, XNO3, AH2O) + GNO3 = HNO3 + GNH3 = TMASSNH3 - ANH4 + RETURN + + ELSE + +!...................................... +!......... Low Ammonia Case ........... +!...................................... + +!...coded by Dr. Francis S. Binkowski 12/8/91.(4/26/95) + ! modified 8/28/98 + +!...All cases covered by this logic + + WH2O = 0.0 + CALL AWATER ( IRH, TSO4, TNH4, TNO3, AH2O ) + WH2O = 1.0E-3 * AH2O + ZH2O = AH2O + +!...convert 10**(-6) kg water/(cubic meter of air) to micrograms of water +!... per cubic meter of air (1000 g = 1 kg) +! 2/25/99 IJA + ASO4 = TSO4 * MWSO4 + ANH4 = TNH4 * MWNH4 + ANO3 = NO3 + GNO3 = TMASSHNO3 - ANO3 + GNH3 = FLOOR + +!...Check for zero water. + + IF ( WH2O == 0.0 ) RETURN + ZSO4 = TSO4 / WH2O + +!...ZSO4 is the molality of total sulfate i.e. MSO4 + MHSO4 + +!!! IF ( ZSO4 > 11.0 ) THEN + +!...do not solve for aerosol nitrate for total sulfate molality +!... greater than 11.0 because the model parameters break down +!... greater than 9.0 because the model parameters break down + + IF ( ZSO4 > 9.0 ) THEN ! 18 June 97 + RETURN + END IF + +!...First solve with activity coeffs of 1.0, then iterate. + + PHIOLD = 1.0 + GAMANA = 1.0 + GAMAS1 = 1.0 + GAMAS2 = 1.0 + GAMAAB = 1.0 + GAMOLD = 1.0 + +!...All ammonia is considered to be aerosol ammonium. + + MNH4 = TNH4 / WH2O + +!...MNH4 is the molality of ammonium ion. + + YNH4 = TNH4 + +!...loop for iteration + + DO 1601 NNN = 1, 150 + NITR = NNN + +!...set up equilibrium constants including activities +!... solve the system for hplus first then sulfate & nitrate + + RK2SA = K2SA * GAMAS2 * GAMAS2 / ( GAMAS1 * GAMAS1 * GAMAS1 ) + RKNA = KNA / ( GAMANA * GAMANA ) + RKNWET = RKNA * WH2O + T21 = ZSO4 - MNH4 + T221 = ZSO4 + T21 + +!...set up coefficients for cubic + + A2 = RK2SA + RKNWET - T21 + A1 = RK2SA * RKNWET - T21 * ( RK2SA + RKNWET ) & + - RK2SA * ZSO4 - RKNA * TNO3 + A0 = - (T21 * RK2SA * RKNWET & + + RK2SA * RKNWET * ZSO4 + RK2SA * RKNA * TNO3 ) + + CALL CUBIC ( A2, A1, A0, NR, CRUTES,deb ) + +!...Code assumes the smallest positive root is in CRUTES(1) + + HPLUS = CRUTES( 1 ) + BAL = HPLUS **3 + A2 * HPLUS**2 + A1 * HPLUS + A0 + MSO4 = RK2SA * ZSO4 / ( HPLUS + RK2SA ) ! molality of sulfate ion + MHSO4 = ZSO4 - MSO4 ! molality of bisulfate ion + MNA = RKNA * TNO3 / ( HPLUS + RKNWET ) ! molality of nitrate ion + MNA = MAX( 0.0, MNA ) + MNA = MIN( MNA, TNO3 / WH2O ) + XNO3 = MNA * WH2O + ANO3 = MNA * WH2O * MWNO3 +! 2/25/99 IJA + GNO3 = TMASSHNO3 - ANO3 + +!...Calculate ionic strength + + STION = 0.5 * ( HPLUS + MNA + MNH4 + MHSO4 + 4.0 * MSO4 ) + +!...Update water + + CALL AWATER ( IRH, 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) + + WH2O = 1.0E-3 * AH2O + CAT( 1 ) = HPLUS + CAT( 2 ) = MNH4 + AN ( 1 ) = MSO4 + AN ( 2 ) = MNA + AN ( 3 ) = MHSO4 + + CALL ACTCOF ( CAT, AN, GAMS, MOLNU, PHIBAR, ERRMARK,2,deb) + + GAMANA = GAMS( 1, 2 ) + GAMAS1 = GAMS( 1, 1 ) + GAMAS2 = GAMS( 1, 3 ) + GAMAAN = GAMS( 2, 2 ) + + GAMAHAT = ( GAMAS2 * GAMAS2 / ( GAMAAB * GAMAAB ) ) + BHAT = KHAT * GAMAHAT +!!! EROR = ABS ( ( PHIOLD - PHIBAR ) / PHIOLD ) +!!! PHIOLD = PHIBAR + EROR = ABS ( GAMOLD - GAMAHAT ) / GAMOLD + GAMOLD = GAMAHAT + +!...write out molalities and activity coefficient +!... and return with good solution + + IF ( EROR <= TOLER2 ) THEN +!!! WRITE(12,*) RH, STION,HPLUS,ZSO4,MSO4,MHSO4,MNH4,MNA +!!! WRITE(11,*) RH, STION, GAMS(1,1),GAMS(1,2),GAMS(1,3), +!!! & GAMS(2,1),GAMS(2,2),GAMS(2,3), PHIBAR + RETURN + END IF + +1601 CONTINUE + +!...after NITR iterations, failure to solve the system, no ANO3 +! 2/25/99 IJA + ANH4 = TNH4 * MWNH4 + GNH3 = FLOOR + GNO3 = HNO3 + ANO3 = NO3 + CALL AWATER ( IRH, TSO4, TNH4, TNO3, AH2O ) + RETURN + + END IF ! ratio .gt. 2.0 + + end subroutine rpmares ! end RPMares + +!>-------------------------------------------------------------------------------< +!<-------------------------------------------------------------------------------> + + subroutine cubic(a2,a1,a0,nr,crutes,deb) + + !.. subroutine to find the roots of a cubic equation / 3rd order polynomial + !.. formulae can be found in numer. recip. on page 145 + !.. kiran developed this version on 25/4/1990 + !.. dr. francis binkowski modified the routine on 6/24/91, 8/7/97 +!======= + + implicit none + + real, intent(in) :: a2,a1,a0 + integer, intent(out) :: nr + real, intent(out) :: crutes(3) + logical, intent(in) :: deb +!.. local + real :: qq,rr,a2sq,theta, sqrt3, one3rd + real :: dum1,dum2,part1,part2,part3,rrsq,phi,yy1,yy2,yy3 + real :: costh, sinth + + data sqrt3/1.732050808/, one3rd/0.333333333/ +!======= + + a2sq=a2*a2 + qq=(a2sq-3.*a1)/9. + rr=( a2*(2.*a2sq - 9.*a1) + 27.*a0 )/54. +! CASE 1 THREE real ROOTS or CASE 2 ONLY ONE real ROOT + dum1=qq*qq*qq + rrsq=rr*rr + dum2=dum1 - rrsq + + if(dum2 >= 0.) then +! NOW WE HAVE THREE real ROOTS + phi=sqrt(dum1) + if(abs(phi) <= 1.e-20) then +! write(10,*) ' cubic phi small, phi = ',phi + crutes(1) = 0.0 + crutes(2) = 0.0 + crutes(3) = 0.0 + nr = 0 + stop + end if + theta=acos(rr/phi)/3.0 + costh = cos(theta) + sinth = sin(theta) +! *** use trig identities to simplify the expressions +! *** binkowski's modification + part1=sqrt(qq) + yy1=part1*costh + yy2=yy1-a2/3.0 + yy3=sqrt3*part1*sinth + crutes(3) = -2.0*yy1 - a2/3.0 + crutes(2) = yy2 + yy3 + crutes(1) = yy2 - yy3 +! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE + if(crutes(1) <= 0.0) crutes(1) = 1.0e9 + if(crutes(2) <= 0.0) crutes(2) =1.0e9 + if(crutes(3) <= 0.0) crutes(3) = 1.0e9 +! *** put smallest positive root in crutes(1) + crutes(1)=min( crutes(1),crutes(2),crutes(3)) + nr=3 + else ! dum IS NEGATIVE +! NOW HERE WE HAVE ONLY ONE real ROOT + part1=sqrt(rrsq-dum1) + part2=abs(rr) + part3=(part1+part2)**one3rd + crutes(1) = -sign(1.0,rr) * ( part3 + (qq/part3) ) - a2/3. + crutes(2)=0. + crutes(3)=0. +!IAREV02...ADDITIONAL CHECK on NEGATIVE ROOTS +! *** SET NEGATIVE ROOTS TO A LARGE POSITIVE VALUE +!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 + end if + nr=1 + end if + + end subroutine cubic + +!>-------------------------------------------------------------------------------< +!<-------------------------------------------------------------------------------> + + subroutine actcof ( CAT, AN, GAMA, MOLNU, PHIMULT , ERRMARK, IA2, deb) + +!C----------------------------------------------------------------------- +!C +!C DESCRIPTION: +!C +!C This subroutine computes the activity coefficients of (2NH4+,SO4--), +!C (NH4+,NO3-),(2H+,SO4--),(H+,NO3-),AND (H+,HSO4-) in aqueous +!C multicomponent solution, using Bromley's model and Pitzer's method. +!C +!C REFERENCES: +!C +!C Bromley, L.A. (1973) Thermodynamic properties of strong electrolytes +!C in aqueous solutions. AIChE J. 19, 313-320. +!C +!C Chan, C.K. R.C. Flagen, & J.H. Seinfeld (1992) Water Activities of +!C NH4NO3 / (NH4)2SO4 solutions, Atmos. Environ. (26A): 1661-1673. +!C +!C Clegg, S.L. & P. Brimblecombe (1988) Equilibrium partial pressures +!C of strong acids over saline solutions - I HNO3, +!C Atmos. Environ. (22): 91-100 +!C +!C Clegg, S.L. & P. Brimblecombe (1990) Equilibrium partial pressures +!C and mean activity and osmotic coefficients of 0-100% nitric acid +!C as a function of temperature, J. Phys. Chem (94): 5369 - 5380 +!C +!C Pilinis, C. and J.H. Seinfeld (1987) Continued development of a +!C general equilibrium model for inorganic multicomponent atmospheric +!C aerosols. Atmos. Environ. 21(11), 2453-2466. +!C + + +! +!CC ARGUMENT DESCRIPTION: +! +!C CAT(1) : conc. of H+ (moles/kg) +!C CAT(2) : conc. of NH4+ (moles/kg) +!C AN(1) : conc. of SO4-- (moles/kg) +!C AN(2) : conc. of NO3- (moles/kg) +!C AN(3) : conc. of HSO4- (moles/kg) +!C GAMA(2,1) : mean molal ionic activity coeff for (2NH4+,SO4--) +!C GAMA(2,2) : " " " " " " (NH4+,NO3-) +!C GAMA(2,3) : " " " " " " (NH4+. HSO4-) +!C GAMA(1,1) : " " " " " " (2H+,SO4--) +!C GAMA(1,2) : " " " " " " (H+,NO3-) +!C GAMA(1,3) : " " " " " " (H+,HSO4-) +!C MOLNU : the total number of moles of all ions. +!C PHIMULT : the multicomponent paractical osmotic coefficient. +!C +!C REVISION HISTORY: +!C Who When Detailed description of changes +!C --------- -------- ------------------------------------------- +!C S.Roselle 7/26/89 Copied parts of routine BROMLY, and began this +!C new routine using a method described by Pilinis +!C and Seinfeld 1987, Atmos. Envirn. 21 pp2453-2466. +!C S.Roselle 7/30/97 Modified for use in Models-3 +!C F.Binkowski 8/7/97 Modified coefficients BETA0, BETA1, CGAMA +!C +!----------------------------------------------------------------------- + + + + +!...........INCLUDES and their descriptions + +! INCLUDE SUBST_XSTAT ! M3EXIT status codes + +!...........ARGUMENTS and their descriptions + + + real, intent(in) :: cat(2) & ! cation conc in moles/kg (input) + ,an (3) & ! anion conc in moles/kg (input) + ,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 + +!.................................................................... + + INTEGER XSTAT0 ! Normal, successful completion + PARAMETER (XSTAT0 = 0) + INTEGER XSTAT1 ! File I/O error + PARAMETER (XSTAT1 = 1) + INTEGER XSTAT2 ! Execution error + PARAMETER (XSTAT2 = 2) + INTEGER XSTAT3 ! Special error + PARAMETER (XSTAT3 = 3) + INTEGER ERRMARK + INTEGER IDUM + INTEGER JDUM + INTEGER LAYER + + INTEGER IA2 + + CHARACTER*120 XMSG + +!...........PARAMETERS and their descriptions: + + INTEGER NCAT ! number of cations + PARAMETER ( NCAT = 2 ) + + INTEGER NAN ! number of anions + PARAMETER ( NAN = 3 ) + + +!...........SCRATCH LOCAL VARIABLES and their descriptions: + + CHARACTER*16 PNAME ! driver program name + SAVE PNAME + + INTEGER IAN ! anion indX + INTEGER ICAT ! cation indX + + REAL FGAMA ! + REAL I ! ionic strength + REAL R ! + REAL S ! + REAL TA ! + REAL TB ! + REAL TC ! + REAL TEXPV ! + REAL TRM ! + REAL TWOI ! 2*ionic strength + REAL TWOSRI ! 2*sqrt of ionic strength + REAL ZBAR ! + REAL ZBAR2 ! + REAL ZOT1 ! + REAL SRI ! square root of ionic strength + REAL F2( NCAT ) ! + REAL F1( NAN ) ! + REAL ZP( NCAT ) ! absolute value of charges of cation + REAL ZM( NAN ) ! absolute value of charges of anion + REAL BGAMA ( NCAT, NAN ) ! + REAL X ( NCAT, NAN ) ! + REAL M ( NCAT, NAN ) ! molality of each electrolyte + REAL LGAMA0( NCAT, NAN ) ! binary activity coefficients + REAL Y ( NAN, NCAT ) ! + REAL BETA0 ( NCAT, NAN ) ! binary activity coefficient parameter + REAL BETA1 ( NCAT, NAN ) ! binary activity coefficient parameter + REAL CGAMA ( NCAT, NAN ) ! binary activity coefficient parameter + REAL V1 ( NCAT, NAN ) ! number of cations in electrolyte formula + REAL V2 ( NCAT, NAN ) ! number of anions in electrolyte formula + + DATA ZP / 1.0, 1.0 / + DATA ZM / 2.0, 1.0, 1.0 / + DATA XMSG / ' ' / + DATA PNAME / 'ACTCOF' / + +! *** Sources for the coefficients BETA0, BETA1, CGAMA: + +! *** (1,1);(1,3) - Clegg & Brimblecombe (1988) +! *** (2,3) - Pilinis & Seinfeld (1987), cgama different +! *** (1,2) - Clegg & Brimblecombe (1990) +! *** (2,1);(2,2) - Chan, Flagen & Seinfeld (1992) + +! *** now set the basic constants, BETA0, BETA1, CGAMA + + DATA BETA0(1,1) /2.98E-2/, BETA1(1,1) / 0.0/, & + CGAMA(1,1) / 4.38E-2/ ! 2H+SO4- + + DATA BETA0(1,2) / 1.2556E-1/, BETA1(1,2) / 2.8778E-1/, & + CGAMA(1,2) / -5.59E-3/ ! HNO3 + + DATA BETA0(1,3) / 2.0651E-1/, BETA1(1,3) / 5.556E-1/, & + CGAMA(1,3) /0.0/ ! H+HSO4- + + DATA BETA0(2,1) /4.6465E-2/, BETA1(2,1) /-0.54196/, & + CGAMA(2,1) /-1.2683E-3/ ! (NH4)2SO4 + + DATA BETA0(2,2) /-7.26224E-3/, BETA1(2,2) /-1.168858/, & + CGAMA(2,2) /3.51217E-5/ ! NH4NO3 + + DATA BETA0(2,3) / 4.494E-2/, BETA1(2,3) / 2.3594E-1/, & + CGAMA(2,3) /-2.962E-3/ ! NH4HSO4 + + DATA V1(1,1), V2(1,1) / 2.0, 1.0 / ! 2H+SO4- + DATA V1(2,1), V2(2,1) / 2.0, 1.0 / ! (NH4)2SO4 + DATA V1(1,2), V2(1,2) / 1.0, 1.0 / ! HNO3 + DATA V1(2,2), V2(2,2) / 1.0, 1.0 / ! NH4NO3 + DATA V1(1,3), V2(1,3) / 1.0, 1.0 / ! H+HSO4- + DATA V1(2,3), V2(2,3) / 1.0, 1.0 / ! NH4HSO4 + +!----------------------------------------------------------------------- +! begin body of subroutine ACTCOF + +!...compute ionic strength + I = 0.0 + + DO ICAT = 1, NCAT + I = I + CAT( ICAT ) * ZP( ICAT ) * ZP( ICAT ) + END DO + + DO IAN = 1, NAN + I = I + AN( IAN ) * ZM( IAN ) * ZM( IAN ) + END DO + + I = 0.5 * I + +!...check for problems in the ionic strength + + IF ( I .EQ. 0.0 ) THEN + + DO IAN = 1, NAN + DO ICAT = 1, NCAT + GAMA( ICAT, IAN ) = 0.0 + END DO + END DO + + XMSG = 'Ionic strength is zero...returning zero activities' + if(deb ) WRITE(6,*) XMSG + RETURN + + ELSE IF ( I .LT. 0.0 ) THEN + XMSG = 'Ionic strength below zero...negative concentrations' + if(deb ) then + WRITE(6,*) XMSG + WRITE(6,*) 'called over ', IA2 + WRITE(6,*) ' I =', I + WRITE(6,*) 'CAT=', CAT + WRITE(6,*) 'AN=', AN + WRITE(6,*) 'GAMA=', GAMA + WRITE(6,*) 'MOLNU=',MOLNU + WRITE(6,*) 'PHIMULT=',PHIMULT + endif + !! CALL M3EXIT( PNAME, 0, 0, XMSG, XSTAT2 ) + !emep1.2 call stop_test(.true.,me,NPROC,ios,'##MARS-negat.con') + END IF + +!...compute some essential expressions + + SRI = SQRT( I ) + TWOSRI = 2.0 * SRI + TWOI = 2.0 * I + TEXPV = 1.0 - EXP( -TWOSRI ) * ( 1.0 + TWOSRI - TWOI ) + R = 1.0 + 0.75 * I + S = 1.0 + 1.5 * I + ZOT1 = 0.511 * SRI / ( 1.0 + SRI ) + +!...Compute binary activity coeffs + + FGAMA = -0.392 * ( ( SRI / ( 1.0 + 1.2 * SRI ) & + + ( 2.0 / 1.2 ) * ALOG( 1.0 + 1.2 * SRI ) ) ) + + DO ICAT = 1, NCAT + DO IAN = 1, NAN + + BGAMA( ICAT, IAN ) = 2.0 * BETA0( ICAT, IAN ) & + + ( 2.0 * BETA1( ICAT, IAN ) / ( 4.0 * I ) ) & + * TEXPV + +!...compute the molality of each electrolyte for given ionic strength + + M( ICAT, IAN ) = ( CAT( ICAT )**V1( ICAT, IAN ) & + * AN( IAN )**V2( ICAT, IAN ) )**( 1.0 & + / ( V1( ICAT, IAN ) + V2( ICAT, IAN ) ) ) + +!...calculate the binary activity coefficients + + LGAMA0( ICAT, IAN ) = ( ZP( ICAT ) * ZM( IAN ) * FGAMA & + + M( ICAT, IAN ) & + * ( 2.0 * V1( ICAT, IAN ) * V2( ICAT, IAN ) & + / ( V1( ICAT, IAN ) + V2( ICAT, IAN ) ) & + * BGAMA( ICAT, IAN ) ) & + + M( ICAT, IAN ) * M( ICAT, IAN ) & + * ( 2.0 * ( V1( ICAT, IAN ) & + * V2( ICAT, IAN ) )**1.5 & + / ( V1( ICAT, IAN ) + V2( ICAT, IAN ) ) & + * CGAMA( ICAT, IAN ) ) ) / 2.302585093 + + END DO + END DO + +!...prepare variables for computing the multicomponent activity coeffs + + DO IAN = 1, NAN + DO ICAT = 1, NCAT + ZBAR = ( ZP( ICAT ) + ZM( IAN ) ) * 0.5 + ZBAR2 = ZBAR * ZBAR + Y( IAN, ICAT ) = ZBAR2 * AN( IAN ) / I + X( ICAT, IAN ) = ZBAR2 * CAT( ICAT ) / I + END DO + END DO + + DO IAN = 1, NAN + F1( IAN ) = 0.0 + DO ICAT = 1, NCAT + F1( IAN ) = F1( IAN ) + X( ICAT, IAN ) * LGAMA0( ICAT, IAN ) & + + ZOT1 * ZP( ICAT ) * ZM( IAN ) * X( ICAT, IAN ) + END DO + END DO + + DO ICAT = 1, NCAT + F2( ICAT ) = 0.0 + DO IAN = 1, NAN + F2( ICAT ) = F2( ICAT ) + Y( IAN, ICAT ) * LGAMA0( ICAT, IAN ) & + + ZOT1 * ZP( ICAT ) * ZM( IAN ) * Y( IAN, ICAT ) + END DO + END DO + +!...now calculate the multicomponent activity coefficients + + DO IAN = 1, NAN + DO ICAT = 1, NCAT + + TA = -ZOT1 * ZP( ICAT ) * ZM( IAN ) + TB = ZP( ICAT ) * ZM( IAN ) / ( ZP( ICAT ) + ZM( IAN ) ) + TC = ( F2( ICAT ) / ZP( ICAT ) + F1( IAN ) / ZM( IAN ) ) + TRM = TA + TB * TC + + IF ( TRM > 30.0 ) THEN + GAMA( ICAT, IAN ) = 1.0E+30 + XMSG = 'Multicomponent activity coefficient is >>' + !! if(deb ) WRITE(6,*) XMSG, gama(icat,ian) + ERRMARK=2 + + ELSE + GAMA( ICAT, IAN ) = 10.0**TRM + END IF + + END DO + END DO + + end subroutine actcof +!>-------------------------------------------------------------------------------< + + end module MARS_ml + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..3a1bff7 --- /dev/null +++ b/Makefile @@ -0,0 +1,61 @@ +# +# +PROG = Unimod +################################################### + +include Makefile.SRCS + +################################################### + + +F90_CONFORM_CHECK_ABORT=ON + +################################################### + +LIBS = -lmpi -lnetcdf +INCL = -I/home/u4/mifahik/netcdf/include +LLIB = -L/home/u4/mifahik/netcdf/lib64 + + +F90 = f90 + +F90FLAGS = -64 -r8 -O2 -mieee-fp -ftz -OPT:IEEE_arithm=3:roundoff=3 -TARG:exc_min=0ZV $(INCL) +#F90FLAGS = -64 -r8 -O3 -OPT:IEEE_arithm=3:roundoff=3 -TARG:exc_min=0ZV $(INCL) +#F90FLAGS = -64 -r8 -g -C -DEBUG:trap_uninitialized=ON:verbose_runtime=ON -TARG:exc_min=0ZV $(INCL) +#F90FLAGS = -64 -r8 -g -C -DEBUG:trap_uninitialized=ON:verbose_runtime=ON -DEBUG:conform_check=ON -DEBUG:subscript_check:verbose_runtime=ON -DEBUG:fullwarn=ON -TARG:exc_min=0ZV $(INCL) + +LDFLAGS = -64 -r8 -O2 -mieee-fp -ftz -OPT:IEEE_arithm=3:roundoff=3 -TARG:exc_min=0ZV +#LDFLAGS = -64 -r8 -O 3 -OPT:IEEE_arithm=3:roundoff=3 -TARG:exc_min=0ZV +#LDFLAGS = -64 -r8 -C -g -DEBUG:trap_uninitialized=ON:verbose_runtime=ON -TARG:exc_min=0ZV +#LDFLAGS = -64 -r8 -g -C -DEBUG:trap_uninitialized=ON:verbose_runtime=ON -DEBUG:conform_check=ON -DEBUG:subscript_check:verbose_runtime=ON -DEBUG:fullwarn=ON -TARG:exc_min=0ZV +LD = f90 + + +.SUFFIXES: $(SUFFIXES) .f .f90 + +.f90.o: + $(F90) $(F90FLAGS) -c $< + +.f.o: + $(F90) $(F90FLAGS) -c $< + + +# Include the dependency-list created by makedepf90 below +all: $(PROG) + +include .depend + +#LLIB added, ds +depend .depend: + /home/u4/mifahik/bin/makedepf90 $(SRCS) \ + -o $(PROG) \ + -l "$$(F90) $$(LDFLAGS) $$(LLIB) -o $$(PROG) $$(FOBJ) $$(INCL) $$(LIBS)" > .depend + +clean: + rm -f $(PROG) *.o *.mod .depend; \ + #touch .depend +#make depend + + +########################################################## + diff --git a/Makefile.SRCS b/Makefile.SRCS new file mode 100644 index 0000000..0ff20e9 --- /dev/null +++ b/Makefile.SRCS @@ -0,0 +1,21 @@ +#============================================================================= +SRCS = Aero_Rb_ml.f90 Aero_water_ml.f90 Ammonium_ml.f90 \ + Advection_ml.f90 AirEmis_ml.f90 Aqueous_ml.f90 Biogenics_ml.f90 \ + BoundaryConditions_ml.f90 CellMet_ml.f90 CheckStop_ml.f90 Chem_ml.f90 CoDep_ml.f90 Country_ml.f90 \ + DefPhotolysis_ml.f90 Derived_ml.f90 DO3SE_ml.f90 DryDep_ml.f90 \ + EmisDef_ml.f90 EmisGet_ml.f90 Emissions_ml.f90 Functions_ml.f90 \ + GlobalBCs_ml.f90 GridAllocate_ml.f90 GridValues_ml.f90 \ + Io_ml.f90 Io_Nums_ml.f90 Io_Progs_ml.f90 KeyValue_ml.f90 LandDefs_ml.f90 Landuse_ml.f90 \ + LocalVariables_ml.f90 MassBudget_ml.f90 \ + Met_ml.f90 EQSAM_ml.f90 MARS_ml.f90 MicroMet_ml.f90 ModelConstants_ml.f90 My_Aerosols_ml.f90 \ + My_BoundConditions_ml.f90 My_Chem_ml.f90 My_Derived_ml.f90 \ + My_DryDep_ml.f90 My_Emis_ml.f90 My_MassBudget_ml.f90 \ + My_Outputs_ml.f90 My_WetDep_ml.f90 N2O5_hydrolysis_ml.f90 NetCDF_ml.f90 \ + Nest_ml.f90 Output_hourly.f90 OutputChem_ml.f90 Par_ml.f90 \ + PhysicalConstants_ml.f90 Radiation_ml.f90 Rb_ml.f90 \ + ReadField_ml.f90 Rsurface_ml.f90 Runchem_ml.f90 SOA_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 Timefactors_ml.f90 Timing_ml.f90 \ + Trajectory_ml.f90 Unimod.f90 Volcanos_ml.f90 Wesely_ml.f90 \ + global2local.f90 local2global.f90 PhyChem_ml.f90 diff --git a/Makefile_njord b/Makefile_njord new file mode 100755 index 0000000..e21507e --- /dev/null +++ b/Makefile_njord @@ -0,0 +1,53 @@ +# +# +PROG = Unimod + +################################################### + +include Makefile.SRCS + +################################################### + +LIBS = -lnetcdf +INCL = -I/home/ntnu/usrlocal/netcdf/netcdf-3.6.1/include +LLIB = -L/home/ntnu/usrlocal/netcdf/netcdf-3.6.1/lib -L/usr/lib + +F90 = mpxlf90_r +F90FLAGS = -q64 -qrealsize=8 -O3 -qarch=pwr5 -qtune=pwr5 $(INCL) +LDFLAGS = -q64 -qrealsize=8 -O3 -qarch=pwr5 -qtune=pwr5 + + +LD = $(F90) + + +.SUFFIXES: $(SUFFIXES) .f90 + +.f90.o: + $(F90) $(F90FLAGS) -c $< + +.f.o: + $(F90) $(F90FLAGS) -c $< + + +# Include the dependency-list created by makedepf90 below +all: $(PROG) + +include .depend + +# +depend .depend: + /home/ntnu/mifahik/local/bin/makedepf90 $(SRCS) \ + -o $(PROG) \ + -l "$(F90) $(LDFLAGS) $(LLIB) -o $(PROG) $(FOBJ) $(INCL) $(LIBS)" > .depend + +clean: diskclean touchdepend depend + +diskclean: + rm -f $(PROG) *.o *.mod + +touchdepend: + touch .depend + + +########################################################## + diff --git a/Makefile_snow b/Makefile_snow new file mode 100644 index 0000000..325a8be --- /dev/null +++ b/Makefile_snow @@ -0,0 +1,51 @@ +# +# +PROG = Unimod +################################################### + +include Makefile.SRCS + +################################################### + +LIBS = -lnetcdf +INCL = -I/usr/include/netcdf-3 +LLIB = -L/usr/lib/netcdf-3 + + +F90 = scampif90 + +#LDFLAGS = -r8 -debug-parameters all -traceback -ftrapuv -g -fpe0 -O0 -convert big_endian -IPF_fp_relaxed $(INCL) +#LDFLAGS = -r8 -O3 -convert big_endian -IPF_fp_relaxed +LDFLAGS = -r8 -O2 -mieee-fp -ftz -convert big_endian -IPF_fp_relaxed +F90FLAGS = $(LDFLAGS) $(INCL) + + +LD = scampif90 + + +.SUFFIXES: $(SUFFIXES) .f90 + +.f90.o: + $(F90) $(F90FLAGS) -c $< + + +# Include the dependency-list created by makedepf90 below +all: $(PROG) + +include .depend + +# +depend .depend: + /home/mifapw/bin/makedepf90 $(SRCS) \ + -o $(PROG) \ + -l "$(F90) $(LDFLAGS) $(LLIB) -o $(PROG) $(FOBJ) $(INCL) $(LIBS)" > .depend + +clean: diskclean touchdepend depend + +diskclean: + rm -f $(PROG) *.o *.mod + +touchdepend: + touch .depend +########################################################## + diff --git a/Makefile_stallo b/Makefile_stallo new file mode 100755 index 0000000..e9f639e --- /dev/null +++ b/Makefile_stallo @@ -0,0 +1,50 @@ +# +# +PROG = Unimod +################################################### + +include Makefile.SRCS + +################################################### + +LIBS = -lnetcdf +INCL = -I/global/apps/netcdf/3.6.2/include +LLIB = -L/global/apps/netcdf/3.6.2/lib + + +F90 = mpif90 + +#LDFLAGS = -shared-intel -r8 -debug-parameters all -traceback -ftrapuv -g -fpe0 -O0 -convert big_endian -IPF_fp_relaxed $(INCL) +LDFLAGS = -shared-intel -r8 -O3 -mieee-fp -ftz -convert big_endian -IPF_fp_relaxed +F90FLAGS = $(LDFLAGS) $(INCL) + + +LD = mpif90 + + +.SUFFIXES: $(SUFFIXES) .f90 + +.f90.o: + $(F90) $(F90FLAGS) -c $< + + +# Include the dependency-list created by makedepf90 below +all: $(PROG) + +include .depend + +# +depend .depend: + /home/mifapw/bin/makedepf90 $(SRCS) \ + -o $(PROG) \ + -l "$(F90) $(LDFLAGS) $(LLIB) -o $(PROG) $(FOBJ) $(INCL) $(LIBS)" > .depend + +clean: diskclean touchdepend depend + +diskclean: + rm -f $(PROG) *.o *.mod + +touchdepend: + touch .depend +########################################################## + diff --git a/MassBudget_ml.f90 b/MassBudget_ml.f90 new file mode 100644 index 0000000..56cafd6 --- /dev/null +++ b/MassBudget_ml.f90 @@ -0,0 +1,446 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 MassBudget_ml + +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! DESCRIPTION +! Routine to cross check the mass balance of the model +! Cleanup, May 2007, SV +! 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 My_DryDep_ml, only : NDRYDEP_ADV, Dep + use My_MassBudget_ml,only : MY_MASS_PRINT ! Species to be printed + + use GenChemicals_ml, only : species ! species identifier + use GenSpec_adv_ml, only : NSPEC_ADV ! No. species (long-lived) + use GenSpec_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 Met_ml , only : ps ! surface pressure + use ModelConstants_ml, & + only : KMAX_MID & ! Number of levels in vertical + ,NPROC & ! No. processors + ,PT & ! Pressure at top + ,ATWAIR ! Mol. weight of air(Jones,1992) + use Par_ml, only : MAXLIMAX & + ,MAXLJMAX & + ,li0,li1 & + ,lj0,lj1 & + ,me & + ,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) + +! 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 + + logical, private, parameter :: DEBUG = .false. + + public :: Init_massbudget + public :: massbudget + 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 + 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(me == 0)then + do n = 1,NSPEC_ADV + if(sumint(n) > 0. ) then + write(IO_RES,"(a15,i2,4x,e10.3)") "Initial mass",n,sumint(n) + write(6,"(a15,i2,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 :: ispec, ifam ! Species and family index + real, dimension(NSPEC_ADV,KMAX_MID) :: sumk ! total mass in each layer + character(len=12) :: spec_name ! Species name + integer, parameter :: NFAMILIES = 3 ! No. of families + character(len=8), dimension(NFAMILIES), save :: family_name = & + (/ "Sulphur ", "Nitrogen", "Carbon " /) + integer ispec_name + + 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 + ! be one) 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,ammfac, 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(:) + + + sumk(:,:) = 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 + + enddo + 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 +! 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) + 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 (me == 0 ) then + + do n = 1,NSPEC_ADV + if (gtotem(n) > 0.0 ) 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. + + 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 (me == 0) then ! printout from node 0 + + !/.. now use species array which is set in My_MassBudget_ml + + do nn = 1,size ( MY_MASS_PRINT ) + + write(6,*) + write(IO_RES,*) + n = MY_MASS_PRINT(nn) + 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 nn = 1,size ( MY_MASS_PRINT ) + n = MY_MASS_PRINT(nn) + + 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,*)'++++++++++++++++++++++++++++++++++++++++++++++++' + + enddo +! + + end if ! me = 0 + + end subroutine massbudget + + + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine DryDep_Budget(i,j,Loss,convfac) + !use GenSpec_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 = Dep(n)%adv + totddep( nadv ) = totddep (nadv) + DryLoss(nadv) + + enddo + end subroutine DryDep_Budget + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + end module MassBudget_ml +!-------------------------------------------------------------------------- diff --git a/Met_ml.f90 b/Met_ml.f90 new file mode 100644 index 0000000..a5eeb32 --- /dev/null +++ b/Met_ml.f90 @@ -0,0 +1,3812 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + +module Met_ml + + ! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + ! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + !_____________________________________________________________________________ + + + + use CheckStop_ml, only : CheckStop + use Functions_ml, only : Exner_tab, Exner_nd + use GridValues_ml, only : xmd, i_fdom, j_fdom, METEOfelt, projection & + ,gl,gb, gb_glob, gl_glob, MIN_ADVGRIDS & + ,Poles, xm_i, xm_j, xm2, sigma_bnd,sigma_mid & + ,xp, yp, fi, GRIDWIDTH_M,ref_latitude & + ,GlobalPosition,DefGrid + use ModelConstants_ml, only : PASCAL, PT, CLOUDTHRES, METSTEP & + ,KMAX_BND,KMAX_MID,NMET & + ,IIFULLDOM, JJFULLDOM, NPROC & + ,DEBUG_i, DEBUG_j, identi, V_RAIN, nmax & + ,nstep + use Par_ml , only : MAXLIMAX,MAXLJMAX,GIMAX,GJMAX, me & + ,limax,ljmax,li0,li1,lj0,lj1 & + ,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 + use PhysicalConstants_ml, only : KARMAN, KAPPA, R, 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 + use Io_ml , only : IO_INFIELD, ios, IO_SNOW, IO_ROUGH, open_file + use ReadField_ml, only : ReadField ! reads ascii fields + use netcdf + + + + implicit none + private + + + + + !----------------- basic met fields ----------------------------------! + ! Here we declare the metoeorlogical fields used in the model ! + ! From old eulmc.inc=eulmet.inc + !---------------------------------------------------------------------! + ! + ! + ! Vertical levels: z_mid, z_bnd, sigma_mid, sigma_bnd + !============================================================================= + !* "mid" and "bnd" are used as suffixes on z and sigma as shown in + !* the sketch below. "bnd" is the boundary between two layers and + !* "mid" the midddle of the layer. The numbering of layers starts + !* from 1 at the surface. + !* + !* + !* + !* --------------------------- + !* + !* + !* - - - - - - - - - - - - KMAX_MID -1 + !* + !* + !* -------------------------- KMAX_BDN-1 (z_bnd) (sigma_bnd) + !* + !* + !* - - - - - - - - - KMAX_MID(old kmax2) = 20 (z_mid) (sigma_mid) (old z2) + !* + !* ------------------------ KMAX_BND = 21 (z_bnd) (old z1) + !* \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ surface \\\\\\\\\\\\\\\\ + !* + + + + INCLUDE 'mpif.h' + INTEGER MPISTATUS(MPI_STATUS_SIZE),INFO + + + ! 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) + ! + real,public, save, dimension(0:MAXLIMAX,MAXLJMAX,KMAX_MID,NMET) :: u ! m/s + real,public, save, dimension(MAXLIMAX,0:MAXLJMAX,KMAX_MID,NMET) :: v ! m/s + real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_BND,NMET) :: sdot ! dp/dt + + real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID,NMET) :: & + th & ! Potential teperature ( deg. k ) + ,q ! Specific humidity + + + ! since pr,cc3d,cc3dmax used only for 1 time layer - define without NMET + real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: & + pr & ! Precipitation + ,cc3d & ! 3-d cloud cover (cc3d), + ,cc3dmax & ! and maximum for layers above a given layer + ,lwc & !liquid water content + ,sst ! SST Sea Surface Temprature- ONLY from 2002 + + + + ! surface fields + real,public, save, dimension(MAXLIMAX,MAXLJMAX,NMET) :: & + ps & ! Surface pressure hPa (or Pa- CHECK!) + ,t2_nwp & ! Temp 2 m deg. K + ,fh & ! surf.flux.sens.heat W/m^2 + ,fl & ! latent heat flux W/m^2 + ,tau & ! surf. stress N/m^2 + ! These fields only available for EMEP from 2002 on + ,rh2m & ! RH at 2m + ,SoilWater&! Upper 7.2cm + ,SoilWater_deep ! Next 6x7cm + + + + + + + ! Fields below are derived/calculated from the input meteorological fields + + real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_BND,NMET) :: skh + real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID,NMET) :: roa ! kg/m^3 + real,public, save, dimension(MAXLIMAX,MAXLJMAX) :: & + surface_precip & ! Surface precip mm/hr + ,u_ref !wind speed + + + real,public, save, dimension(MAXLIMAX,MAXLJMAX) :: & + rho_surf & ! Surface density + ,Tpot2m & ! Potential temp at 2m + ,ustar_nwp ! friction velocity m/s ustar^2 = tau/roa + + 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 + + integer,public, save, dimension(MAXLIMAX,MAXLJMAX) :: & + snow ! monthly snow (1=true), read in MetModel_LandUse + + + logical,public, save, dimension(MAXLIMAX,MAXLJMAX) :: & + nwp_sea ! Sea in NWP mode, determined in HIRLAM from roughness class + + logical, private, parameter :: MY_DEBUG = .false. + logical, private, save :: debug_proc = .false. + integer, private, save :: debug_iloc, debug_jloc ! local coords + + logical, public, save :: foundustar ! Used for MM5-type, where u* but + ! not tau + logical, public, save :: foundsdot ! If not found: compute using + ! divergence=0 + logical, public, save :: sdot_at_mid ! set false if sdot is defined + logical, public, save :: foundSST ! false if no SeaSurfaceT in metdata + + ! (when read) at level boundaries + ! and therefore do not need to be + ! interpolated. + + ! for tiphys + !check dimension + real,public, save, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: & + xksig ! estimated exchange coefficient, Kz, in intermediate + ! sigma levels, m2/s + + real,public, save, dimension(MAXLIMAX,MAXLJMAX) :: & + pzpbl, & !stores H(ABL) for averaging and plotting purposes, m + Kz_min ! Min Kz below hmix !hf Hilde&Anton + + + + + ! temnporary placement of solar radiation variations + + real, public, dimension(MAXLIMAX, MAXLJMAX), save:: & + zen & ! Zenith angle (degrees) + ,coszen=0.0 & ! cos of zenith angle + ,Idiffuse & ! diffuse solar radiation (W/m^2) + ,Idirect ! total direct solar radiation (W/m^2) + + integer, public :: startdate(4) + 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 + ! (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 + + + + public :: MeteoGridRead + public :: infield,MeteoRead + public :: MetModel_LandUse + public :: metvar + public :: metint + public :: tiphys + + + +contains + + + + + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine MeteoRead(numt) + + ! the subroutine reads meteorological fields and parameters (every + ! METSTEP-hours) from NetCDF fields-files, divide the fields into + ! domains and sends subfields to the processors + + + implicit none + + integer, intent(in):: numt + + character (len = 100), save :: meteoname ! name of the meteofile + character (len = 100) :: namefield & ! name of the requested field + ,validity ! field is either instaneous + ! or averaged + integer :: ndim,nyear,nmonth,nday,nhour,k + integer :: nr ! Fields are interpolate in + ! time (NMET = 2): between + ! nr=1 and nr=2 + + + type(date) :: next_inptime ! hfTD,addhours_to_input + type(timestamp) :: ts_now ! time in timestamp format + + + real :: nsec ! step in seconds + + + + + + if( METEOfelt==1)then + call infield(numt) + return + endif + + nr=2 !set to one only when the first time meteo is read + + + + if(numt == 1)then !first time meteo is read + nr = 1 + sdot_at_mid = .false. + foundustar = .false. + foundsdot = .false. + foundSST = .false. + + next_inptime = current_date + + ! If origin of meteodomain does not coincide with origin of large domain, + ! xp and yp should be shifted here, and coordinates must be shifted when + ! meteofields are read (not yet implemented) + + + + else + + nsec=METSTEP*3600.0 !from hr to sec + ts_now = make_timestamp(current_date) + call add_secs(ts_now,nsec) + next_inptime=make_current_date(ts_now) + + + endif + + + + + nyear=next_inptime%year + nmonth=next_inptime%month + + nday=next_inptime%day + nhour=next_inptime%hour + + if( current_date%month == 1 .and. & + current_date%day == 1 .and. & + current_date%hour == 0 ) & + call Init_nmdays( current_date ) + + + + if(me == 0 .and. MY_DEBUG) write(6,*) & + '*** nyear,nmonth,nday,nhour,numt,nmdays2' & + ,next_inptime%year,next_inptime%month,next_inptime%day & + ,next_inptime%hour,numt,nmdays(2) + + + ! Read rec=1 in case 00:00 from 1st January is missing + if((numt-1)*METSTEP<=nhour_first)nrec=0 + nrec=nrec+1 + + + + + + if(nrec>Nhh.or.nrec==1) then ! define a new meteo input file +56 FORMAT(a5,i4.4,i2.2,i2.2,a3) + write(meteoname,56)'meteo',nyear,nmonth,nday,'.nc' + if(me==0)write(*,*)'reading ',trim(meteoname) + nrec = 1 + !could open and close file here instead of in Getmeteofield + endif + + + if(me==0 .and. MY_DEBUG) write(*,*)'nrec,nhour=',nrec,nhour + + + + ! 3D fields (i,j,k) + ndim=3 + + !note that u and v have dimensions 0:MAXLIJMAX instead of 1:MAXLIJMAX + !u(i=0) and v(j=0) are set in metvar + + namefield='u_wind' + call Getmeteofield(meteoname,namefield,nrec,ndim, & + validity,u(1:MAXLIMAX,1:MAXLJMAX,:,nr)) + + namefield='v_wind' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity,v(1:MAXLIMAX,1:MAXLJMAX,:,nr)) + + namefield='specific_humidity' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, q(:,:,:,nr)) + + namefield='sigma_dot' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, sdot(:,:,:,nr)) + foundsdot = .true. + + namefield='potential_temperature' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, th(:,:,:,nr)) + + namefield='precipitation' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, pr(:,:,:)) + + namefield='3D_cloudcover' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, cc3d(:,:,:)) + + if(trim(validity)/='averaged')then + if(me==0)write(*,*)'WARNING: 3D cloud cover is not averaged' + endif + + + + + ! 2D fields (surface) (i,j) + ndim=2 + + namefield='surface_pressure' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, ps(:,:,nr)) + + namefield='temperature_2m' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, t2_nwp(:,:,nr)) + + namefield='surface_flux_sensible_heat' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, fh(:,:,nr)) + if(validity=='averaged')fh(:,:,1)=fh(:,:,nr) + + namefield='surface_flux_latent_heat' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, fl(:,:,nr)) + if(validity=='averaged')fl(:,:,1)=fl(:,:,nr) + + namefield='surface_stress' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, tau(:,:,nr)) + tau=max(0.0,tau) + if(validity=='averaged')tau(:,:,1)=tau(:,:,nr) + + namefield='sea_surface_temperature' + call Getmeteofield(meteoname,namefield,nrec,ndim,& + validity, sst(:,:,nr)) + foundSST = .true. +!.. Note: this foudSST test doesn't work for NetCDF meteorology yet +!.. The model will crash if SST is not in the met.file + + 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 :: ndim,nyear,nmonth,nday,nhour,k + + character (len = 100),save :: meteoname !name of the meteofile + + + + + if( METEOfelt==1)then + cyclicgrid=0 + poles=0 + GRIDWIDTH_M=50000.0 + call infield(1)!to get sigma_mid etc + call DefGrid() + return + endif + + 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(me==0)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( METEOfelt==1) then + cyclicgrid=0 + poles=0 + GRIDWIDTH_M=50000.0 + call infield(1) + call DefGrid() + return + endif + + if(me==0 .and. MY_DEBUG)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 infield(numt) + + + !pw + ! NB: This routine may disapear in later versions + ! + ! the subroutine reads meteorological fields and parameters every + ! six-hour from fields-files, divide the fields into domains + ! and sends subfields to the processors using nx calls + + + implicit none + + integer, intent(in):: numt + + + + ! local + + integer ierr, fid, nr, i, j, k, ij + integer nyear, nmonth, nday, nhour, nprognosis + + integer, dimension(20) :: ident + integer*2, dimension(21+MAXLIMAX*MAXLJMAX) :: itmp + + character*20 fname + + type(date) addhours_to_input + type(date) next_inptime, buf_date + + type(timestamp)::ts_now ! time in timestamp format + + real, dimension(MAXLIMAX,MAXLJMAX) :: dumhel + real, dimension(20) :: xrand + + real :: nsec ! step in seconds + + + + + ! definition of the parameter number of the meteorological variables + ! read from field-files: + + ! + ! u(2),v(3),q(9),sdot(11),th(18),cw(22),pr(23),cc3d(39), + ! ps(8),t2_nwp(31),fh(36),fl(37),tau(38),ustar(53),trw(845), sst(103) + ! Meteorology available from year 2002 in EMEP files: + ! rh2m(32), SWC(85, first 7.2cm), + ! SWCdeep(86, in the following 6x7.2cm = 43.2 cm)) + + + + + projection='Stereographic' + + nr=2 + if(numt == 1)then + nr = 1 + u = 0.0 + v = 0.0 + endif + + + + + + !*********************** + if(me.eq.0) then + !*********************** + + fid=IO_INFIELD + fname='filxxxx' + + write(fname,fmt='(''fil'',i4.4)') numt + + open (fid,file=fname & + ,form='unformatted',access='sequential' & + ,status='old',iostat=ios) + + call CheckStop(ios, "Error opening infield in Met_ml" // fname) + + ierr=0 + + endif ! me == 0 + + + + + sdot_at_mid = .true. + foundustar = .false. + foundsdot = .true. + foundSST = .false. + + + + do while(.true.) + !! do while(ierr /= 2) + + call getflti2Met(fid,ident,itmp,ierr) + if(ierr == 2)goto 998 + + k = ident(7) + + if (ident(6) .eq. 2.and.k.eq.1)then + + nyear=ident(12) + nmonth=ident(13)/100 + nday=ident(13)-(ident(13)/100)*100 + nhour=ident(14)/100 + + if(ident(17)>0.0)then + xp = ident(15)/100. + yp = ident(16)/100. + else + xp = ident(15)/1. + yp = ident(16)/1. + endif + + fi = ident(18) + if(ident(2).eq.1841)then + GRIDWIDTH_M = 50000.0 ! =~ 1000.*abs(ident(17))/10. + else + GRIDWIDTH_M = 1000.*abs(ident(17))/10. + if(me==0 .and. MY_DEBUG)write(*,*)'GRIDWIDTH_M=' ,GRIDWIDTH_M ,& + 'AN= ',6.370e6*(1.0+0.5*sqrt(3.0))/GRIDWIDTH_M + endif + + + if(ident(2).eq.1600)then + xp = 41.006530761718750 !=~ ident(15) + yp = 3234.5815429687500 !=~ ident(16) + fi = 10.50000 ! =~ ident(18) + if(me==0 .and. MY_DEBUG)write(*,*)ident(15),ident(16),ident(18),xp,yp,fi + endif + nprognosis = ident(4) + + identi(:)=ident(:) + + !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + ! + !..hj..ko + !.. the name of the fltqhh.yymmdd-file input contains the "ifelt" + !.. time parameters of the analysis, thus the 3 hour prognosis + !.. data are valid 9-12 hours later!!!! + ! + !vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv + + !pw use nprognosis=ident(4) for determining the date of the prognosis + + + if(numt == 1) then !!! initialise + current_date = date(nyear, nmonth, nday, nhour, 0 ) + call Init_nmdays( current_date ) + nsec= nprognosis*3600.0 + ts_now=make_timestamp(current_date) + call add_secs(ts_now,nsec) + current_date=make_current_date(ts_now) + + ! if we start 1. of January, then nyear is the year before + ! so we have to rerun Init_nmdays! + + if(current_date%year.ne.nyear) & + call Init_nmdays( current_date ) + + ! for printout assign current_date to next_inptime! + + + next_inptime = current_date !hfTD ?? Can this be done? + !Why add_dates before?? + + else + + ! find time for which meteorology is valid: + + next_inptime = date(nyear, nmonth, nday, nhour, 0 ) + nsec= nprognosis*3600.0 + ts_now=make_timestamp(next_inptime) + call add_secs(ts_now,nsec) + next_inptime=make_current_date(ts_now) + + ! compare the input time with current_date, + ! it should be METSTEP hours later + ! check if current_date+METSTEP = next_inptime + + nsec= METSTEP*3600.0 + ts_now=make_timestamp(current_date) + call add_secs(ts_now,nsec) + buf_date=make_current_date(ts_now) + + + ! now check: + + call CheckStop(buf_date%year, next_inptime%year, & + "In infield: wrong next input year") + call CheckStop(buf_date%month, next_inptime%month, & + "In infield: wrong next input month") + call CheckStop(buf_date%day, next_inptime%day, & + "In infield: wrong next input day") + call CheckStop(buf_date%hour, next_inptime%hour, & + "In infield: wrong next input hour") + call CheckStop(buf_date%seconds,next_inptime%seconds,& + "In infield: wrong next input seconds") + + + ! now the last check, if we have reached a new year, i.e. current date + ! is 1.1. midnight, then we have to rerun Init_nmdays + + if( current_date%month == 1 .and. & + current_date%day == 1 .and. & + current_date%hour == 0 ) & + call Init_nmdays( current_date ) + + end if ! numt + + if(me == 0 .and. MY_DEBUG) write(6,*) & + '*** nyear,nmonth,nday,nhour,numt,nmdays2,nydays' & + ,next_inptime%year,next_inptime%month,next_inptime%day & + ,next_inptime%hour,numt,nmdays(2),nydays + + endif + + + + select case (ident(6)) + + case (2) + + sigma_mid(k)=ident(19)/1.0e+4 + + call getmetfieldMet(ident(20),itmp,dumhel) + + do j = 1,ljmax + do i = 1,limax + u(i,j,k,nr) = dumhel(i,j)-1.E-9 ! the "-1.E-9" is included + ! in order to avoid possible + ! different roundings on + ! different machines. + enddo + enddo + + + + case (3) + + call getmetfieldMet(ident(20),itmp,dumhel) + + do j = 1,ljmax + do i = 1,limax + v(i,j,k,nr) = dumhel(i,j)-1.E-9 ! the "-1.E-9" is included + ! in order to avoid possible + ! different roundings on + ! different machines. + enddo + enddo + + case (9) + + call getmetfieldMet(ident(20),itmp,q(1,1,k,nr)) + + case (11) + + call getmetfieldMet(ident(20),itmp,sdot(1,1,k,nr)) + + case (-11) !pw (not standard convention) + + call getmetfieldMet(ident(20),itmp,sdot(1,1,k,nr)) + + sdot_at_mid = .false. + + case (810) !pw u3 MM5 SIGMADOT + + call getmetfieldMet(ident(20),itmp,sdot(1,1,k,nr)) + + case (18) + + call getmetfieldMet(ident(20),itmp,th(1,1,k,nr)) + + ! case (22) + ! + ! call getmetfield(ident(20),itmp,cw(1,1,k,nr)) + + ! case (26) !ASSYCON + ! call getmetfield(ident(20),itmp,ccc(1,1,k,nr)) !ASSYCON + + case (23) + + call getmetfieldMet(ident(20),itmp,pr(1,1,k)) + + ! case (845) ! pw u3 MM5 TOTALRW + ! + ! call getmetfield(ident(20),itmp,trw(1,1,k)) + + case (39) + + call getmetfieldMet(ident(20),itmp,cc3d(1,1,k)) + + !..2D fields! + + case (8) + + call getmetfieldMet(ident(20),itmp,ps(1,1,nr)) + + case (31) + + call getmetfieldMet(ident(20),itmp,t2_nwp(1,1,nr)) + ! NEWMET: + ! rh2m(32), SWC(85, first 7.2cm), SWCdeep(86, in the following + ! 6x7.2cm = 43.2 cm)) + case (32) + rh2m(:,:,nr) = 0.0 + call getmetfieldMet(ident(20),itmp,rh2m(1,1,nr)) + case (85) + SoilWater(:,:,nr) = 0.0 + call getmetfieldMet(ident(20),itmp,SoilWater(1,1,nr)) + case (86) + SoilWater_deep(:,:,nr) = 0.0 + call getmetfieldMet(ident(20),itmp,SoilWater_deep(1,1,nr)) + + + case (36) + + call getmetfieldMet(ident(20),itmp,fh(1,1,nr)) + + case (37) + + call getmetfieldMet(ident(20),itmp,fl(1,1,nr)) + + case (38) + + call getmetfieldMet(ident(20),itmp,tau(1,1,nr)) + + case (53) + + foundustar = .true. + call getmetfieldMet(ident(20),itmp,ustar_nwp(1,1)) + + case (103) ! SST + + foundSST = .true. + call getmetfieldMet(ident(20),itmp,sst(1,1,nr)) + + + end select + + enddo + +998 continue + + ! definition of the half-sigma levels from the full levels. + + + end subroutine infield + + + + + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + + + + + + subroutine getflti2Met(ifile,ident,itmp,ierr) + + ! NB: This routine may disapear in later versions + + !fpp$ noconcur r + ! + ! 16 bit input and unpack + ! + ! input: + ! mode: 0 = read field is now hardcoded + ! 1 = read field, skip fields until time > itime + ! 2 = read field if field time = itime + ! (otherwise next read starts at the same field) + ! 100 = read field identification + ! (next read starts at the same field) + ! 101 = read field identification, skip fields + ! until time > itime + ! (next read starts at the same (last) field) + ! 102 = read field identification, skip fields + ! until time >= itime + ! (next read starts at the same (last) field) + ! 200 = scan rest of the file and read field with + ! matching identification, specified identification + ! input in ident(1:20) where -32767 means any value + ! 201 = scan the whole file and read field with + ! matching identification, specified identification + ! input in ident(1:20) where -32767 means any value + ! -1 = clean up after a file is closed, and the same + ! file unit no. is used for another file. + ! ifile: file unit no. + ! MFSIZEINPUT: length of fdata (max field size) + ! + ! output: + ! ident(20): field identification + ! fdata(..): field (unscaled, according to identification) + ! ierr = 0: read o.k. + ! 1: read error + ! 2: read error, end_of_file + ! + ! + ! warning: using file unit no. (not file name) to identify + ! files when storing field identification. + ! if more than one file is opened with the same + ! unit, use 'call getflt(-1,...)' after closing + ! a file to avoid errors. + ! + ! computer dependant i/o methodes for: + ! 1) computer='cray' (integer*2 not available) + ! 2) computer='not.cray' (integer*2 used) + ! + ! dnmi/fou 19.08.1993 anstein foss + ! + ! + ! modified by Peter Wind 11.03.2002: + ! uses nx=ident(10) (read from file) as first dimension of array, + ! instead of IIFULLDOM. (only modified for not _CRAY) + ! + + implicit none + + integer d,i,j,info + + ! MAXPK4: max record length in cray 64 bit integer words + + integer, parameter :: NUMHOR4 = MAXLIMAX*MAXLJMAX + integer, parameter :: MAXPK4 = IIFULLDOM*JJFULLDOM + + integer ida,itp + integer*2 idpack(20) + integer*2 ipack(21+MAXPK4) + integer*2 itmp(21+NUMHOR4) + + + ! input/output + integer ifile,ident(20),ierr,iteserr + ! + ! + ! cray uses ipack as a standard length integer + ! + ! + ! + integer isave,nsave,ios,ierror + integer nxin,nyin,nword,npack + + ierr = 0 + iteserr = 0 + + if(me.eq.0)then + + ipack(1) = 0 + + call CheckStop(ifile < 1, "ifile<1 in Met_ml") + call CheckStop(ifile > 99, "ifile>99 in Met_ml") + + endif + + if(me == 0)then + ! a) read field identification (one record) + ! b) read field data (one record) + ! + ! + + read(ifile,iostat=ios) (idpack(i),i=1,20) + if ( ios < 0 ) ierr = 2 ! End of file + call CheckStop( ios > 0 , "**getflt** read error 1 " ) + + do i=1,20 + ident(i)=idpack(i) + ipack(i+1)=idpack(i) + end do + + ! + ! not using extra geometry identification (after field data) + if(ident(9).gt.999) ident(9)=ident(9)/1000 + + nxin=ident(10) + nyin=ident(11) + nword=nxin*nyin + + if(nword.gt.MFSIZEINP) then + write(6,*) ' **getflt** field length too big', & + ' (input buffer MFSIZEINP too small)' + write(6,*) ' ** MFSIZEINP = ',MFSIZEINP + write(6,*) ' ** ident: ',(ident(i),i=1,11) + write(6,*) ' ** ',(ident(i),i=12,20) + write(6,*) ' ** nx,ny,nx*ny: ',nxin,nyin,nword + ierr=1 + iteserr = 1 + + else + npack=nword + read(ifile,iostat=ios) (ipack(i),i=22,npack+21) + + if ( ios < 0 ) ierr = 2 ! End of file is allowed. Therefore + ! check ios > 0 in Checkstop + call CheckStop( ios > 0 , "**getflt** read error 2 " ) + + endif + endif + + call CheckStop(ierr==1, "getflti2ex in Met_ml") + + + + if(me.eq.0)then + + if(ierr.eq.2)then ! end of file + ipack(1) = -999 + do d = 1, NPROC-1 + + CALL MPI_SEND(ipack,2*(21+NUMHOR4),MPI_BYTE,d,MSG_INIT3 & + ,MPI_COMM_WORLD,INFO) + + enddo + close(ifile) + return + endif + + + + + !.... scaling is done within the getflti2 subroutine!!!!!!!! + ! + if (ident(1) .ne. 88) then + write(6,*) 'ERROR IN INFIELD : produsent =',ident(1) + endif + ! + if (ident(2) .ne. 1841.and. ident(2) .ne. 1600) then + write(6,*) 'ERROR IN INFIELD : grid =',ident(2) + endif + ! + + + do i=1,21 + itmp(i) = ipack(i) + enddo + do d = 1, NPROC-1 + ida = 21 + itp = 21+(tgj0(d)+JRUNBEG-2)*ipack(11) + tgi0(d)+IRUNBEG-2 + do j = 1,tljmax(d) + do i = 1,tlimax(d) + itmp(ida+i) = ipack(itp+i) + enddo + ida = ida + MAXLIMAX + itp = itp + ipack(11) + enddo + CALL MPI_SEND(itmp,2*(21+NUMHOR4),MPI_BYTE,d,MSG_INIT3 & + ,MPI_COMM_WORLD,INFO) + enddo + ida = 21 + itp = 21+(JRUNBEG-1)*ipack(11) + IRUNBEG-1 + do j = 1,ljmax + do i = 1,limax + itmp(ida+i) = ipack(itp+i) + enddo + ida = ida + MAXLIMAX + itp = itp + ipack(11) + enddo + + + + else + + ! me.ne.0, always receive to get itmp(1) + + + CALL MPI_RECV( itmp, 2*(21+NUMHOR4), MPI_BYTE, 0, & + MSG_INIT3, MPI_COMM_WORLD,MPISTATUS, INFO) + + if(itmp(1).eq.-999)then + ierr = 2 + return + endif + + do i=1,20 + ident(i) = itmp(i+1) + enddo + + endif + + end subroutine getflti2Met + + + + + + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + + + + subroutine getmetfieldMet(ident,itmp,array) + + + ! NB: This routine may disapear in later versions + + implicit none + + integer NUMHOR4 + integer i + integer ident + + parameter (NUMHOR4=MAXLIMAX*MAXLJMAX) + integer*2 itmp(21+NUMHOR4) + + real scale + real array(MAXLIMAX*MAXLJMAX) + + scale = 10.**ident + + + do i = 1,MAXLIMAX*MAXLJMAX + array(i) = scale * itmp(i+21) + enddo + + + return + end subroutine getmetfieldMet + + + + + + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine metvar(numt) + + ! This routines postprocess the meteo fields: + ! Unit changes, special definitions etc... + + + implicit none + + integer, intent(in):: numt + + ! local + + real, dimension(KMAX_MID) :: prhelp & + ,exf2 + real, dimension(KMAX_BND) :: exf1 + + real, dimension(MAXLJMAX,KMAX_MID) :: usnd ! send in x + real, dimension(MAXLIMAX,KMAX_MID) :: vsnd ! and in y direction + real, dimension(MAXLJMAX,KMAX_MID) :: urcv ! rcv in x + real, dimension(MAXLIMAX,KMAX_MID) :: vrcv ! and in y direction + + real bm, cm, dm, divt, x1,x2, xkmin, p1, p2, uvh2, uvhs + real ri, z00, a2, cdh, fac, fac2, ro, xkh, dvdz, dvdzm, xlmix + real ric, arg, sl2,dz2k,dex12 + real prhelp_sum + real inv_METSTEP + + integer :: i, j, k, lx1,lx2, nr,info + integer request_s,request_n,request_e,request_w + + + + + nr = 2 + if (numt.eq.1) then + + nr = 1 + + !------------------------------------------------------------------- + ! Initialisations: + + call Exner_tab() + + ! Look for processor containing debug coordinates + debug_iloc = -999 + debug_jloc = -999 + + do i = 1, limax + do j = 1, ljmax + if (MY_DEBUG .and. & + 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) + !------------------------------------------------------------------- + + end if + + + divt = 1./(3600.0*METSTEP) + + + if (neighbor(EAST) .ne. NOPROC) then + do k = 1,KMAX_MID + do j = 1,ljmax + usnd(j,k) = u(limax,j,k,nr) + enddo + enddo +! CALL MPI_SEND( usnd, 8*MAXLJMAX*KMAX_MID, MPI_BYTE, & +! neighbor(EAST), MSG_WEST2, MPI_COMM_WORLD, INFO) + CALL MPI_ISEND( usnd, 8*MAXLJMAX*KMAX_MID, MPI_BYTE, & + neighbor(EAST), MSG_WEST2, MPI_COMM_WORLD, request_e, INFO) + endif + + + + + if (neighbor(NORTH) .ne. NOPROC) then + do k = 1,KMAX_MID + do i = 1,limax + vsnd(i,k) = v(i,ljmax,k,nr) + enddo + enddo +! CALL MPI_SEND( vsnd , 8*MAXLIMAX*KMAX_MID, MPI_BYTE, & +! neighbor(NORTH), MSG_SOUTH2, MPI_COMM_WORLD, INFO) + CALL MPI_ISEND( vsnd , 8*MAXLIMAX*KMAX_MID, MPI_BYTE, & + neighbor(NORTH), MSG_SOUTH2, MPI_COMM_WORLD, request_n, INFO) + endif + + + + + + ! receive from WEST neighbor if any + + if (neighbor(WEST) .ne. NOPROC) then + + CALL MPI_RECV( urcv, 8*MAXLJMAX*KMAX_MID, MPI_BYTE, & + neighbor(WEST), MSG_WEST2, MPI_COMM_WORLD, MPISTATUS, INFO) + do k = 1,KMAX_MID + do j = 1,ljmax + u(0,j,k,nr) = urcv(j,k) + enddo + enddo + + else + + do k = 1,KMAX_MID + do j = 1,ljmax + u(0,j,k,nr) = u(1,j,k,nr) + enddo + enddo + + + endif + + ! receive from SOUTH neighbor if any + + if (neighbor(SOUTH) .ne. NOPROC) then + + CALL MPI_RECV( vrcv, 8*MAXLIMAX*KMAX_MID, MPI_BYTE, & + neighbor(SOUTH), MSG_SOUTH2, MPI_COMM_WORLD, MPISTATUS, INFO) + do k = 1,KMAX_MID + do i = 1,limax + v(i,0,k,nr) = vrcv(i,k) + enddo + enddo + + else + + if(Poles(2)/=1) then + do k = 1,KMAX_MID + do i = 1,limax + v(i,0,k,nr) = v(i,1,k,nr) + enddo + enddo + else + !"close" the South pole + do k = 1,KMAX_MID + do i = 1,limax + v(i,0,k,nr) = 0.0 + enddo + enddo + endif + + endif + + + + + if (neighbor(NORTH) == NOPROC.and.Poles(1)==1) then + !"close" the North pole + do k = 1,KMAX_MID + do i = 1,limax + v(i,ljmax,k,nr) = 0.0 + enddo + enddo + endif + + if (neighbor(EAST) .ne. NOPROC) then + CALL MPI_WAIT(request_e, MPISTATUS, INFO) + endif + + if (neighbor(NORTH) .ne. NOPROC) then + CALL MPI_WAIT(request_n, MPISTATUS, INFO) + endif + + + inv_METSTEP = 1.0/METSTEP + + do j = 1,ljmax + do i = 1,limax + + ! conversion of pressure from mb to Pascal. + + ps(i,j,nr) = ps(i,j,nr)*PASCAL + + + + + ! surface precipitation, mm/hr + + surface_precip(i,j) = pr(i,j,KMAX_MID) * inv_METSTEP + + + rho_surf(i,j) = ps(i,j,nr)/(RGAS_KG * t2_nwp(i,j,nr) ) + + ! For MM5 we get u*, not tau. Since it seems better to + ! interpolate tau than u* between time-steps we convert + + if ( foundustar) then + tau(i,j,nr) = ustar_nwp(i,j)*ustar_nwp(i,j)* rho_surf(i,j) + end if + + + prhelp_sum = 0.0 + prhelp(1) = max(pr(i,j,1),0.) + + prhelp_sum = prhelp_sum + prhelp(1) + + ! pr is 3 hours accumulated precipitation in mm in each + ! layer summed from above. This is first converted to precipitation + ! release in each layer. + + do k = 2,KMAX_MID + + prhelp(k) = pr(i,j,k) - pr(i,j,k-1) + + enddo + + ! accumulated deposition over 3 hour interval + ! k=KMAX_MID now includes accumulated precipitation over all layers + ! evaporation has been set to zero as it is not accounted for in the + ! wet deposition + + + ! Add up in WetDeposition, to have the prec used in the model + + pr(i,j,:) = prhelp(:)*divt + + + + + ! interpolation of sigma dot for half layers + + if(foundsdot.and.sdot_at_mid)then !pw rv1_9_24 + do k = KMAX_MID,2,-1 + + sdot(i,j,k,nr) = sdot(i,j,k-1,nr) & + + (sdot(i,j,k,nr)-sdot(i,j,k-1,nr)) & + * (sigma_bnd(k)-sigma_mid(k-1)) & + / (sigma_mid(k)-sigma_mid(k-1)) + + enddo + endif + + ! set sdot equal to zero at the top and bottom of atmosphere. + + sdot(i,j,KMAX_BND,nr)=0.0 + sdot(i,j,1,nr)=0.0 + + ! conversion from % to fractions (<0,1>) for cloud cover + ! calculation of cc3dmax (see eulmc.inc) - + ! maximum of cloud fractions for layers above a given layer + + cc3d(i,j,1) = 0.01 * cc3d(i,j,1) + cc3dmax(i,j,1) = cc3d(i,j,1) + + + lwc(i,j,:)=0. + do k=2,KMAX_MID + cc3d(i,j,k) = 0.01 * cc3d(i,j,k) + cc3dmax(i,j,k) = amax1(cc3dmax(i,j,k-1),cc3d(i,j,k-1)) + lwc(i,j,k)=0.6e-6*cc3d(i,j,k) + enddo + + enddo + enddo + + + + + + + ! lines associated with computation of surface diffusion + ! coefficient are commented + + xkmin = 1.e-3 + + ! derive the meteorological parameters from the basic parameters + ! read from field-files. + + do j = 1,ljmax + do i = 1,limax + p1 = sigma_bnd(KMAX_BND)*(ps(i,j,nr) - PT) + PT + + exf1(KMAX_BND) = CP * Exner_nd(p1) + + z_bnd(i,j,KMAX_BND) = 0.0 + + + + do k = KMAX_MID,1,-1 + + ! eddy diffusivity in the surface-layer follows the formulation used + ! in the nwp-model which is based on Louis (1979), (see mc7e.f). + + ! the shorter loop is the inner loop to save memory. the order + ! of the do loops will be changed on a vector machine. + + ! exner-function of the half-layers + + p1 = sigma_bnd(k)*(ps(i,j,nr) - PT) + PT + + + exf1(k) = CP * Exner_nd( p1 ) + + p2 = sigma_mid(k)*(ps(i,j,nr) - PT) + PT + + ! exner-function of the full-levels + + exf2(k) = CP * Exner_nd(p2) + + ! height of the half-layers + + z_bnd(i,j,k) = z_bnd(i,j,k+1) + (th(i,j,k,nr)* & + (exf1(k+1) - exf1(k)))/GRAV + + + ! height of the full levels. + + z_mid(i,j,k) = z_bnd(i,j,k+1) + (th(i,j,k,nr)* & + (exf1(k+1) - exf2(k)))/GRAV + + roa(i,j,k,nr) = CP*((ps(i,j,nr) - PT)*sigma_mid(k) + PT)/ & + (R*th(i,j,k,nr)*exf2(k)) + + enddo ! k + + enddo + enddo + !----------------------------------------------------------------------- + + if( MY_DEBUG .and. debug_proc ) then + write(*,*) "DEBUG meIJ" , me, limax, ljmax + do k = 1, KMAX_MID + write(6,"(a12,2i3,2f12.4)") "DEBUG Z",me, k, & + z_bnd(debug_iloc,debug_jloc,k), z_mid(debug_iloc,debug_jloc,k) + end do + end if + + + + + ! Horizontal velocity divided by map-factor. + + do k = 1,KMAX_MID + do j = 1,ljmax + do i = 0,limax + u(i,j,k,nr) = u(i,j,k,nr)/xm_j(i,j) + + !divide by the scaling in the perpendicular direction to get effective u + !(for conformal projections like Polar Stereo, xm_i and xm_j are equal) + + enddo + enddo + do j = 0,ljmax + do i = 1,limax + v(i,j,k,nr) = v(i,j,k,nr)/xm_i(i,j) + + ! divide by the scaling in the perpendicular direction to get effective v + enddo + enddo + enddo + + + + + + + + + + + if(.not.foundsdot)then + ! sdot derived from divergence=0 principle + do j = 1,ljmax + do i = 1,limax + sdot(i,j,KMAX_BND,nr)=0.0 + sdot(i,j,1,nr)=0.0 + do k=KMAX_MID,2,-1 + sdot(i,j,k,nr) = ((u(i,j,k,nr)-u(i-1,j,k,nr)) & + + (v(i,j,k,nr)-v(i,j-1,k,nr))) & + * xm2(i,j)*(sigma_bnd(k+1)-sigma_bnd(k)) & + / GRIDWIDTH_M+sdot(i,j,k+1,nr) + enddo + enddo + enddo + endif + + call met_derived !compute derived meteo fields + + call tiphys(numt) + + end subroutine metvar + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + + + + + + subroutine metint + + ! this routine does the forward linear stepping of the meteorological + ! fields read or derived every 3 hours. + + + implicit none + + integer :: i,j + real :: div,ii + + if (nstep.lt.nmax) then + + div = 1./real(nmax-(nstep-1)) + + u(:,:,:,1) = u(:,:,:,1) & + + (u(:,:,:,2) - u(:,:,:,1))*div + v(:,:,:,1) = v(:,:,:,1) & + + (v(:,:,:,2) - v(:,:,:,1))*div + sdot(:,:,:,1) = sdot(:,:,:,1) & + + (sdot(:,:,:,2) - sdot(:,:,:,1))*div + th(:,:,:,1) = th(:,:,:,1) & + + (th(:,:,:,2) - th(:,:,:,1))*div + q(:,:,:,1) = q(:,:,:,1) & + + (q(:,:,:,2) - q(:,:,:,1))*div + ! ccc(:,:,:,1) = ccc(:,:,:,1) & !ASSYCON + ! + (ccc(:,:,:,2) - ccc(:,:,:,1))*div !ASSYCON + skh(:,:,:,1) = skh(:,:,:,1) & + + (skh(:,:,:,2) - skh(:,:,:,1))*div + roa(:,:,:,1) = roa(:,:,:,1) & + + (roa(:,:,:,2) - roa(:,:,:,1))*div + ps(:,:,1) = ps(:,:,1) & + + (ps(:,:,2) - ps(:,:,1))*div + t2_nwp(:,:,1) = t2_nwp(:,:,1) & + + (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_deep(:,:,1) = SoilWater_deep(:,:,1) & + + (SoilWater_deep(:,:,2) - SoilWater_deep(:,:,1))*div + + + fh(:,:,1) = fh(:,:,1) & + + (fh(:,:,2) - fh(:,:,1))*div + fl(:,:,1) = fl(:,:,1) & + + (fl(:,:,2) - fl(:,:,1))*div + tau(:,:,1) = tau(:,:,1) & + + (tau(:,:,2) - tau(:,:,1))*div + sst(:,:,1) = sst(:,:,1) & + + (sst(:,:,2) - sst(:,:,1))*div + + + ! precipitation and cloud cover are no longer interpolated + + else + + ! assign the the meteorological data at time-level 2 to level 1 for + ! the next 6 hours integration period before leaving the inner loop. + + u(:,:,:,1) = u(:,:,:,2) + v(:,:,:,1) = v(:,:,:,2) + sdot(:,:,:,1) = sdot(:,:,:,2) + th(:,:,:,1) = th(:,:,:,2) + q(:,:,:,1) = q(:,:,:,2) + ! ccc(:,:,:,1) = ccc(:,:,:,2) !ASSYCON + skh(:,:,:,1) = skh(:,:,:,2) + roa(:,:,:,1) = roa(:,:,:,2) + ! - note we need pressure first before surface_pressure + ps(:,:,1) = ps(:,:,2) + t2_nwp(:,:,1) = t2_nwp(:,:,2) + rh2m(:,:,1) = rh2m(:,:,2) + SoilWater(:,:,1) = SoilWater(:,:,2) + SoilWater_deep(:,:,1) = SoilWater_deep(:,:,2) + + + fh(:,:,1) = fh(:,:,2) + tau(:,:,1) = tau(:,:,2) + fl(:,:,1) = fl(:,:,2) + + sst(:,:,1) = sst(:,:,2) + + endif + + call met_derived !update derived meteo fields + + end subroutine metint + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + + + + + + + + subroutine met_derived + + ! This routine calculates fields derived from meteofields. + ! The interpolation in time is done for the meteofields and the + ! fields here are derived from the interpolated fields after + ! each interpolation (i.e. every dt_advec). + ! CPU costly fields (those with special functions like log ) + ! can be computed in metvar only once every METSTEP and interpolated + ! in metint. + + !horizontal wind speed (averaged over the four edges) + !Note that u and v are wind velocities divided by xm + !At present u_ref is defined at KMAX_MID + + + implicit none + integer ::i,j + logical :: DEBUG_DERIV = .false. + + do j = 1,ljmax + do i = 1,limax + u_ref(i,j)=0.25*(& + sqrt((0.5*( u(i,j,KMAX_MID,1)*xm_j(i,j)& + +u(i-1,j,KMAX_MID,1)*xm_j(i-1,j) ))**2& + +( v(i,j,KMAX_MID,1)*xm_i(i,j))**2)& + +sqrt((0.5*( u(i,j,KMAX_MID,1)*xm_j(i,j)& + +u(i-1,j,KMAX_MID,1)*xm_j(i-1,j) ))**2& + +( v(i,j-1,KMAX_MID,1)*xm_i(i,j-1) )**2)& + +sqrt(( u(i,j,KMAX_MID,1)*xm_j(i,j) )**2& + +(0.5*( v(i,j,KMAX_MID,1)*xm_i(i,j) & + +v(i,j-1,KMAX_MID,1)*xm_i(i,j-1) ))**2)& + +sqrt((u(i-1,j,KMAX_MID,1)*xm_j(i-1,j) )**2& + +(0.5*( v(i,j,KMAX_MID,1)*xm_i(i,j) & + +v(i,j-1,KMAX_MID,1)*xm_i(i,j-1) ))**2) ) + + enddo + enddo + + ! Tmp ustar solution. May need re-consideration for MM5 etc., but + ! basic principal should be that fm is interpolated with time, and + ! ustar derived from this. + + !aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + + forall( i=1:limax, j=1:ljmax ) + rho_surf(i,j) = ps(i,j,1)/(RGAS_KG * t2_nwp(i,j,1) ) + end forall + + if(.not. foundustar)then + forall( i=1:limax, j=1:ljmax ) + ustar_nwp(i,j) = sqrt( tau(i,j,1)/rho_surf(i,j) ) + end forall + endif + + + forall( i=1:limax, j=1:ljmax ) + ustar_nwp(i,j) = max( ustar_nwp(i,j), 1.0e-5 ) + end forall + + if ( DEBUG_DERIV .and. debug_proc ) then + i = debug_iloc + j = debug_jloc + write(*,*) "MET_DERIV DONE ", me, ustar_nwp(i,j), rho_surf(i,j) + end if + !aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa + + + end subroutine met_derived + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + + + + + + + + + subroutine MetModel_LandUse(callnum) + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! This subroutine reads parameterfields from file + ! reading surface roughness classes from file: rough.170 + ! reading snow from file: snowc.dat + ! + ! ... fields as used in meteorological model + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + implicit none + + integer, intent(in) :: callnum + integer :: i,j, err + + real, dimension(MAXLIMAX,MAXLJMAX) :: r_class ! Roughness (real) + + character*20 fname + + ios = 0 + + if ( callnum == 1 ) then + + if ( me == 0 ) then + write(fname,fmt='(''rough.170'')') + write(6,*) 'filename for landuse ',fname + end if + + call ReadField(IO_ROUGH,fname,r_class) + + ! And convert from real to integer field + + nwp_sea(:,:) = .false. + do j=1,ljmax + do i=1,limax + if ( nint(r_class(i,j)) == 0 ) nwp_sea(i,j) = .true. + enddo + enddo + + else ! callnum == 2 + if (me == 0) then + write(fname,fmt='(''snowc'',i2.2,''.dat'')') current_date%month + write(6,*) 'filename for snow ',fname + + endif !me==0 + + call ReadField(IO_SNOW,fname,snow) + + end if ! callnum == 1 + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + end subroutine MetModel_LandUse + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + + + + + + + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + + + + + + + subroutine tiphys(numt) + !c + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c + !c written by Trond Iversen, modified by Hugo Jakobsen, 060994 + !c + !c Called from: eulmain.f + !c + !c----------------------------------------------------------------- + !c + !! This routine calculates the exner function, + !! the geopotential height, and the vertical exchange coefficient + !! in sigma surfaces. + !! The height zi of the "well mixed layer" or ABL-height + !! is also calculated. + !c + !c + !c if nroa = 1 also roa is calculated. + !c if nfirst=1 for the initial timelevel + !c + !c + !c----------------------------------------------------------------- + !c routines called: + !c + !c smoosp + !c + !c + !c----------------------------------------------------------------- + !c + !c DescriPTion of the parameters/variables defined in this file: + !c + !c + !c absfac : |xfac| + !c abshd : |fm| + !c amax1 : fortran function, choosing largest value + !c amin1 : fortran function, choosing smallest value + !c CP : heat capaciyt of air at constant pressure, J/(kg K) + !c delq : available heat flux for developing the unstable ABL, J/m2 + !! : heat-input per m2 from the ground during unstable BL + !c deltaz : zm(i,k) - zm(i,k+1), m + !c dpidth : heat increasement in accordance with temp. increasement, J/m2 + !c dth : iterative increament in potential temperature + !c dth0 : accumulated increament in iterative temperature + !c dtz : time interwall for integration of surface heat fluxes + !c in the ABL-height calculations, s + !c dvdz : Wind shear, 1/s + !c eps : small number avoiding ri to become infinitely large + !c exfrco : parameter in the Kz model + !c exnm : exner function in the full sigma-levels, J/(kg K) + !c exns : exner function in the half sigma-levels, J/(kg K) + !c fh : surface flux of sensible heat, W/m2 + !c fl : surface flux of sensible heat, W/m2 ! ds u7.4vg + !c fm : surface stress (flux of momentum), N/m2 + !c g : gravitational acceleration, m/s2 + !c hs : height of surface layer (i.e. prandtl-layer), m + !c hsl : (= hs/l, where l is the monin-obhukov length) + !c i : grid index in x-direction + !c iip : limax + 1 + !c limax : max number of grid points in x-direction + !c iznew : index for new value of the ABL-height, m + !c izold : index for previous value of the ABL-height, m + !c j : grid index in y-direction + !c jjp : ljmax + 1 + !c ljmax : max number of grid points in y-direction + !c k : grid index in vertical-direction + !c kkk : helping index for the cycling of ABL-height + !c kkm : number of full s-levels, *** not used *** + !c KMAX_BND : max number of vertical half levels + !c in sigma coordinates + !c KMAX_MID : max number of vertical full levels + !c in sigma coordinates + !c kzmax : maximum value of xksig, m2/s + !c kzmin : minimum value of xksig, m2/s + !c ndth : do variable for convective ABL-height iteration loop + !c nh1 : counts number of layers below zlimax + !c nh2 : counts number of layers with Kz > ( Kz )limit + !c nr : number of met.fields stored in arrays (= 1 or 2) + !c nt : time counting variable of the outer time-loop + !c p : local pressure, hPa (mb) + !c pi : pi = 4.*atan(1.) = 3.14 ... + !c pidth : heat used to adjust air temperature, J/m2 + !c pref : refference pressure (at ground level), 1.e+5 Pa + !c ps : surface pressure, hPa + !c PT : pressure at the top of the model atmosphere, hPa (mb) + !c pz : local pressure in half sigma levels, hPa (mb), + !c helping array (j - slices) for pressure + !c pzpbl : stores H(ABL) for averaging and plotting purposes, m + !c ri : richardson`s number + !c ri0 : critical richardson`s number + !c risig : richardson's number in sigmas-levels + !c roas : air density at surface, kg/m3 + !c sigma_bnd : height of the half-sigma layers + !c sigma_mid : height of the full-sigma layers + !c sm : height of the surface layer in s-coordinates (4% of H(ABL), m + !c th : potensial temperature (theta), K + !c t2_nwp : potensial temperature at 2m height, K + !c thadj : adjustable surface temperature, K + !c thsrf : potensial temperature at the surface, K + !c trc : helping variable telling whether or not unstable ABL exists + !! : 0 => no need for further calc. of ziu + !! : 1 => ziu not found yet. + !c u : wind speed in the x-direction, m/s + !c umax : maximum value of u and v, m/s + !c ustar : friction velocity, m/s + !c v : wind speed in the y-direction, m/s + !c ven : ventilation coefficient, m3 + !c venav : time averaged ventilation coefficient, m3 + !c venmax : maximum value of ven, m3 + !c venmin : minimum value of ven, m3 + !c ven00 : averaged ventilation coefficient at 00 UTC, m3 + !c ven06 : averaged ventilation coefficient at 06 UTC, m3 + !c ven12 : averaged ventilation coefficient at 12 UTC, m3 + !c ven18 : averaged ventilation coefficient at 18 UTC, m3 + !c vdfac : factor for reduction of vD(1m) to vD(hs) + !! : i.e. factor for aerodynamic resistance towards dry deposition + !! : vd(50m) = vd(1m)/(1 + vd(1m)*vdfac) + !c x12 : mixing length squared, m2 + !c xfac : helping variable for reducing concentrations to 1m values + !c xfrco : parameter in the Kz model + !c KAPPA : r/CP (-) + !c KARMAN : von Karmans constant + !c xkdz : the vertical derivative of xkhs at hs, m/s + !! : i.e. vertical gradient of xkhs + !c xkhs : diffusivity at hs (in surface layer), m2/s + !! : i.e. vertical exchange coeff. on top of prandtl-layer + !c xksig : estimated exchange coefficient, Kz, in intermediate + !c sigma levels, m2/s + !c xksm : spacially smoothed Kz in z direction, m2/s. + !! : xksig smoothed over three adjacent layers + !c xkzi : local helping array for the vertical diffusivity, m2/s + !! : i.e. vertical exchange coeff. on top of ABL for unstable BL + !c xtime : 6.*3600. (seconds in one term, six hours) + !c zi : Height of ABL (final value), m + !c zlimax : maximum value of ABL-height, zi, (2000), m + !c zimhs : ziu - hs + !c zimin : minimum value of ABL-height, zi, (200), m + !c zimz : ziu - zs_bnd + !c zis : height of the stable ABL, m + !c ziu : height of the unstable ABL, m + !c zixx : Height og ABL (intermediate value), m + !c zm : geopotential height of full sigma levels above topography, m + !c zmhs : zs_bnd - hs + !c zs_bnd : geopotential height of half sigma levels above topography, m + !c ztop : height of the uppermost layer in s-coordinates + !c + !c------------------------------------------------------------------- + !c..the following sketches the sigma-surfaces: + !c + !c + !! /////////////////// + !c sigma_bnd(1) = 0 - -sigmas - - - - - sdot(1) = 0, xksig(1)=xksm(1)=0, + !! pr(1)=0,PT,exns(1), zs_bnd(1) + !c + !c sigma_mid(1) ---sigmam---------- u, v, th, q, cw, exnm (1) + !c + !c + !c sigma_bnd(2) - - - - s - - - - - sdot(2), xksig(2), exns(2), pr(2) + !! zs_bnd(2), xksm(2) + !c + !c sigma_mid(2) --------m---------- u, v, th, q, cw, exnm (2) + !c + !c + !c sigma_bnd(3) - - - - s - - - - - sdot(3), xksig(3), exns(3), pr(3) + !! zs_bnd(3), xksm(3) + !c + !c sigma_mid(3) --------m---------- u, v, th, q, cw, exnm (3) + !c + !c + !c sigma_bnd(4) - - - - s - - - - - sdot(4), xksig(4), exns(4), pr(4) + !! zs_bnd(4), xksm(4) + !c + !c sigma_mid(4) --------m---------- u, v, th, q, cw, exnm (4) + !c + !c + !c sigma_bnd(5) - - - - s - - - - - sdot(5), xksig(5), exns(5), pr(5) + !! zs_bnd(5), xksm(5) + !c + !! : + !! : + !c + ! sigma_bnd(KMAX_BND-1) - - - - s - - - - sdot(KMAX_BND-1), xksig(KMAX_MID), + !! exns(KMAX_BND-1),zs_bnd(KMAX_BND-1), + !! pr(KMAX_BND-1),xksm(KMAX_MID) + !c + !c sigma_mid(KMAX_MID) --------m-------- u, v, th, q, cw, exnm (KMAX_MID); + !! this level is assumed to be + !! the top of Prandtl-layer (LAM50E) + !c + ! sigma_bnd(KMAX_BND) = 1- - - s - - - - sdot(KMAX_BND) = 0, ps, t2_nwp, fh, + !! /////////////////// fm, mslp, xksig(KMAX_MID)=0, + !! exns(KMAX_BND), zs_bnd(KMAX_BND), + !! pr(KMAX_BND),xksm(KMAX_BND)=0. + !c + !c + !c..alternativ names: kkin = KMAX_MID=20 (number of sigma-layers) + !! kkinp = kkin+1 = KMAX_BND=21 (number of + !! level-bounds for layers) + !! kkinm = kkin-1 = KMAX_MID-1 + !c + !c********************************************************************** + logical, parameter :: DEBUG_KZ = .false. + logical, parameter :: PIELKE_KZ = .true. ! Default + logical, parameter :: TKE_DIFF = .false. !!! CODE NEEDS TESTING/TIDY UP + ! STILL!!!! + ! Kz-tests + real, parameter :: KZ_MINIMUM = 0.001 ! m2/s + real, parameter :: KZ_MAXIMUM = 1.0e3 ! m2/s - as old kzmax + real, parameter :: KZ_SBL_LIMIT = 0.1 ! m2/s - Defines stable BL height + + real, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID)::exnm + real, dimension(MAXLIMAX,MAXLJMAX,KMAX_BND)::exns,zs_bnd + real, dimension(MAXLIMAX,KMAX_MID)::zm,dthdz,deltaz,thc + real, dimension(MAXLIMAX,KMAX_BND)::risig,xksm,pz + real, dimension(MAXLIMAX)::zis,delq,thsrf,trc,pidth,dpidth,xkhs,xkdz,xkzi,& + hs,xkh100 + real, dimension(MAXLIMAX,MAXLJMAX)::ziu,help,a,zixx,uabs,vdfac + real ::lim,xdthdz,zmmin,zimin,zlimax,kzmin,kzmax,sm,pref,xtime,umax,eps,ric,& + ric0,dthdzm,dthc,xdth,xfrco,exfrco,hsl,dtz,p,dvdz,xl2,uvhs,zimhs,& + zimz,zmhs,ux0,fac,fac2,dex12,ro + real ::h100 ! Top of lowest layer - replaces 100.0 + real ::hsurfl + + integer i,j,k,km,km1,km2,kabl,iip,jjp,numt,kp, nr + + + integer, dimension(MAXLIMAX) :: nh1, nh2 + + ! Check: + call CheckStop( KZ_SBL_LIMIT < 1.01*KZ_MINIMUM, & + "SBLlimit too low! in Met_ml") + + iip = limax+1 + jjp = ljmax+1 + + ! + ! Preliminary definitions + ! + nr = 2 + if (numt.eq.1) nr = 1 + pref = 1.e+5 + + !from ModelC pi = 4.*atan(1.) + + xtime = 6.*3600. + umax=+70. + zlimax = 3000. + zimin = 100. + zmmin = 200. + + eps = 0.01 + dtz = 3600. + sm = 0.04 + ! + ! + !..preset=zero: + xksm(:,:) = 0 + risig(:,:) = 0. + xksig(:,:,:)= 0. + + + !c.................................. + !c..exner-function in the full sigma-levels.. + !c + do k=1,KMAX_MID + do j=1,ljmax + do i=1,limax + + !c..pressure (pa) + p = PT + sigma_mid(k)*(ps(i,j,nr) - PT) + !c..exner (j/k kg) + exnm(i,j,k)= CP * Exner_nd(p) + end do + end do + end do + + !c......................................... + !c..procedure to arrive at mixing height..: + !c + !c++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + !c + !c Start j-slice here. + !c + + + do j=1,ljmax + + !c..exner in half-sigma levels: + do k=1,KMAX_BND + do i=1,limax + p = PT + sigma_bnd(k)*(ps(i,j,nr) - PT) + pz(i,k) = p + exns(i,j,k)= CP * Exner_nd(p) + end do + end do + ! + ! + !.. exns(KMAX_BND), th(KMAX_BND) and height of sigmas: + do i=1,limax + zs_bnd(i,j,KMAX_BND)=0. + end do + ! + ! Height of the half levels + ! + do k=KMAX_BND-1,1,-1 + do i=1,limax + zs_bnd(i,j,k)=zs_bnd(i,j,k+1)+th(i,j,k,nr)*& + (exns(i,j,k+1)-exns(i,j,k))/GRAV + + end do + end do + ! + !..height of sigma: + do k=1,KMAX_MID + do i=1,limax + zm(i,k) = ((exnm(i,j,k)-exns(i,j,k))*zs_bnd(i,j,k+1)& + + (exns(i,j,k+1)-exnm(i,j,k))*zs_bnd(i,j,k))& + / (exns(i,j,k+1)-exns(i,j,k)) + end do + end do + + + !---------------------------------------------------------------------- + !........................................... + !..the following variables in sigmas-levels: + ! + do k=2,KMAX_MID + km=k-1 + do i=1,limax + ! + !......................... + !..wind sheare + ! + ! Slightly different formulation of dvdz than in metvar + dvdz = ( (u(i,j,km,nr)-u(i,j,k,nr))**2 & + + (v(i,j,km,nr)-v(i,j,k,nr))**2 + eps) + ! + risig(i,k)=(2.*GRAV/(th(i,j,km,nr)+th(i,j,k,nr)))*& + (th(i,j,km,nr)-th(i,j,k,nr))*(zm(i,km)-zm(i,k))& + /dvdz + !........................ + !..mixing length squared: + ! + xl2=(KARMAN*amin1(zs_bnd(i,j,k),zmmin))**2 + + ! + !.............................. + !..critical richardsons number: + ! + ric0=0.115*((zm(i,km)-zm(i,k))*100.)**0.175 + ric=amax1(0.25,ric0) + + + + dvdz = sqrt(dvdz)/(zm(i,km)-zm(i,k)) + + !.................................................................. + !..exchange coefficient (Pielke,...) + if ( PIELKE_KZ ) then + if (risig(i,k) > ric ) then + xksig(i,j,k) = KZ_MINIMUM + else + xksig(i,j,k) = 1.1 * (ric-risig(i,k)) * xl2 * dvdz /ric + end if + else + + !..exchange coefficient (blackadar, 1979; iversen & nordeng, 1987): + ! + if(risig(i,k).le.0.) then + xksig(i,j,k)=xl2*dvdz*sqrt(1.1-87.*risig(i,k)) + elseif(risig(i,k).le.0.5*ric) then + xksig(i,j,k)=xl2*dvdz*(1.1-1.2*risig(i,k)/ric) + elseif(risig(i,k).le.ric) then + xksig(i,j,k)=xl2*dvdz*(1.-risig(i,k)/ric) + else + xksig(i,j,k)=0.001 + endif + end if ! Pielke or Blackadar + ! + end do + end do + ! + !tttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttttt + ! + !--------------------------------------------------------------------- + !.................................. + !..height of stable boundary layer: + ! + !......................................................... + !..vertical smoothing of xksig over three adjacent layers: + ! + k=2 + km=1 + kp=3 + do i=1,limax + xksm(i,k)=( (zm(i,km)-zm(i,k))*xksig(i,j,k)& + + (zm(i,k)-zm(i,kp))*xksig(i,j,kp) )& + / ( zm(i,km) - zm(i,kp) ) + enddo + !c + k=KMAX_MID + km2=k-2 + km1=k-1 + do i=1,limax + xksm(i,k)=( (zm(i,km2)-zm(i,km1))*xksig(i,j,km1)& + + (zm(i,km1)-zm(i,k))*xksig(i,j,k) )& + / ( zm(i,km2) - zm(i,k) ) + enddo + !c + do k = 3,KMAX_MID-1 + km1=k-1 + km2=k-2 + kp=k+1 + do i=1,limax + xksm(i,k)=( (zm(i,km2)-zm(i,km1))*xksig(i,j,km1)& + + (zm(i,km1)-zm(i,k))*xksig(i,j,k)& + + (zm(i,k)-zm(i,kp))*xksig(i,j,kp) )& + / ( zm(i,km2) - zm(i,kp) ) + enddo + enddo + + + !c + !c............................................................ + !c..The height of the stable BL is the lowest level for which: + !c..xksm .le. 1 m2/s (this limit may be changed): + !c + do i = 1,limax + zis(i)=zimin + nh1(i) = KMAX_MID + nh2(i) = 1 + enddo + !c + do k=KMAX_MID,2,-1 + do i=1,limax + + if(xksm(i,k) >= KZ_SBL_LIMIT .and. nh2(i) == 1) then + nh1(i)=k ! Still unstable + else + nh2(i)=0 ! Now stable + endif + !c + end do + end do + !c + do i=1,limax + !c + k=nh1(i) + !c + if(zs_bnd(i,j,nh1(i)).ge.zimin) then + + if( abs(xksm(i,k)-xksm(i,k-1)) .gt. eps) then + + zis(i)=((xksm(i,k)-KZ_SBL_LIMIT )*zs_bnd(i,j,k-1) & + + (KZ_SBL_LIMIT -xksm(i,k-1))*zs_bnd(i,j,k))& + /(xksm(i,k)-xksm(i,k-1)) + else + + zis(i)=zimin + endif + + endif + ! + end do + ! + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + ! + !--------------------------------------------------------------------- + !.................................... + !..height of unstable boundary layer: + ! + ! + !..assuring that th is increasing with height. + !..adjusted th-sounding is assigned to thc-array. + !..This adjusted th is not meant to be used in + !..other parts of the model program + ! + dthdzm = 1.e-4 + do i =1,limax + thc(i,KMAX_MID)=th(i,j,KMAX_MID,nr) + do k=KMAX_MID-1,1,-1 + + dthc = (th(i,j,k,nr)-th(i,j,k+1,nr))& + / (zm(i,k)-zm(i,k+1)) + + dthdz(i,k)=amax1(dthc,dthdzm) + + thc(i,k)=thc(i,k+1)+dthdz(i,k)*(zm(i,k)-zm(i,k+1)) + + enddo + enddo + + ! + ! + !..estimated as the height to which an hour's input + !..of heat from the ground is vertically distributed, + !..assuming dry adiabatic adjustment. + ! + ! + do i=1,limax + + delq(i)=-amin1((fh(i,j,nr)),0.)*dtz + thsrf(i)=0. + ziu(i,j)=0. + ! + !................................. + !..trc=1 for unstable BL (delq>0): + !.. =0 for stable BL (delq=0): + ! + if(delq(i).gt.0.00001) then + trc(i)=1. + else + trc(i)=0. + endif + ! + !------------------------------------------------------------ + ! calculating the height of unstable ABL + ! + !! if(trc(i).eq.1.) then + kabl = KMAX_MID + do while( trc(i).eq.1) + !! 28 if(trc(i).eq.1.) then + kabl = kabl-1 + pidth(i)=0. + + + do k=KMAX_MID,kabl,-1 + xdth = thc(i,kabl)-thc(i,k) + dpidth(i) = exnm(i,j,k)*xdth*(pz(i,k+1)-pz(i,k))/GRAV + pidth(i) = pidth(i) + dpidth(i) + end do + + + if(pidth(i).ge.delq(i).and.trc(i).eq.1.) then + + !c at level kabl or below level kabl and above level kabl+1 + + + thsrf(i) = thc(i,kabl) & + - (thc(i,kabl)-thc(i,KMAX_MID)) & + * (pidth(i)-delq(i))/pidth(i) + + xdthdz = (thc(i,kabl)-thc(i,kabl+1)) & + / (zm(i,kabl)-zm(i,kabl+1)) + + ziu(i,j) = zm(i,kabl+1) & + + (thsrf(i)-thc(i,kabl+1))/xdthdz + + trc(i)=0. + + endif + + + if(kabl.le.4 .and. trc(i).eq.1.) then + + write(6,*)'ziu calculations failed!' + + ziu(i,j)=zlimax + + trc(i)=0. + endif + + + end do ! while + !! go to 28 + + !! endif + + !! endif + + end do + + !..iteration, finding height of unstable BL finished + !..................................................................... + + + do i=1,limax + + zixx(i,j)=amax1(ziu(i,j),zis(i)) + zixx(i,j)=amin1(zlimax,zixx(i,j)) + end do + + + + + + end do ! End j-slice + !!------------------------------------------- + + + + + !..spatial smoothing of new zi: + + call smoosp(zixx,zimin,zlimax) + + do j=1,ljmax + do i=1,limax + pzpbl(i,j) = zixx(i,j) + enddo + enddo + + + !cttttttttttttttttttttttttttttttttttttttttttttttttttttttt + !c..height of ABL finished.............................. + !c------------------------------------------------------ + + + + + !----------------------------------------------------------! + if( TKE_DIFF ) then + call tkediff (nr) ! guta + else + call O_Brian(nr, KZ_MINIMUM, KZ_MAXIMUM, zimin, zs_bnd, ziu & + , exns, exnm, zixx ) + end if + !----------------------------------------------------------! + + end subroutine tiphys + + !c+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! + + + + + + subroutine smoosp(f,rmin,rmax) + + !c file: eulmet-mnd.f + !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc + !c + !c written by Trond Iversen, modified by Hugo Jakobsen, 080994 + ! parallellized and modified by Peter February 2003 + ! + !c + !c Called from: tiphys.f + !c + !c---------------------------------------------------------------------- + !c + !c This routine applies the shapiro filter with s=0.5 and s=-0.5 + !c to the field f usinh h as a work space also the boundaries + !c are smoothed. f contains the smoothed field upon return. + !c + + !c Definition of the variables: + !c + !c + !c f : data to be smoothed + !c iif : =limax + !c jjf : =ljmax + !c h1,h2 : = help variable + !c rmin : min allowed + !c rmax : max allowed + !c + implicit none + + real, intent(inout) :: f(MAXLIMAX,MAXLJMAX) + real, intent(in) :: rmin,rmax + + real, dimension(MAXLIMAX+4,MAXLJMAX+4) :: h1, h2 + real, dimension(MAXLIMAX,2) :: f_south,f_north + real, dimension(MAXLJMAX+2*2,2) :: f_west,f_east + real s + + integer thick + integer iif,jjf,is,i,j,ii,jj,iifl,jjfl + + iif=limax + jjf=ljmax + + thick=2 !we fetch 2 neighbors at once, so that we don't need to call + ! readneighbours twice + iifl=iif+2*thick + jjfl=jjf+2*thick + + call readneighbors(f,f_south,f_north,f_west,f_east,thick) + + do j=1,jjf + jj=j+thick + do i=1,iif + ii=i+thick + h1(ii,jj) = f(i,j) + enddo + enddo + do j=1,thick + do i=1,iif + ii=i+thick + h1(ii,j) = f_south(i,j) + enddo + enddo + + do j=1,thick + jj=j+jjf+thick + do i=1,iif + ii=i+thick + h1(ii,jj) = f_north(i,j) + enddo + enddo + + do j=1,jjfl + do i=1,thick + h1(i,j) = f_west(j,i) + enddo + enddo + + do j=1,jjfl + do i=1,thick + ii=i+iif+thick + h1(ii,j) = f_east(j,i) + enddo + enddo + + do j=1,jjfl + h2(1,j) = 0. + h2(iifl,j) = 0. + enddo + + do i=1,iifl + h2(i,1) = 0. + h2(i,jjfl) = 0. + enddo + !! 44 format(I2,30F5.0) + + do is=2,1,-1 + + s=is-1.5 !s=0,5 s=-0.5 + if(is /= 2)h1=h2 + + !..the smoothing + + do j=2,jjfl-1 + do i=2,iifl-1 + h2(i,j)=(1.-2.*s+s*s)*h1(i,j)& + + 0.5*s*(1.-s)*(h1(i+1,j)+h1(i-1,j)+h1(i,j+1)+h1(i,j-1)) & + + s*s*(h1(i+1,j+1)+h1(i-1,j-1)+h1(i+1,j-1)+h1(i-1,j+1))/4. + h2(i,j) = amax1(h2(i,j),rmin) + h2(i,j) = amin1(h2(i,j),rmax) + end do + end do + + end do + + + do j=1,jjf + jj=j+thick + do i=1,iif + ii=i+thick + f(i,j)=h2(ii,jj) + enddo + enddo + + end subroutine smoosp + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + + + + subroutine readneighbors(data,data_south,data_north,data_west,data_east,thick) + + + ! Read data at the other side of the boundaries + ! + ! thick is the number of gridcells in each direction to be transferred + ! Note that we also fetch data from processors in the "diagonal" + ! directions + ! + ! Written by Peter February 2003 + ! + !Note, + !The data_west(jj,:)=data(1,j) is not a bug: when there is no west + !neighbour, + !the data is simply copied from the nearest points: data_west(jj,:) should + !be =data(-thick+1:0,j), but since this data does not exist, we + !put it =data(1,j). + + + implicit none + + integer, intent(in) :: thick + real,intent(in), dimension(MAXLIMAX,MAXLJMAX) ::data + real,intent(out), dimension(MAXLIMAX,thick) ::data_south,data_north + real,intent(out), dimension(MAXLJMAX+2*thick,thick) ::data_west,data_east + + integer :: msgnr,info + integer :: i,j,tj,jj,jt + + !check that limax and ljmax are large enough + call CheckStop(limax < thick, "ERROR readneighbors in Met_ml") + call CheckStop(ljmax < thick, "ERROR readneighbors in Met_ml") + + + msgnr=1 + + data_south(:,:)=data(:,1:thick) + data_north(:,:)=data(:,ljmax-thick+1:ljmax) + if(neighbor(SOUTH) >= 0 )then + CALL MPI_SEND( data_south , 8*MAXLIMAX*thick, MPI_BYTE,& + neighbor(SOUTH), msgnr, MPI_COMM_WORLD, INFO) + endif + if(neighbor(NORTH) >= 0 )then + CALL MPI_SEND( data_north , 8*MAXLIMAX*thick, MPI_BYTE,& + neighbor(NORTH), msgnr+9, MPI_COMM_WORLD, INFO) + endif + + if(neighbor(SOUTH) >= 0 )then + CALL MPI_RECV( data_south, 8*MAXLIMAX*thick, MPI_BYTE,& + neighbor(SOUTH), msgnr+9, MPI_COMM_WORLD, MPISTATUS, INFO) + else + do tj=1,thick + data_south(:,tj)=data(:,1) + enddo + endif +44 format(I2,30F5.0) + if(neighbor(NORTH) >= 0 )then + CALL MPI_RECV( data_north, 8*MAXLIMAX*thick, MPI_BYTE,& + neighbor(NORTH), msgnr, MPI_COMM_WORLD, MPISTATUS, INFO) + else + do tj=1,thick + data_north(:,tj)=data(:,ljmax) + enddo + endif + + jj=0 + do jt=1,thick + jj=jj+1 + data_west(jj,:)=data_south(1:thick,jt) + data_east(jj,:)=data_south(limax-thick+1:limax,jt) + enddo + do j=1,ljmax + jj=jj+1 + data_west(jj,:)=data(1:thick,j) + data_east(jj,:)=data(limax-thick+1:limax,j) + enddo + do jt=1,thick + jj=jj+1 + data_west(jj,:)=data_north(1:thick,jt) + data_east(jj,:)=data_north(limax-thick+1:limax,jt) + enddo + + if(neighbor(WEST) >= 0 )then + CALL MPI_SEND( data_west , 8*(MAXLJMAX+2*thick)*thick, MPI_BYTE,& + neighbor(WEST), msgnr+3, MPI_COMM_WORLD, INFO) + endif + if(neighbor(EAST) >= 0 )then + CALL MPI_SEND( data_east , 8*(MAXLJMAX+2*thick)*thick, MPI_BYTE,& + neighbor(EAST), msgnr+7, MPI_COMM_WORLD, INFO) + endif + + if(neighbor(WEST) >= 0 )then + CALL MPI_RECV( data_west, 8*(MAXLJMAX+2*thick)*thick, MPI_BYTE,& + neighbor(WEST), msgnr+7, MPI_COMM_WORLD, MPISTATUS, INFO) + else + jj=0 + do jt=1,thick + jj=jj+1 + data_west(jj,:)=data_south(1,jt) + enddo + do j=1,ljmax + jj=jj+1 + data_west(jj,:)=data(1,j) + enddo + do jt=1,thick + jj=jj+1 + data_west(jj,:)=data_north(1,jt) + enddo + endif + if(neighbor(EAST) >= 0 )then + CALL MPI_RECV( data_east, 8*(MAXLJMAX+2*thick)*thick, MPI_BYTE, & + neighbor(EAST), msgnr+3, MPI_COMM_WORLD, MPISTATUS, INFO) + else + jj=0 + do jt=1,thick + jj=jj+1 + data_east(jj,:)=data_south(limax,jt) + enddo + do j=1,ljmax + jj=jj+1 + data_east(jj,:)=data(limax,j) + enddo + do jt=1,thick + jj=jj+1 + data_east(jj,:)=data_north(limax,jt) + enddo + endif + + end subroutine readneighbors + + + + + + + !************************************************************************! + subroutine tkediff (nr) ! + !************************************************************************! + ! ! + ! This routine computes vertical eddy diffusivities as a function ! + ! altitude, height of PBL, and a velocity scale, square root of ! + ! turbulent kinetic energy (TKE). This is a non-local scheme. ! + ! The TKE at the surface is diagnosed using scales for horizontaland ! + ! vertical velocities (ustar and wstar) in the surface layer ! + ! (Alapaty 2004; Holstag et al. 1990 and Mihailovic et al. 2004) ! + ! PBL ht is calculated using the EMEP formulation ! + ! ! + ! Written by DT Mihailovic (October 2004) ! + ! EMEP polishing and comments: JE Jonson and P Wind ! + !************************************************************************! + + implicit none + + ! Local constants + real , parameter :: SZKM=1600. & ! Constant (Blackadar, 1976) + ,CKZ=0.001 & ! Constant (Zhang and Athens, 1982) + ,REFPR=1.0E+05 & ! Referent pressure + ,KZ0LT=1.0E-04 & ! Constant (Alapaty et al., 1997) + ,RIC=0.10 & ! Critical Richardson number + ! (Holstlag et al., 1993) + ,ROVG=R/GRAV ! Used in Calculation of R-number + integer, parameter :: KLM =KMAX_MID-1 + + + + ! INPUT + integer, intent(in) :: nr ! Number of meteorological stored + ! in arrays (1 or 2) + + ! OUTPUT + ! skh(i,j,k,nr) array + ! Values of the Kz coefficients (eddyz (i,j,k)) are transformed nto + ! sigma system and then they stored in this array which is later used + ! in ADVECTION module + + + ! Local arrays + + integer, dimension(MAXLIMAX,MAXLJMAX) :: iblht ! Level of the PBL top + real, dimension(MAXLIMAX,MAXLJMAX,KMAX_BND):: eddyz ! Eddy coefficients + ! (m2/s) + real, dimension(MAXLIMAX,MAXLJMAX,KMAX_MID):: & + t_virt &! Potential temperature (K) + ,e &! Kinetic energy with respect to height (m2/s2) + ,dzq &! Thickness of sigma interface layers (m) + ,u_mid &! Wind speed in x-direction (m/s) + ,v_mid ! Wind speed in y-direction (m/s) + + real, dimension(MAXLIMAX,MAXLJMAX,KLM):: & + dza ! Thickness of half sigma layers (m) + + real, dimension(MAXLIMAX,MAXLJMAX):: & + pblht , &! PBL (Holstag, 1990) (m) + h_flux, &! Sensible heat flux (W/m2) + ust_r , &! Friction velocity (m/s) + mol , &! Monin-obukhov length (m) + wstar ! Convective velocity (m/s) + + real, dimension(KMAX_BND) :: rib ! Bulk Richardson number + + real, dimension(KMAX_MID) :: & + rich, &! Richardson number + psi_zi ! Used in the vertical integration + + real, dimension (10) :: & + psi_z & ! Used for calculating + , zovh ! TKE + + ! Local variables + real dtmp, tog, wssq1, wssq2, wssq, tconv, wss, wst, PSI_TKE, & + dusq, dvsq, ri, ss, dthdz, busfc, zvh, & + part1, part2, fract1, fract2, apbl, fac0, fac02, kz0, & + cell, dum1, rpsb, press, teta_h, u_s, goth, pressure + + integer i, j, k, l, kcbl + + + ! Functions for averaging the vertical turbulent kinetic energy + ! (Alapaty, 2003) + data psi_z /0.00,2.00,1.85,1.51,1.48,1.52,1.43,1.10,1.20,0.25/ + data zovh /0.00,0.05,0.10,0.20,0.40,0.60,0.80,1.00,1.10,1.20/ + + ! Store the NMW meteorology and variables derived from its + + ! Change the sign + h_flux(1:limax,1:ljmax)=-fh(1:limax,1:ljmax,nr) + + ! Avoid devision by zero later in the code + + where (ABS(h_flux(1:limax,1:ljmax))<0.0001) h_flux(1:limax,1:ljmax)=0.0001 + + ! Check PBL height ! strange tests! Negative pzpbl check? From 1 to 100m + ! - odd! + do i=1,limax + do j=1,ljmax + if(ABS(pzpbl(i,j)) < 1.) then + pzpbl(i,j)=100. + endif + enddo + enddo + + ! Calculate velocity components in the (h) poits (Arakawa notation) + do k=1,KMAX_MID + do i=1,limax + do j=1,ljmax + ! u_mid(i,j,k)=0.5*(u(i-1,j ,k,nr)+u(i,j,k,nr)) + ! v_mid(i,j,k)=0.5*(v(i ,j-1,k,nr)+v(i,j,k,nr)) + + u_mid(i,j,k)=u(i,j ,k,nr) + v_mid(i,j,k)=v(i ,j,k,nr) + + enddo + enddo + enddo + + ! Avoid small values + where (ABS(u_mid(1:limax,1:ljmax,1:KMAX_MID))<0.001) & + u_mid(1:limax,1:ljmax,1:KMAX_MID)=0.001 + where (ABS(v_mid(1:limax,1:ljmax,1:KMAX_MID))<0.001) & + v_mid(1:limax,1:ljmax,1:KMAX_MID)=0.001 + + ! Initialize eddy difussivity arrays + eddyz(1:limax,1:ljmax,1:KMAX_MID)=0. + + ! Calculate tickness of the full layers + dzq(1:limax,1:ljmax,1:KMAX_MID) = z_bnd(1:limax,1:ljmax,1:KMAX_MID) & + - z_bnd(1:limax,1:ljmax,2:KMAX_BND) + + ! ... and the half sigma layers + dza(1:limax,1:ljmax,1:KLM) = z_mid(1:limax,1:ljmax,1:KLM) & + - z_mid(1:limax,1:ljmax,2:KMAX_MID) + + ! Calculate virtual temperature + + t_virt(1:limax,1:ljmax,1:KMAX_MID) = th(1:limax,1:ljmax,1:KMAX_MID,nr) & + * (1.0+0.622*q(1:limax,1:ljmax,1:KMAX_MID,nr)) + + + ! Calculate Monin-Obuhkov length (Garratt, 1994) + + do i=1,limax + do j=1,ljmax + u_s = ustar_nwp(i,j) + mol(i,j) = -(ps(i,j,nr)*u_s*u_s*u_s)/ & + (KARMAN*GRAV*h_flux(i,j)*KAPPA) + enddo + enddo + + ! Calculate the convective velocity (wstar) + do i=1,limax + do j=1,ljmax + wstar(i,j) = GRAV*h_flux(i,j)*pzpbl(i,j)/rho_surf(i,j) & + /CP/th(i,j,KMAX_MID,nr) + if(wstar(i,j) < 0.) then + wstar(i,j)=-ABS(wstar(i,j))**(0.3333) + else + wstar(i,j)=(wstar(i,j))**(0.3333) + endif + enddo + enddo + + ! ------------------------------------------> + ! Start with a long loop ------------------------------------------> + ! ------------------------------------------> + DO i=1,limax + DO j=1,ljmax + + rib(1:KMAX_MID) = 0.0 ! Initialize bulk Richardson number + + part1=ust_r(i,j)*ust_r(i,j)*ust_r(i,j) + wst=AMAX1(wstar(i,j),1.0E-20) + part2=0.6*wst*wst*wst + wss=AMAX1(1.0E-4,(part1+part2)) + wss=EXP(0.333333*ALOG(wss)) + + if (h_flux(i,j) < 0.0) then + tconv=0.0 ! Holstlag et al. (1990) + else + tconv=8.5*h_flux(i,j)/rho_surf(i,j)/CP/wss ! Conversion to + ! kinematic flux + endif + + do k=KMAX_MID,1,-1 + dtmp=t_virt(i,j,k)-t_virt(i,j,KMAX_MID)-tconv + tog=0.5*(t_virt(i,j,k)+t_virt(i,j,KMAX_MID))/GRAV + wssq1=u_mid(i,j,k)*u_mid(i,j,k) + wssq2=v_mid(i,j,k)*v_mid(i,j,k) + wssq=wssq1+wssq2 + wssq=AMAX1(wssq,1.0E-4) + rib(k)=z_mid(i,j,k)*dtmp/(tog*wssq) + if(rib(k).ge.RIC) go to 9001 + enddo +9001 continue + + ! Calculate PBL height according to Holtslag et al. (1993) + pblht(i,j)=0. + if(k.ne.KMAX_MID) then + fract1=(RIC-rib(k+1))/(rib(k)-rib(k+1)) + fract2=1.-fract1 + apbl=z_mid(i,j,k)*fract1 + pblht(i,j)=apbl+z_mid(i,j,k+1)*fract2 + if(pblht(i,j) > z_bnd(i,j,k+1)) then + kcbl=k + else + kcbl=k+1 + endif + endif + iblht(i,j)=kcbl + + if(pblht(i,j) 0.) then + eddyz(i,j,k)=kz0 + else + eddyz(i,j,k)=kz0+SZKM*SQRT(ss)*(rich(k)-ri)/rich(k) + endif + eddyz(i,j,k)=AMIN1(eddyz(i,j,k),100.) + enddo + + ! Eddy diffusivity coefficients for all regimes in the mixed layer + + do k=iblht(i,j),KMAX_MID + if (mol(i,j) < 0.0) then !Unstable conditions + ri=(1.0-15.*z_mid(i,j,k)/mol(i,j))**(-0.25) + ri=ri/KARMAN/z_mid(i,j,k) + ri=ri*AMAX1(0.0,pblht(i,j)-z_mid(i,j,k)) + dthdz=ri*ust_r(i,j)**3. + goth=AMAX1(wstar(i,j),0.0) + dusq=0.4*goth**3. + ri=(dthdz+dusq)**(2./3.) + e(i,j,k)=0.5*ri*(2.6)**(2./3.) !Moeng and Sullivan (1994) + else + ri=z_bnd(i,j,k)/pblht(i,j) !Stable + ri=z_mid(i,j,k)/pblht(i,j) !New + ri=(1.0-ri) + ri=AMAX1(0.0,ri) + ri=(1.0-ri)**1.75 + e(i,j,k)=6.*ust_r(i,j)*ust_r(i,j)*ri !Lenshow(1988) + endif + + ! Calculate Ksi function using interpolation in the vertical + ! Alapaty (2001, 2003) + + zvh=z_mid(i,j,k)/pblht(i,j) + do l=1,9 + if (zvh > zovh(l).and. zvh < zovh(l+1)) then + psi_zi(k)=(psi_z(l+1)-psi_z(l))/(zovh(l+1)-zovh(l)) + psi_zi(k)=psi_zi(k)*(zvh-zovh(l)) + psi_zi(k)=psi_zi(k)+psi_z(l) + psi_zi(k)=psi_zi(k)/2.0 !Normalized the value + endif + enddo + enddo + + ! Calculate integral for Ksi + psi_tke=0. + do k=KMAX_MID,iblht(i,j),-1 + psi_tke=psi_tke+psi_zi(k)*dzq(i,j,k)*sqrt(e(i,j,k)) + enddo + + psi_tke=psi_tke/pblht(i,j) + + + + do k=iblht(i,j),KMAX_MID !Calculate coefficients + goth=psi_tke + goth=goth*KARMAN*z_mid(i,j,k) + dthdz=z_mid(i,j,k)/pblht(i,j) + dthdz=1.0-dthdz + dthdz=AMAX1(1.0E-2,dthdz) + if(mol(i,j) > 0.0) then !Stable + goth=sqrt(e(i,j,iblht(i,j))) ! Mihailovic (2004) + goth=goth*KARMAN*z_mid(i,j,k) ! ----------------- + dthdz=z_mid(i,j,k)/pzpbl(i,j) ! ----------------- + dthdz=1.0-dthdz + dthdz=AMAX1(1.0E-2,dthdz) + busfc=0.74+4.7*z_mid(i,j,KMAX_MID)/mol(i,j) + busfc=AMAX1(busfc,1.0) + dthdz=dthdz**1.50 !test (2004) + eddyz(i,j,k)=goth*dthdz/busfc + else + dthdz=dthdz*dthdz + busfc=1.0 + eddyz(i,j,k)=goth*dthdz/busfc + endif + enddo + + ! Checking procedure + do k=2,iblht(i,j)-1 + if(eddyz(i,j,k).le.0.0) THEN + eddyz(i,j,k)= KZ0LT + endif + enddo + + ! Avoid phisically unrealistic values + do k=2,KMAX_MID + IF(eddyz(i,j,k).le.0.1) then + eddyz(i,j,k)=0.1 + endif + enddo + + ! To avoid loss of mass/energy through top of the model + ! put eddyz (I,J,K) to zero at the last level from top + eddyz(i,j,KMAX_BND)=0.0 + + ! Calculate eddy coefficients at the interfaces + do k=2,KMAX_MID + eddyz(i,j,k)=0.5*(eddyz(i,j,k-1)+eddyz(i,j,k)) !! + + ! if(i.eq.10.and.j.eq.10.) then + ! if (abs(u(i,j ,k,nr)-u_mid(i,j,k)).gt.5.) then + ! + ! print *,"NEW ",i,j,u(i,j ,KMAX_MID,nr),u_mid(i,j,KMAX_MID) + ! endif + enddo + + ! Transform values of the eddy coeficients into the the sigma coordinate + + do k=2,KMAX_MID + eddyz(i,j,k)=eddyz(i,j,k)*((sigma_mid(k)-sigma_mid( k-1))/ & + ( z_mid(i,j,k)-z_mid(i,j,k-1)))**2. + + enddo + + ENDDO !----------------------------------------> + ENDDO !----------------------------------------> + !----------------------------------------> + + ! Store diffusivity coefficients into skh(i,j,k,nr) array + do k=2,KMAX_MID + do i=1,limax + do j=1,ljmax + skh(i,j,k,nr)=eddyz(i,j,k) + enddo + enddo + enddo + + ! For plotting set pblht = pzpbl + + pzpbl(:,:) = pblht(:,:) + + end subroutine tkediff + !--------------------------------------------------------------- + + + + + + !************************************************************************! + subroutine O_Brian(nr, KZ_MINIMUM, KZ_MAXIMUM, zimin, zs_bnd, ziu & + , exns, exnm, zixx ) ! + !************************************************************************! + + !...................................................... + !..exchange coefficients for convective boundary layer: + !..o'brien's profile formula: + !..and the air density at ground level: + ! + !..constants for free-convection limit: + ! + + integer, intent(in) :: nr + + real, intent(in) :: zimin & + ,KZ_MINIMUM & + ,KZ_MAXIMUM + + real,intent(in), dimension(MAXLIMAX,MAXLJMAX,KMAX_BND) :: zs_bnd & + ,exns + real,intent(in), dimension(MAXLIMAX,MAXLJMAX,KMAX_MID) :: exnm + + real,intent(in), dimension(MAXLIMAX,MAXLJMAX) :: ziu & + ,zixx + + + real :: h100 & ! Top of lowest layer - replaces 100.0 + ,xfrco & + ,exfrco & + ,sm & + ,ux0 & ! local ustar + ,ux3 & ! ustar**3, ds apr2005 + ,hsl & + ,hsurfl & + ,zimhs & + ,zimz & + ,zmhs & + ,fac & + ,fac2 & + ,dex12 & + ,ro + + + integer :: i,j,k + + ! local arrays: + real, dimension(MAXLIMAX):: xkh100 & + ,xkhs & + ,xkdz & + ,xkzi & + ,hs + + + real, dimension(MAXLIMAX,MAXLJMAX) :: help + + + + sm = 0.04 + + + xfrco=0.5*(sqrt(6859.)-1) + exfrco=1./3. + + + + + !c..exchange parameter and its vertical derivative at z = hs + + do j=1,ljmax + do i=1,limax + + xkh100(i)=0. + xkhs(i)=0. + xkdz(i)=0. + xkzi(i)=0. + h100 = zs_bnd(i,j,KMAX_MID) + ! + ! + !................................................................... + !..air density at ground level is always calculated diagnostically: + ! + + ux0 = ustar_nwp(i,j) + ux3 = ux0*ux0*ux0 + + + if(ziu(i,j) >= zimin) then + ! + !.......................... + !..unstable surface-layer.: + ! + !..height of surface layer + hs(i)=sm*ziu(i,j) + + !c..hsl=hs/l where l is the monin-obhukov length + hsl = KARMAN*GRAV*hs(i)*fh(i,j,nr)*KAPPA & + /(ps(i,j,nr)*ux3) + + + !changes: use simple Garratt \Phi function + ! instead of "older" Businge and Iversen/Nordeng stuff: + + xkhs(i) = ux0*KARMAN*hs(i)*sqrt(1.0-16.0*hsl) ! /Pr=1.00 + xkdz(i) = xkhs(i)*(1.-0.5*16.0*hsl/(1.0-16.0*hsl))/hs(i) + + hsurfl = KARMAN*GRAV*h100*fh(i,j,nr)*KAPPA & + /(ps(i,j,nr)*ux3) + xkh100(i) = ux0*KARMAN*h100*sqrt(1.-16.*hsurfl) + + Kz_min(i,j)=xkh100(i) + xksig(i,j,KMAX_MID)=xkhs(i) + + else + ! + !.......................... + !..stable surface-layer...: + !---------------------------------- + ! + !..height of surface layer + hs(i)=sm*zixx(i,j) + ! + !..hsl=hs/l where l is the monin-obhukov length + hsl = KARMAN*GRAV*hs(i)*amax1(0.001,fh(i,j,nr))*KAPPA& + /(ps(i,j,nr)*ux3) + + + xksig(i,j,KMAX_MID)=ux0*KARMAN*hs(i)/(1.00+5.0*hsl) + + + + endif + + hsurfl = KARMAN*GRAV*100.*amax1(0.001,fh(i,j,nr))*KAPPA& + /(ps(i,j,nr)*ux3) + Kz_min(i,j)=ux0*KARMAN*h100/(1.00+5.0*hsurfl) + ! + !............................................................... + + end do + ! + ! + !..exchange parameter at z = ziu + ! + do k=1,KMAX_MID + do i=1,limax + + if(ziu(i,j).gt.zimin .and. zs_bnd(i,j,k).ge.ziu(i,j)) then + xkzi(i)=xksig(i,j,k) + elseif (ziu(i,j).gt.zimin) then + ! + !..................................................... + !..the obrien-profile for zz_mid(i,j,k)) )then + xksig(i,j,k)=max(xksig(i,j,k),Kz_min(i,j)) + endif + + help(i,j) = xksig(i,j,k) + enddo + enddo + + call smoosp(help,KZ_MINIMUM ,KZ_MAXIMUM ) + + do i=1,limax + do j=1,ljmax + xksig(i,j,k) = help(i,j) + + fac = GRAV/(ps(i,j,nr) - PT) + fac2 = fac*fac + dex12 = th(i,j,k-1,nr)*(exnm(i,j,k) - exns(i,j,k)) & + + th(i,j,k,nr)*(exns(i,j,k) - exnm(i,j,k-1)) + ro = ((ps(i,j,nr) - PT)*sigma_bnd(k) + PT)*CP*(exnm(i,j,k) & + - exnm(i,j,k-1))/(R*exns(i,j,k)*dex12) + skh(i,j,k,nr) = xksig(i,j,k)*ro*ro*fac2 + enddo + enddo + + end do + + + ! + !............................................................... + !..mixing-layer parameterization finished....................... + !............................................................... + ! + + end subroutine O_Brian + + + + + + + + + + + + subroutine Getmeteofield(meteoname,namefield,nrec,& + ndim,validity,field) + ! + ! Read the meteofields and distribute to nodes + ! + + + implicit none + + real, dimension(*),intent(out) :: field ! dimensions: (MAXLIMAX,MAXLJMAX) + ! or (MAXLIMAX,MAXLJMAX,KMAX) + + character (len = *),intent(in) ::meteoname,namefield + character (len = *),intent(out) ::validity + + integer,intent(in) :: nrec,ndim + + + + integer*2 :: var_local(MAXLIMAX,MAXLJMAX,KMAX_MID) + 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='' + + if(ndim==3)KMAX=KMAX_MID + if(ndim==2)KMAX=1 + if(me==0)then + allocate(var_global(GIMAX,GJMAX,KMAX)) + nfetch=1 + call GetCDF_short(namefield,meteoname,var_global,GIMAX,IRUNBEG,GJMAX, & + JRUNBEG,KMAX,nrec,nfetch,scalefactors,validity) + else + 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,20,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + + deallocate(var_global) + + + ijk=0 + do k=1,KMAX ! KMAX is =1 for 2D arrays + do j=1,MAXLJMAX + do i=1,MAXLIMAX + ijk=ijk+1 + field(ijk)=var_local(i,j,k)*scalefactors(1)+scalefactors(2) + enddo + enddo + enddo + + end subroutine Getmeteofield + + + + + + + + subroutine GetCDF_short(varname,fileName,var,GIMAX,IRUNBEG,GJMAX,JRUNBEG & + ,KMAX,nstart,nfetch,scalefactors,validity) + ! + ! open and reads CDF file + ! + ! The nf90 are functions which return 0 if no error occur. + ! check is only a subroutine which check wether the function returns zero + ! + ! + implicit none + + character (len=*),intent(in) :: fileName + + character (len = *),intent(in) ::varname + character (len = *),intent(out) ::validity + real,intent(out) :: scalefactors(2) + integer, intent(in) :: nstart,GIMAX,IRUNBEG,GJMAX,JRUNBEG,KMAX + integer, intent(inout) :: nfetch + integer*2, dimension(GIMAX*GJMAX*KMAX*NFETCH),intent(out) :: var + integer :: varID,ndims + integer :: ncFileID,var_date,status + real :: scale,offset + character *100 :: period_read + + ndims=3 + if(KMAX==1)ndims=2 + !open an existing netcdf dataset + call check(nf90_open(path=trim(fileName),mode=nf90_nowrite,ncid=ncFileID)) + + !get varID: + call check(nf90_inq_varid(ncid=ncFileID,name=trim(varname),varID=VarID)) + + !get scale factors + 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 + + !find validity + validity=' ' !initialisation + period_read=' ' !initialisation + status = nf90_get_att(ncFileID, VarID, "validity", period_read ) + if(status == nf90_noerr)then + validity = trim(period_read) + else + status = nf90_get_att(ncFileID, VarID, "period_of_validity", & + period_read ) + if(status /= nf90_noerr)then + validity='instantaneous' !default + endif + endif + + ! if(Nfetch 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") + + ihh=1 + n1=1 + call check(nf90_get_var(ncFileID,timeVarID,nseconds,& + start=(/ihh/),count=(/n1 /))) + + call datefromsecondssince1970(ndate,nseconds(1),0) + 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 + call check(nf90_get_var(ncFileID, timeVarID, nseconds,& + start=(/ ihh /),count=(/ n1 /))) + call datefromsecondssince1970(ndate,nseconds(1),0) + + call CheckStop( mod((ihh-1)*METSTEP+nhour_first,24), ndate(4), & + "NetCDF_ml: wrong meteo hour" ) + + 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, gl_glob(1:IIFULLDOM,1) )) + do i=1,IIFULLDOM + if(gl_glob(i,1)>180.0)gl_glob(i,1)=gl_glob(i,1)-360.0 + enddo + do j=1,JJFULLDOM + gl_glob(:,j)=gl_glob(:,1) + enddo + call check(nf90_inq_varid(ncid = ncFileID, name = "lat", varID = varID)) + call check(nf90_get_var(ncFileID, varID, gb_glob(1,1:JJFULLDOM) )) + do i=1,IIFULLDOM + gb_glob(i,:)=gb_glob(1,:) + enddo + else + 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, gl_glob(1:IIFULLDOM,1:JJFULLDOM) )) + + call check(nf90_inq_varid(ncid = ncFileID, name = "lat", varID = varID)) + call check(nf90_get_var(ncFileID, varID, gb_glob(1:IIFULLDOM,1:JJFULLDOM) )) + + 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(gb_glob(1:IIFULLDOM,1:JJFULLDOM),8*IIFULLDOM*JJFULLDOM,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(gl_glob(1:IIFULLDOM,1:JJFULLDOM),8*IIFULLDOM*JJFULLDOM,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(projection,4*25,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + + do j=1,MAXLJMAX + do i=1,MAXLIMAX + gl(i,j)=gl_glob(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2) + gb(i,j)=gb_glob(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2) + 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(gl_glob(GIMAX,j)+360+360.0/GIMAX),360)/=& + mod(nint(gl_glob(IRUNBEG,j)+360.0),360))then + Cyclicgrid=0 !not cyclicgrid + endif + enddo + + if(me==0 .and. MY_DEBUG)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*gb_glob(gi0+i+IRUNBEG-2,gj0+j+JRUNBEG-2)-0.5*gb_glob(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 make 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 treat + !by "BoundaryConditions_ml". + !Note that "Poles" is defined in subdomains + + North_pole=1 + do i=1,limax + if(nint(gb(i,ljmax))<=88)then + North_pole=0 !not north pole + endif + enddo + + South_pole=1 + do i=1,limax + if(nint(gb(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 check(status) + implicit none + integer, intent ( in) :: status + + call CheckStop( status, nf90_noerr, "Error in Met_ml/NetCDF stuff" & + // trim( nf90_strerror(status) ) ) + + end subroutine check + !_______________________________________________________________________ + + subroutine datefromsecondssince1970(ndate,nseconds,printdate) + ! calculate date from seconds that have passed since the start of + ! the year 1970 + + implicit none + + integer, intent(out) :: ndate(4) + integer, intent(in) :: nseconds + integer, intent(in) :: printdate + + integer :: n,nday,nmdays(12),nmdays2(13) + nmdays = (/31,28,31,30,31,30,31,31,30,31,30,31/) + + nmdays2(1:12)=nmdays + nmdays2(13)=0 + ndate(1)=1969 + n=0 + do while(n<=nseconds) + n=n+24*3600*365 + ndate(1)=ndate(1)+1 + if(mod(ndate(1),4)==0)n=n+24*3600 + enddo + n=n-24*3600*365 + if(mod(ndate(1),4)==0)n=n-24*3600 + if(mod(ndate(1),4)==0)nmdays2(2)=29 + ndate(2)=0 + do while(n<=nseconds) + ndate(2)=ndate(2)+1 + n=n+24*3600*nmdays2(ndate(2)) + enddo + n=n-24*3600*nmdays2(ndate(2)) + ndate(3)=0 + do while(n<=nseconds) + ndate(3)=ndate(3)+1 + n=n+24*3600 + enddo + n=n-24*3600 + ndate(4)=-1 + do while(n<=nseconds) + ndate(4)=ndate(4)+1 + n=n+3600 + enddo + n=n-3600 + ! ndate(5)=nseconds-n + if(printdate>0)then + write(*,*)'year: ',ndate(1),', month: ',ndate(2),', day: ',& + ndate(3),', hour: ',ndate(4),', seconds: ',nseconds-n + endif + end subroutine datefromsecondssince1970 + +end module met_ml +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + + diff --git a/MicroMet_ml.f90 b/MicroMet_ml.f90 new file mode 100644 index 0000000..280c1b3 --- /dev/null +++ b/MicroMet_ml.f90 @@ -0,0 +1,209 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Micromet_ml +!____________________________________________________________________ +! Miscellaneous collection of "standard" micromet functions +! Including PsiM, PsiH, AerRes +! Some based upon code from Juha-Pekka Tuovinen, based upon Garrett +!____________________________________________________________________ +! +!** includes +! +! Depends on: none - self-contained. +! Language: F +!____________________________________________________________________ + implicit none + !F private + + !/-- Micromet (Aerodynamic) routines + + public :: rh2vpd + + public :: AerRes + + public :: AerResM + + public :: PsiH + + public :: PsiM + + public :: wind_at_h !wind for given height + + !/-- define PI here rather than use PhysicalCOnstants_ml, to + ! preserve self-sufficiency + + real, public, parameter :: & + PI = 3.14159265358979312000 ! pi, from 4.0*atan(1.) on cray + + + !======================================== + contains + !======================================== + + + !======================================================================= + !-------------------------------------------------------------------- + function rh2vpd(T,rh) result (vpd_res) + !This function is not currently in use. + + real, intent(in) :: T ! Temperature (K) + real, intent(in) :: rh ! relative humidity (%) + real :: vpd_res ! vpd = water vapour pressure deficit (Pa) + + ! Local: + real :: vpSat ! vpSat = saturated water vapour pressure (Pa) + real :: arg + + arg = 17.67 * (T-273.15)/(T-29.65) + vpSat = 611.2 * exp(arg) + vpd_res = (1.0 - rh/100.0) * vpSat + + end function rh2vpd + + !-------------------------------------------------------------------- + function AerRes(z1,z2,uStar,Linv,Karman) result (Ra) +!... +! Ref: Garratt, 1994, pp.55-58 +! In: + real, intent(in) :: z1 ! lower height (m), equivalent to h-d+1 or h-d+3 + real, intent(in) :: z2 ! upper height (m), equivalent to z-d + real, intent(in) :: uStar ! friction velocity (m/s) + real, intent(in) :: Linv ! inverse of the Obukhov length (1/m) + + real, intent(in) :: Karman ! von Karman's constant +! For AerRes, the above dummy argument is replaced by the actual argument +! KARMAN in the module GetMet_ml. + +! Out: + real :: Ra ! = aerodynamic resistance to transfer of sensible heat + !from z2 to z1 (s/m) + +! uses functions: +! PsiH = integral flux-gradient stability function for heat +!... + + Ra = log(z2/z1) - PsiH(z2*Linv) + PsiH(z1*Linv) + Ra = Ra/(Karman*uStar) + + end function AerRes + + !-------------------------------------------------------------------- + function AerResM(z1,z2,uStar,Linv,Karman) result (Ra) +!... +! Ref: Garratt, 1994, pp.55-58 +! In: + real, intent(in) :: z1 ! lower height (m), equivalent to h-d+1 or h-d+3 + real, intent(in) :: z2 ! upper height (m), equivalent to z-d + real, intent(in) :: uStar ! friction velocity (m/s) + real, intent(in) :: Linv ! inverse of the Obukhov length (1/m) + + real, intent(in) :: Karman ! von Karman's constant +! For AerRes, the above dummy argument is replaced by the actual argument +! KARMAN in the module GetMet_ml. + +! Out: + real :: Ra ! = aerodynamic resistance to transfer of momentum + !from z2 to z1 (s/m) + +! uses functions: +! PsiM = integral flux-gradient stability function for momentum +!... + + Ra = log(z2/z1) - PsiM(z2*Linv) + PsiM(z1*Linv) + Ra = Ra/(Karman*uStar) + + end function AerResM + + !-------------------------------------------------------------------- + function PsiH(zL) result (stab_h) + ! PsiH = integral flux-gradient stability function for heat + ! Ref: Garratt, 1994, pp52-54 + + ! In: + real, intent(in) :: zL ! surface layer stability parameter, (z-d)/L + + ! Out: + real :: stab_h ! PsiH(zL) + + ! Local + real :: x + + 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 + end if + + end function PsiH + + !-------------------------------------------------------------------- + function PsiM(zL) result (stab_m) + ! Out: + ! PsiM = integral flux-gradient stability function for momentum + ! Ref: Garratt, 1994, pp52-54 + + real, intent(in) :: zL ! = surface layer stability parameter, (z-d)/L + ! notation must be preserved + real :: stab_m + real :: x + + 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 + end if + + end function PsiM + +!-------------------------------------------------------------------- + function Wind_at_h(u_ref, z_ref, zh, d, z0, Linv) result (u_zh) +!... +! Ref: Garratt, 1994, +! In: + real, intent(in) :: u_ref ! windspeed at z_ref + real, intent(in) :: z_ref ! centre of call, ca. 45m (m) + real, intent(in) :: zh ! height required (m) + real, intent(in) :: d ! displacement height (m) + real, intent(in) :: z0 ! roughness height (m) + real, intent(in) :: Linv ! inverse of the Obukhov length (1/m) + +! Out: + real :: u_zh ! = wind-speed at height h (m/s) + + u_zh = u_ref * & + ( log((zh-d)/z0) -PsiM((zh-d)*Linv) + PsiM(z0*Linv) )/ & + ( log((z_ref-d)/z0) -PsiM((z_ref-d)*Linv) + PsiM(z0*Linv)) + + !NB - COULD USE INSTEAD: Ra = log(z2/z1) - PsiM(z2*Linv) + PsiM(z1*Linv) + ! Or could optimise with explicit PsiM, etc. + + end function Wind_at_h + +end module Micromet_ml diff --git a/ModelConstants_ml.f90 b/ModelConstants_ml.f90 new file mode 100644 index 0000000..efa2d0d --- /dev/null +++ b/ModelConstants_ml.f90 @@ -0,0 +1,159 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 ModelConstants_ml + !+ + ! Specifies a number of constants used in the model. Note that + ! physical constants (e.g. gravity, Cp, etc ( are specified in + ! the module PhysicalConstants_ml.f90) + ! + !---------------------------------------------------------------------------- + use PhysicalConstants_ml, only : AVOG + + implicit none + private + +!============================================================================= +!+ 1) Define first dimensions that might change quite often - for different +! run domains or debug points: + + integer, public, parameter, dimension(4) :: & + ! x0 x1 y0 y1 + RUNDOMAIN = (/ 36, 167, 12, 122 /) ! EMEP domain + !TESTER + ! RUNDOMAIN = (/ 80, 107, 40, 75 /) ! (changeable) + ! RUNDOMAIN = (/ 20, 167, 1, 122 /) ! OSPAR/HELCOM domain + ! RUNDOMAIN = (/ 18, 169, 1, 124 /) ! OSPAR/HELCOM domain+borders + + integer, public, parameter :: & + NPROCX = 3 & ! Actual number of processors in longitude + , NPROCY = 2 & ! Actual number of processors in latitude + , NPROC = NPROCX * NPROCY + + ! For debugging, we often want to print out for a specific location + ! Set here: + + !integer, public, parameter :: DEBUG_i=79, DEBUG_j=56 ! Eskdalemuir + !integer, public, parameter :: DEBUG_i=73, DEBUG_j=48 ! Mace Head + !integer, public, parameter :: DEBUG_i=91, DEBUG_j=71 ! Rorvik + integer, public, parameter :: DEBUG_i=82, DEBUG_j=72 ! Voss, has some snow + !integer, public, parameter :: DEBUG_i=101, DEBUG_j=51 ! Schauinsland + ! integer, public, parameter :: DEBUG_i=87, DEBUG_j=20 ! Aveiro + !integer, public, parameter :: DEBUG_i=103, DEBUG_j=50 ! Mid-Europe + !integer, public, parameter :: DEBUG_i=97, DEBUG_j=62 ! Waldhof + +!============================================================================= + ! Source-receptor runs? + ! We don't (generally) want daily outputs for SR runs, so in + ! Derived_ml, we set all IOU_DAY false if SOURCE_RECPTOR = .true.. + + logical, public, parameter :: SOURCE_RECEPTOR = .false. + + +!============================================================================= +!+ 2) Define domain-name, something that will +! generally only change when switching Met-driver or large domain + + character(len=20), parameter, public :: DomainName = "EMEP-50kmEurope" + +!============================================================================= +!+ 3) Define main model dimensions, things that will +! generally only change when switching Met-driver or large domain + integer, public, parameter :: & + IIFULLDOM = 170 & ! x-Dimensions of full domain + , JJFULLDOM = 133 & ! y-Dimensions of full domain + , NLANDUSE = 19 & ! Number of land use types in Inputs.Landuse file +! + , METSTEP = 3 & ! time-step of met. (h) + , KMAX_MID = 20 & ! Number of points (levels) in vertical + , KMAX_BND = KMAX_MID+1 & ! Number of points (levels) in vertical + 1 + , KTOP = 1 & ! K-value at top of domain + , NMET = 2 & ! No. met fields in memory + , KCHEMTOP = 2 & ! chemistry not done for k=1 + , KCLOUDTOP = 8 & ! limit of clouds (for MADE dj ??) + , KUPPER = 6 & ! limit of clouds (for wet dep.) + , AOT_HORIZON = 89 ! Limit of daylight zenith angle for AOTs + + +! EMEP measurements end at 6am, used in daily averages + integer, public, parameter :: END_OF_EMEPDAY = 6 + + real, public :: dt_advec ! time-step for advection (s) + real, public :: dt_advec_inv ! =1/dt_advec + + !NTDAY: Number of 2D O3 to be saved each day (for SOMO) + ! 24/NTDAY is the time integration step for SOMO + !large value-> large memory use; too small value ->bad approximation for SOMO + !NB must be choosen: 24*3600/dt_advec <= NTDAY >=3 and + !preferably an integer fraction of 24*3600/dt_advec + integer, public, parameter :: NTDAY = 72 + + !/-- choose temperature range: from 148 K (-125C) ro 333K (+60C). + + integer, parameter, public :: CHEMTMIN=148,CHEMTMAX=333 + + real, public, parameter :: & + V_RAIN = 5. & ! pw approximate vertical speed of rain m/ + ,CLOUDTHRES = 1.0e-5 !pw when cloudwater is larger than + !CLOUDTHRES, there are clouds. + !THIS VALUE MUST BE CHECKED BEFORE USE! +! +! additional parameters +! + integer, public, save :: nterm, nmax, nstep, nprint, nass, nbound + + integer, public, save :: iyr_trend ! Year specified for say BC changes + + integer, public, save , dimension(20) :: identi !! ???? + + character(len=120), public, save :: runlabel1& !SHORT Allows explanatory text + ,runlabel2 !LONG Read in from grun.pl + + real, public, parameter :: & + EPSIL=1.0e-30 & ! small number + , PASCAL=100.0 & ! Conv. from hPa to Pa + , PPB = 1.0e-9 & ! parts per billion (mixing ratio) + , PPBINV = 1.0e+9 & + , PPT = 1.0e-12 & ! parts per trillion (mixing ratio) + , PPTINV = 1.0e+12 & + , PT = 1.0e+4 ! Top of model region = 100 hPa + + real, public, parameter :: & + ATWAIR = 28.964 & ! Mol. weight of air (Jones, 1992) + , atwS = 32. & ! Atomic weight of Sulphur + , atwN = 14. & ! Atomic weight of Nitrogen + , atwPM = 100. + + ! MFAC replaces earlier use of CHEFAC and ATWAIR - to scale from + ! density (roa, kg/m3) to molecules/cm3 + ! (kg/m3 = 1000 g/m3 = 0.001 * Avog/Atw molecules/cm3) + + real, public, parameter :: MFAC = 0.001*AVOG/ATWAIR + + +end module ModelConstants_ml +!_____________________________________________________________________________ diff --git a/My_Aerosols_ml.f90 b/My_Aerosols_ml.f90 new file mode 100644 index 0000000..9888c57 --- /dev/null +++ b/My_Aerosols_ml.f90 @@ -0,0 +1,316 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module My_Aerosols_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!---------------------------------------------------------------------- +! Allows to select aerosol types for the model run: +! 1. AERO_DYNAMICS - for running UNI-AERO (presently not included) +! Options for aeroso-gas equilibrium partitioning: +! 2. EQUILIB_EMEP - old EMEP scheme +! 3. EQUILIB_MARS - run MARS equilibrium model +! 4. EQUILIB_EQSAM - run EQSAM equilibrium model +! 5. ORGANIC_AEROSOLS - for including Secondary Organic Aerosol (not active) +!---------------------------------------------------------------------- + + 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 + , ORGANIC_AEROSOLS = .false. + ! Number of aerosol sizes (1-fine, 2-coarse) + integer, public, parameter :: NSIZE = 2 + + logical, public, parameter :: SEASALT = .true. + +contains + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine My_MARS(deb) + + !.................................................................. + ! Pretty old F. Binkowski code from EPA CMAQ-Models3 + ! JGR, 108, D6, 4183 + !.................................................................. + + use Setup_1dfields_ml, only : xn_2d ! SIA concentration + use GenSpec_tot_ml, only : NH3, HNO3, SO4, aNO3, aNH4, NO3 + use Setup_1dfields_ml, only : temp, rh + use ModelConstants_ml, only : KMAX_MID, KCHEMTOP + use GenChemicals_ml, only : species + use PhysicalConstants_ml, only : AVOG + use MARS_ml, only: rpmares + + implicit none + real, parameter :: FLOOR = 1.0E-30 ! minimum concentration + + logical, intent(in) :: deb + + + !.. local + real :: so4in, no3in, nh4in, hno3in, nh3in, & + aSO4out, aNO3out, aH2Oout, aNH4out, gNH3out, gNO3out, & + coef + integer :: k, ic, bin, spec, errmark + logical :: debsub + !----------------------------------- + + coef = 1.e12 / AVOG + + 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(aNO3,k) * species(aNO3)%molwt *coef + nh4in = xn_2d(aNH4,k) * species(aNH4)%molwt *coef + + !-------------------------------------------------------------------------- + call rpmares (so4in, hno3in,no3in ,nh3in, nh4in , rh(k), temp(k), & + aSO4out, aNO3out, aH2Oout, aNH4out, gNH3out, gNO3out, & + ERRMARK,debsub) + !-------------------------------------------------------------------------- + + xn_2d(HNO3,k) = max (FLOOR, gNO3out / (species(HNO3)%molwt *coef) ) + xn_2d(NH3,k) = max (FLOOR, gNH3out / (species(NH3)%molwt *coef) ) + xn_2d(aNO3,k) = max (FLOOR, aNO3out / (species(aNO3)%molwt *coef) ) + xn_2d(aNH4,k) = max (FLOOR, aNH4out / (species(aNH4)%molwt *coef) ) + + enddo ! K-levels + + end subroutine My_MARS + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine My_EQSAM(debug_cell) + + !.................................................................. + !EQSAM - Equlibrium Simplified Aerosol Model by Swen Metzger + ! version v03d is implemented here + ! Metzger, S., Dentener, F., Pandis, S., and Lelieveld, J. (a): + ! Gas/Aerosol Partitioning 1: A computationally efficient model. + ! JGR, 107(D16), 10.1029/2001JD001102, 2002. + !.................................................................. + + use EQSAM_v03d_ml, only : eqsam_v03d + use Setup_1dfields_ml, only : xn_2d ! SIA concentration + use GenSpec_tot_ml, only : NH3, HNO3, SO4, aNO3, aNH4,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 + + logical, intent(in) :: debug_cell + + + !.. local + real :: so4in(KCHEMTOP:KMAX_MID), & + no3in(KCHEMTOP:KMAX_MID), & + nh4in(KCHEMTOP:KMAX_MID), & + hno3in(KCHEMTOP:KMAX_MID), & + nh3in(KCHEMTOP:KMAX_MID), & +! The following input is not in use + NAin(KCHEMTOP:KMAX_MID), & + CLin(KCHEMTOP:KMAX_MID), & + + aSO4out(KCHEMTOP:KMAX_MID), & + aNO3out(KCHEMTOP:KMAX_MID), & + aH2Oout(KCHEMTOP:KMAX_MID), & + aNH4out(KCHEMTOP:KMAX_MID), & + gNH3out(KCHEMTOP:KMAX_MID), & + gNO3out(KCHEMTOP:KMAX_MID), & + aNAout(KCHEMTOP:KMAX_MID), & + aCLout(KCHEMTOP:KMAX_MID), & + gCLout(KCHEMTOP:KMAX_MID), & + gSO4out(KCHEMTOP:KMAX_MID) + + integer :: i,j,k, errmark + logical :: debsub = .false. + !----------------------------------- + + + if ( debsub .and. debug_cell ) then ! Selected debug cell + write(*,*)'Before EQSAM',xn_2d(SO4,20),xn_2d(HNO3,20),& + xn_2d(NH3,20),xn_2d(aNO3,20),xn_2d(aNH4,20) + endif + +!//.... molec/cm3 -> micromoles/m**3 + so4in(KCHEMTOP:KMAX_MID) = xn_2d(SO4,KCHEMTOP:KMAX_MID)*1.e12/AVOG + hno3in(KCHEMTOP:KMAX_MID) = xn_2d(HNO3,KCHEMTOP:KMAX_MID)*1.e12/AVOG + nh3in(KCHEMTOP:KMAX_MID) = xn_2d(NH3,KCHEMTOP:KMAX_MID)*1.e12/AVOG + no3in(KCHEMTOP:KMAX_MID) = xn_2d(aNO3,KCHEMTOP:KMAX_MID)*1.e12/AVOG + nh4in(KCHEMTOP:KMAX_MID) = xn_2d(aNH4,KCHEMTOP:KMAX_MID)*1.e12/AVOG + + NAin(KCHEMTOP:KMAX_MID) = 0.0 + CLin(KCHEMTOP:KMAX_MID) = 0.0 + + !-------------------------------------------------------------------------- + + call eqsam_v03d (so4in, hno3in,no3in,nh3in,nh4in,NAin,CLin, rh,temp,pp, & + aSO4out, aNO3out, aNH4out, aNAout, aCLout, & + gSO4out, gNH3out, gNO3out, gClout, aH2Oout) + + !-------------------------------------------------------------------------- + +!//.... micromoles/m**3 -> molec/cm3 +! xn_2d(NO3,KCHEMTOP:KMAX_MID) = FLOOR !different for ACID/OZONE + + xn_2d(HNO3,KCHEMTOP:KMAX_MID) = max(FLOOR,gNO3out(KCHEMTOP:KMAX_MID)*AVOG/1.e12 ) + xn_2d(NH3,KCHEMTOP:KMAX_MID) = max(FLOOR,gNH3out(KCHEMTOP:KMAX_MID)*AVOG/1.e12 ) + xn_2d(aNO3,KCHEMTOP:KMAX_MID) = max(FLOOR,aNO3out(KCHEMTOP:KMAX_MID)*AVOG/1.e12 ) + xn_2d(aNH4,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 .and. debug_cell ) then ! Selected debug cell + write(*,*)'After EQSAM',xn_2d(SO4,20),xn_2d(HNO3,20),& + xn_2d(NH3,20),xn_2d(aNO3,20),xn_2d(aNH4,20) + endif + + end subroutine My_EQSAM + + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + + + !water + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine Aero_water(i,j) + + !..................................................................... + ! EQSAM is called before every daily output to calculate aerosol water + ! at T=20C and Rh = 50%. This should model the particle water content + ! for gravitationally determined PM mass + ! Tsyro, S. (2005). To what extent can aerosol water explain the + ! discrepancy between model calculated and gravimetric PM10 and PM2.5?. + ! 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 : PM_water !PMwater + use GenSpec_tot_ml, only : NH3, HNO3, SO4, aNO3, aNH4 + 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 + + integer, intent(in) :: i, j + + !.. local + real :: so4in(KCHEMTOP:KMAX_MID), & + no3in(KCHEMTOP:KMAX_MID), & + nh4in(KCHEMTOP:KMAX_MID), & + hno3in(KCHEMTOP:KMAX_MID), & + nh3in(KCHEMTOP:KMAX_MID), & +! fix + NAin(KCHEMTOP:KMAX_MID) , & + CLin(KCHEMTOP:KMAX_MID) , & + aSO4out(KCHEMTOP:KMAX_MID), & + aNO3out(KCHEMTOP:KMAX_MID), & + aH2Oout(KCHEMTOP:KMAX_MID), & + aNH4out(KCHEMTOP:KMAX_MID), & + gNH3out(KCHEMTOP:KMAX_MID), & + gNO3out(KCHEMTOP:KMAX_MID), & + aNAout(KCHEMTOP:KMAX_MID), & + aCLout(KCHEMTOP:KMAX_MID), & + gCLout(KCHEMTOP:KMAX_MID), & + gSO4out(KCHEMTOP:KMAX_MID), & + + rh50(KCHEMTOP:KMAX_MID),t20(KCHEMTOP:KMAX_MID) + + integer :: k, errmark + logical :: debsub = .false. + !----------------------------------- + + +! if ( debsub .and. debug_cell ) then ! Selected debug cell +! write(*,*)'Before EQSAM',xn_2d(SO4,20),xn_2d(HNO3,20),& +! xn_2d(NH3,20),xn_2d(aNO3,20),xn_2d(aNH4,20) +! endif + +!//.... molec/cm3 -> micromoles/m**3 + so4in(KCHEMTOP:KMAX_MID) = xn_2d(SO4,KCHEMTOP:KMAX_MID)*1.e12/AVOG + hno3in(KCHEMTOP:KMAX_MID) = xn_2d(HNO3,KCHEMTOP:KMAX_MID)*1.e12/AVOG + nh3in(KCHEMTOP:KMAX_MID) = xn_2d(NH3,KCHEMTOP:KMAX_MID)*1.e12/AVOG + no3in(KCHEMTOP:KMAX_MID) = xn_2d(aNO3,KCHEMTOP:KMAX_MID)*1.e12/AVOG + nh4in(KCHEMTOP:KMAX_MID) = xn_2d(aNH4,KCHEMTOP:KMAX_MID)*1.e12/AVOG + + NAin(KCHEMTOP:KMAX_MID) = 0. + CLin(KCHEMTOP:KMAX_MID) = 0. + + rh50(:) = 0.5 + t20(:) = 293. + + !-------------------------------------------------------------------------- + + call eqsam_v03d (so4in, hno3in,no3in,nh3in,nh4in,NAin,CLin, rh50,t20,pp, & + aSO4out, aNO3out, aNH4out, aNAout, aCLout, & + gSO4out, gNH3out, gNO3out, gClout, aH2Oout) + + !-------------------------------------------------------------------------- + +!//....aerosol water (ug/m**3 + + PM_water(i,j,KCHEMTOP:KMAX_MID) = max(0., aH2Oout(KCHEMTOP:KMAX_MID) ) + +! if ( debsub .and. debug_cell ) then ! Selected debug cell +! write(*,*)'After EQSAM',xn_2d(SO4,20),xn_2d(HNO3,20),& +! xn_2d(NH3,20),xn_2d(aNO3,20),xn_2d(aNH4,20) +! endif + + end subroutine Aero_water + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + end module My_Aerosols_ml + + + + + + diff --git a/My_BoundConditions_ml.f90 b/My_BoundConditions_ml.f90 new file mode 100644 index 0000000..8f8b03f --- /dev/null +++ b/My_BoundConditions_ml.f90 @@ -0,0 +1,319 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!################ OZONE model ############################################### +module My_BoundConditions_ml +!____________________________________________________________________________ +! This module specifies model-dependant: +! (A) boundary-condition (bc) indices and +! (B) mapping arrays "bc2xn_adv" and "bc2xn_bgn" +! - which tell how boundary conditions (bcs) are to be assigned to emep +! concentrations (xn_adv, xn_bgn). +! +! THIS FILE WILL CHANGE FOR DIFFERENT CHEMISTRIES - MUST BE SUPPLIED BY USER. +! AS A FIRST INDICATION OF THIS I HAVE SUPPLIED A "MY_MODEL" LABEL BELOW. +! +! The module BoundaryConditions_ml calls up this module with just: +! +! call My_bcmap() +! +! So far this module copes only with boundary condistion supplied either +! by the UiO global model (through the UiO_ml), or defined here as +! constant mixing ratios. +! +! Language: F +! History : +! ds - December 2000-January 2001 +! hf - september 2001 Misc BC's added as a function of sigma +!____________________________________________________________________________ +! IMPORTANT NOTE: +! The routines given here are constructed around the global model fields from +! the University of Oslo (T21) global model. In order to use other models as +! bcs then usually these routines will have to be replaced by model-specific +! routines. The important thing is that the inputs and outputs from the routine +! are independant of the global module used. +!_____________________________________________________________________________ + use GenSpec_bgn_ml, only: NSPEC_BGN + use GenSpec_adv_ml, only: NSPEC_ADV & + ,IXADV_H2,IXADV_O3, IXADV_SO2, IXADV_SO4 & + ,IXADV_HNO3,IXADV_PAN,IXADV_CO,IXADV_C2H4 & + ,IXADV_C2H6,IXADV_NC4H10,IXADV_HCHO,IXADV_CH3CHO & + ,IXADV_H2O2,IXADV_CH3O2H,IXADV_ISOP,IXADV_NO,IXADV_NO2 & + ,IXADV_CH4,IXADV_aNH4,IXADV_pNO3,IXADV_aNO3 & + ,IXADV_CH3COO2 + use GenSpec_shl_ml, only: IXSHL_OH + use GridValues_ml, only: sigma_mid !sigma layer midpoint + use Met_ml ,only : z_mid ! height of half layers + use ModelConstants_ml , only: KMAX_MID, NPROC ! No. levels in vertical, processors + use Par_ml, only: me + 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_aNH4,IBC_aNO3,IBC_pNO3& + ,IBC_H2O2,IBC_CH3COO2 + implicit none + private + + !/-- subroutines + public :: My_bcmap ! sets bc2xn_adv, bc2xn_bc, and misc_bc + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + !/-- model-type + ! for consistency checks, possibly to match label in My_model_ml?? + character(len=12), public :: MY_MODEL = "emepds" + + logical, public, parameter :: BGN_2D = .false. !No 2d bgn species + logical, private, parameter :: DEBUG_MYBC = .false. + + + ! A. Set indices + ! =========================================================================== + ! For species which have constant mixing ratios: + + integer, public, parameter :: NMISC_BC = 2 ! H2, CH4 ! OC + + integer, public, parameter :: IBC_H2 = NGLOB_BC + 1 & + ,IBC_CH4 = NGLOB_BC + 2 + !6s ,IBC_OC = NGLOB_BC + 2 + + integer, public, parameter :: NTOT_BC = NGLOB_BC + NMISC_BC + + ! We also need the array misc_bc to specify concentrations of these species: + + real, public, save, dimension(NGLOB_BC+1:NTOT_BC,KMAX_MID) :: misc_bc +!real, public, save, dimension(NGLOB_BC+1:NTOT_BC) :: misc_bc + + ! B. Define mapping arrays + ! =========================================================================== + ! The mapping is done through the arrays bc2xn_adv and bc2xn_bgn, such that + ! the emep species are given along the x-dimension and the bc species along + ! the y. e.g., the statement + ! + ! bc2xn_adv(IBC_NOX,IXADV_NO2) = 0.55 + ! + ! would assign the BC concentration of NOX to the EMEP model concentration + ! of NO2 after multiplication with a factor 0.55. + !(The CTM2 concentration of NOx used as BC after a multilication + ! with a factor 0.55.) + !_______________________________________________________________________ + + real, public, save, dimension(NTOT_BC,NSPEC_ADV) :: bc2xn_adv ! see above + real, public, save, dimension(NTOT_BC,NSPEC_BGN) :: bc2xn_bgn ! see above + + !------- + contains + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine My_bcmap(iyr_trend) ! sets bc2xn_adv, bc2xn_bc, and misc_bc + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + integer, intent(in) :: iyr_trend !ds Year for which BCs are wanted + real :: ppb = 1.0e-9 + real :: trend_ch4 !ds rv1.6.11 + integer :: ii,i,j,k + real :: decrease_factor(NGLOB_BC+1:NTOT_BC) ! Decrease factor for misc bc's + ! Gives the factor for how much of + ! the top-layer conc. that is left + ! at bottom layer + + real :: top_misc_bc(NGLOB_BC+1:NTOT_BC) ! Conc. at top of misc bc +! real :: ratio_length(KMAX_MID) ! Vertical length of the actual layer + ! divided by length from midpoint of + ! layer 1 to layer KMAX_MID + + misc_bc = 0.0 ! Initialise + bc2xn_adv = 0.0 ! Initialise + bc2xn_bgn = 0.0 ! Initialise + + ! Own (constant mixing ratio) boundary conditions ********** + + ! NOTE - these species have to have the bc2xn_ indices set to 1.0 for either + ! the advected or the background concentrations, in order that the + ! concentrations specified in misc_bc are transferred correctly into the + ! boundary conditions. + ! + ! 18.09.01 -hf- misc bc'c as function of sigma possible + + !ds top_misc_bc(IBC_CH4) = 1760.0 * ppb + + !ds set values of 1625 in 1980, 1780 in 1990, and 1820 in 2000. 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. + + 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 + !exp(-0.01*0.6633*(1975-iyr_trend)) !Zander,1951-1975, check + end if + trend_ch4 = top_misc_bc(IBC_CH4)/1780.0 ! Crude for now. + if (me== 0) write(6,"(a20,i5,2f12.3)") "TREND CH4", iyr_trend, trend_ch4, top_misc_bc(IBC_CH4) + + top_misc_bc(IBC_CH4) = top_misc_bc(IBC_CH4) * ppb + + top_misc_bc(IBC_H2) = 600.0 * ppb + + !! top_misc_bc(IBC_OC) = 0.0 !!! 1.0 * ppb + + decrease_factor(IBC_H2) =0.0 !No increase/decrease with height + decrease_factor(IBC_CH4)=0.0 !No increase/decrease with height + + +!a) Function of height(not included yet!): +!ratio_length(i,j,k)=(z_mid(i,j,1)-z_mid(i,j,k))/ & +! (z_mid(i,j,1)-z_mid(i,j,KMAX_MID)) +!Replace sigma_mid with ratio_length and make misc_bc 4 dimentional +! +!b)Function of sigma_mid (I assume that top_misc_bc is given for +!top(sigma_bnd(1)=0.), and that at ground (sigma_bnd(KMAX_BND)=1.) the conc. +!is top_misc_bc -decrease_factor*top_misc_bc. Since I choose to set the +! concentration as a factor of sigma_mid, the concentration in the lowest +! grid cell will not be +! excactly top_misc_bc -decrease_factor*top_misc_bc, but close. + + do ii=NGLOB_BC+1,NTOT_BC + do k=1,KMAX_MID + misc_bc(ii,k) = top_misc_bc(ii) - & + top_misc_bc(ii)*decrease_factor(ii)*sigma_mid(k) + if (me == 0) then + if (DEBUG_MYBC) write(*,"(a20,2es12.4,i4)")"height,misc_vert,k", & + sigma_mid(k),misc_bc(ii,k),k + endif + enddo + enddo + +! misc_bc(IBC_H2) = 600.0 * ppb +! misc_bc(IBC_OC) = 1.0*ppb !!! 0.0 + + bc2xn_adv(IBC_H2, IXADV_H2) = 1.0 + bc2xn_adv(IBC_CH4, IXADV_CH4) = 1.0 + + !/-- check, just in case we forgot something...! + + if ( DEBUG_MYBC ) then + print *, "In My_bcmap, NGLOB_BC, NTOT_BC is", NGLOB_BC, NTOT_BC + do i = NGLOB_BC+1 , NTOT_BC + print *, "In My_bcmap, sum-adv", i, " is", sum(bc2xn_adv(i,:)) + print *, "In My_bcmap, sum-bgn", i, " is", sum(bc2xn_bgn(i,:)) + end do + end if ! DEBUG + + do i = NGLOB_BC+1 , NTOT_BC + if ( sum(bc2xn_adv(i,:)) + sum(bc2xn_bgn(i,:)) /= 1.0 )then + WRITE(*,*) 'MPI_ABORT: ', "BCproblem - my" + call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + endif + end do + + + ! mappings for species from LOgan + obs model *********** + + bc2xn_adv(IBC_O3 ,IXADV_O3 ) = 1.0 + bc2xn_adv(IBC_HNO3 ,IXADV_HNO3 ) = 1.0 + bc2xn_adv(IBC_SO2 ,IXADV_SO2 ) = 1.0 + bc2xn_adv(IBC_SO4 ,IXADV_SO4 ) = 1.0 + bc2xn_adv(IBC_PAN ,IXADV_PAN ) = 1.0 + bc2xn_adv(IBC_CO ,IXADV_CO ) = 1.0 + bc2xn_adv(IBC_C2H6 ,IXADV_C2H6 ) = 1.0 + bc2xn_adv(IBC_C4H10 ,IXADV_NC4H10 ) = 1.0 + bc2xn_adv(IBC_NO ,IXADV_NO ) = 1.0 + bc2xn_adv(IBC_NO2 ,IXADV_NO2 ) = 1.0 + bc2xn_adv(IBC_HCHO ,IXADV_HCHO ) = 1.0 + bc2xn_adv(IBC_CH3CHO ,IXADV_CH3CHO ) = 1.0 + bc2xn_adv(IBC_aNO3 ,IXADV_aNO3 ) = 1.0 + bc2xn_adv(IBC_pNO3 ,IXADV_pNO3 ) = 1.0 + bc2xn_adv(IBC_aNH4 ,IXADV_aNH4 ) = 1.0 +!hfOH NEW: When a smaller domain than the full, there are BCs for these from OZONE +!hf err bc2xn_bgn(IBC_H2O2 ,IXADV_H2O2 ) = 1.0!hfOH +!hf err bc2xn_bgn(IBC_CH3COO2 ,IXADV_CH3COO2 ) = 1.0 !hfOH +!hf err bc2xn_bgn(IBC_OH ,IXSHL_OH ) = 1.0 !hfOH + bc2xn_adv(IBC_H2O2 ,IXADV_H2O2 ) = 1.0!hfOH + bc2xn_adv(IBC_CH3COO2 ,IXADV_CH3COO2 ) = 1.0 !hfOH + + +! The following species are excluded either because they have no corresponding +! species in the emep model, or because they have lifetimes which are so +! short that initialisation is uncessary. +!----------------------------------------------------------------------------- +!u3 bc2xn_adv(IBC_C2H4 ,IXADV_C2H4 ) = 1.0 +!u3 bc2xn_adv(IBC_C3H6 ,IXADV_NC4H10 ) = 0.75 +!u3 bc2xn_adv(IBC_C6H14 ,IXADV_NC4H10 ) = 1.5 ! ds - scale by C6/C4 +!u3 bc2xn_adv(IBC_CH2O ,IXADV_HCHO ) = 1.0 ! ds -rename +!u3 bc2xn_adv(IBC_CH3CHO ,IXADV_CH3CHO ) = 1.0 +!u3 bc2xn_adv(IBC_H2O2 ,IXADV_H2O2 ) = 1.0 +!u3 bc2xn_adv(IBC_CH3O2H ,IXADV_CH3O2H ) = 1.0 +!u3 bc2xn_adv(IBC_ISOPRENE,IXADV_ISOP ) = 1.0 ! ds-rename +!u3 bc2xn_adv(IBC_RCOHCO ,IXADV_CH3CHO ) = 1.0 ! ds - unknown scale +!u3 bc2xn_adv(IBC_CH4 ,IXADV_CH4 ) = 1.0 ! Re-included for DSMACH +!u3 bc2xn_adv(IBC_C3H8 ,IXADV_NC4H10 ) = 0.75 ! mini +!u3 bc2xn_adv(IBC_C3H8 ,IXADV_NC4H10 ) = 0.5 ! ds-split C2H6/NC4H10 +!!bc2xn_adv(IBC_NOX ,IXADV_NOX ) = -1.0 ! Excluded, we have NO and NO2 +!!bc2xn_adv(IBC_C6HXR ,IXADV_C6HXR ) = 1.0 +!!bc2xn_adv(IBC_HO2NO2 ,IXADV_HO2NO2 ) = 1.0 +!!bc2xn_adv(IBC_CH3COY ,IXADV_CH3COY ) = 1.0 +!!bc2xn_adv(IBC_CH3COX ,IXADV_CH3COX ) = 1.0 +!!bc2xn_adv(IBC_HO2 ,IXADV_HO2 ) = -1.0 ! SHort-lived +!!bc2xn_adv(IBC_CH2O2OH ,IXADV_CH2O2OH ) = 1.0 +!!bc2xn_adv(IBC_CH3COB ,IXADV_CH3COB ) = -1.0 ! ??? +!!bc2xn_adv(IBC_CH3XX ,IXADV_CH3XX ) = 1.0 +!!bc2xn_adv(IBC_AR1 ,IXADV_AR1 ) = -1.0 ! ??? +!!bc2xn_adv(IBC_AR2 ,IXADV_AR2 ) = 1.0 +!!bc2xn_adv(IBC_AR3 ,IXADV_AR3 ) = -1.0 ! ??? +!!bc2xn_adv(IBC_ISOR1 ,IXADV_ISOR1 ) = -1.0 ! Re-Excluded +!!bc2xn_adv(IBC_ISOK ,IXADV_ISOK ) = -1.0 ! ?? +!!bc2xn_adv(IBC_ISOR2 ,IXADV_ISOR2 ) = -1.0 ! SHort-lived +!!bc2xn_adv(IBC_HCOHCO ,IXADV_HCOHCO ) = -1.0 ! Excluded +!!bc2xn_adv(IBC_CH3X ,IXADV_CH3X ) = -1.0 ! ?? +!!bc2xn_adv(IBC_NO3 ,IXADV_NO3 ) = -1.0 ! SHort-lived +!!bc2xn_adv(IBC_N2O5 ,IXADV_N2O5 ) = 1.0 ! jej - 000927 +!!bc2xn_adv(IBC_C3H7O2 ,IXADV_C3H7O2 ) = 1.0 +!!bc2xn_adv(IBC_ACETONE ,IXADV_ACETON ) = 1.0 +!!bc2xn_adv(IBC_CH3COD ,IXADV_CH3COD ) = -1.0 ! ?? +!!bc2xn_adv(IBC_NOZ ,IXADV_NOZ ) = -1.0 ! ??? +!!bc2xn_adv(IBC_CH3O2 ,IXADV_CH3O2 ) = Short-lived +!!bc2xn_adv(IBC_C2H5O2 ,IXADV_C2H5O2 ) = Short-lived +!!bc2xn_adv(IBC_C4H9O2 ,IXADV_C4H9O2 ) = Short-lived +!!bc2xn_adv(IBC_C6H13O2 ,IXADV_C6H13O2 ) = Short-lived +!!bc2xn_adv(IBC_O3P ,IXADV_O3P ) = -1.0 ! Short-lived +!!bc2xn_adv(IBC_O1D ,IXADV_O1D ) = -1.0 ! Short-lived +!!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 ???? + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + end subroutine My_bcmap + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +end module My_BoundConditions_ml +!_____________________________________________________________________________ + + + + diff --git a/My_Chem_ml.f90 b/My_Chem_ml.f90 new file mode 100644 index 0000000..6079fb7 --- /dev/null +++ b/My_Chem_ml.f90 @@ -0,0 +1,665 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!########### OZONE model ################################### +!>_________________________________________________________< + + module GenSpec_bgn_ml +!----------------------------------------------------------- + use ModelConstants_ml, only : KMAX_MID,KCHEMTOP + implicit none + private + +!+ Defines indices and NSPEC for bgn : Background species + + ! Species which can be specified simply for each column, e.g. + ! as function of local meteorology or zenith angle + ! o2, m, and for MADE-like, oh, ch3coo2 + + integer, public, parameter :: NSPEC_BGN = 0 ! No. 3D bgn species + integer, public, parameter :: NSPEC_COL = 0 ! total no. prescribed specs + + !/ define xn_2d_bgn here. + real, public, save, dimension(1,KCHEMTOP:KMAX_MID) :: xn_2d_bgn + +!----------------------------------------------------------- + end module GenSpec_bgn_ml + + +!>_________________________________________________________< + + module GenSpec_adv_ml +!----------------------------------------------------------- + implicit none +!/ ...... .. ( from GenChem ) + +!+ Defines indices and NSPEC for adv : Advected species + +! ( Output from GenChem, sub print_species ) + + integer, public, parameter :: NSPEC_ADV = 60 + + ! Aerosols: + + logical, public, parameter :: ORG_AEROSOLS = .false. + + integer, public, parameter :: & + NAEROSOL = 0, &! Number of aerosol species + FIRST_SOA = -99, &! First aerosol species + LAST_SOA = -99 ! Last aerosol species + + + + integer, public, parameter :: & + IXADV_O3 = 1 & + , IXADV_NO = 2 & + , IXADV_NO2 = 3 & + , IXADV_PAN = 4 & + , IXADV_MPAN = 5 & + , IXADV_NO3 = 6 & + , IXADV_N2O5 = 7 & + , IXADV_ISONO3 = 8 & + , IXADV_HNO3 = 9 + + integer, public, parameter :: & + IXADV_CH2CCH3 = 10 & + , IXADV_CH3COO2 = 11 & + , IXADV_MACR = 12 & + , IXADV_ISNI = 13 & + , IXADV_ISNIR = 14 & + , IXADV_GLYOX = 15 & + , IXADV_MGLYOX = 16 & + , IXADV_MAL = 17 & + , IXADV_MEK = 18 & + , IXADV_MVK = 19 + + integer, public, parameter :: & + IXADV_HCHO = 20 & + , IXADV_CH3CHO = 21 & + , IXADV_C2H6 = 22 & + , IXADV_NC4H10 = 23 & + , IXADV_C2H4 = 24 & + , IXADV_C3H6 = 25 & + , IXADV_OXYL = 26 & + , IXADV_ISOP = 27 & + , IXADV_CH3O2H = 28 & + , IXADV_C2H5OOH = 29 + + integer, public, parameter :: & + IXADV_BURO2H = 30 & + , IXADV_ETRO2H = 31 & + , IXADV_PRRO2H = 32 & + , IXADV_OXYO2H = 33 & + , IXADV_MEKO2H = 34 & + , IXADV_MALO2H = 35 & + , IXADV_MVKO2H = 36 & + , IXADV_MARO2H = 37 & + , IXADV_ISRO2H = 38 & + , IXADV_H2O2 = 39 + + integer, public, parameter :: & + IXADV_CH3COO2H = 40 & + , IXADV_CH2CO2HCH3 = 41 & + , IXADV_ISONO3H = 42 & + , IXADV_ISNIRH = 43 & + , IXADV_CH3OH = 44 & + , IXADV_C2H5OH = 45 & + , IXADV_H2 = 46 & + , IXADV_CO = 47 & + , IXADV_CH4 = 48 & + , IXADV_SO2 = 49 + + integer, public, parameter :: & + IXADV_SO4 = 50 & + , IXADV_pNO3 = 51 & + , IXADV_NH3 = 52 & + , IXADV_aNH4 = 53 & !total NH4 + , IXADV_aNO3 = 54 & !total fine particulate nitrate + , IXADV_PM25 = 55 & + , IXADV_PMco = 56 & + , IXADV_SSfi = 57 & !SeaSalt + , IXADV_SSco = 58 & + , IXADV_Rn222 = 59 & ! + , IXADV_Pb210 = 60 ! + !----------------------------------------------------------- + end module GenSpec_adv_ml +!>_________________________________________________________< + + module GenSpec_shl_ml +!----------------------------------------------------------- + implicit none +!/ ...... .. ( from GenChem ) + +!+ Defines indices and NSPEC for shl : Short-lived (non-advected) species + +! ( Output from GenChem, sub print_species ) + + integer, public, parameter :: NSPEC_SHL = 16 + + ! Aerosols: + integer, public, parameter :: & + NAEROSOL = 0, &! Number of aerosol species + FIRST_SOA = -99, &! First aerosol species + LAST_SOA = -99 ! Last aerosol species + + + + integer, public, parameter :: & + IXSHL_OD = 1 & + , IXSHL_OP = 2 & + , IXSHL_OH = 3 & + , IXSHL_HO2 = 4 & + , IXSHL_CH3O2 = 5 & + , IXSHL_C2H5O2 = 6 & + , IXSHL_SECC4H9O2 = 7 & + , IXSHL_ISRO2 = 8 & + , IXSHL_ETRO2 = 9 + + integer, public, parameter :: & + IXSHL_PRRO2 = 10 & + , IXSHL_OXYO2 = 11 & + , IXSHL_MEKO2 = 12 & + , IXSHL_MALO2 = 13 & + , IXSHL_MVKO2 = 14 & + , IXSHL_MACRO2 = 15 & + , IXSHL_PHNO3 = 16 + !----------------------------------------------------------- + end module GenSpec_shl_ml +!>_________________________________________________________< + + module GenSpec_tot_ml +!----------------------------------------------------------- + + + implicit none +!/ ...... .. ( from GenChem ) + +!+ Defines indices and NSPEC for tot : All reacting species + +! ( Output from GenChem, sub print_species ) + + logical, public, parameter :: ORG_AEROSOLS = .false. + + integer, public, parameter :: NSPEC_TOT = 76 + + + ! Aerosols: + integer, public, parameter :: & + NAEROSOL = 0, &! Number of aerosol species + FIRST_SOA = -99, &! First aerosol species + LAST_SOA = -99 ! Last aerosol species + + + + integer, public, parameter :: & + OD = 1 & + , OP = 2 & + , OH = 3 & + , HO2 = 4 & + , CH3O2 = 5 & + , C2H5O2 = 6 & + , SECC4H9O2 = 7 & + , ISRO2 = 8 & + , ETRO2 = 9 + + integer, public, parameter :: & + PRRO2 = 10 & + , OXYO2 = 11 & + , MEKO2 = 12 & + , MALO2 = 13 & + , MVKO2 = 14 & + , MACRO2 = 15 & + , PHNO3 = 16 & + , O3 = 17 & + , NO = 18 & + , NO2 = 19 & + , PAN = 20 + + integer, public, parameter :: & + MPAN = 21 & + , NO3 = 22 & + , N2O5 = 23 & + , ISONO3 = 24 & + , HNO3 = 25 & + , CH2CCH3 = 26 & + , CH3COO2 = 27 & + , MACR = 28 & + , ISNI = 29 & + , ISNIR = 30 + + integer, public, parameter :: & + GLYOX = 31 & + , MGLYOX = 32 & + , MAL = 33 & + , MEK = 34 & + , MVK = 35 & + , HCHO = 36 & + , CH3CHO = 37 & + , C2H6 = 38 & + , NC4H10 = 39 & + , C2H4 = 40 + + integer, public, parameter :: & + C3H6 = 41 & + , OXYL = 42 & + , ISOP = 43 & + , CH3O2H = 44 & + , C2H5OOH = 45 & + , BURO2H = 46 & + , ETRO2H = 47 & + , PRRO2H = 48 & + , OXYO2H = 49 & + , MEKO2H = 50 + + integer, public, parameter :: & + MALO2H = 51 & + , MVKO2H = 52 & + , MARO2H = 53 & + , ISRO2H = 54 & + , H2O2 = 55 & + , CH3COO2H = 56 & + , CH2CO2HCH3 = 57 & + , ISONO3H = 58 & + , ISNIRH = 59 & + , CH3OH = 60 + + integer, public, parameter :: & + C2H5OH = 61 & + , H2 = 62 & + , CO = 63 & + , CH4 = 64 & + , SO2 = 65 & + , SO4 = 66 & + , pNO3 = 67 & + , NH3 = 68 & + , aNH4 = 69 & + , aNO3 = 70 & + , PM25 = 71 & + , PMco = 72 & + , SSFI = 73 & !SeaS + , SSco = 74 & !SeaS + , Rn222 = 75 & + , Pb210 = 76 !ds apr2005 + + !----------------------------------------------------------- + end module GenSpec_tot_ml +!>_________________________________________________________< +!>_________________________________________________________< + + module GenChemicals_ml +!----------------------------------------------------------- + + use GenSpec_tot_ml, only: NSPEC_TOT ! Total number of species for chemistry + implicit none + private +!/ ...... .. ( from GenChem ) + + + !/-- 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 + character(len=12) :: name + real :: molwt + integer :: nmhc ! nmhc (1) or not(0) + integer :: carbons ! Carbon-number + real :: nitrogens ! Nitrogen-number + integer :: sulphurs ! Sulphur-number + end type Chemical + type(Chemical), public, dimension(NSPEC_TOT) :: species + + 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 NMHC C N S + species( 1) = Chemical("OD ", 16, 0, 0, 0, 0 ) + species( 2) = Chemical("OP ", 16, 0, 0, 0, 0 ) + species( 3) = Chemical("OH ", 17, 0, 0, 0, 0 ) + species( 4) = Chemical("HO2 ", 33, 0, 0, 0, 0 ) + species( 5) = Chemical("CH3O2 ", 47, 0, 1, 0, 0 ) + species( 6) = Chemical("C2H5O2 ", 61, 0, 2, 0, 0 ) + species( 7) = Chemical("SECC4H9O2 ", 89, 0, 4, 0, 0 ) + species( 8) = Chemical("ISRO2 ", 101, 0, 5, 0, 0 ) + species( 9) = Chemical("ETRO2 ", 77, 0, 2, 0, 0 ) + species( 10) = Chemical("PRRO2 ", 91, 0, 3, 0, 0 ) + species( 11) = Chemical("OXYO2 ", 1, 0, 8, 0, 0 ) !ds1 + species( 12) = Chemical("MEKO2 ", 103, 0, 4, 0, 0 ) + species( 13) = Chemical("MALO2 ", 147, 0, 5, 0, 0 ) + species( 14) = Chemical("MVKO2 ", 119, 0, 4, 0, 0 ) + species( 15) = Chemical("MACRO2 ", 102, 0, 4, 0, 0 ) + species( 16) = Chemical("PHNO3 ", 0, 0, 0, 0, 0 ) + species( 17) = Chemical("O3 ", 48, 0, 0, 0, 0 ) + species( 18) = Chemical("NO ", 30, 0, 0, 1, 0 ) + species( 19) = Chemical("NO2 ", 46, 0, 0, 1, 0 ) + species( 20) = Chemical("PAN ", 121, 0, 2, 1, 0 ) + species( 21) = Chemical("MPAN ", 132, 0, 4, 1, 0 ) + species( 22) = Chemical("NO3 ", 62, 0, 0, 1, 0 ) + species( 23) = Chemical("N2O5 ", 108, 0, 0, 2, 0 ) + species( 24) = Chemical("ISONO3 ", 110, 0, 5, 1, 1 ) + species( 25) = Chemical("HNO3 ", 63, 0, 0, 1, 0 ) + species( 26) = Chemical("CH2CCH3 ", 73, 0, 3, 0, 0 ) + species( 27) = Chemical("CH3COO2 ", 75, 0, 2, 0, 0 ) + species( 28) = Chemical("MACR ", 70, 0, 4, 0, 0 ) + species( 29) = Chemical("ISNI ", 46, 0, 4, 1, 1 ) + species( 30) = Chemical("ISNIR ", 46, 0, 4, 1, 1 ) + species( 31) = Chemical("GLYOX ", 58, 0, 2, 0, 0 ) + species( 32) = Chemical("MGLYOX ", 72, 0, 3, 0, 0 ) + species( 33) = Chemical("MAL ", 98, 0, 5, 0, 0 ) + species( 34) = Chemical("MEK ", 72, 0, 4, 0, 0 ) + species( 35) = Chemical("MVK ", 70, 0, 4, 0, 0 ) + species( 36) = Chemical("HCHO ", 30, 0, 1, 0, 0 ) + species( 37) = Chemical("CH3CHO ", 44, 0, 2, 0, 0 ) + species( 38) = Chemical("C2H6 ", 30, 1, 2, 0, 0 ) + species( 39) = Chemical("NC4H10 ", 58, 1, 4, 0, 0 ) + species( 40) = Chemical("C2H4 ", 28, 1, 2, 0, 0 ) + species( 41) = Chemical("C3H6 ", 42, 1, 3, 0, 0 ) + species( 42) = Chemical("OXYL ", 106, 1, 8, 0, 0 ) + species( 43) = Chemical("ISOP ", 68, 1, 5, 0, 0 ) + species( 44) = Chemical("CH3O2H ", 48, 0, 1, 0, 0 ) + species( 45) = Chemical("C2H5OOH ", 62, 0, 2, 0, 0 ) + species( 46) = Chemical("BURO2H ", 90, 0, 4, 0, 0 ) + species( 47) = Chemical("ETRO2H ", 78, 0, 2, 0, 0 ) + species( 48) = Chemical("PRRO2H ", 92, 0, 3, 0, 0 ) + species( 49) = Chemical("OXYO2H ", 1, 0, 8, 0, 0 ) + species( 50) = Chemical("MEKO2H ", 104, 0, 4, 0, 0 ) + species( 51) = Chemical("MALO2H ", 147, 0, 5, 0, 0 ) + species( 52) = Chemical("MVKO2H ", 1, 0, 4, 0, 0 ) + species( 53) = Chemical("MARO2H ", 1, 0, 5, 0, 0 ) + species( 54) = Chemical("ISRO2H ", 1, 0, 5, 0, 0 ) + species( 55) = Chemical("H2O2 ", 34, 0, 0, 0, 0 ) + species( 56) = Chemical("CH3COO2H ", 76, 0, 2, 0, 0 ) + species( 57) = Chemical("CH2CO2HCH3 ", 74, 0, 3, 0, 0 ) + species( 58) = Chemical("ISONO3H ", 1, 0, 5, 0, 0 ) + species( 59) = Chemical("ISNIRH ", 1, 0, 5, 0, 0 ) + species( 60) = Chemical("CH3OH ", 32, 0, 1, 0, 0 ) + species( 61) = Chemical("C2H5OH ", 46, 0, 2, 0, 0 ) + species( 62) = Chemical("H2 ", 2, 0, 0, 0, 0 ) + species( 63) = Chemical("CO ", 28, 0, 1, 0, 0 ) + species( 64) = Chemical("CH4 ", 16, 0, 1, 0, 0 ) + species( 65) = Chemical("SO2 ", 64, 0, 0, 0, 1 ) + species( 66) = Chemical("SO4 ", 96, 0, 0, 0, 1 ) + species( 67) = Chemical("pNO3 ", 62, 0, 0, 1, 0 ) + species( 68) = Chemical("NH3 ", 17, 0, 0, 1, 0 ) + species( 69) = Chemical("aNH4 ", 18, 0, 0, 1, 0 ) + species( 70) = Chemical("aNO3 ", 62, 0, 0, 1, 0 ) + species( 71) = Chemical("PM25 ", 100, 0, 0, 0, 0 ) + species( 72) = Chemical("PMCO ", 100, 0, 0, 0, 0 ) + species( 73) = Chemical("SSfi ", 58, 0, 0, 0, 0 ) !SeaS + species( 74) = Chemical("SSco ", 58, 0, 0, 0, 0 ) + species( 75) = Chemical("Rn222 ", 222, 0, 0, 0, 0 ) + species( 76) = Chemical("Pb210 ", 210, 0, 0, 0, 0 ) + + end subroutine define_chemicals + end module GenChemicals_ml + !----------------------------------------------------------- +!>_________________________________________________________< + + module GenRates_rcmisc_ml +!----------------------------------------------------------- + + + use PhysicalConstants_ml, only : PI, RGAS_J + use ModelConstants_ml, only : KMAX_MID,KCHEMTOP +! VOLFAC ! for N2O5-> NO3- + + use Functions_ml, only : troe + implicit none + private +!/ ...... .. ( from GenChem ) + + + !+ Tabulates Rate-coefficients - complex dependancies + + public :: set_rcmisc_rates + + integer, parameter, public :: NRCMISC = 18 !! No. coefficients + + real, save, public, dimension(NRCMISC) :: rcvmisc + real, save, public, dimension(366) :: & + tab_so2ox ! Tabulated so2->so4 rate for 366 days (leap-year safe!) + + contains + !------------------------------------ + subroutine set_rcmisc_rates(itemp,tinv,m,o2,h2o,rh,rcmisc) + integer, intent(in), dimension(KCHEMTOP:KMAX_MID) :: itemp + real, intent(in), dimension(KCHEMTOP:KMAX_MID) :: tinv,m,o2,h2o,rh + real, intent(out),dimension(NRCMISC,KCHEMTOP:KMAX_MID) :: rcmisc + integer :: k ! local + real, dimension(KCHEMTOP:KMAX_MID) :: n2 ! nitrogen + real :: lt3(KCHEMTOP:KMAX_MID) ! - for Troe + n2 = m - o2 + + rcmisc(1,:) = 6.0e-34*m*o2*(300.0*tinv)**2.3 + 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,:) = (1.0+1.4e-21*h2o*exp(2200.0*tinv))*2.3e-13*exp(600.0*tinv) + rcmisc(6,:) = (1.0+1.4e-21*h2o*exp(2200.0*tinv))*1.7e-33*exp(1000.0*tinv)*m + rcmisc(7,:) = 1.3e-13*(1+0.6*m/2.55e19) + + + do k = KCHEMTOP, KMAX_MID + if ( rh(k) > 0.4) then + rcmisc(8,k) = & + sqrt(3.0 * RGAS_J * itemp(k) / 0.108) & ! mean molecular speed,m/s ! + /(4*(2.5 - rh(k)*1.25))!density, corrected for rh (moderate approx.) + !VOLFAC now in My_Reactions + else + rcmisc(8,k) = 0.0 + endif + + if (rh(k) > 0.9 ) then + rcmisc(10,k) = 1.0e-4 + else + rcmisc(10,k) = 5.0e-6 + end if + end do ! k + + ! - new SO2 -> SO4 method from old ACID code + + + ! - troe stuff put here to simplify ..... + + lt3(:) = log(300.0*tinv(:)) + + + rcmisc(11,:) = troe(1.0e-31*exp(1.6*lt3(:)),3.0e-11*exp(-0.3*lt3(:)), -0.1625,m(:)) + rcmisc(12,:) = troe(2.7e-30*exp(3.4*lt3(:)),2.0e-12*exp(-0.2*lt3(:)), -1.109,m(:)) + rcmisc(13,:) = troe(1.0e-3*exp(3.5*lt3(:))*exp(-11000*tinv(:)),9.70e14*exp(-0.1*lt3(:))*exp(-11080*tinv(:)), -1.109,m(:)) + rcmisc(14,:) = troe(2.6e-30*exp(2.9*lt3(:)),6.7e-11*exp(0.6*lt3(:)), -0.844,m(:)) + rcmisc(15,:) = troe(2.7e-28*exp(7.1*lt3(:)),1.2e-11*exp(0.1*lt3(:)), -1.204,m(:)) + rcmisc(16,:) = 1*troe(4.9e-3*exp(-12100*tinv(:)),5.4e16*exp(-13830*tinv(:)), -1.204,m(:)) + rcmisc(17,:) = troe(7.0e-29*exp(3.1*lt3(:)),9.0e-12, -0.3567,m(:)) + rcmisc(18,:) = troe(8.0e-17*exp(3.5*lt3(:)),3.0e-11,-0.6931,m(:)) + + end subroutine set_rcmisc_rates +end module GenRates_rcmisc_ml +!>_________________________________________________________< + + module GenRates_rct_ml +!----------------------------------------------------------- + use ModelConstants_ml, only : KMAX_MID,KCHEMTOP & + , CHEMTMIN, CHEMTMAX !u3 + implicit none + private +!/ ...... .. ( from GenChem ) + + + !+ Tabulates Rate-coefficients - temperature dependant + + public :: set_rct_rates, set_night_rct + + integer, parameter, public :: NRCT = 37 !! No. coefficients + + real, save, public, dimension(NRCT) :: rcvt + +!/ Output gas-phase chemical rates: ! - from Tabulations + + real, save, public, & + dimension(NRCT,CHEMTMIN:CHEMTMAX) :: rcit ! rate-coefficients + +!- added for ozone model also (consistency with ACID) +! Only nighttime NO2->NO3 + logical, public, parameter :: ONLY_NIGHT = .false. + + + contains + !------------------------------------ + subroutine set_rct_rates(tinv) + real, intent(in) :: tinv + rcvt(1) = 1.8e-12*exp(-1370.0*tinv) + rcvt(2) = 1.2e-13*exp(-2450.0*tinv) + rcvt(3) = 1.9e-12*exp(-1000.0*tinv) + rcvt(4) = 1.4e-14*exp(-600.0*tinv) + rcvt(5) = 1.8e-11*exp(110.0*tinv) + rcvt(6) = 3.7e-12*exp(240.0*tinv) + rcvt(7) = 7.2e-14*exp(-1414.0*tinv) + rcvt(8) = 4.8e-11*exp(250.0*tinv) + rcvt(9) = 2.9e-12*exp(-160.0*tinv) + rcvt(10) = 7.7e-12*exp(-2100.0*tinv) + rcvt(11) = 1.05e-14*exp(785.0*tinv) + rcvt(12) = 3.9e-12*exp(-1765.0*tinv) + rcvt(13) = 4.2e-12*exp(180.0*tinv) + rcvt(14) = 5.9e-14*exp(509.0*tinv) + rcvt(15) = 7.04e-14*exp(365.0*tinv) + rcvt(16) = 3.1e-12*exp(-360.0*tinv) + rcvt(17) = 3.8e-13*exp(780.0*tinv) + rcvt(18) = 1e-12*exp(190.0*tinv) + rcvt(19) = 1.9e-12*exp(190.0*tinv) + rcvt(20) = 8.6e-12*exp(20.0*tinv) + rcvt(21) = 7.9e-12*exp(-1030.0*tinv) + rcvt(22) = 2.7e-13*exp(1000.0*tinv) + rcvt(23) = 5.8e-12*exp(190.0*tinv) + rcvt(24) = 5.6e-12*exp(310.0*tinv) + rcvt(25) = 2.8e-12*exp(530*tinv) + rcvt(26) = 1.3e-13*exp(1040.0*tinv) + rcvt(27) = 3e-13*exp(1040.0*tinv) + rcvt(28) = 3.69e-12*exp(-70*tinv) + rcvt(29) = 1.64e-11*exp(-559.0*tinv) + rcvt(30) = 1.2e-14*exp(-2630.0*tinv) + rcvt(31) = 6.5e-15*exp(-1880.0*tinv) + rcvt(32) = 1.23e-14*exp(-2013*tinv) + rcvt(33) = 2.54e-11*exp(410.0*tinv) + rcvt(34) = 4.13e-12*exp(452.0*tinv) + rcvt(35) = 1.86e-11*exp(175.0*tinv) + rcvt(36) = 1.34e+16*exp(-13330.0*tinv) + rcvt(37) = 4.32e-15*exp(-2016.0*tinv) + + end subroutine set_rct_rates + !------------------------------------------------------ + subroutine set_night_rct(rct,rh,i,j) + implicit none + integer,intent(in) :: i,j + real,intent(in) :: rct(NRCT,KCHEMTOP:KMAX_MID) + real,intent(in) :: rh(KCHEMTOP:KMAX_MID) + + ! Dummy for OZONE + + end subroutine set_night_rct + !------------------------------------------------------ +end module GenRates_rct_ml + +!>_________________________________________________________< + + module MyChem_ml +!----------------------------------------------------------- +! Module containijng initial setup routine calls (Init_mychem) +! and intended to allow the user to specify miscelanneaous +! bits of extra code as needed. Here we have so far included +! Set_2dBgnd in orer to get xn_2d:bgnd for MADE. +! +! We have a new subroutine Init_mychem for all model versions +! which now does tabulations previously done in Tabulations_ml + + use Functions_ml, only : Daily_sine ! to specify so2ox + use GenSpec_bgn_ml, only : NSPEC_COL ! - nothing more needed + ! for OZONE , xn_2d_bgn, IXBGN_OH, + + use GenRates_rct_ml, only : & ! + NRCT, & ! No. temperature dependant coefficients + rcvt, & ! Temperature dependant coefficients + rcit, & ! Rate coeffs as rc(n, temp(k) ) + set_rct_rates ! Gives RCT as function of temp t + + use GenRates_rcmisc_ml, only : tab_so2ox + + use ModelConstants_ml, only : KMAX_MID,KCHEMTOP, KCLOUDTOP & + ,CHEMTMIN, CHEMTMAX !u3 temp. range + use PhysicalConstants_ml, only : PI, DEG2RAD + implicit none + private + !depending on clouds + + public :: Init_mychem ! Calls model-specific routines + public :: Set_2dBgnd ! Sets model-specific background concs. + ! (dummy for OZONE so far) + + + contains + !------------------------------------------------------------------ + + subroutine Init_mychem() + + !+1) Temperature-dependant rates (rct). Only needs to be called once + ! at beginning of simulations to set up table + + integer :: it ! Local loop variable + real :: tinv ! temperature in K + + do it = CHEMTMIN, CHEMTMAX + tinv = 1.0/real(it) + call set_rct_rates(tinv) + rcit(:,it) = rcvt(:) + end do + + !+2) + ! Tabulate SO2 oxidation rates with a safe 366 value for ndays + ! Coefficients taken from Eliassen+Saltbones (1983) (also in + ! Berge and Jakobsen, 1998 + + tab_so2ox = Daily_sine(4.0e-6,2.5e-6,80+91,366) + + + end subroutine Init_mychem + !------------------------------------------------------------------ + + subroutine Set_2dBgnd(izen,cloud,m) + integer, intent(in) :: izen + real,dimension(KMAX_MID), intent(in) :: cloud ! cloud-cover fraction + real, intent(in), dimension(KCHEMTOP:KMAX_MID) :: m ! air density + + ! Dummy for OZONE + end subroutine Set_2dBgnd + + end module MyChem_ml + !----------------------------------------------------------- +!>_________________________________________________________< diff --git a/My_Derived_ml.f90 b/My_Derived_ml.f90 new file mode 100644 index 0000000..1e98557 --- /dev/null +++ b/My_Derived_ml.f90 @@ -0,0 +1,416 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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_Derived_ml + + !--------------------------------------------------------------------------- + ! DESCRIPTION + ! This module specifies the "derived" fields, such as accumulated + ! precipitation + ! or sulphate, daily, monthly or yearly averages, depositions. These fields + ! are all typically output as netCDF fields. + ! + ! This module provides the user-defined setups which are used in Derived_ml. + ! Derived fields are identified by a "class", such as "ADV" of "VOC", and + ! the Derived_ml should perform any integrations for this. + ! + ! Several often-used routines (e.g. for AOTs, acc. sulphate, are defined + ! in the Derived_ml.f90, but users can define their own here, since + ! we do not use "use only" in Derived_ml. + ! + ! Only text strings used here to define wanted data + ! All data field characteristics should be defined in Derived_ml, e.g. + ! in f_2d arrays. + ! Derived fields such as d_2d only exist in Derived_ml, so are + ! accessed here through subroutine calls - using just the (i,j) part + ! of the bigger d_2d arrays + !--------------------------------------------------------------------------- + +use GenSpec_adv_ml ! Use IXADV_ indices... +use GenSpec_shl_ml ! Use IXSHL_ indices... +use GenSpec_tot_ml, only : SO4, HCHO, CH3CHO & ! For mol. wts. + ,aNO3, pNO3, aNH4, PM25, PMCO & + ,SSfi, SSco !SeaS +use GenChemicals_ml, only : species ! For mol. wts. +use ModelConstants_ml, only : atwS, atwN, ATWAIR & + , SOURCE_RECEPTOR & + , KMAX_MID & ! => z dimension + , PPBINV & ! 1.0e9 + , MFAC ! converts roa (kg/m3 to M, molec/cm3) + +use Chemfields_ml, only : xn_adv, xn_shl, cfac +use GenSpec_adv_ml ! Use NSPEC_ADV amd any of IXADV_ indices +use Met_ml, only : z_bnd, roa ! 6c REM: zeta +use Par_ml, only: me, MAXLIMAX,MAXLJMAX, & ! => max. x, y dimensions + limax, ljmax ! => used x, y area +use SmallUtils_ml, only : AddArray, LenArray, NOT_SET_STRING, WriteArray +use TimeDate_ml, only : current_date +implicit none +private + + public :: Init_My_Deriv + public :: My_DerivFunc + + private :: misc_xn & ! Miscelleaneous Sums and fractions of xn_adv + ,pm_calc ! Miscelleaneous PM's + + + character(len=8), public ,parameter :: model='ZD_OZONE' + + + !/** Depositions are stored in separate arrays for now - to keep size of + ! derived arrays smaller and to allow possible move to a Deposition + ! module at a later stage. + ! Factor 1.0e6 converts from kg/m2/a to mg/m2/a + + ! We normally distinguish source-receptor (SR) stuff from model + ! evaluation. The SR runs should use as few as possible outputs + ! to keep CPU and disc-requirements down. We define first then the + ! minimum list of outputs for use in SR, then define an extra list + ! of parameters needed in model evaluation, or even for the base-case + ! of SR runs. + + + !============ parameters for source-receptor modelling: ===================! + + integer, public, parameter :: MAX_NUM_DERIV2D = 200 + integer, public, parameter :: MAX_NUM_DERIV3D = 5 + character(len=12), public, save, & + dimension(MAX_NUM_DERIV2D) :: wanted_deriv2d = NOT_SET_STRING + character(len=12), public, save, & + dimension(MAX_NUM_DERIV3D) :: wanted_deriv3d = NOT_SET_STRING + + integer, private, save :: mynum_deriv2d + integer, private, save :: mynum_deriv3d + + + + character(len=12), public, parameter, dimension(49) :: & + D2_SR = (/ & +! +! Particles: components + "D2_SO4 ","D2_aNO3 ","D2_pNO3 ","D2_aNH4 " & + ,"D2_PPM25 ","D2_PPMco ","D2_PM25_H2O " & +! +! Particles: sums + ,"D2_SIA ","D2_PM25 ","D2_PM10 ","D2_PMco " & + ,"D2_SS ","D2_tNO3 " & +! +! Ozone and AOTs + ,"D2_O3 ","D2_MAXO3 " & + ,"D2_AOT30 ","D2_AOT40 ","D2_AOT60 " & + ,"D2_AOT30f ","D2_AOT40f ","D2_AOT60f ","D2_AOT40c " & + ,"D2_EUAOT30WH","D2_EUAOT30DF","D2_EUAOT40WH","D2_EUAOT40DF" & + ,"D2_UNAOT30WH","D2_UNAOT30DF","D2_UNAOT40WH","D2_UNAOT40DF" & + ,"D2_MMAOT30WH","D2_MMAOT40WH" & + ,"D2_SOMO35 ","D2_SOMO0 " & +! +! NOy-type sums + ,"D2_NO2 ","D2_OXN ","D2_NOX ","D2_NOZ " & + ,"D2_OX " & +! +! Ecosystem - fluxes: + ,"D2_AFSTDF0 ","D2_AFSTDF16 ","D2_AFSTBF0 ","D2_AFSTBF16 " & + ,"D2_AFSTCR0 ","D2_AFSTCR3 ","D2_AFSTCR6 " & ! + ,"D2_O3DF ","D2_O3WH " & +! +! Surface pressure (for cross section): + ,"PS " & + /) + + !============ Extra parameters for model evaluation: ===================! + + character(len=12), public, parameter, dimension(7) :: & + D2_EXTRA = (/ & + "D2_SO2 ","D2_HNO3 ","D2_NH3 ","D2_VOC "& + ,"D2_REDN ","D2_SSfi ","D2_SSco " & + /) + + +!---------------------- +! Less often needed: + !exc "D2_CO ","D2T_HCHO ","D2T_CH3CHO","D2_VOC ", + !exc ,"D2_O3CF ","D2_O3TC ","D2_O3GR ","D2_ACCSU ", + !"D2_FRNIT ","D2_MAXOH ","D2_HMIX ","D2_HMIX00 ","D2_HMIX12 " & + !exc "D2_PAN ","D2_AOT20 " /) + + !======= MY_DERIVED SYSTEM ====================================== + + ! use character arrays to specify which outputs are wanted + + character(len=9), public, parameter, dimension(4) :: & + WDEP_WANTED = (/ "WDEP_PREC", "WDEP_SOX ", "WDEP_OXN ", & + "WDEP_RDN " /) ! WDEP_PM not used + + !( waters and wetlands removed:) + + character(len=10), public, parameter, dimension(15) :: & + DDEP_WANTED = (/ & + "DDEP_SOX ","DDEP_OXN ","DDEP_RDN " & + ,"DDEP_OXSCF","DDEP_OXSDF","DDEP_OXSCR","DDEP_OXSSN" & + ,"DDEP_OXNCF","DDEP_OXNDF","DDEP_OXNCR","DDEP_OXNSN" & + ,"DDEP_RDNCF","DDEP_RDNDF","DDEP_RDNCR","DDEP_RDNSN" & + /) + + character(len=13), public, parameter, dimension(2) :: & + D3_WANTED = (/ "D3_O3 ","D3_TH " /) + + + integer, private :: i,j,k,n, ivoc, index ! Local loop variables + + contains + + !========================================================================= + subroutine Init_My_Deriv() + + ! Build up the array wanted_deriv2d with the required field names + + call AddArray(WDEP_WANTED, wanted_deriv2d, NOT_SET_STRING) + call AddArray(DDEP_WANTED, wanted_deriv2d, NOT_SET_STRING) + call AddArray( D2_SR, wanted_deriv2d, NOT_SET_STRING) + + if ( .not. SOURCE_RECEPTOR ) then !may want extra? + call AddArray( D2_EXTRA, wanted_deriv2d, NOT_SET_STRING) + end if + mynum_deriv2d = LenArray( wanted_deriv2d, NOT_SET_STRING ) + + ! ditto wanted_deriv3d.... + + !if ( .not. SOURCE_RECEPTOR ) then + ! call AddArray( D3_WANTED, wanted_deriv3d, NOT_SET_STRING) + !end if + mynum_deriv3d = LenArray( wanted_deriv3d, NOT_SET_STRING ) + + + if ( me == 0 ) then + write(*,*) "Init_My_Deriv, mynum_deriv2d = ", mynum_deriv2d + call WriteArray(wanted_deriv2d,mynum_deriv2d," Wanted 2d array is") + write(*,*) "Init_My_Deriv, mynum_deriv3d = ", mynum_deriv3d + call WriteArray(wanted_deriv3d,mynum_deriv3d," Wanted 3d array is") + + end if + + end subroutine Init_My_Deriv + !========================================================================= + subroutine My_DerivFunc( e_2d, n, class , timefrac, density ) + + ! We define here here any functions which cannot easily be defined + ! in the more general Derived_ml. For example, we need the + ! index for IXADV_O3 for AOTs, and this might not be available in the model + ! we are running (a PM2.5 model for example), so it is better to define + ! this function here. + + real, dimension(:,:), intent(inout) :: e_2d ! (i,j) 2-d extract of d_2d + integer, intent(in) :: n ! index in Derived_ml::d_2d arrays + character(len=*), intent(in) :: class ! Class of data + real, intent(in) :: timefrac ! Timestep as frationof hour, dt/3600 + + real, intent(in), dimension(MAXLIMAX,MAXLJMAX) :: density +! density = 1 ( or = roa when unit ug) + + select case ( class ) + + case ( "OX", "NOX", "NOZ", "TOXN", "TRDN", "FRNIT", "tNO3 ", "SSalt" ) + + call misc_xn( e_2d, n, class, density ) + + case ( "SIA", "PM10", "PM25", "PMco" ) + + call pm_calc(e_2d, n, class, density) + + case default + + print *, "WARNING - REQUEST FOR UNDEFINED OUTPUT:", n, class + end select + + + + end subroutine My_DerivFunc + !========================================================================= + + subroutine pm_calc( pm_2d, n, class, density ) + + !/-- calulates PM10 = SIA + PPM2.5 + PPMco + + real, dimension(:,:), intent(inout) :: pm_2d ! i,j section of d_2d arrays + integer, intent(in) :: n ! index in Derived_ml::d_2d arrays + character(len=*) :: class ! Type of data + real, intent(in), dimension(MAXLIMAX,MAXLJMAX) :: density + + select case ( class ) + + case ( "SIA" ) + + forall ( i=1:limax, j=1:ljmax ) + !ds d_2d( n, i,j,IOU_INST) = & + pm_2d( i,j) = & + ( xn_adv(IXADV_SO4,i,j,KMAX_MID) *species(SO4)%molwt *cfac(IXADV_SO4,i,j) & + + xn_adv(IXADV_aNO3,i,j,KMAX_MID)*species(aNO3)%molwt*cfac(IXADV_aNO3,i,j) & + + xn_adv(IXADV_pNO3,i,j,KMAX_MID)*species(pNO3)%molwt*cfac(IXADV_pNO3,i,j) & + + xn_adv(IXADV_aNH4,i,j,KMAX_MID)*species(aNH4)%molwt*cfac(IXADV_aNH4,i,j))& + * density(i,j) + end forall + + case ( "PM25" ) + + forall ( i=1:limax, j=1:ljmax ) + pm_2d( i,j ) = & + ( xn_adv(IXADV_SO4,i,j,KMAX_MID) *species(SO4)%molwt *cfac(IXADV_SO4,i,j) & + + xn_adv(IXADV_aNO3,i,j,KMAX_MID)*species(aNO3)%molwt*cfac(IXADV_aNO3,i,j) & + + xn_adv(IXADV_aNH4,i,j,KMAX_MID)*species(aNH4)%molwt*cfac(IXADV_aNH4,i,j) & + + xn_adv(IXADV_PM25,i,j,KMAX_MID)*species(PM25)%molwt*cfac(IXADV_PM25,i,j) & + + xn_adv(IXADV_SSfi,i,j,KMAX_MID)*species(SSfi)%molwt *cfac(IXADV_SSfi,i,j))& !SeaS + * density(i,j) + end forall + + case ( "PMco" ) + + forall ( i=1:limax, j=1:ljmax ) + pm_2d( i,j ) = & + ( xn_adv(IXADV_pNO3,i,j,KMAX_MID)*species(pNO3)%molwt*cfac(IXADV_pNO3,i,j) & + + xn_adv(IXADV_PMco,i,j,KMAX_MID)*species(PMCO)%molwt*cfac(IXADV_PMco,i,j) & + + xn_adv(IXADV_SSco,i,j,KMAX_MID) *species(SSco)%molwt *cfac(IXADV_SSco,i,j))& !SeaS + * density(i,j) + end forall + + case ( "PM10" ) + + forall ( i=1:limax, j=1:ljmax ) + pm_2d( i,j ) = & + ( xn_adv(IXADV_SO4,i,j,KMAX_MID) *species(SO4)%molwt*cfac(IXADV_SO4,i,j) & + + xn_adv(IXADV_aNO3,i,j,KMAX_MID)*species(aNO3)%molwt*cfac(IXADV_aNO3,i,j) & + + xn_adv(IXADV_pNO3,i,j,KMAX_MID)*species(pNO3)%molwt*cfac(IXADV_pNO3,i,j) & + + xn_adv(IXADV_aNH4,i,j,KMAX_MID)*species(aNH4)%molwt*cfac(IXADV_aNH4,i,j) & + + xn_adv(IXADV_PM25,i,j,KMAX_MID)*species(PM25)%molwt*cfac(IXADV_PM25,i,j) & + + xn_adv(IXADV_PMco,i,j,KMAX_MID)*species(PMCO)%molwt*cfac(IXADV_PMco,i,j) & + + xn_adv(IXADV_SSfi,i,j,KMAX_MID)*species(SSfi)%molwt*cfac(IXADV_SSfi,i,j) & !SeaS + + xn_adv(IXADV_SSco,i,j,KMAX_MID)*species(SSco)%molwt*cfac(IXADV_SSco,i,j))& !SeaS + * density(i,j) + end forall + + end select + + end subroutine pm_calc + !========================================================================= + +!========================================================================= + + subroutine misc_xn( e_2d, n, class, density) + real, dimension(:,:), intent(inout) :: e_2d ! i,j section of d_2d arrays + integer, intent(in) :: n ! index in Derived_ml::d_2d arrays + character(len=*) :: class ! Type of data + real, intent(in), dimension(MAXLIMAX,MAXLJMAX) :: density +! density = 1 ( or = roa when unit ug) + + + !/-- adds up sulphate, nitrate, or whatever is defined + + select case ( class ) + + case ( "TOXN" ) + forall ( i=1:limax, j=1:ljmax ) + e_2d( i,j ) = & + ( xn_adv(IXADV_HNO3,i,j,KMAX_MID) * cfac(IXADV_HNO3,i,j) & + + xn_adv(IXADV_aNO3,i,j,KMAX_MID) * cfac(IXADV_aNO3,i,j) & + + xn_adv(IXADV_pNO3,i,j,KMAX_MID) * cfac(IXADV_pNO3,i,j)) & + * density(i,j) + end forall + + +! OX for O3 and NO2 trend studies + + case ( "OX" ) + forall ( i=1:limax, j=1:ljmax ) + e_2d( i,j ) = & + xn_adv(IXADV_O3,i,j,KMAX_MID) * cfac(IXADV_O3,i,j) & + + xn_adv(IXADV_NO2,i,j,KMAX_MID) * cfac(IXADV_NO2,i,j) + end forall + + case ( "NOX" ) + forall ( i=1:limax, j=1:ljmax ) + e_2d( i,j ) = & + ( xn_adv(IXADV_NO,i,j,KMAX_MID) & + + xn_adv(IXADV_NO2,i,j,KMAX_MID) * cfac(IXADV_NO2,i,j) & + ) * density(i,j) + end forall + + case ( "NOZ" ) + forall ( i=1:limax, j=1:ljmax ) + e_2d( i,j ) = & + ( xn_adv(IXADV_HNO3,i,j,KMAX_MID) * cfac(IXADV_HNO3,i,j) & + + xn_adv(IXADV_aNO3,i,j,KMAX_MID) * cfac(IXADV_aNO3,i,j) & + + xn_adv(IXADV_pNO3,i,j,KMAX_MID) * cfac(IXADV_pNO3,i,j) & + + xn_adv(IXADV_PAN,i,j,KMAX_MID) * cfac(IXADV_PAN,i,j) & + + xn_adv(IXADV_MPAN,i,j,KMAX_MID) * cfac(IXADV_MPAN,i,j) & + + xn_adv(IXADV_NO3,i,j,KMAX_MID) & + + 2.0* xn_adv(IXADV_N2O5,i,j,KMAX_MID) & + + xn_adv(IXADV_ISNI,i,j,KMAX_MID) & + ) * density(i,j) + end forall + + + case ( "TRDN" ) + forall ( i=1:limax, j=1:ljmax ) + e_2d( i,j ) = & + ( xn_adv(IXADV_NH3,i,j,KMAX_MID) * cfac(IXADV_NH3,i,j) & + + xn_adv(IXADV_aNH4,i,j,KMAX_MID) * cfac(IXADV_aNH4,i,j)) & + * density(i,j) + end forall + + + case ( "FRNIT" ) + forall ( i=1:limax, j=1:ljmax ) + e_2d( i,j ) = & + ( xn_adv(IXADV_aNO3,i,j,KMAX_MID) * cfac(IXADV_aNO3,i,j) & + + xn_adv(IXADV_pNO3,i,j,KMAX_MID) * cfac(IXADV_pNO3,i,j)) & + /max(1E-80, (xn_adv(IXADV_HNO3,i,j,KMAX_MID) * cfac(IXADV_HNO3,i,j))& + + xn_adv(IXADV_aNO3,i,j,KMAX_MID) * cfac(IXADV_aNO3,i,j) & + + xn_adv(IXADV_pNO3,i,j,KMAX_MID) * cfac(IXADV_pNO3,i,j)) + end forall + + case ( "tNO3" ) + forall ( i=1:limax, j=1:ljmax ) + e_2d( i,j ) = & + ( xn_adv(IXADV_aNO3,i,j,KMAX_MID) * cfac(IXADV_aNO3,i,j) & + + xn_adv(IXADV_pNO3,i,j,KMAX_MID) * cfac(IXADV_pNO3,i,j) )& + * density(i,j) + end forall + + case ( "SSalt" ) + forall ( i=1:limax, j=1:ljmax ) + e_2d( i,j ) = & + ( xn_adv(IXADV_SSfi,i,j,KMAX_MID) * cfac(IXADV_SSfi,i,j) & + + xn_adv(IXADV_SSco,i,j,KMAX_MID) * cfac(IXADV_SSco,i,j) )& + * density(i,j) + end forall + + end select + end subroutine misc_xn + !========================================================================= +end module My_Derived_ml diff --git a/My_DryDep_ml.f90 b/My_DryDep_ml.f90 new file mode 100644 index 0000000..586f522 --- /dev/null +++ b/My_DryDep_ml.f90 @@ -0,0 +1,475 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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_DryDep_ml ! DryDep_ml +!+ +! Module to define the dry deposition components and rates. We +! define the min (vd_min) and max dep. velocity (Vg) first and then derive the +! daytime addition (vd_day). +!/************************************************************************** +! Specifies which of the possible species (from Wesely's list) +! are required in the current air pollution model +!/************************************************************************** + + use Derived_ml, only : f_2d, d_2d, IOU_INST + + use GenSpec_adv_ml ! e.g. NSPEC_ADV,IXADV_O3,IXADV_H2O2, + use LandDefs_ml, only : LandDefs, LandType + use Landuse_ml, only : WheatGrowingSeason + use LocalVariables_ml, only : Grid !=> izen integer of zenith angle + use ModelConstants_ml , only : atwS, atwN, AOT_HORIZON + use PhysicalConstants_ml, only : AVOG + use SmallUtils_ml, only: find_index + use StoFlux_ml, only : unit_flux, lai_flux, leaf_flux + use TimeDate_ml, only : current_date + use Wesely_ml + implicit none + private + + public :: Init_DepMap + public :: Add_ddep + + + !/** 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 + + + integer, private, save :: & + DDEP_SOX, DDEP_OXN, DDEP_RDN, & + DDEP_OXSSW, DDEP_OXSCF, DDEP_OXSDF, DDEP_OXSCR, DDEP_OXSSN, DDEP_OXSWE, & + DDEP_OXNSW, DDEP_OXNCF, DDEP_OXNDF, DDEP_OXNCR, DDEP_OXNSN, DDEP_OXNWE, & + DDEP_RDNSW, DDEP_RDNCF, DDEP_RDNDF, DDEP_RDNCR, DDEP_RDNSN, DDEP_RDNWE, & + D2_AFSTDF0, D2_AFSTDF16, D2_AFSTBF0, D2_AFSTBF16, & + D2_AFSTCR0, D2_AFSTCR3, D2_AFSTCR6,& + iam_medoak, iam_beech, iam_wheat, & ! For Fluxes + D2_O3DF, D2_O3WH, & + D2_EUAOT30WH, D2_EUAOT40WH, D2_EUAOT30DF, D2_EUAOT40DF, & + D2_UNAOT30WH, D2_UNAOT40WH, D2_UNAOT30DF, D2_UNAOT40DF, & + D2_MMAOT40WH, D2_MMAOT30WH + + + ! 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. + + integer, public, parameter :: NDRYDEP_CALC = 10 ! gases + integer, public, parameter :: NDRYDEP_AER = 2 ! aerosols + integer, public, parameter :: NDRYDEP_TOT = NDRYDEP_CALC + NDRYDEP_AER + + + integer, public, parameter :: & + CDEP_HNO3 = 1, CDEP_O3 = 2, CDEP_SO2 = 3 & + ,CDEP_NH3 = 4, CDEP_NO2 = 5, CDEP_PAN = 6 & + ,CDEP_H2O2 = 7, CDEP_ALD = 8, CDEP_HCHO = 9, & + CDEP_OP = 10, CDEP_FIN = 11, CDEP_COA = 12 + + integer, public, parameter :: CDEP_SET = -99 + + + + ! WE NEED A FLUX_CDEP, FLUX_ADV FOR OZONE; + ! (set to one for non-ozone models) + + logical, public, parameter :: STO_FLUXES = .true. + integer, public, parameter :: FLUX_CDEP = CDEP_O3 + integer, public, parameter :: FLUX_ADV = IXADV_O3 + + + integer, public, parameter, dimension(NDRYDEP_CALC) :: & + DRYDEP_CALC = (/ WES_HNO3, WES_O3, WES_SO2, & + WES_NH3, WES_NO2 , WES_PAN, & + WES_H2O2, WES_ALD, WES_HCHO, WES_OP /) + + !/** Compensation pount approach from CEH used?: + + logical, public, parameter :: COMPENSATION_PT = .false. + + + + ! We define also the number of species which will be deposited in + ! total, NDRYDEP_ADV. This number should be >= NDRYDEP_CALC + ! The actual species used and their relation to the CDEP_ indices + ! above will be defined in Init_DepMap + + integer, public, parameter :: NDRYDEP_ADV = 22 + + !/-- we define a type to map indices of species to be deposited + ! to the lesser number of species where Vg is calculated + + type, public :: depmap + integer :: adv ! Index of species in IXADV_ arrays + integer :: calc ! Index of species in calculated dep arrays + real :: vg ! if CDEP_SET, give vg in m/s + end type depmap + + type(depmap), public, dimension(NDRYDEP_ADV):: Dep + + real, public, save, dimension(NSPEC_ADV) :: DepLoss ! Amount lost + + + logical, private, parameter :: MY_DEBUG = .false. + +contains + subroutine Init_DepMap + real :: cms = 0.01 ! Convert to m/s + + ! .... Define the mapping between the advected species and + ! the specied for which the calculation needs to be done. + + Dep(1) = depmap( IXADV_HNO3 , CDEP_HNO3, -1.) + Dep(2) = depmap( IXADV_PAN, CDEP_PAN, -1. ) + Dep(3) = depmap( IXADV_NO2, CDEP_NO2, -1. ) + Dep(4) = depmap( IXADV_SO2, CDEP_SO2, -1. ) + Dep(5) = depmap( IXADV_SO4, CDEP_FIN, -1) + Dep(6) = depmap( IXADV_NH3, CDEP_NH3, -1. ) + Dep(7) = depmap( IXADV_aNH4, CDEP_FIN, -1) + Dep(8) = depmap( IXADV_aNO3, CDEP_FIN, -1) + Dep(9) = depmap( IXADV_O3 , CDEP_O3 , -1.) + Dep(10) = depmap( IXADV_H2O2 , CDEP_H2O2, -1.) + Dep(11) = depmap( IXADV_MPAN , CDEP_PAN , -1.) + Dep(12) = depmap( IXADV_HCHO , CDEP_HCHO, -1.) + Dep(13) = depmap( IXADV_CH3CHO,CDEP_ALD , -1.) + Dep(14) = depmap( IXADV_MAL ,CDEP_ALD , -1.) + Dep(15) = depmap( IXADV_CH3O2H,CDEP_OP , -1.) + Dep(16) = depmap( IXADV_C2H5OOH,CDEP_OP , -1.) + Dep(17) = depmap( IXADV_pNO3, CDEP_COA, -1.) + Dep(18) = depmap( IXADV_PM25, CDEP_FIN, -1. ) + Dep(19) = depmap( IXADV_PMco, CDEP_COA, -1. ) + Dep(20) = depmap( IXADV_SSfi, CDEP_FIN, -1. ) + Dep(21) = depmap( IXADV_SSco, CDEP_COA, -1. ) + Dep(22) = depmap( IXADV_Pb210, CDEP_FIN, -1. ) + +!####################### NEW define indices here ####################### + +DDEP_SOX = find_index("DDEP_SOX",f_2d(:)%name) +DDEP_OXN = find_index("DDEP_OXN",f_2d(:)%name) +DDEP_RDN = find_index("DDEP_RDN",f_2d(:)%name) + +DDEP_OXSCF = find_index("DDEP_OXSCF",f_2d(:)%name) +DDEP_OXSDF = find_index("DDEP_OXSDF",f_2d(:)%name) +DDEP_OXSCR = find_index("DDEP_OXSCR",f_2d(:)%name) +DDEP_OXSSN = find_index("DDEP_OXSSN",f_2d(:)%name) + +DDEP_OXNCF = find_index("DDEP_OXNCF",f_2d(:)%name) +DDEP_OXNDF = find_index("DDEP_OXNDF",f_2d(:)%name) +DDEP_OXNCR = find_index("DDEP_OXNCR",f_2d(:)%name) +DDEP_OXNSN = find_index("DDEP_OXNSN",f_2d(:)%name) + +DDEP_RDNCF = find_index("DDEP_RDNCF",f_2d(:)%name) +DDEP_RDNDF = find_index("DDEP_RDNDF",f_2d(:)%name) +DDEP_RDNCR = find_index("DDEP_RDNCR",f_2d(:)%name) +DDEP_RDNSN = find_index("DDEP_RDNSN",f_2d(:)%name) + +D2_AFSTDF0 = find_index("D2_AFSTDF0",f_2d(:)%name) +D2_AFSTDF16 = find_index("D2_AFSTDF16",f_2d(:)%name) + +D2_AFSTBF0 = find_index("D2_AFSTBF0",f_2d(:)%name) +D2_AFSTBF16 = find_index("D2_AFSTBF16",f_2d(:)%name) + +D2_AFSTCR0 = find_index("D2_AFSTCR0",f_2d(:)%name) +D2_AFSTCR3 = find_index("D2_AFSTCR3",f_2d(:)%name) +D2_AFSTCR6 = find_index("D2_AFSTCR6",f_2d(:)%name) + +D2_O3DF = find_index("D2_O3DF ",f_2d(:)%name) +D2_O3WH = find_index("D2_O3WH ",f_2d(:)%name) + +D2_EUAOT30WH = find_index("D2_EUAOT30WH",f_2d(:)%name) +D2_EUAOT40WH = find_index("D2_EUAOT40WH",f_2d(:)%name) +D2_EUAOT30DF = find_index("D2_EUAOT30DF",f_2d(:)%name) +D2_EUAOT40DF = find_index("D2_EUAOT40DF",f_2d(:)%name) + +D2_UNAOT30WH = find_index("D2_UNAOT30WH",f_2d(:)%name) +D2_UNAOT40WH = find_index("D2_UNAOT40WH",f_2d(:)%name) +D2_UNAOT30DF = find_index("D2_UNAOT30DF",f_2d(:)%name) +D2_UNAOT40DF = find_index("D2_UNAOT40DF",f_2d(:)%name) + +D2_MMAOT30WH = find_index("D2_MMAOT30WH",f_2d(:)%name) +D2_MMAOT40WH = find_index("D2_MMAOT40WH",f_2d(:)%name) + +iam_wheat = find_index("IAM_CR",LandDefs(:)%code) +iam_beech = find_index("IAM_DF",LandDefs(:)%code) +iam_medoak = find_index("IAM_MF",LandDefs(:)%code) +!####################### ds END of define indices ####################### + + end subroutine Init_DepMap + + !<========================================================================== + subroutine Add_ddep(debug_flag,dt,i,j,convfac,lossfrac,fluxfrac,c_hvegppb) + + !<========================================================================== + ! Adds deposition losses to ddep arrays + logical, intent(in) :: debug_flag + real, intent(in) :: dt ! time-step + integer, intent(in) :: i,j ! coordinates + real, intent(in) :: convfac, lossfrac + real, dimension(:,:), intent(in) :: fluxfrac ! dim (NADV, NLANDUSE) + real, dimension(:), intent(in) :: c_hvegppb ! dim (NLANDUSE) + integer :: n, nadv, ihh, idd, imm + real :: o3WH, o3DF ! O3 over wheat, decid forest + logical, parameter :: DEBUG_ECO = .false. + + integer, parameter :: N_OXS = 2 ! Number in ox. sulphur family + real, parameter, dimension(N_OXS) :: OXS = & + (/ IXADV_SO2, IXADV_SO4 /) + integer, parameter :: N_OXN = 5 ! Number in ox. nitrogen family + real, parameter, dimension(N_OXN) :: OXN = & + (/ IXADV_HNO3, IXADV_PAN, IXADV_NO2, IXADV_aNO3, IXADV_pNO3 /) + integer, parameter :: N_RDN = 2 ! Number in red. nitrogen family + real, parameter, dimension(N_RDN) :: RDN = & + (/ IXADV_NH3, IXADV_aNH4 /) + + real, parameter :: NMOLE_M3 = 1.0e6*1.0e9/AVOG ! Converts from + ! mol/cm3 to nmole/m3 + + real :: to_nmole, timefrac, fstfrac + to_nmole = NMOLE_M3 + timefrac = dt/3600.0 + fstfrac = dt*1.0e-6 ! Converts also nmole to mmole + + +! waters and wetland categories removed after discussions with CCE/IIASA + +!! OXIDIZED SULPHUR +!!----------------------- + + d_2d(DDEP_SOX,i,j,IOU_INST) = ( & + DepLoss(IXADV_SO2) + DepLoss(IXADV_SO4) ) * convfac * atwS + + + d_2d(DDEP_OXSCF,i,j,IOU_INST) = 0.0 + d_2d(DDEP_OXSDF,i,j,IOU_INST) = 0.0 + d_2d(DDEP_OXSCR,i,j,IOU_INST) = 0.0 + d_2d(DDEP_OXSSN,i,j,IOU_INST) = 0.0 + + + do n = 1,N_OXS + nadv = OXS(n) + + ! == make use of ECO_ arrays from DepVariables - specifies ==== ! + ! which landuse is in which category ==== ! + + + d_2d(DDEP_OXSCF,i,j,IOU_INST) = d_2d(DDEP_OXSCF,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_conif ) * DepLoss(nadv) + + + d_2d(DDEP_OXSDF,i,j,IOU_INST) = d_2d(DDEP_OXSDF,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_decid ) * DepLoss(nadv) + + d_2d(DDEP_OXSCR,i,j,IOU_INST) = d_2d(DDEP_OXSCR,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_crop ) * DepLoss(nadv) + + + d_2d(DDEP_OXSSN,i,j,IOU_INST) = d_2d(DDEP_OXSSN,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_seminat ) * DepLoss(nadv) + + end do + + d_2d(DDEP_OXSCF,i,j,IOU_INST) = d_2d(DDEP_OXSCF,i,j,IOU_INST)*convfac*atwS + d_2d(DDEP_OXSDF,i,j,IOU_INST) = d_2d(DDEP_OXSDF,i,j,IOU_INST)*convfac*atwS + d_2d(DDEP_OXSCR,i,j,IOU_INST) = d_2d(DDEP_OXSCR,i,j,IOU_INST)*convfac*atwS + d_2d(DDEP_OXSSN,i,j,IOU_INST) = d_2d(DDEP_OXSSN,i,j,IOU_INST)*convfac*atwS + + + +!! OXIDIZED NITROGEN +!!----------------------- + + + d_2d(DDEP_OXN,i,j,IOU_INST) = ( & + DepLoss(IXADV_HNO3) + DepLoss(IXADV_PAN) + DepLoss(IXADV_NO2) + & + DepLoss(IXADV_aNO3)+ DepLoss(IXADV_pNO3) ) * convfac * atwN + + + d_2d(DDEP_OXNCF,i,j,IOU_INST) = 0.0 + d_2d(DDEP_OXNDF,i,j,IOU_INST) = 0.0 + d_2d(DDEP_OXNCR,i,j,IOU_INST) = 0.0 + d_2d(DDEP_OXNSN,i,j,IOU_INST) = 0.0 + + do n = 1, N_OXN + nadv = OXN(n) + + ! == make use of ECO_ arrays from DepVariables - specifies ==== ! + ! which landuse is in which category ==== ! + + + d_2d(DDEP_OXNCF,i,j,IOU_INST) = d_2d(DDEP_OXNCF,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_conif ) * DepLoss(nadv) + + + d_2d(DDEP_OXNDF,i,j,IOU_INST) = d_2d(DDEP_OXNDF,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_decid ) * DepLoss(nadv) + + d_2d(DDEP_OXNCR,i,j,IOU_INST) = d_2d(DDEP_OXNCR,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_crop ) * DepLoss(nadv) + + + d_2d(DDEP_OXNSN,i,j,IOU_INST) = d_2d(DDEP_OXNSN,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_seminat ) * DepLoss(nadv) + + ! == ==== ! + + + end do + + d_2d(DDEP_OXNCF,i,j,IOU_INST) = d_2d(DDEP_OXNCF,i,j,IOU_INST)*convfac*atwN + d_2d(DDEP_OXNDF,i,j,IOU_INST) = d_2d(DDEP_OXNDF,i,j,IOU_INST)*convfac*atwN + d_2d(DDEP_OXNCR,i,j,IOU_INST) = d_2d(DDEP_OXNCR,i,j,IOU_INST)*convfac*atwN + d_2d(DDEP_OXNSN,i,j,IOU_INST) = d_2d(DDEP_OXNSN,i,j,IOU_INST)*convfac*atwN + + + +!! REDUCED NITROGEN +!!----------------------- + + d_2d(DDEP_RDN,i,j,IOU_INST) = ( & + DepLoss(IXADV_NH3) + DepLoss(IXADV_aNH4) ) * convfac * atwN + + + + d_2d(DDEP_RDNCF,i,j,IOU_INST) = 0.0 + d_2d(DDEP_RDNDF,i,j,IOU_INST) = 0.0 + d_2d(DDEP_RDNCR,i,j,IOU_INST) = 0.0 + d_2d(DDEP_RDNSN,i,j,IOU_INST) = 0.0 + + do n = 1, N_RDN + nadv = RDN(n) + + ! == make use of ECO_ arrays from DepVariables - specifies ==== ! + ! which landuse is in which category ==== ! + + + d_2d(DDEP_RDNCF,i,j,IOU_INST) = d_2d(DDEP_RDNCF,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_conif ) * DepLoss(nadv) + + + d_2d(DDEP_RDNDF,i,j,IOU_INST) = d_2d(DDEP_RDNDF,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_decid ) * DepLoss(nadv) + + d_2d(DDEP_RDNCR,i,j,IOU_INST) = d_2d(DDEP_RDNCR,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_crop ) * DepLoss(nadv) + + + d_2d(DDEP_RDNSN,i,j,IOU_INST) = d_2d(DDEP_RDNSN,i,j,IOU_INST) + & + sum( fluxfrac(nadv,:), LandType(:)%is_seminat ) * DepLoss(nadv) + + ! == ==== ! + + end do + + d_2d(DDEP_RDNCF,i,j,IOU_INST) = d_2d(DDEP_RDNCF,i,j,IOU_INST)*convfac*atwN + d_2d(DDEP_RDNDF,i,j,IOU_INST) = d_2d(DDEP_RDNDF,i,j,IOU_INST)*convfac*atwN + d_2d(DDEP_RDNCR,i,j,IOU_INST) = d_2d(DDEP_RDNCR,i,j,IOU_INST)*convfac*atwN + d_2d(DDEP_RDNSN,i,j,IOU_INST) = d_2d(DDEP_RDNSN,i,j,IOU_INST)*convfac*atwN + +!MAPPING_MANUAL CHANGES: +! Use 1.6 for Beech and 3 for crops + +!Beech: + d_2d(D2_AFSTDF0,i,j,IOU_INST) = fstfrac*leaf_flux(iam_beech) + d_2d(D2_AFSTDF16,i,j,IOU_INST) = fstfrac* max(leaf_flux(iam_beech)-1.6,0.0) +!Med. Oak: + d_2d(D2_AFSTBF0,i,j,IOU_INST) = fstfrac*leaf_flux(iam_medoak) + d_2d(D2_AFSTBF16,i,j,IOU_INST) = fstfrac* max(leaf_flux(iam_medoak)-1.6,0.0) +!Crops + d_2d(D2_AFSTCR0,i,j,IOU_INST) = fstfrac*leaf_flux(iam_wheat) + d_2d(D2_AFSTCR3,i,j,IOU_INST) = fstfrac*max(leaf_flux(iam_wheat)-3.0,0.0) + d_2d(D2_AFSTCR6,i,j,IOU_INST) = fstfrac*max(leaf_flux(iam_wheat)-6.0,0.0) + + !--- ecosystem specific concentrations.. + ! - use Conif forest for forests - safer for growing seasons + + imm = current_date%month ! for debugging + idd = current_date%day ! for debugging + ihh = current_date%hour ! for debugging + + + o3WH = c_hvegppb(iam_wheat)* lossfrac + o3DF = c_hvegppb(iam_beech)* lossfrac + + d_2d(D2_O3DF,i,j,IOU_INST) = o3DF + d_2d(D2_O3WH,i,j,IOU_INST) = o3WH + + if ( ihh >= 9 .and. ihh <= 21 ) then ! 8-20 CET, assuming summertime + + d_2d(D2_EUAOT30WH,i,j,IOU_INST) = max(o3WH-30.0,0.0) * timefrac + d_2d(D2_EUAOT40WH,i,j,IOU_INST) = max(o3WH-40.0,0.0) * timefrac + d_2d(D2_EUAOT30DF,i,j,IOU_INST) = max(o3DF-30.0,0.0) * timefrac + d_2d(D2_EUAOT40DF,i,j,IOU_INST) = max(o3DF-40.0,0.0) * timefrac + else + d_2d(D2_EUAOT30WH,i,j,IOU_INST) = 0.0 + d_2d(D2_EUAOT40WH,i,j,IOU_INST) = 0.0 + d_2d(D2_EUAOT30DF,i,j,IOU_INST) = 0.0 + d_2d(D2_EUAOT40DF,i,j,IOU_INST) = 0.0 + end if + + + !/-- Calcuates AOT values for specific veg. Daylight values calculated + ! only, for zenith < AOT_HORIZON ( e.g. 89 ) + + + if ( Grid%izen < AOT_HORIZON ) then + + d_2d(D2_UNAOT30WH,i,j,IOU_INST) = max(o3WH-30.0,0.0) * timefrac + d_2d(D2_UNAOT40WH,i,j,IOU_INST) = max(o3WH-40.0,0.0) * timefrac + d_2d(D2_UNAOT30DF,i,j,IOU_INST) = max(o3DF-30.0,0.0) * timefrac + d_2d(D2_UNAOT40DF,i,j,IOU_INST) = max(o3DF-40.0,0.0) * timefrac + + else + d_2d(D2_UNAOT30WH,i,j,IOU_INST) = 0.0 + d_2d(D2_UNAOT40WH,i,j,IOU_INST) = 0.0 + d_2d(D2_UNAOT30DF,i,j,IOU_INST) = 0.0 + d_2d(D2_UNAOT40DF,i,j,IOU_INST) = 0.0 + end if + + ! MM AOT added (same as UNECE, but different growing season) + d_2d(D2_MMAOT30WH,i,j,IOU_INST) = d_2d(D2_UNAOT30WH,i,j,IOU_INST)& + * WheatGrowingSeason(i,j) + d_2d(D2_MMAOT40WH,i,j,IOU_INST) = d_2d(D2_UNAOT40WH,i,j,IOU_INST)& + * WheatGrowingSeason(i,j) + + if ( DEBUG_ECO .and. debug_flag ) then + write(6,"(a12,3i5,f7.2,5es12.3,i3,es12.3)") "DEBUG_ECO ", & + imm, idd, ihh, o3WH, & + leaf_flux(iam_beech), d_2d(D2_AFSTDF0,i,j,IOU_INST), & + leaf_flux(iam_wheat), d_2d(D2_AFSTCR0,i,j,IOU_INST), & + d_2d(D2_UNAOT40WH,i,j,IOU_INST), & + WheatGrowingSeason(i,j), d_2d(D2_MMAOT40WH,i,j,IOU_INST) + end if ! DEBUG + + !---- end ecosystem specific ---------------------------------------------- + + end subroutine Add_ddep + +end module My_DryDep_ml + diff --git a/My_Emis_ml.f90 b/My_Emis_ml.f90 new file mode 100644 index 0000000..eab83de --- /dev/null +++ b/My_Emis_ml.f90 @@ -0,0 +1,196 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module My_Emis_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!_____________________________________________________________________________ +implicit none + + !----------------- "my" emissions choices ---------------------------! + ! Here we define the emissions stuff likely to change between different ! + ! model versions - e.g. the number of emission files. The consistency ! + ! of some of these choices will be checked in the Emissions_ml module ! + ! Includes setting of biogenic emissions and AIRNOX (lightning+aircraft)! + !------------------------------------------------------------------------! + + !-- contains subroutines: + + public :: set_molwts ! Called from Emissions_ml + + !/** emissions. + ! + ! NEMIS_PLAIN gives the number of emission file used for compounds which + ! do not have speciation (typically, so2, nox). + ! NEMIS_SPLIT gives the number of emission file used for compounds which + ! do have speciation (typically, voc, pm). + ! + ! NRCEMIS: the total number of species where emissions enter into the + ! rate-coefficients. This should be equal to the sum of + ! NEMIS_PLAIN + sum(EMIS_SPLIT). ( Checked in consistency check ) + ! ------------------------------------------------------------------------ + + integer, public, parameter :: & + NEMIS_PLAIN = 5 & ! No. emission files to be read for non-speciated + , NEMIS_SPLIT = 2 & ! No. emission files to be read for speciated + , NRCEMIS = 17 ! No. chemical species with emissions + + integer, public, parameter :: & ! ** derived ** shouldn't need to change: + NEMIS = & ! Sum of the above - all emissions + NEMIS_PLAIN + NEMIS_SPLIT & + , NRCSPLIT = & ! No. species from speciated (split) compounds + NRCEMIS - NEMIS_PLAIN + + !/** The names used below must have length of 6 characters and must + ! belong to the full list given in Emissions_ml, as they will + ! be used together with information in that module. An error + ! message (fatal) will be produced if this is not the case. + !----------------------------------------------------------------- + + character(len=6), public, save, dimension(NEMIS) :: & + EMIS_NAME = & + (/ "sox ", "co " & ! =non-split first + , "nh3 ", "pm25 ", "pmco " & + , "nox ", "voc " /) ! =to be split + + character(len=6), public, save, dimension(NEMIS_SPLIT) :: & + SPLIT_NAME = & + (/ "nox ", "voc " /) + !! for SOA (/ "voc ", "pm25 " /) + + integer, public, save, dimension(NEMIS_SPLIT) :: & + EMIS_NSPLIT = & + (/ 2 , 10 /) + !! for SOA (/ 10 , 3 /) + + !/-- and now join the above name arrays to make the complete list: + +! character(len=6), public, save, dimension(NEMIS) :: & +! EMIS_NAME = & +! (/ (EMIS_PLAIN(1:NEMIS_PLAIN)), & +! (EMIS_SPLIT(1:NEMIS_SPLIT)) /) + + +!... define integers for emitted species which are entered into the chemistry +! calculation. The index Qxxx is used for the species which have gridded +! emissions, e.g. so2 or total VOC. The index QRCxxx is then used to allow +! for emissions of VOC-split species,e.g. C2H6. +! +! nb species such as so4 and no2 are not included here as they are +! derived in setup as simple fractions of the so2 and no emissions +! (Of course, they could be defined as SPLIT above and then they +! should be included). + + integer, public, parameter :: & + QRCSO2 = 1 & ! IQSO2 & ! 1 + , QRCCO = 2 & ! IQCO ! 4 + , QRCNH3 = 3 & ! IQCO ! 4 + , QRCPM25= 4 & ! IQSO2 & ! 1 + , QRCPMCO= 5 & + , QRCNO2 = 6 & ! IQNOX & ! 2 + , QRCNO = 7 & ! IQNOX & ! 2 + !/**now we deal with the emissions which are split,e.g.VOC + ! ****************************************************** + ! **** must be in same order as EMIS_SPLIT array **** ** + ! **** AND vocsplit.defaults file !!!!!!! ***** **** ** + ! ****************************************************** + , QRCC2H6 = 8 & + , QRCNC4H10 = 9 & + , QRCC2H4 =10 & + , QRCC3H6 =11 & + , QRCOXYL = 12 & + , QRCHCHO = 13 & + , QRCCH3CHO = 14 & + , QRCMEK = 15 & + , QRCC2H5OH = 16 & + , QRCCH3OH = 17 + + ! Biogenics + + integer, public, parameter :: NBVOC = 2 + character(len=8),public, save, dimension(NBVOC) :: & + BVOC_USED = (/ "isoprene","terpene "/) + integer, public, parameter :: & + QRCISOP = 18 & + ,QRCTERP = 19 +!SeaS + integer, public, parameter :: NSS = 2 & ! number of sea salt size modes + ,QSSFI = 1 & ! production of fine SS + ,QSSCO = 2 ! production of coarse SS + + real, public, dimension(NRCEMIS), save :: molwt ! Molecular weights + + !/** Lightning and aircraft NOx. QRCAIRNO is set equal to QRCNO + ! and QRCAIRNO2 is set equal to QRCNO2 + ! if AIRNOX is true, otherwise to one. Avoids problems with + ! dimensions. + + logical, public, parameter :: AIRNOX = .true. ! Gives NOx emission + integer, public, parameter :: QRCAIRNO = QRCNO ! + integer, public, parameter :: QRCAIRNO2 = QRCNO2 ! + + !/** Volcanos. QRCVOL is set equal to QRCSO2 + ! if VOLCANOES is true, otherwise to one. Avoids problems with + ! dimensions + + logical, public, parameter :: VOLCANOES = .true. ! Gives Volcanos + integer, public, parameter :: QRCVOL = QRCSO2 + + contains + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + !+ set molecular weights for the QRCxx species . + subroutine set_molwts() + !--------------------------------------------------------------------- + + ! + ! ACID and OZONE .. + molwt(QRCSO2) = 32.0 ! Emissions as S + molwt(QRCNO) = 14.0 ! Emissions as N + molwt(QRCNO2) = 14.0 ! Emissions as N + molwt(QRCNH3) = 14.0 ! Emissions as N + molwt(QRCPM25) = 100.0 ! Fake for PM2.5 + molwt(QRCPMCO) = 100.0 ! Fake for PM2.5 + + molwt(QRCCO ) = 28.0 ! Emissions as N + molwt(QRCC2H4) = 24.0 ! Emissions as C + molwt(QRCC2H6) = 24.0 ! + molwt(QRCC3H6) = 36.0 ! + molwt(QRCNC4H10) = 48.0 ! + molwt(QRCOXYL) = 106.0 ! + molwt(QRCC2H5OH) = 46.0 + molwt(QRCHCHO) = 30.0 + molwt(QRCCH3CHO) = 44.0 + molwt(QRCCH3OH) = 32.0 + molwt(QRCMEK) = 72.0 + end subroutine set_molwts + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +end module My_Emis_ml diff --git a/My_FastReactions.inc b/My_FastReactions.inc new file mode 100644 index 0000000..ac0f034 --- /dev/null +++ b/My_FastReactions.inc @@ -0,0 +1,1246 @@ +!-> OD + + P = & + rcphot(IDBO3,K) * xnew(O3 ) + + L = & + rcmisc(2,k) & + + rcmisc(3,k) & + + rcmisc(4,k) + + xnew(OD)= amax1(0.0, ( xold(OD) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> OP + + P = & + rcmisc(2,k) * xnew(OD ) & + + rcmisc(3,k) * xnew(OD ) & + + 0.3*rct(32,k) * xnew(ISOP ) * xnew(O3 ) & + + 0.2*rct(37,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(11,k)* xnew(NO ) + + xnew(OP)= amax1(0.0, ( xold(OP) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> OH + + P = & + 2.*rcmisc(4,k) * xnew(OD ) & + + rct(4,k) * xnew(O3 ) * xnew(HO2 ) & + + rct(6,k) * xnew(NO ) * xnew(HO2 ) & + + rct(18,k) * xnew(CH3O2H ) * xnew(OH ) & + + rct(23,k) * xnew(C2H5OOH ) * xnew(OH ) & + + rct(23,k) * xnew(BURO2H ) * xnew(OH ) & + + rct(23,k) * xnew(ETRO2H ) * xnew(OH ) & + + 0.15*rct(31,k) * xnew(O3 ) * xnew(C3H6 ) & + + rct(23,k) * xnew(PRRO2H ) * xnew(OH ) & + + 0.55*rct(32,k) * xnew(ISOP ) * xnew(O3 ) & + + 2.0e-11 * xnew(ISRO2H ) * xnew(OH ) & + + 0.08*rct(37,k) * xnew(MVK ) * xnew(O3 ) & + + 2*rcphot(IDH2O2,K) * xnew(H2O2 ) & + + rcphot(IDHNO3,K) * xnew(HNO3 ) & + + rcphot(IDCH3O2H,K) * xnew(CH3O2H ) & + + rcphot(IDCH3O2H,K) * xnew(C2H5OOH ) & + + rcphot(IDCH3O2H,K) * xnew(ETRO2H ) & + + rcphot(IDCH3O2H,K) * xnew(BURO2H ) & + + rcphot(IDCH3O2H,K) * xnew(MEKO2H ) & + + rcphot(IDCH3O2H,K) * xnew(CH3COO2H ) & + + rcphot(IDCH3O2H,K) * xnew(OXYO2H ) & + + rcphot(IDCH3O2H,K) * xnew(MALO2H ) + + L = & + rct(3,k)* xnew(O3 ) & + + rcmisc(14,k)* xnew(NO2 ) & + + rct(8,k)* xnew(HO2 ) & + + rct(9,k)* xnew(H2O2 ) & + + rct(10,k)* xnew(H2 ) & + + rct(11,k)* xnew(HNO3 ) & + + 2e-12*aqrck(ICLOHSO2,K)* xnew(SO2 ) & + + rct(12,k)* xnew(CH4 ) & + + rcmisc(7,k)* xnew(CO ) & + + rct(16,k)* xnew(CH3OH ) & + + rct(18,k)* xnew(CH3O2H ) & + + rct(19,k)* xnew(CH3O2H ) & + + rct(20,k)* xnew(HCHO ) & + + rct(21,k)* xnew(C2H6 ) & + + rct(23,k)* xnew(C2H5OOH ) & + + rct(19,k)* xnew(C2H5OOH ) & + + rct(24,k)* xnew(CH3CHO ) & + + rct(19,k)* xnew(CH3COO2H ) & + + rct(28,k)* xnew(C2H5OH ) & + + rct(29,k)* xnew(NC4H10 ) & + + 1.15e-12* xnew(MEK ) & + + 4.8e-12* xnew(MEKO2H ) & + + rct(19,k)* xnew(BURO2H ) & + + rct(23,k)* xnew(BURO2H ) & + + rcmisc(17,k)* xnew(C2H4 ) & + + rct(23,k)* xnew(ETRO2H ) & + + rct(19,k)* xnew(ETRO2H ) & + + rcmisc(18,k)* xnew(C3H6 ) & + + rct(23,k)* xnew(PRRO2H ) & + + rct(19,k)* xnew(PRRO2H ) & + + 1.37e-11* xnew(OXYL ) & + + 1.7e-11* xnew(OXYO2H ) & + + 2.0e-11* xnew(MAL ) & + + 2.4e-11* xnew(MALO2H ) & + + 1.1e-11* xnew(GLYOX ) & + + 1.5e-11* xnew(MGLYOX ) & + + rct(33,k)* xnew(ISOP ) & + + rct(34,k)* xnew(MVK ) & + + 2.0e-11* xnew(ISRO2H ) & + + rct(35,k)* xnew(MACR ) & + + 3.35e-11* xnew(ISNI ) & + + 3.2e-11* xnew(CH2CO2HCH3 ) & + + 2.0e-11* xnew(ISONO3H ) & + + 2.2e-11* xnew(MVKO2H ) & + + 3.7e-11* xnew(ISNIRH ) & + + 3.7e-11* xnew(MARO2H ) + + xnew(OH)= amax1(0.0, ( xold(OH) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> HO2 + + P = & + rct(3,k) * xnew(O3 ) * xnew(OH ) & + + rct(9,k) * xnew(OH ) * xnew(H2O2 ) & + + rct(10,k) * xnew(OH ) * xnew(H2 ) & + + 2e-12*aqrck(ICLOHSO2,K) * xnew(OH ) * xnew(SO2 ) & + + rcmisc(7,k) * xnew(OH ) * xnew(CO ) & + + rct(13,k) * xnew(CH3O2 ) * xnew(NO ) & + + 2.*rct(14,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & + + rct(16,k) * xnew(OH ) * xnew(CH3OH ) & + + rct(20,k) * xnew(OH ) * xnew(HCHO ) & + + 5.8e-16 * xnew(NO3 ) * xnew(HCHO ) & + + 8.7e-12 * xnew(C2H5O2 ) * xnew(NO ) & + + 0.5*1.1e-11 * xnew(CH3O2 ) * xnew(CH3COO2 ) & + + rct(28,k) * xnew(OH ) * xnew(C2H5OH ) & + + 0.65*rct(13,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + + rct(13,k) * xnew(ETRO2 ) * xnew(NO ) & + + 0.12*rct(30,k) * xnew(C2H4 ) * xnew(O3 ) & + + 0.28*rct(31,k) * xnew(O3 ) * xnew(C3H6 ) & + + rct(13,k) * xnew(NO ) * xnew(PRRO2 ) & + + rct(13,k) * xnew(OXYO2 ) * xnew(NO ) & + + rct(13,k) * xnew(MALO2 ) * xnew(NO ) & + + 1.1e-11 * xnew(OH ) * xnew(GLYOX ) & + + 0.06*rct(32,k) * xnew(ISOP ) * xnew(O3 ) & + + 0.78*rct(13,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.95*rct(13,k) * xnew(MVKO2 ) * xnew(NO ) & + + rct(13,k) * xnew(CH2CCH3 ) * xnew(NO ) & + + 0.06*rct(37,k) * xnew(MVK ) * xnew(O3 ) & + + 0.05*rct(13,k) * xnew(ISNIR ) * xnew(NO ) & + + 0.8*rct(13,k) * xnew(ISONO3 ) * xnew(NO ) & + + 2*rcphot(IDACH2O,K) * xnew(HCHO ) & + + rcphot(IDCH3CHO,K) * xnew(CH3CHO ) & + + rcphot(IDCH3O2H,K) * xnew(CH3O2H ) & + + 0.5 * rcphot(IDHCOHCO,K) * xnew(GLYOX ) & + + rcphot(IDRCOHCO,K) * xnew(MGLYOX ) & + + rcphot(IDCH3O2H,K) * xnew(C2H5OOH ) & + + rcphot(IDCH3O2H,K) * xnew(ETRO2H ) & + + 0.65*rcphot(IDCH3O2H,K) * xnew(BURO2H ) & + + rcphot(IDCH3O2H,K) * xnew(PRRO2H ) & + + rcphot(IDCH3O2H,K) * xnew(OXYO2H ) & + + rcphot(IDCH3O2H,K) * xnew(MALO2H ) + + L = & + rct(4,k)* xnew(O3 ) & + + rct(6,k)* xnew(NO ) & + + rct(8,k)* xnew(OH ) & + + rcmisc(5,k)* xnew(HO2 ) & + + rcmisc(5,k)* xnew(HO2 ) & + + rcmisc(6,k)* xnew(HO2 ) & + + rcmisc(6,k)* xnew(HO2 ) & + + rct(17,k)* xnew(CH3O2 ) & + + rct(22,k)* xnew(C2H5O2 ) & + + rct(26,k)* xnew(CH3COO2 ) & + + rct(27,k)* xnew(CH3COO2 ) & + + 1.0e-11* xnew(MEKO2 ) & + + 1.0e-11* xnew(SECC4H9O2 ) & + + 1.0e-11* xnew(ETRO2 ) & + + 1.0e-11* xnew(PRRO2 ) & + + 1.0e-11* xnew(OXYO2 ) & + + 1.0e-11* xnew(MALO2 ) & + + 1.0e-11* xnew(ISRO2 ) & + + 1.0e-11* xnew(MVKO2 ) & + + 1.0e-11* xnew(MACRO2 ) & + + 1.0e-11* xnew(CH2CCH3 ) & + + 1.0e-11* xnew(ISNIR ) & + + 1.0e-11* xnew(ISONO3 ) + + xnew(HO2)= amax1(0.0, ( xold(HO2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> CH3O2 + + P = & + rct(12,k) * xnew(OH ) * xnew(CH4 ) & + + rct(19,k) * xnew(CH3O2H ) * xnew(OH ) & + + 2.0e-11 * xnew(CH3COO2 ) * xnew(NO ) & + + 0.5*1.1e-11 * xnew(CH3O2 ) * xnew(CH3COO2 ) & + + rct(25,k) * xnew(CH3COO2 ) * xnew(CH3COO2 ) & + + rct(25,k) * xnew(CH3COO2 ) * xnew(CH3COO2 ) & + + 0.31*rct(31,k) * xnew(O3 ) * xnew(C3H6 ) & + + rcphot(IDCH3CHO,K) * xnew(CH3CHO ) & + + rcphot(IDCH3O2H,K) * xnew(CH3COO2H ) + + L = & + rct(13,k)* xnew(NO ) & + + rct(14,k)* xnew(CH3O2 ) & + + rct(14,k)* xnew(CH3O2 ) & + + rct(15,k)* xnew(CH3O2 ) & + + rct(15,k)* xnew(CH3O2 ) & + + rct(17,k)* xnew(HO2 ) & + + 1.1e-11* xnew(CH3COO2 ) + + xnew(CH3O2)= amax1(0.0, ( xold(CH3O2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> C2H5O2 + + P = & + rct(21,k) * xnew(OH ) * xnew(C2H6 ) & + + rct(19,k) * xnew(C2H5OOH ) * xnew(OH ) & + + 0.35*rct(13,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + + 0.35*rcphot(IDCH3O2H,K) * xnew(BURO2H ) & + + rcphot(IDCH3COX,K) * xnew(MEK ) + + L = & + 8.7e-12* xnew(NO ) & + + rct(22,k)* xnew(HO2 ) + + xnew(C2H5O2)= amax1(0.0, ( xold(C2H5O2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> SECC4H9O2 + + P = & + rct(29,k) * xnew(OH ) * xnew(NC4H10 ) & + + rct(19,k) * xnew(BURO2H ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(SECC4H9O2)= amax1(0.0, ( xold(SECC4H9O2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> ISRO2 + + P = & + rct(33,k) * xnew(ISOP ) * xnew(OH ) & + + 0.12*rct(13,k) * xnew(ISRO2 ) * xnew(NO ) & + + 2.0e-11 * xnew(ISRO2H ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(ISRO2)= amax1(0.0, ( xold(ISRO2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> ETRO2 + + P = & + rcmisc(17,k) * xnew(C2H4 ) * xnew(OH ) & + + rct(19,k) * xnew(ETRO2H ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(ETRO2)= amax1(0.0, ( xold(ETRO2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> PRRO2 + + P = & + rcmisc(18,k) * xnew(OH ) * xnew(C3H6 ) & + + rct(19,k) * xnew(PRRO2H ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(PRRO2)= amax1(0.0, ( xold(PRRO2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> OXYO2 + + P = & + 1.37e-11 * xnew(OXYL ) * xnew(OH ) & + + 1.7e-11 * xnew(OXYO2H ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(OXYO2)= amax1(0.0, ( xold(OXYO2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MEKO2 + + P = & + 1.15e-12 * xnew(OH ) * xnew(MEK ) & + + 4.8e-12 * xnew(MEKO2H ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(MEKO2)= amax1(0.0, ( xold(MEKO2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MALO2 + + P = & + 2.0e-11 * xnew(MAL ) * xnew(OH ) & + + 2.4e-11 * xnew(MALO2H ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(MALO2)= amax1(0.0, ( xold(MALO2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MVKO2 + + P = & + rct(34,k) * xnew(MVK ) * xnew(OH ) & + + 2.2e-11 * xnew(MVKO2H ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(MVKO2)= amax1(0.0, ( xold(MVKO2) + dt2 * P)) & + /(1.0 + dt2*L ) + + + +!-> O3 + + P = & + rcmisc(1,k) * xnew(OP ) & + + rct(27,k) * xnew(CH3COO2 ) * xnew(HO2 ) + + L = & + rct(1,k)* xnew(NO ) & + + rct(2,k)* xnew(NO2 ) & + + rct(3,k)* xnew(OH ) & + + rct(4,k)* xnew(HO2 ) & + + rct(30,k)* xnew(C2H4 ) & + + rct(31,k)* xnew(C3H6 ) & + + rct(32,k)* xnew(ISOP ) & + + 8.0e-18* xnew(ISRO2H ) & + + rct(37,k)* xnew(MVK ) & + + rcphot(IDAO3,K) & + + rcphot(IDBO3,K) + + xnew(O3)= amax1(0.0, ( xold(O3) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!->NOy + +! P=rcemis(QRCNO,K)+ rcphot(IDHNO3,K) * xnew(HNO3 ) & +! + rct(11,k) * xnew(OH ) * xnew(HNO3 ) + +! L= 0.14*rct(13,k) * xnew(ISRO2 ) * xnew(NO ) & !ISNI +! + 0.05*rct(13,k) * xnew(MVKO2 ) * xnew(NO ) & !ISNI +! + 0.85*rct(13,k) * xnew(ISONO3 ) * xnew(NO ) & !ISNI +! + rcmisc(14,k) * xnew(NO2 ) * xnew(OH ) & !HNO3 +! + 5.8e-16 * xnew(NO3 ) * xnew(HCHO ) & !HNO3 +! + 2.0*rcmisc(8,k)*(xnew(SO4))*xnew(N2O5) & !HNO3 +! + 1.0e-11 * xnew(ISONO3 ) * xnew(HO2 ) !ISONO3H! +! +! NOy=x(NO)+x(NO2)+x(PAN)+x(MPAN)+x(NO3)+2*x(N2O5)+x(ISONO3) +! NOy=NOy+ (P-L)*dti(ichem) + +!-> NO + + P = & + rct(7,k) * xnew(NO2 ) * xnew(NO3 ) & + + rcphot(IDNO2,K) * xnew(NO2 ) & + + rcemis(QRCNO,K) + + L = & + rcmisc(11,k)* xnew(OP ) & + + rct(1,k)* xnew(O3 ) & + + rct(5,k)* xnew(NO3 ) & + + rct(6,k)* xnew(HO2 ) & + + rct(13,k)* xnew(CH3O2 ) & + + 8.7e-12* xnew(C2H5O2 ) & + + 2.0e-11* xnew(CH3COO2 ) & + + rct(13,k)* xnew(SECC4H9O2 ) & + + rct(13,k)* xnew(MEKO2 ) & + + rct(13,k)* xnew(ETRO2 ) & + + rct(13,k)* xnew(PRRO2 ) & + + rct(13,k)* xnew(OXYO2 ) & + + rct(13,k)* xnew(MALO2 ) & + + rct(13,k)* xnew(ISRO2 ) & + + rct(13,k)* xnew(MVKO2 ) & + + 2.0e-11* xnew(MACRO2 ) & + + rct(13,k)* xnew(CH2CCH3 ) & + + rct(13,k)* xnew(ISNIR ) & + + rct(13,k)* xnew(ISONO3 ) + + xnew(NO)= amax1(0.0, ( xold(NO) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> NO2 + + P = & + rcmisc(11,k) * xnew(OP ) * xnew(NO ) & + + rct(1,k) * xnew(O3 ) * xnew(NO ) & + + rct(5,k) * xnew(NO ) * xnew(NO3 ) & + + rct(5,k) * xnew(NO ) * xnew(NO3 ) & + + rct(6,k) * xnew(NO ) * xnew(HO2 ) & + + rct(7,k) * xnew(NO2 ) * xnew(NO3 ) & + + rcmisc(13,k) * xnew(N2O5 ) & + + rct(13,k) * xnew(CH3O2 ) * xnew(NO ) & + + 8.7e-12 * xnew(C2H5O2 ) * xnew(NO ) & + + rcmisc(16,k) * xnew(PAN ) & + + 2.0e-11 * xnew(CH3COO2 ) * xnew(NO ) & + + rct(13,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + + rct(13,k) * xnew(MEKO2 ) * xnew(NO ) & + + rct(13,k) * xnew(ETRO2 ) * xnew(NO ) & + + rct(13,k) * xnew(NO ) * xnew(PRRO2 ) & + + rct(13,k) * xnew(OXYO2 ) * xnew(NO ) & + + rct(13,k) * xnew(MALO2 ) * xnew(NO ) & + + 0.86*rct(13,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.95*rct(13,k) * xnew(MVKO2 ) * xnew(NO ) & + + rct(36,k) * xnew(MPAN ) & + + 2.0e-11 * xnew(MACRO2 ) * xnew(NO ) & + + rct(13,k) * xnew(CH2CCH3 ) * xnew(NO ) & + + 1.9*rct(13,k) * xnew(ISNIR ) * xnew(NO ) & + + 1.1*rct(13,k) * xnew(ISONO3 ) * xnew(NO ) & + + rcphot(IDHNO3,K) * xnew(HNO3 ) & + + rcphot(IDNO3,K) * xnew(NO3 ) & + + rcphot(IDN2O5,K) * xnew(N2O5 ) & + + rcemis(QRCNO2,K) + + L = & + rct(2,k)* xnew(O3 ) & + + rct(7,k)* xnew(NO3 ) & + + rcmisc(12,k)* xnew(NO3 ) & + + rcmisc(14,k)* xnew(OH ) & + + rcmisc(15,k)* xnew(CH3COO2 ) & + + 1.0e-11* xnew(MACRO2 ) & + + rcphot(IDNO2,K) + + xnew(NO2)= amax1(0.0, ( xold(NO2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> PAN + + P = & + rcmisc(15,k) * xnew(CH3COO2 ) * xnew(NO2 ) + + L = & + rcmisc(16,k) + +! xnew(PAN)= amax1(0.0, ( xold(PAN) + dt2 * P)) & +! /(1.0 + dt2*L ) + + L1=1.+dt2*L + C1=rcmisc(15,k) * xnew(NO2 ) *dt2 + P1=P*dt2 - C1*xnew(CH3COO2 ) + +!-> CH3COO2 + + P = & + rct(24,k) * xnew(OH ) * xnew(CH3CHO ) & + + rcmisc(16,k) * xnew(PAN ) & + + rct(19,k) * xnew(CH3COO2H ) * xnew(OH ) & + + rct(13,k) * xnew(MEKO2 ) * xnew(NO ) & + + 1.5e-11 * xnew(OH ) * xnew(MGLYOX ) & + + 0.684*rct(13,k) * xnew(MVKO2 ) * xnew(NO ) & + + rcphot(IDRCOHCO,K) * xnew(MGLYOX ) & + + rcphot(IDCH3O2H,K) * xnew(MEKO2H ) & + + rcphot(IDCH3COX,K) * xnew(MEK ) + + L = & + rcmisc(15,k)* xnew(NO2 ) & + + 2.0e-11* xnew(NO ) & + + 1.1e-11* xnew(CH3O2 ) & + + rct(25,k)* xnew(CH3COO2 ) & + + rct(25,k)* xnew(CH3COO2 ) & + + rct(26,k)* xnew(HO2 ) & + + rct(27,k)* xnew(HO2 ) + +! xnew(CH3COO2)= amax1(0.0, ( xold(CH3COO2) + dt2 * P)) & +! /(1.0 + dt2*L ) + L2=1.+dt2*L + C2=rcmisc(16,k) *dt2 + P2=P*dt2 - C2* xnew(PAN ) + DIVID=1./(L1*L2-C1*C2) + + xnew(PAN)=amax1(0.0, ((xold(PAN)+P1)*L2+ & + C1*(xold(CH3COO2)+P2))*DIVID ) + + xnew(CH3COO2)=amax1(0.0, ((xold(CH3COO2)+P2)*L1+ & + C2*(xold(PAN)+P1))*DIVID ) + + + + +!-> MPAN + + P = & + 1.0e-11 * xnew(MACRO2 ) * xnew(NO2 ) + + L = & + rct(36,k) + +! xnew(MPAN)= amax1(0.0, ( xold(MPAN) + dt2 * P)) & +! /(1.0 + dt2*L ) + L1=1.+dt2*L + C1=1.0e-11 * xnew(NO2 ) *dt2 + P1=P*dt2 - C1*xnew(MACRO2 ) + + +!-> MACRO2 + + P = & + 0.5*rct(35,k) * xnew(MACR ) * xnew(OH ) & + + rct(36,k) * xnew(MPAN ) & + + 3.7e-11 * xnew(MARO2H ) * xnew(OH ) + + L = & + 1.0e-11* xnew(NO2 ) & + + 2.0e-11* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + +! xnew(MACRO2)= amax1(0.0, ( xold(MACRO2) + dt2 * P)) & +! /(1.0 + dt2*L ) + L2=1.+dt2*L + C2=rct(36,k)*dt2 + P2=P*dt2 - C2* xnew(MPAN ) + DIVID=1./(L1*L2-C1*C2) + + xnew(MPAN)=amax1(0.0, ((xold(MPAN)+P1)*L2+ & + C1*(xold(MACRO2)+P2))*DIVID ) + + xnew(MACRO2)=amax1(0.0, ((xold(MACRO2)+P2)*L1+ & + C2*(xold(MPAN)+P1))*DIVID ) + + +!-> NO3 + + P = & + rct(2,k) * xnew(O3 ) * xnew(NO2 ) & + + rcmisc(13,k) * xnew(N2O5 ) & + + rct(11,k) * xnew(OH ) * xnew(HNO3 ) & + + rcphot(IDN2O5,K) * xnew(N2O5 ) + + L = & + rct(5,k)* xnew(NO ) & + + rct(7,k)* xnew(NO2 ) & + + rcmisc(12,k)* xnew(NO2 ) & + + 5.8e-16* xnew(HCHO ) & + + 7.8e-13* xnew(ISOP ) & + + rcphot(IDNO3,K) + +! xnew(NO3)= amax1(0.0, ( xold(NO3) + dt2 * P)) & +! /(1.0 + dt2*L ) + + L1=1.+dt2*L + C1=rcmisc(13,k)*dt2 + P1=P*dt2 - C1*xnew(N2O5 ) + +!-> N2O5 + + P = & + rcmisc(12,k) * xnew(NO2 ) * xnew(NO3 ) + + L = & + rcmisc(13,k) & + + (0.9*f_Riemer(k)+0.1) * rcmisc(8,k)* & + ( VOLFACSO4*xnew(SO4) & !Total sulpate aerosol surface + + VOLFACNO3*xnew(aNO3) & !Total sulpate aerosol surface + + VOLFACNH4*xnew(aNH4) ) & !Total sulpate aerosol surface + + rcphot(IDN2O5,K) + +! xnew(N2O5)= amax1(0.0, ( xold(N2O5) + dt2 * P)) & +! /(1.0 + dt2*L ) + + L2=1.+dt2*L + C2=rcmisc(12,k) * xnew(NO2 )*dt2 + P2=P*dt2 - C2* xnew(NO3 ) + DIVID=1./(L1*L2-C1*C2) + + xnew(NO3)=amax1(0.0, ((xold(NO3)+P1)*L2+ & + C1*(xold(N2O5)+P2))*DIVID ) + + xnew(N2O5)=amax1(0.0, ((xold(N2O5)+P2)*L1+ & + C2*(xold(NO3)+P1))*DIVID ) + + + +!-> ISONO3 + + P = & + 7.8e-13 * xnew(ISOP ) * xnew(NO3 ) & + + 2.0e-11 * xnew(ISONO3H ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(ISONO3)= amax1(0.0, ( xold(ISONO3) + dt2 * P)) & + /(1.0 + dt2*L ) + + + +!NOynew=xnew(NO)+xnew(NO2)+xnew(PAN)+xnew(MPAN)+xnew(NO3)+& +! 2*xnew(N2O5)+xnew(ISONO3) +! +! +!Ntotnew=xnew(NO)+xnew(NO2)+xnew(PAN)+xnew(MPAN)+xnew(NO3)+& +!2*xnew(N2O5)+xnew(ISONO3) +! +!Nrel=Ntotold/Ntotnew +!Nrel=NOy/NOynew +!Nrelmin=min(Nrelmin,Nrel) +!Nrelmax=max(Nrelmax,Nrel) +!Nrel=1. +!xnew(NO)=xnew(NO)*Nrel +!xnew(NO2)=xnew(NO2)*Nrel +!xnew(PAN)=xnew(PAN)*Nrel +!xnew(MPAN)=xnew(MPAN)*Nrel +!xnew(NO3)=xnew(NO3)*Nrel +!xnew(N2O5)=xnew(N2O5)*Nrel +!xnew(ISONO3)=xnew(ISONO3)*Nrel + + + +!-> HNO3 + + P = & + !u1 rctroe(4,k) * xnew(NO2 ) * xnew(OH ) & + rcmisc(14,k) * xnew(NO2 ) * xnew(OH ) & + + 5.8e-16 * xnew(NO3 ) * xnew(HCHO ) & +! +2.0*rcmisc(8,k)*(xnew(SO4))*xnew(N2O5) !N ch +! New based on Riemer 2003 +!f=xnew(SO4)*96/(xnew(SO4)*96+xnew(aNO3)*62) + + 2.*(0.9*f_Riemer(k)+0.1) * rcmisc(8,k) * xnew(N2O5) * & + ( VOLFACSO4 * xnew(SO4) + & !Total sulphateaerosol surface + VOLFACNO3 * xnew(aNO3) + & !Total sulphateaerosol surface + VOLFACNH4 * xnew(aNH4) ) !Total sulphateaerosol surface + + +!Production rate of hno3 from no2 to be saved + xnew(PHNO3) = P/max( xnew(NO2),1.0 ) !reaction rate in s-1 + + + L = & + rct(11,k)* xnew(OH ) & + + rcmisc(10,k) & ! Coarse pNO3 formation + + rcphot(IDHNO3,K) + + xnew(HNO3)= amax1(0.0, ( xold(HNO3) + dt2 * P)) & + /(1.0 + dt2*L ) + +!-> CH2CCH3 + + P = & + 2.0e-11 * xnew(MACRO2 ) * xnew(NO ) & + + 3.2e-11 * xnew(CH2CO2HCH3 ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(CH2CCH3)= amax1(0.0, ( xold(CH2CCH3) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MACR + + P = & + 0.67*rct(32,k) * xnew(ISOP ) * xnew(O3 ) & + + 0.32*rct(13,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.1*rct(13,k) * xnew(ISONO3 ) * xnew(NO ) + + L = & + rct(35,k)* xnew(OH ) + + xnew(MACR)= amax1(0.0, ( xold(MACR) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> ISNI + + P = & + 0.14*rct(13,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.05*rct(13,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.85*rct(13,k) * xnew(ISONO3 ) * xnew(NO ) + + L = & + 3.35e-11* xnew(OH ) + + xnew(ISNI)= amax1(0.0, ( xold(ISNI) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> ISNIR + + P = & + 3.35e-11 * xnew(ISNI ) * xnew(OH ) & + + 3.7e-11 * xnew(ISNIRH ) * xnew(OH ) + + L = & + rct(13,k)* xnew(NO ) & + + 1.0e-11* xnew(HO2 ) + + xnew(ISNIR)= amax1(0.0, ( xold(ISNIR) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> GLYOX + + P = & + rct(13,k) * xnew(MALO2 ) * xnew(NO ) & + + rcphot(IDCH3O2H,K) * xnew(MALO2H ) + + L = & + 1.1e-11* xnew(OH ) & + + rcphot(IDHCOHCO,K) + + xnew(GLYOX)= amax1(0.0, ( xold(GLYOX) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MGLYOX + + P = & + rct(13,k) * xnew(OXYO2 ) * xnew(NO ) & + + rct(13,k) * xnew(MALO2 ) * xnew(NO ) & + + 0.266*rct(13,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.82*rct(37,k) * xnew(MVK ) * xnew(O3 ) & + + rcphot(IDCH3O2H,K) * xnew(OXYO2H ) & + + rcphot(IDCH3O2H,K) * xnew(MALO2H ) + + L = & + 1.5e-11* xnew(OH ) & + + rcphot(IDRCOHCO,K) + + xnew(MGLYOX)= amax1(0.0, ( xold(MGLYOX) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MAL + + P = & + rct(13,k) * xnew(OXYO2 ) * xnew(NO ) & + + rcphot(IDCH3O2H,K) * xnew(OXYO2H ) + + L = & + 2.0e-11* xnew(OH ) + + xnew(MAL)= amax1(0.0, ( xold(MAL) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MEK + + P = & + 0.65*rct(13,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + + rct(23,k) * xnew(BURO2H ) * xnew(OH ) & + + rct(23,k) * xnew(PRRO2H ) * xnew(OH ) & + + rct(13,k) * xnew(CH2CCH3 ) * xnew(NO ) & + + 0.95*rct(13,k) * xnew(ISNIR ) * xnew(NO ) & + + 0.65*rcphot(IDCH3O2H,K) * xnew(BURO2H ) & + + rcemis(QRCMEK,K) + + L = & + 1.15e-12* xnew(OH ) & + + rcphot(IDCH3COX,K) + + xnew(MEK)= amax1(0.0, ( xold(MEK) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MVK + + P = & + 0.26*rct(32,k) * xnew(ISOP ) * xnew(O3 ) & + + 0.42*rct(13,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.05*rct(13,k) * xnew(ISONO3 ) * xnew(NO ) + + L = & + rct(34,k)* xnew(OH ) & + + rct(37,k)* xnew(O3 ) + + xnew(MVK)= amax1(0.0, ( xold(MVK) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> HCHO + + P = & + rct(13,k) * xnew(CH3O2 ) * xnew(NO ) & + + 2.*rct(14,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & + + rct(15,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & + + rct(16,k) * xnew(OH ) * xnew(CH3OH ) & + + rct(18,k) * xnew(CH3O2H ) * xnew(OH ) & + + 1.1e-11 * xnew(CH3O2 ) * xnew(CH3COO2 ) & + + 2.*rct(13,k) * xnew(ETRO2 ) * xnew(NO ) & + + rct(30,k) * xnew(C2H4 ) * xnew(O3 ) & + + 0.5*rct(31,k) * xnew(O3 ) * xnew(C3H6 ) & + + rct(13,k) * xnew(NO ) * xnew(PRRO2 ) & + + 0.8*rct(32,k) * xnew(ISOP ) * xnew(O3 ) & + + 0.74*rct(13,k) * xnew(ISRO2 ) * xnew(NO ) & + + 0.266*rct(13,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.7*8.0e-18 * xnew(ISRO2H ) * xnew(O3 ) & + + 0.8*rct(37,k) * xnew(MVK ) * xnew(O3 ) & + + 0.15*rct(13,k) * xnew(ISONO3 ) * xnew(NO ) & + + rcphot(IDCH3O2H,K) * xnew(CH3O2H ) & + + 1.56*rcphot(IDCH3O2H,K) * xnew(ETRO2H ) & + + rcphot(IDCH3O2H,K) * xnew(PRRO2H ) & + + 1.9*rcphot(IDHCOHCO,K) * xnew(GLYOX ) & + + rcemis(QRCHCHO,K) + + L = & + rct(20,k)* xnew(OH ) & + + 5.8e-16* xnew(NO3 ) & + + rcphot(IDACH2O,K) & + + rcphot(IDBCH2O,K) + + xnew(HCHO)= amax1(0.0, ( xold(HCHO) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> CH3CHO + + P = & + 8.7e-12 * xnew(C2H5O2 ) * xnew(NO ) & + + rct(23,k) * xnew(C2H5OOH ) * xnew(OH ) & + + rct(28,k) * xnew(OH ) * xnew(C2H5OH ) & + + 0.35*rct(13,k) * xnew(NO ) * xnew(SECC4H9O2 ) & + + rct(13,k) * xnew(MEKO2 ) * xnew(NO ) & + + rct(23,k) * xnew(ETRO2H ) * xnew(OH ) & + + 0.5*rct(31,k) * xnew(O3 ) * xnew(C3H6 ) & + + rct(13,k) * xnew(NO ) * xnew(PRRO2 ) & + + 0.684*rct(13,k) * xnew(MVKO2 ) * xnew(NO ) & + + 0.04*rct(37,k) * xnew(MVK ) * xnew(O3 ) & + + 0.95*rct(13,k) * xnew(ISNIR ) * xnew(NO ) & + + rcphot(IDCH3O2H,K) * xnew(C2H5OOH ) & + + 0.22*rcphot(IDCH3O2H,K) * xnew(ETRO2H ) & + + 0.35*rcphot(IDCH3O2H,K) * xnew(BURO2H ) & + + rcphot(IDCH3O2H,K) * xnew(PRRO2H ) & + + rcphot(IDCH3O2H,K) * xnew(MEKO2H ) & + + rcemis(QRCCH3CHO,K) + + L = & + rct(24,k)* xnew(OH ) & + + rcphot(IDCH3CHO,K) + + xnew(CH3CHO)= amax1(0.0, ( xold(CH3CHO) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> C2H6 + + P = & + rcemis(QRCC2H6,K) + + L = & + rct(21,k)* xnew(OH ) + + xnew(C2H6)= amax1(0.0, ( xold(C2H6) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> NC4H10 + + P = & + rcemis(QRCNC4H10,K) + + L = & + rct(29,k)* xnew(OH ) + + xnew(NC4H10)= amax1(0.0, ( xold(NC4H10) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> C2H4 + + P = & + rcemis(QRCC2H4,K) + + L = & + rcmisc(17,k)* xnew(OH ) & + + rct(30,k)* xnew(O3 ) + + xnew(C2H4)= amax1(0.0, ( xold(C2H4) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> C3H6 + + P = & + 0.07*rct(32,k) * xnew(ISOP ) * xnew(O3 ) & + + rcemis(QRCC3H6,K) + + L = & + rct(31,k)* xnew(O3 ) & + + rcmisc(18,k)* xnew(OH ) + + xnew(C3H6)= amax1(0.0, ( xold(C3H6) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> OXYL + + P = & + rcemis(QRCOXYL,K) + + L = & + 1.37e-11* xnew(OH ) + + xnew(OXYL)= amax1(0.0, ( xold(OXYL) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> ISOP + + P = & + RCBIO(BIO_ISOP,K) + + L = & + rct(32,k)* xnew(O3 ) & + + rct(33,k)* xnew(OH ) & + + 7.8e-13* xnew(NO3 ) + + xnew(ISOP)= amax1(0.0, ( xold(ISOP) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> CH3O2H + + P = & + rct(17,k) * xnew(HO2 ) * xnew(CH3O2 ) + + L = & + rct(18,k)* xnew(OH ) & + + rct(19,k)* xnew(OH ) & + + 1.0e-5 & + + 1.0e-5 & + + rcphot(IDCH3O2H,K) + + xnew(CH3O2H)= amax1(0.0, ( xold(CH3O2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> C2H5OOH + + P = & + rct(22,k) * xnew(C2H5O2 ) * xnew(HO2 ) + + L = & + rct(23,k)* xnew(OH ) & + + rct(19,k)* xnew(OH ) & + + rcphot(IDCH3O2H,K) + + xnew(C2H5OOH)= amax1(0.0, ( xold(C2H5OOH) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> BURO2H + + P = & + 1.0e-11 * xnew(SECC4H9O2 ) * xnew(HO2 ) + + L = & + rct(19,k)* xnew(OH ) & + + rct(23,k)* xnew(OH ) & + + rcphot(IDCH3O2H,K) + + xnew(BURO2H)= amax1(0.0, ( xold(BURO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> ETRO2H + + P = & + 1.0e-11 * xnew(ETRO2 ) * xnew(HO2 ) + + L = & + rct(23,k)* xnew(OH ) & + + rct(19,k)* xnew(OH ) & + + rcphot(IDCH3O2H,K) + + xnew(ETRO2H)= amax1(0.0, ( xold(ETRO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> PRRO2H + + P = & + 1.0e-11 * xnew(PRRO2 ) * xnew(HO2 ) + + L = & + rct(23,k)* xnew(OH ) & + + rct(19,k)* xnew(OH ) & + + rcphot(IDCH3O2H,K) + + xnew(PRRO2H)= amax1(0.0, ( xold(PRRO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> OXYO2H + + P = & + 1.0e-11 * xnew(OXYO2 ) * xnew(HO2 ) + + L = & + 1.7e-11* xnew(OH ) & + + rcphot(IDCH3O2H,K) + + xnew(OXYO2H)= amax1(0.0, ( xold(OXYO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MEKO2H + + P = & + 1.0e-11 * xnew(MEKO2 ) * xnew(HO2 ) + + L = & + 4.8e-12* xnew(OH ) & + + rcphot(IDCH3O2H,K) + + xnew(MEKO2H)= amax1(0.0, ( xold(MEKO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MALO2H + + P = & + 1.0e-11 * xnew(MALO2 ) * xnew(HO2 ) + + L = & + 2.4e-11* xnew(OH ) & + + rcphot(IDCH3O2H,K) + + xnew(MALO2H)= amax1(0.0, ( xold(MALO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MVKO2H + + P = & + 1.0e-11 * xnew(MVKO2 ) * xnew(HO2 ) + + L = & + 2.2e-11* xnew(OH ) + + xnew(MVKO2H)= amax1(0.0, ( xold(MVKO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> MARO2H + + P = & + 1.0e-11 * xnew(MACRO2 ) * xnew(HO2 ) + + L = & + 3.7e-11* xnew(OH ) + + xnew(MARO2H)= amax1(0.0, ( xold(MARO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> ISRO2H + + P = & + 1.0e-11 * xnew(ISRO2 ) * xnew(HO2 ) + + L = & + 2.0e-11* xnew(OH ) & + + 8.0e-18* xnew(O3 ) + + xnew(ISRO2H)= amax1(0.0, ( xold(ISRO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> H2O2 + + P = & + rcmisc(5,k) * xnew(HO2 ) * xnew(HO2 ) & + + rcmisc(6,k) * xnew(HO2 ) * xnew(HO2 ) + + L = & + rct(9,k)* xnew(OH ) & + + 1.0e-5 & + + rcphot(IDH2O2,K) & +! Ox limitation + + aqrck(ICLRC1,K)*xnew(SO2 ) + + xnew(H2O2)= amax1(0.0, ( xold(H2O2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> CH3COO2H + + P = & + rct(26,k) * xnew(CH3COO2 ) * xnew(HO2 ) + + L = & + rct(19,k)* xnew(OH ) & + + rcphot(IDCH3O2H,K) + + xnew(CH3COO2H)= amax1(0.0, ( xold(CH3COO2H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> CH2CO2HCH3 + + P = & + 1.0e-11 * xnew(CH2CCH3 ) * xnew(HO2 ) + + L = & + 3.2e-11* xnew(OH ) + + xnew(CH2CO2HCH3)= amax1(0.0, ( xold(CH2CO2HCH3) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> ISONO3H + + P = & + 1.0e-11 * xnew(ISONO3 ) * xnew(HO2 ) + + L = & + 2.0e-11* xnew(OH ) + + xnew(ISONO3H)= amax1(0.0, ( xold(ISONO3H) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> ISNIRH + + P = & + 1.0e-11 * xnew(ISNIR ) * xnew(HO2 ) + + L = & + 3.7e-11* xnew(OH ) + + xnew(ISNIRH)= amax1(0.0, ( xold(ISNIRH) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> CH3OH + + P = & + rct(15,k) * xnew(CH3O2 ) * xnew(CH3O2 ) & + + rcemis(QRCCH3OH,K) + + L = & + rct(16,k)* xnew(OH ) + + xnew(CH3OH)= amax1(0.0, ( xold(CH3OH) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> C2H5OH + + P = & + rcemis(QRCC2H5OH,K) + + L = & + rct(28,k)* xnew(OH ) + + xnew(C2H5OH)= amax1(0.0, ( xold(C2H5OH) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> H2 + + P = & + 0.13*rct(30,k) * xnew(C2H4 ) * xnew(O3 ) & + + 0.07*rct(31,k) * xnew(O3 ) * xnew(C3H6 ) & + + rcphot(IDBCH2O,K) * xnew(HCHO ) + + L = & + rct(10,k)* xnew(OH ) + + xnew(H2)= amax1(0.0, ( xold(H2) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> CO + + P = & + rct(20,k) * xnew(OH ) * xnew(HCHO ) & + + 5.8e-16 * xnew(NO3 ) * xnew(HCHO ) & + + 0.44*rct(30,k) * xnew(C2H4 ) * xnew(O3 ) & + + 0.4*rct(31,k) * xnew(O3 ) * xnew(C3H6 ) & + + 1.1e-11 * xnew(OH ) * xnew(GLYOX ) & + + 1.1e-11 * xnew(OH ) * xnew(GLYOX ) & + + 1.5e-11 * xnew(OH ) * xnew(MGLYOX ) & + + 0.05*rct(32,k) * xnew(ISOP ) * xnew(O3 ) & + + 0.05*rct(37,k) * xnew(MVK ) * xnew(O3 ) & + + rcphot(IDACH2O,K) * xnew(HCHO ) & + + rcphot(IDBCH2O,K) * xnew(HCHO ) & + + rcphot(IDCH3CHO,K) * xnew(CH3CHO ) & + + 1.9*rcphot(IDHCOHCO,K) * xnew(GLYOX ) & + + rcphot(IDRCOHCO,K) * xnew(MGLYOX ) & + + rcemis(QRCCO,K) + + L = & + rcmisc(7,k)* xnew(OH ) + + xnew(CO)= amax1(0.0, ( xold(CO) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> CH4 + + P = & + 0.07*rct(31,k) * xnew(O3 ) * xnew(C3H6 ) + + L = & + rct(12,k)* xnew(OH ) + + xnew(CH4)= amax1(0.0, ( xold(CH4) + dt2 * P)) & + /(1.0 + dt2*L ) + + +!-> SO2 + + P = & + (1-0.05)*rcemis(QRCSO2,K) + + L = & + 2e-12*aqrck(ICLOHSO2,K)* xnew(OH ) & + + aqrck(ICLRC1,K)*XNEW(H2O2) & + + aqrck(ICLRC2,K)*XNEW(O3) & + + aqrck(ICLRC3,K) ! Fe-catalysed reaction & + + xnew(SO2)= amax1(0.0, ( xold(SO2) + dt2 * P)) & + /(1.0 + dt2*L ) diff --git a/My_MassBudget_ml.f90 b/My_MassBudget_ml.f90 new file mode 100644 index 0000000..95eaed4 --- /dev/null +++ b/My_MassBudget_ml.f90 @@ -0,0 +1,94 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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_MassBudget_ml +!_____________________________________________________________________________ + use GenSpec_adv_ml !! Can be many species + use My_Emis_ml, only : QRCSO2, QRCNO, QRCCO, QRCNH3, QRCPM25 & + , QRCPMCO, QRCNO2 + + implicit none + private + + !----------------- "my" mass budget terms ---------------------------! + ! Here we define a few indices needed to relate species with IXADV_ ! + ! indices to their equivalent emission with QRC_ index. + ! ! + ! Plus, the array MY_MASS_PRINT to say which species to print out ! + !------------------------------------------------------------------------! + + !-- contains subroutine: + + public :: set_mass_eqvs ! Called from Emissions_ml + + ! Mass budget equivalency terms + + integer, public, parameter :: N_MASS_EQVS = 7 + integer, public, save , dimension( N_MASS_EQVS ):: & + ixadv_eqv & ! IXADV_ no. of species + ,qrc_eqv ! QRC_ no. of equivalent species + + + !/** species to print out in MassBudget_ml (old myprint) + ! Note - we can any number of species we need here - the dimensions + ! are obtained in MassBudget_ml with a size command. + + integer, public, parameter, dimension(16) :: MY_MASS_PRINT = & !SeaS + (/ IXADV_O3, IXADV_HNO3, IXADV_PAN, IXADV_NO3, IXADV_N2O5 ,IXADV_NO, & + IXADV_NO2, IXADV_SO2, IXADV_SO4, IXADV_NH3, IXADV_aNH4, IXADV_aNO3 & + ,IXADV_PM25, IXADV_PMco, IXADV_SSfi, IXADV_SSco /) !SeaS + + contains + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine set_mass_eqvs() + !--------------------------------------------------------------------- + !+ relates say IXADV_SO2 to QRCSO2 + + ! Should have dimsnions N_MASS_EQVS + + ixadv_eqv(1) = IXADV_SO2 + ixadv_eqv(2) = IXADV_CO + ixadv_eqv(3) = IXADV_NH3 + ixadv_eqv(4) = IXADV_PM25 + ixadv_eqv(5) = IXADV_PMco + ixadv_eqv(6) = IXADV_NO2 + ixadv_eqv(7) = IXADV_NO + + qrc_eqv(1) = QRCSO2 + qrc_eqv(2) = QRCCO + qrc_eqv(3) = QRCNH3 + qrc_eqv(4) = QRCPM25 + qrc_eqv(5) = QRCPMco + qrc_eqv(6) = QRCNO2 + qrc_eqv(7) = QRCNO + + end subroutine set_mass_eqvs + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +end module My_MassBudget_ml diff --git a/My_Outputs_ml.f90 b/My_Outputs_ml.f90 new file mode 100644 index 0000000..3598b68 --- /dev/null +++ b/My_Outputs_ml.f90 @@ -0,0 +1,357 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module My_Outputs_ml + +! MOD OD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +! ----------------------------------------------------------------------- +! Allows user to specify which species are output to various +! ascii and binary output files. +! +! Sites - surface sites, to sites.out +! Sondes - vertical profiles, to sondes.out +! Hourly - ascii output of selected species, selcted domain +! ----------------------------------------------------------------------- + + use CheckStop_ml, only: CheckStop + use Derived_ml, only: f_2d, d_2d + use GenSpec_adv_ml + use GenSpec_shl_ml, only: IXSHL_OH,IXSHL_HO2 + use GenChemicals_ml , only: species + use ModelConstants_ml, only: PPBINV, PPTINV, ATWAIR, atwS, atwN, NPROC + use Par_ml, only: me, GIMAX,GJMAX,IRUNBEG,JRUNBEG + use SmallUtils_ml, only: find_index + use TimeDate_ml, only: date + + implicit none + +INCLUDE 'mpif.h' +INTEGER STATUS(MPI_STATUS_SIZE),INFO +logical, public, parameter :: out_binary = .false. +logical, public, parameter :: Ascii3D_WANTED = .false. + + +! Site outputs (used in Sites_ml) +!============================================================== +! Specify the species to be output to the sites.out file +! For met params we have no simple index, so we use characters. +! These must be defined in Sites_ml.f90. + +integer, private :: isite ! To assign arrays, if needed +integer, public, parameter :: & + NSITES_MAX = 99 & ! Max. no surface sites allowed + ,FREQ_SITE = 1 & ! Interval (hrs) between outputs + ,NADV_SITE = NSPEC_ADV & ! No. advected species (1 up to NSPEC_ADV) + ,NSHL_SITE = 1 & ! No. short-lived species + ,NXTRA_SITE = 2 ! No. Misc. met. params ( now T2) + + integer, public, parameter, dimension(NADV_SITE) :: & + SITE_ADV = (/ (isite, isite=1,NADV_SITE) /) ! Everything + + integer, public, parameter, dimension(NSHL_SITE) :: & + SITE_SHL = (/ IXSHL_OH /) ! More limited + +! Extra parameters - need to be coded in Sites_ml also. So far +! we can choose from T2, or th (pot. temp.) + + character(len=10), public, parameter, dimension(NXTRA_SITE) :: & + SITE_XTRA= (/ "hmix ", "th "/) +! SITE_XTRA= (/ "hmix ", "Vg_ref ", "Vg_1m " /) + + ! - can access d_2d fields through index here, by + ! setting "D2D" above and say D2_FSTCF0 here: + + integer, public, parameter, dimension(NXTRA_SITE) :: & + SITE_XTRA_INDEX= (/ 0, 0 /) ! Height at mid-cell + + + + !/*** Aircraft outputs (used in Polinat_ml) + !============================================================== + ! Specify the species to be output by Polinat for aircraft flight tracks + + integer, public, parameter :: & + NFLIGHT_MAX = 10 & ! Max. no sondes allowed + ,FREQ_FLIGHT = 12 & ! Interval (hrs) between outputs + ,NADV_FLIGHT = 1 ! No. advected species + + integer, public, parameter, dimension(NADV_FLIGHT) :: & + FLIGHT_ADV = (/ IXADV_O3 /) + + + !/*** Sonde outputs (used in Sites_ml) + !============================================================== + ! Specify the species to be output to the sondes.out file + ! We typically deal with fewer species for sonde output than + ! surface sites, so we use a different method to specify. + ! For met params we have no simple index, so we use characters. + ! These must be defined in Sites_ml.f90. + + integer, public, parameter :: & + NSONDES_MAX = 99 & ! Max. no sondes allowed + ,NLEVELS_SONDE = 20 & ! No. k-levels (9 => 0--2500 m) + ,FREQ_SONDE = 12 & ! Interval (hrs) between outputs + ,NADV_SONDE = 8 & ! No. advected species + ,NSHL_SONDE = 1 & ! No. short-lived species + ,NXTRA_SONDE = 4 & ! No. Misc. met. params (now th) + ,N_NOy = 10 ! # of N species in NOy + + integer, public, parameter, dimension(NADV_SONDE) :: & + SONDE_ADV = (/ IXADV_O3, IXADV_NO2, IXADV_HNO3, IXADV_aNO3, & + IXADV_pNO3, IXADV_SO4, IXADV_aNH4, IXADV_NH3/) + + + integer, public, parameter, dimension(N_NOy) :: & + NOy_SPEC = (/ IXADV_HNO3, IXADV_NO, IXADV_NO2, IXADV_PAN, & + IXADV_MPAN, IXADV_NO3, IXADV_N2O5, IXADV_ISONO3, & + IXADV_ISNI, IXADV_ISNIR /) + + integer, public, parameter, dimension(NSHL_SONDE) :: & + SONDE_SHL = (/ IXSHL_OH /) + character(len=10), public, parameter, dimension(NXTRA_SONDE) :: & +! SONDE_XTRA= (/ "PM25 ", "PMco ", "NOy ", "z_mid", "p_mid", "th " /) + SONDE_XTRA= (/ "NOy ", "z_mid", "p_mid", "th " /) !Height at mid-cell + + ! can access d_3d fields through index here, by + ! setting "D3D" above and say D3_XKSIG12 here: + + integer, public, parameter, dimension(NXTRA_SONDE) :: & + SONDE_XTRA_INDEX= (/ 0, 0, 0, 0 /) + + + + !==================================================================== + !/*** Hourly outputs (from hourly_out routine) to print out + ! concentrations or even met. parameters every hour + ! (or multiple: HOURLY_FREQ) for specified sub-grid. + ! Note: as to met. parameters, only temp2m Th arespecified + ! so far- others need change in hourly_out.f also). + + !------------------------------------------------------------------- + ! Possibility of multi-layer output. Specify NLEVELS_HOURLY here + ! and in hr_out defs use either: + ! + ! ADVppbv to get surface concentrations (only relevant for layer k=20 + ! while gives meaningless number for higher levels. + ! + ! 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, parameter :: NHOURLY_OUT = 1 ! No. outputs + integer, public, parameter :: NLEVELS_HOURLY = 1 ! No. outputs + integer, public, parameter :: FREQ_HOURLY = 1 ! 1 hours between outputs + + type, public:: Asc2D + character(len=12):: name ! Name (no spaces!) + character(len=7) :: type ! "ADVppbv" or "ADVugm3" or "SHLmcm3" + character(len=9) :: ofmt ! Output format (e.g. es12.4) + integer :: spec ! Species number in xn_adv or xn_shl array + ! .. or other arrays + integer :: ix1 ! bottom-left x + integer :: ix2 ! upper-right x + integer :: iy1 ! bottom-left y + integer :: iy2 ! upper-right y + integer :: nk ! number of vertical levels + character(len=12) :: unit ! Unit used + real :: unitconv ! conv. factor + real :: max ! Max allowed value for output + end type Asc2D + + type(Asc2D), public, dimension(NHOURLY_OUT) :: hr_out ! Set below + + + !/** wanted binary dates... specify days for which full binary + ! output is wanted. Replaces the hard-coding which was + ! in wrtchem: + + integer, public, parameter :: NBDATES = 3 + type(date), public, save, dimension(NBDATES) :: wanted_dates_inst + + !================================================================ + + public :: set_output_defs + + contains + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine set_output_defs + implicit none + + character(len=44) :: errmsg ! Local error message + integer :: i ! Loop index + + real :: to_ug_S & ! conversion to ug of S + ,to_ug_N & ! conversion to ug of N + ,to_mgSIA& ! conversion to mg of N + ,to_ugSIA ! conversion to ug of N + real, save :: m_s = 100.0 ! From cm/s to m/s + + ! introduce some integers to make specification of domain simpler + ! and less error-prone. Numbers can be changed as desired. + + !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 + + ! For Deriv system: + integer :: D2_O3WH, D2_O3DF, & + D2_AFSTDF0, D2_AFSTDF16, D2_AFSTBF0, D2_AFSTBF16, & ! JUN06 + D2_AFSTCR0, D2_AFSTCR3, D2_AFSTCR6,& + D2_AFSTCN0, D2_AFSTCN3, D2_AFSTCN6 + +! WARNING: If the specification of the subdomain is different for +! different components (ix1=125 for ozone and ix1=98 for +! NH4 for example) , the variables i_EMEP, j_EMEP +! latitude and longitude in NetCDF output will be +! wrong. + + to_ug_S = atwS*PPBINV/ATWAIR ! for output in ug(S)/m3 + to_ug_N = atwN*PPBINV/ATWAIR ! for output in ug(N)/m3 + to_mgSIA= PPBINV/ATWAIR*1000.0 + to_ugSIA= PPBINV/ATWAIR + + !/** Hourly outputs + ! Note that the hourly output uses **lots** of disc space, so specify + ! as few as you need and with as small format as possible (cf max value). + + ! ** REMEMBER : ADV species are mixing ratioes !! + ! ** REMEMBER : SHL species are in molecules/cm3, not mixing ratio !! + ! ** REMEMBER : No spaces in name, except at end !! + + !** name type + !** ofmt ispec ix1 ix2 iy1 iy2 nk unit conv max + + hr_out(1)= Asc2D("o3_3m", "ADVppbv", & + "(f9.4)",IXADV_o3, ix1,ix2,iy1,iy2,1, "ppbv",PPBINV,600.0) + +! For deriv system + + D2_O3WH = find_index("D2_O3WH",f_2d(:)%name) + D2_O3DF = find_index("D2_O3DF",f_2d(:)%name) + D2_AFSTDF16 = find_index("D2_AFSTDF16",f_2d(:)%name) + D2_AFSTCR3 = find_index("D2_AFSTCR3",f_2d(:)%name) + +! hr_out(2)= Asc2D("O3_Wheat", "D2D", & +! "(f7.3)", D2_O3WH, ix1,ix2,iy1,iy2,1, "ppbv", 1.0 ,600.0) +! hr_out(3)= Asc2D("O3_Beech", "D2D", & +! "(f7.3)", D2_O3DF, ix1,ix2,iy1,iy2,1, "ppbv", 1.0 ,600.0) +! hr_out(4)= Asc2D("FST_DF00", "D2D", & +! "(f7.3)", D2_FSTDF00, ix1,ix2,iy1,iy2,1, "NNNN", 1.0 ,600.0) +! hr_out(5)= Asc2D("FST_WH00", "D2D", & +! "(f7.3)", D2_FSTWH00, ix1,ix2,iy1,iy2,1, "NNNN", 1.0 ,600.0) + +! hr_out(1)= Asc2D("Ozone", "ADVppbv", & +! "(f9.5)",IXADV_O3, ix1,ix2,iy1,iy2, "ppb",PPBINV,600.0) +! hr_out(2)= Asc2D("aNH4-air", "ADVugm3", & +! "(f8.4)",IXADV_aNH4, ix1,ix2,iy1,iy2, "ug",to_ugSIA,600.0) +! hr_out(3)= Asc2D("aNO3-air", "ADVugm3", & +! "(f8.4)",IXADV_aNO3, ix1,ix2,iy1,iy2, "ug",to_ugSIA,600.0) +! hr_out(4)= Asc2D("SO4-air", "ADVugm3", & +! "(f8.4)",IXADV_aNO3, ix1,ix2,iy1,iy2, "ug",to_ugSIA,600.0) +! hr_out(5)= Asc2D("pNO3-air", "ADVugm3", & +! "(f8.4)",IXADV_pNO3, ix1,ix2,iy1,iy2, "ug",to_ugSIA,400.0) + +! hr_out(2)= & +! Asc2D("ADVugm3", "(f8.4)",IXADV_aNH4, 45, 170, 1, 133, "ug",to_ugSIA,600.0) +! hr_out(3)= & +! Asc2D("ADVugm3", "(f8.4)",IXADV_aNO3, 45, 170, 1, 133, "ug",to_ugSIA,600.0) +! hr_out(4)= & +! Asc2D("ADVugm3", "(f8.4)",IXADV_SO4, 45, 170, 1, 133, "ug",to_ugSIA,400.0) +! hr_out(5)= & +! Asc2D("ADVugm3", "(f8.4)",IXADV_pNO3, 45, 170, 1, 133, "ug",to_ugSIA,400.0) +! + ! 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. + + !** type ofmt ispec ix1 ix2 iy1 iy2 unit conv max + !hr_out(3)= & + ! Asc2D("D2D", "(f6.1)", D2_HMIX, ix1,ix2,iy1,iy2, "m",1.0 ,10000.0) + +!Flux stuff +! hr_out(2)= Asc2D("Fst_TConif ", "D2D", "(f8.5)",& +! D2_FSTCF0, ix1,ix2,iy1,iy2, "nmole/m2/s", 1.0 ,900.0) +! hr_out(3)= Asc2D("Fst_TBroad ", "D2D", "(f8.5)",& +! D2_FSTDF0, ix1,ix2,iy1,iy2, "nmole/m2/s", 1.0 ,900.0) +! hr_out(4)= Asc2D("Fst_Grass ", "D2D", "(f8.5)",& +! D2_FSTGR0, ix1,ix2,iy1,iy2, "nmole/m2/s", 1.0 ,900.0) +! hr_out(5)= Asc2D("Fst_Wheat ", "D2D", "(f8.5)",& +! D2_FSTWH0, ix1,ix2,iy1,iy2, "nmole/m2/s", 1.0 ,900.0) +! hr_out(10)= Asc2D("O3__Conif ", "D2D", "(f7.3)",& +! D2_O3CF, ix1,ix2,iy1,iy2, "ppb ", 1.0 ,900.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) + + + + !/** 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(unit=errmsg,fmt=*) "Failed consistency check in & + set_output_defs: Hourly is ",i, "Nhourly is ",NHOURLY_OUT + + call CheckStop(errmsg) + end if + + + end do + + !/** Wanted dates for instantaneous values output: + ! specify months,days,hours for which full output is wanted. + + wanted_dates_inst(1) = date(-1,1,1,0,0) + wanted_dates_inst(2) = date(-1,1,1,3,0) + wanted_dates_inst(3) = date(-1,1,1,6,0) + + end subroutine set_output_defs +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end module My_Outputs_ml + diff --git a/My_Reactions.inc b/My_Reactions.inc new file mode 100644 index 0000000..6f24a9e --- /dev/null +++ b/My_Reactions.inc @@ -0,0 +1,152 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! + + +! do iter = 1, toiter(k) +! +! The chemistry is iterated several times, more close to the ground +! than aloft. +! For some reason, it proved faster to include files as given below +! than to use loops. +if(k>=KCHEMTOP)then + + include 'My_FastReactions.inc' + +endif +if(k>=6)then + + include 'My_FastReactions.inc' + +endif + +if(k>=KEMISTOP)then + + include 'My_FastReactions.inc' + +endif + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX +! end do !! End iterations + ! Just before SO4 + !XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX + + +!-> SO4 + + P = & + 2e-12*aqrck(ICLOHSO2,K) * xnew(OH ) * xnew(SO2 ) & + + aqrck(ICLRC1,K)*XNEW(H2O2) * xnew(SO2 ) & + + aqrck(ICLRC2,K)*XNEW(O3) * xnew(SO2 ) & + + aqrck(ICLRC3,K) * xnew(SO2 ) & + + 0.05*rcemis(QRCSO2,K) + ! L = 0.0 + + + xnew(SO4)= amax1(0.0, xold(SO4) + dt2 * P) + + +!-> pNO3 + + P = & + rcmisc(10,k) * xnew(HNO3) + L = 0.0 + + + xnew(pNO3)= amax1(0.0, xold(pNO3) + dt2 * P) + + +!-> NH3 + + P = & + rcemis(QRCNH3,K) + ! L = 0.0 + + + xnew(NH3)= amax1(0.0, xold(NH3) + dt2 * P) + +!-> PM25 + + P = & + rcemis(QRCPM25,K) + ! L = 0.0 + xnew(PM25)= amax1(0.0, xold(PM25) + dt2 * P) + + +!-> PMCO + + P = & + rcemis(QRCPMCO,K) + ! L = 0.0 + xnew(PMCO)= amax1(0.0, xold(PMCO) + dt2 * P) + +!-> Rn222 + + P = rc_Rn222(k) + L = 1.0/(5.51614*24.0*3600.0) + xnew(Rn222)= amax1(0.0, ( xold(Rn222) + dt2 * P)) & + /(1.0 + dt2*L ) + +!-> Pb210 + P = 1.0/(5.51614*24.0*3600.0) * xnew(Rn222) + ! L = 0.0 + xnew(Pb210)= max(0.0, xold(Pb210) + dt2 * P) + +!SeaS + if (SEASALT) then + +!-> Sea salt fine + + P = & + rcss(QSSFI,K) + ! L = 0.0 + xnew(SSfi)= amax1(0.0, xold(SSfi) + dt2 * P) + +!-> Sea salt coarse + + P = & + rcss(QSSCO,K) + ! L = 0.0 + xnew(SSco)= amax1(0.0, xold(SSco) + dt2 * P) + endif + +!-> AMSU + ! P = 0.0 + + ! L = 0.0 + + +! xnew(AMSU)= amax1(0.0, xold(AMSU)) + + +!-> AMNI + ! P = 0.0 + + ! L = 0.0 + + +! xnew(AMNI)= amax1(0.0, xold(AMNI)) + diff --git a/My_WetDep_ml.f90 b/My_WetDep_ml.f90 new file mode 100644 index 0000000..68916ea --- /dev/null +++ b/My_WetDep_ml.f90 @@ -0,0 +1,131 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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_WetDep_ml + use MassBudget_ml, only : totwdep + use ModelConstants_ml, only : atwS, atwN, atwPM + use Derived_ml, only : f_2d, d_2d, IOU_INST + use SmallUtils_ml, only : find_index + + + use GenSpec_tot_ml ! SO2, SO4, etc. + use GenSpec_adv_ml ! IXADV_SO2, IXADV_SO4, etc. + implicit none + private + + public :: Init_WetDep ! Call from Unimod + public :: WetDep_Budget ! Call from Aqueous_ml + + type, public :: WScav + integer :: itot !ds may05 - was adv - confusing + 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 = 14 !SeaS 11 ! Number of solublity classes + type(WScav), public, dimension(NWETDEP), save :: WetDep + + integer, public, save :: WDEP_PREC ! Used in Aqueous_ml + integer, private, save :: WDEP_SOX, WDEP_OXN, WDEP_RDN + +contains + + subroutine Init_WetDep() + + !/ INCLOUDFAC is A/v where A is 5.2 m3 kg-1 s-1, ! and v is the fallspeed (5 m/s). + real, parameter :: FALLSPEED = 5.0 ! m/s + real, parameter :: SUBCLFAC = 5.2 / FALLSPEED + + !/ e is the scavenging efficiency (0.1 for fine particles, 0.4 for course) + + real, parameter :: EFF25 = 0.1*SUBCLFAC & + , EFFCO = 0.4*SUBCLFAC ! collection efficiency b/clouds - coarse + + !/.. setup the scavenging ratios for in-cloud and sub-cloud. For + ! gases, sub-cloud = 0.5 * incloud. For particles, sub-cloud= + ! efficiency * INCLOUDFAC. See also notes in Aqueous_ml. + + !/.. W_Sca W_sub + + WetDep(1) = WScav(SO2, 0.3, 0.15) ! Berge+Jakobsen, issh + WetDep(2) = WScav(SO4, 1.0, EFF25) ! Berge+Jakobsen, jej + WetDep(3) = WScav(aNH4, 1.0, EFF25) + WetDep(4) = WScav(NH3, 1.4, 0.5 ) ! subcloud = 1/3 of cloud for gases + WetDep(5) = WScav(aNO3, 1.0, EFF25) + WetDep(6) = WScav(HNO3, 1.4, 0.5) ! + WetDep(7) = WScav(H2O2, 1.4, 0.5) ! + WetDep(8) = WScav(HCHO, 0.1, 0.03) ! + WetDep(9) = WScav(pNO3, 1.0, EFFCO) !! + WetDep(10) = WScav(PM25, 1.0, EFF25) + WetDep(11) = WScav(PMCO, 1.0, EFFCO) + WetDep(12) = WScav(SSFI, 1.0, EFF25) !SeaS + WetDep(13) = WScav(SSCO, 1.0, EFFCO) !SeaS + WetDep(14) = WScav(Pb210, 1.0, EFF25) ! + + !####################### ds NEW define indices here ########## + + WDEP_PREC= find_index("WDEP_PREC",f_2d(:)%name) + WDEP_SOX = find_index("WDEP_SOX",f_2d(:)%name) + WDEP_OXN = find_index("WDEP_OXN",f_2d(:)%name) + WDEP_RDN = find_index("WDEP_RDN",f_2d(:)%name) + !####################### ds END define indices here ########## + + end subroutine Init_WetDep + + subroutine WetDep_Budget(i,j,sumloss,invgridarea) + integer, intent(in) :: i,j + real, dimension(:), intent(in) :: sumloss + real, intent(in) :: invgridarea + real :: wdeps, wdepox, wdepred, wdeppm25, wdeppmco + + + !wdeps = sumloss(SO2) + sumloss(SO4) + wdeps = sumloss(1) + sumloss(2) + + !wdepred = sumloss(NH3) + sumloss(NH4) & + wdepred = sumloss(4) + sumloss(3) ! + + !wdepox = sumloss(HNO3) + sumloss(aNO3) + pNO3 + wdepox = sumloss(6) + sumloss(5) + sumloss(9) + wdeppm25= sumloss(7) + wdeppmco= sumloss(8) + + totwdep(IXADV_SO4) = totwdep(IXADV_SO4) + wdeps + totwdep(IXADV_HNO3) = totwdep(IXADV_HNO3) + wdepox + totwdep(IXADV_NH3) = totwdep(IXADV_NH3) + wdepred + totwdep(IXADV_PM25) = totwdep(IXADV_PM25) + wdeppm25 + totwdep(IXADV_PMco) = totwdep(IXADV_PMco) + wdeppmco + + + d_2d(WDEP_SOX,i,j,IOU_INST) = wdeps * atwS * invgridarea + d_2d(WDEP_OXN,i,j,IOU_INST) = wdepox * atwN * invgridarea + d_2d(WDEP_RDN,i,j,IOU_INST) = wdepred * atwN * invgridarea + + + end subroutine WetDep_Budget +end module My_WetDep_ml diff --git a/N2O5_hydrolysis_ml.f90 b/N2O5_hydrolysis_ml.f90 new file mode 100644 index 0000000..0342ad0 --- /dev/null +++ b/N2O5_hydrolysis_ml.f90 @@ -0,0 +1,115 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 N2O5_hydrolysis_ml + +! N2O5 -> nitrate calculation +!=========================================================================== +! N2O5 -> nitrate calculation. Some constants for +! calculation of volume fraction of sulphate aerosol, and rate of uptake +! +! +! The first order reaction coefficient K (corrected for gas phase diffusion, +! Schwartz, 1986) is given by +! +! K= A* alpha* v/4 +! alpha=sticking coeff. for N2O5 =0.02 +! v=mean molecular speed for N2O5 +! A=aerosol surfac +! +! The surface area of the aerosols can be calculated as +! +! A = V * surface/volume of aerosols +! V=volume fraction of sulphate (cm3 aerosol/cm3 air) +! (similar for nitrate and ammonium): +! +! e.g. +! 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. +! +! +! We do not want to include concentrations or rho yet, so: +! +! Let VOL = M0/AVOG +! +! The surface/volume ratio is calculated using Whitby particle distribution +! with number mean radius 0.034 and standars deviation (Sigma)=2. +! Then surface/volume=3/r * exp( -5/2 *(lnSigma)^2)=26.54 +! 3* exp( -5/2 *(lnSigma)^2)=0.90236 +! (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) +! and +! K = VOL * S * 0.90236 /(0.034e-6*rho) * alpha* v/4 +! Set +! VOLFAC= VOL*0.90236/0.034e-6 *alpha +! Then +! K = VOLFAC *S *v/(4*rho) +! +! rcmisc(8,k) (in My_Chem)=v/(4*rho) +! +! K = VOLFAC *rcmisc(8,k) *S +! 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 +! alpha1=0.02 +! alpha2=0.002 +! f= Mso4/(Mso4+Mno3), M=aerosol mass concentration + + use ModelConstants_ml, only : KMAX_MID, KCHEMTOP + use PhysicalConstants_ml, only :AVOG + + implicit none + private + + + + real, public, dimension(KCHEMTOP:KMAX_MID), save :: & + f_Riemer ! 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 + + + + + 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 + + + + end module N2O5_hydrolysis_ml diff --git a/Nest_ml.f90 b/Nest_ml.f90 new file mode 100644 index 0000000..86f45a3 --- /dev/null +++ b/Nest_ml.f90 @@ -0,0 +1,711 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Nest_ml + ! + !This module performs the reading or writing of data for nested runs + ! + !To make a nested run: + !1) run with MODE=1 to write out 3d BC + !2) run (in a smaller domain) with MODE=2 + + + ! + !Set MODE and istart,jstart,iend,jend + !Choose NHOURSAVE and NHOURREAD + ! + + + !Grids may have any projection. + !Horizontal interpolation uses a weighted average of the four closest points + !This will work also if points in the present grid are not covered by the external grid. + + + !To do: + !At present the vertical coordinates cannot be interpolated and must be the same in both grid. + !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?) + + + !Peter May 2006 + +!hfTD use Dates_ml, only : date + use TimeDate_ml, only : date + use GridValues_ml, only : gl,gb + use GenChemicals_ml , only :species + use GenSpec_shl_ml , only :NSPEC_SHL + use GenSpec_adv_ml , only :NSPEC_ADV + use GenSpec_tot_ml , only :NSPEC_TOT + use netcdf + use netcdf_ml, only : GetCDF,Out_netCDF,Init_new_netCDF,& + secondssince1970,Int1,Int2,Int4,Real4,Real8 + use ModelConstants_ml, only : KMAX_MID, NPROC + 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 NetCDF_ml, only :WriteCDF + + implicit none + + INCLUDE 'mpif.h' + INTEGER INFO + + integer,parameter ::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) + + !coordinates of subdomain to write + !coordinates relative to small domain (only used in write mode) + integer ::istart=60,jstart=11,iend=107,jend=58 !ENEA + + !/-- subroutines + + public :: readxn + public :: wrtxn + + + ! logical, save, public::Nest_BC,Nest_3D + + 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(NHOURREAD0)then + write(*,55)'year: ',ndate(1),', month: ',ndate(2),', day: ',& + ndate(3),', hour: ',ndate(4),', seconds: ',nseconds-n + endif +55 format(A,I5,A,I4,A,I4,A,I4,A,I10) + end subroutine datefromsecondssince1970 + + subroutine init_nest(nseconds_indate) + + implicit none + integer :: ncFileID,idimID,jdimID, kdimID,timeDimID,varid,timeVarID,status + integer :: nseconds_indate,ndate(4) + real :: dist(0:4) + integer :: nseconds(1),n1,n,i,j,k,II,JJ + real, allocatable, dimension(:,:) ::lon_ext,lat_ext + character*80 ::projection + + itime_saved = -999999 !initialization + + !Read dimensions (global) + if(me==0)then + status = nf90_open(path=trim(filename_read),mode=nf90_nowrite,ncid=ncFileID) + + if(status /= nf90_noerr) then + print *,'not found',trim(filename_read) + return + else + print *,' reading ',trim(filename_read) + endif + projection='' + call check(nf90_get_att(ncFileID,nf90_global,"projection",projection)) + 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)) + ! WRITE(*,*) 'MPI_ABORT: ', "PROJECTION NOT RECOGNIZED" + ! call MPI_ABORT(MPI_COMM_WORLD,9,INFO) + 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_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)) + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=timedimID,len=Next)) + + write(*,*)'dimensions external grid',GIMAX_ext,GJMAX_ext,KMAX_ext,Next + endif + CALL MPI_BCAST(GIMAX_ext,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(GJMAX_ext,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(KMAX_ext,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(Next,4*1,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + allocate(lon_ext(GIMAX_ext,GJMAX_ext)) + allocate(lat_ext(GIMAX_ext,GJMAX_ext)) + + if(me==0)then + !Read lon lat of the external grid (global) + if(trim(projection)==trim('lon lat')) then + call check(nf90_inq_varid(ncid = ncFileID, name = "lon", varID = varID)) + call check(nf90_get_var(ncFileID, varID, lon_ext(:,1) )) + do i=1,GJMAX_ext + lon_ext(:,i)=lon_ext(:,1) + enddo + call check(nf90_inq_varid(ncid = ncFileID, name = "lat", varID = varID)) + call check(nf90_get_var(ncFileID, varID, lat_ext(1,:) )) + do i=1,GIMAX_ext + lat_ext(i,:)=lat_ext(1,:) + enddo + else + call check(nf90_inq_varid(ncid = ncFileID, name = "lon", varID = varID)) + call check(nf90_get_var(ncFileID, varID, lon_ext )) + + call check(nf90_inq_varid(ncid = ncFileID, name = "lat", varID = varID)) + call check(nf90_get_var(ncFileID, varID, lat_ext )) + endif + call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = varID)) + + ! do n=1,Next + call check(nf90_get_var(ncFileID, varID, nseconds,start=(/ 1 /),count=(/ 1 /) )) + + if(nseconds(1)>nseconds_indate)then + write(*,*)'WARNING: did not find BIC for date:' + call datefromsecondssince1970(ndate,nseconds_indate,1) + write(*,*)'first date found:' + call datefromsecondssince1970(ndate,nseconds(1),1) + endif + ! enddo + + call check(nf90_close(ncFileID)) + + endif + + CALL MPI_BCAST(lon_ext,8*GIMAX_ext*GJMAX_ext,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + CALL MPI_BCAST(lat_ext,8*GIMAX_ext*GJMAX_ext,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + !find interpolation constants + !note that i,j are local + !find the four closest points + do j=1,ljmax + do i=1,limax + 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),gl(i,j),gb(i,j)) + if(dist(0)=nseconds_indate)then + write(*,*)'Using date ' + call datefromsecondssince1970(ndate,nseconds(1),1) + goto 876 + endif + enddo + write(*,*)'WARNING: did not find correct date' + itime=Next + write(*,*)'Using date ' + call datefromsecondssince1970(ndate,nseconds(1),1) +876 continue + itime=n + itime_saved(2)=nseconds(1) + endif + + CALL MPI_BCAST(itime_saved,4*2,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + do n= 1, NSPEC_ADV + if(nr==2)then + !store the old vaules in 1 + itime_saved(1)=nseconds_old + do k=1,KMAX_ext + do i=1,li0-1 + do j=1,ljmax + xn_adv_bndw(n,j,k,1)=xn_adv_bndw(n,j,k,2) + enddo + enddo + do j=1,lj0-1 + do i=1,limax + xn_adv_bnds(n,i,k,1)=xn_adv_bnds(n,i,k,2) + enddo + enddo + do i=li1+1,limax + do j=1,ljmax + xn_adv_bnde(n,j,k,1)=xn_adv_bnde(n,j,k,2) + enddo + enddo + do j=lj1+1,ljmax + do i=1,limax + xn_adv_bndn(n,i,k,1)=xn_adv_bndn(n,i,k,2) + enddo + enddo + enddo + endif + if(me==0)then + !Could fetch one level at a time if sizes becomes too big + + call check(nf90_inq_varid(ncid=ncFileID, name=trim(species(NSPEC_SHL+n)%name), varID=varID)) + + call check(nf90_get_var(ncFileID, varID, data & + ,start=(/ 1,1,1,itime /),count=(/ GIMAX_ext,GJMAX_ext,KMAX_ext,1 /) )) + + endif + CALL MPI_BCAST(data,8*GIMAX_ext*GJMAX_ext*KMAX_ext,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + !overwrite Global Boundaries (lateral faces) + + do k=1,KMAX_ext + do i=1,li0-1 + do j=1,ljmax + xn_adv_bndw(n,j,k,2)=Weight1(i,j)*data(IIij(i,j,1),JJij(i,j,1),k)+& + Weight2(i,j)*data(IIij(i,j,2),JJij(i,j,2),k)+& + Weight3(i,j)*data(IIij(i,j,3),JJij(i,j,3),k)+& + Weight4(i,j)*data(IIij(i,j,4),JJij(i,j,4),k) + + enddo + enddo + do j=1,lj0-1 + do i=1,limax + xn_adv_bnds(n,i,k,2)=Weight1(i,j)*data(IIij(i,j,1),JJij(i,j,1),k)+& + Weight2(i,j)*data(IIij(i,j,2),JJij(i,j,2),k)+& + Weight3(i,j)*data(IIij(i,j,3),JJij(i,j,3),k)+& + Weight4(i,j)*data(IIij(i,j,4),JJij(i,j,4),k) + enddo + enddo + do i=li1+1,limax + do j=1,ljmax + xn_adv_bnde(n,j,k,2)=Weight1(i,j)*data(IIij(i,j,1),JJij(i,j,1),k)+& + Weight2(i,j)*data(IIij(i,j,2),JJij(i,j,2),k)+& + Weight3(i,j)*data(IIij(i,j,3),JJij(i,j,3),k)+& + Weight4(i,j)*data(IIij(i,j,4),JJij(i,j,4),k) + enddo + enddo + do j=lj1+1,ljmax + do i=1,limax + xn_adv_bndn(n,i,k,2)=Weight1(i,j)*data(IIij(i,j,1),JJij(i,j,1),k)+& + Weight2(i,j)*data(IIij(i,j,2),JJij(i,j,2),k)+& + Weight3(i,j)*data(IIij(i,j,3),JJij(i,j,3),k)+& + Weight4(i,j)*data(IIij(i,j,4),JJij(i,j,4),k) + enddo + enddo + enddo + enddo + + + + deallocate(data) + if(me==0)then + call check(nf90_close(ncFileID)) + endif + + end subroutine read_newdata_LATERAL + + subroutine reset_3D(nseconds_indate) + implicit none + real, allocatable, dimension(:,:,:) ::data + integer :: nseconds(1),ndate(4),n1,n,i,j,k,II,JJ,itime,status + integer :: nseconds_indate + integer :: ncFileID,idimID,jdimID, kdimID,timeDimID,varid,timeVarID + + allocate(data(GIMAX_ext,GJMAX_ext,KMAX_ext), stat=status) + if(me==0)then + call check(nf90_open(path = trim(fileName_read), mode = nf90_nowrite, ncid = ncFileID)) + + call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = varID)) + do n=1,Next + call check(nf90_get_var(ncFileID, varID, nseconds,start=(/ n /),count=(/ 1 /) )) + if(nseconds(1)>=nseconds_indate)then + write(*,*)'found date ' + call datefromsecondssince1970(ndate,nseconds(1),1) + goto 876 + endif + enddo + write(*,*)'WARNING: did not find correct date' + itime=Next +876 continue + itime=n + endif + + do n= 1, NSPEC_ADV + if(me==0)then + !Could fetch one level at a time if sizes becomes too big + + call check(nf90_inq_varid(ncid=ncFileID, name=trim(species(NSPEC_SHL+n)%name), varID=varID)) + + call check(nf90_get_var(ncFileID, varID, data & + ,start=(/ 1,1,1,itime /),count=(/ GIMAX_ext,GJMAX_ext,KMAX_ext,1 /) )) + + endif + CALL MPI_BCAST(data,8*GIMAX_ext*GJMAX_ext*KMAX_ext,MPI_BYTE,0,MPI_COMM_WORLD,INFO) + + ! overwrite everything 3D (init) + do k=1,KMAX_ext + do j=1,ljmax + do i=1,limax + xn_adv(n,i,j,k)=Weight1(i,j)*data(IIij(i,j,1),JJij(i,j,1),k)+& + Weight2(i,j)*data(IIij(i,j,2),JJij(i,j,2),k)+& + Weight3(i,j)*data(IIij(i,j,3),JJij(i,j,3),k)+& + Weight4(i,j)*data(IIij(i,j,4),JJij(i,j,4),k) + enddo + enddo + enddo + + enddo + + deallocate(data) + if(me==0)then + call check(nf90_close(ncFileID)) + endif + + end subroutine reset_3D + +end module Nest_ml + diff --git a/NetCDF_ml.f90 b/NetCDF_ml.f90 new file mode 100644 index 0000000..23f2703 --- /dev/null +++ b/NetCDF_ml.f90 @@ -0,0 +1,1477 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 NetCDF_ml +! +! Routines for netCDF output +! +! Written by Peter january 2003 +! +!compile with options: +!f90 -L/home/u4/mifahik/netcdf/lib64 -I/home/u4/mifahik/netcdf/include -64 NetCDF_ml.f90 -lnetcdf +! +!view results.nc with: +!xrdb -load /home/u4/mifahik/.app-defaults/Ncview (once only) +!/home/u4/mifahik/bin/ncview results.nc +!or +! +!/home/u4/mifahik/bin/ncdump results.nc |less +! +!for details see: +!http://www.unidata.ucar.edu/packages/netcdf/f90/Documentation/f90-html-docs/ +! +! +!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_Derived_ml, only : model + use My_Outputs_ml, only :FREQ_HOURLY + + use Chemfields_ml, only : xn_shl,xn_adv + use CheckStop_ml, only: CheckStop + use Derived_ml, only : Deriv,IOU_INST,IOU_HOUR, IOU_YEAR ,IOU_MON, IOU_DAY + use GenSpec_shl_ml , only :NSPEC_SHL + use GenSpec_adv_ml , only :NSPEC_ADV + use GenSpec_tot_ml , only :NSPEC_TOT + use GenChemicals_ml, only :species + use GridValues_ml, only : GRIDWIDTH_M,fi,xp,yp,xp_EMEP_official& + ,yp_EMEP_official,fi_EMEP,GRIDWIDTH_M_EMEP& + ,GlobalPosition,gb_glob,gl_glob,ref_latitude& + ,projection, sigma_mid + use ModelConstants_ml, only : KMAX_MID, runlabel1, runlabel2 & + ,NPROC, IIFULLDOM,JJFULLDOM & + ,PT, current_date + use netcdf + use Par_ml, only : me,GIMAX,GJMAX,tgi0,tgj0,tlimax,tljmax, & + MAXLIMAX, MAXLJMAX,IRUNBEG,JRUNBEG + use PhysicalConstants_ml, only : PI + use TimeDate_ml, only: nmdays,leapyear ,current_date, date + + + implicit none + + + INCLUDE 'mpif.h' + INTEGER MPISTATUS(MPI_STATUS_SIZE),INFO + + character (len=125), save :: fileName_inst = 'out_inst.nc' + character (len=125), save :: fileName_hour = 'out_hour.nc' + 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 + + 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 with different filename_given) + integer,save :: ncFileID_inst=closedID + integer,save :: ncFileID_hour=closedID + integer,save :: ncFileID_day=closedID + integer,save :: ncFileID_month=closedID + integer,save :: ncFileID_year=closedID + integer,save :: outCDFtag=0 + integer, public, parameter :: Int1=1,Int2=2,Int4=3,Real4=4,Real8=5 !CDF typr for output + character (len=18), parameter :: Default_projection_name = 'General_Projection' + logical, parameter :: MY_DEBUG = .false. + + public :: Out_netCDF + public :: CloseNetCDF + public :: Init_new_netCDF + public :: GetCDF + public :: WriteCDF + public :: ReadCDF + public :: secondssince1970 + + private :: CreatenetCDFfile + private :: createnewvariable + private :: check + +contains +!_______________________________________________________________________ + + +subroutine Init_new_netCDF(fileName,iotyp) + +use Par_ml, only : GIMAX,GJMAX,IRUNBEG,JRUNBEG +use ModelConstants_ml,only : KMAX_MID +use My_Outputs_ml, only : NHOURLY_OUT, & ! No. outputs + Asc2D, hr_out ! Required outputs +!ds 16/12/2003use My_Derived_ml, only :IOU_INST,IOU_HOUR, IOU_YEAR,IOU_MON, IOU_DAY +use Derived_ml, only :IOU_INST,IOU_HOUR, IOU_YEAR,IOU_MON, IOU_DAY + +integer, intent(in) :: iotyp + character(len=*), intent(in) :: fileName + +integer :: GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,KMAXcdf +integer :: ih + +!write(*,*)'Init_new_netCDF ',fileName,iotyp +call CloseNetCDF + +if(iotyp==IOU_YEAR)then + +fileName_year = trim(fileName) +period_type = 'fullrun' +call CreatenetCDFfile(fileName,GIMAX,GJMAX,IRUNBEG,JRUNBEG,KMAX_MID) + +elseif(iotyp==IOU_MON)then + +fileName_month = trim(fileName) +period_type = 'monthly' +call CreatenetCDFfile(fileName,GIMAX,GJMAX,IRUNBEG,JRUNBEG,KMAX_MID) + +elseif(iotyp==IOU_DAY)then + +fileName_day = trim(fileName) +period_type = 'daily' +call CreatenetCDFfile(fileName,GIMAX,GJMAX,IRUNBEG,JRUNBEG,KMAX_MID) + +elseif(iotyp==IOU_HOUR)then + +fileName_hour = trim(fileName) +period_type = 'hourly' +ISMBEGcdf=GIMAX+IRUNBEG-1; JSMBEGcdf=GJMAX+JRUNBEG-1 !initialisations +GIMAXcdf=0; GJMAXcdf=0!initialisations +KMAXcdf=1 +do ih=1,NHOURLY_OUT + ISMBEGcdf=min(ISMBEGcdf,hr_out(ih)%ix1) + JSMBEGcdf=min(JSMBEGcdf,hr_out(ih)%iy1) + GIMAXcdf=max(GIMAXcdf,hr_out(ih)%ix2-hr_out(ih)%ix1+1) + GJMAXcdf=max(GJMAXcdf,hr_out(ih)%iy2-hr_out(ih)%iy1+1) + KMAXcdf =max(KMAXcdf,hr_out(ih)%nk) +enddo +GIMAXcdf=min(GIMAXcdf,GIMAX) +GJMAXcdf=min(GJMAXcdf,GJMAX) +!write(*,*)'sizes CDF ',GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,KMAXcdf +call CreatenetCDFfile(fileName,GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,KMAXcdf) + +elseif(iotyp==IOU_INST)then + +fileName_inst = trim(fileName) +period_type = 'instant' +call CreatenetCDFfile(fileName,GIMAX,GJMAX,IRUNBEG,JRUNBEG,KMAX_MID) + +else +period_type = 'unknown' +call CreatenetCDFfile(fileName,GIMAX,GJMAX,IRUNBEG,JRUNBEG,KMAX_MID) +endif + +end subroutine Init_new_netCDF + +subroutine CreatenetCDFfile(fileName,GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,KMAXcdf,RequiredProjection) + ! Create the netCDF file + +integer, intent(in) :: GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,KMAXcdf +character(len=*), intent(in) :: fileName +character (len=*),optional, intent(in):: requiredprojection +character (len=*), parameter :: author_of_run='Unimod group' +character(len=*), parameter :: vert_coord='sigma: k ps: PS ptop: PT' +character (len=19) :: projection_params='90.0 -32.0 0.933013' !set later on + +real :: xcoord(GIMAX),ycoord(GJMAX),kcoord(KMAX_MID) + +character*8 ::created_date,lastmodified_date +character*10 ::created_hour,lastmodified_hour +integer :: ncFileID,iDimID,jDimID,kDimID,timeDimID,VarID,iVarID,jVarID,kVarID,i,j,k +integer :: iEMEPVarID,jEMEPVarID,latVarID,longVarID,PTVarID +real :: izero,jzero,scale_at_projection_origin +character*80 ::UsedProjection + + ! fileName: Name of the new created file + ! nf90_clobber: protect existing datasets + ! ncFileID: netcdf ID + +!Check that the dimensions are > 0 +if(GIMAXcdf<=0.or.GJMAXcdf<=0.or.KMAXcdf<=0)then +write(*,*)'WARNING:' +write(*,*)trim(fileName),' not created. Requested area too small (or outside domain) ' +write(*,*)'sizes (IMAX,JMAX,IBEG,JBEG,KMAX) ',GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,KMAXcdf +return +endif + +if(present(RequiredProjection))then + UsedProjection=trim(RequiredProjection) +else + UsedProjection=trim(projection) +endif + +write(*,*)'create ',trim(fileName) +write(*,*)'UsedProjection ',trim(UsedProjection) +write(*,*)'with sizes (IMAX,JMAX,IBEG,JBEG,KMAX) ',GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,KMAXcdf + call check(nf90_create(path = trim(fileName), cmode = nf90_clobber, ncid = ncFileID)) + + ! Define the dimensions + if(UsedProjection=='Stereographic')then + + call check(nf90_def_dim(ncid = ncFileID, name = "i", len = GIMAXcdf, dimid = iDimID)) + call check(nf90_def_dim(ncid = ncFileID, name = "j", len = GJMAXcdf, dimid = jDimID)) + + elseif(UsedProjection=='lon lat')then + + call check(nf90_def_dim(ncid = ncFileID, name = "lon", len = GIMAXcdf, dimid = iDimID)) + call check(nf90_def_var(ncFileID, "lon", nf90_double, dimids = iDimID, varID = iVarID) ) + call check(nf90_put_att(ncFileID, iVarID, "standard_name", "longitude")) + call check(nf90_put_att(ncFileID, iVarID, "long_name", "longitude")) + call check(nf90_put_att(ncFileID, iVarID, "units", "degrees_east")) + call check(nf90_def_dim(ncid = ncFileID, name = "lat", len = GJMAXcdf, dimid = jDimID)) + call check(nf90_def_var(ncFileID, "lat", nf90_double, dimids = jDimID, varID =jVarID) ) + call check(nf90_put_att(ncFileID, jVarID, "standard_name", "latitude")) + call check(nf90_put_att(ncFileID, jVarID, "long_name", "latitude")) + call check(nf90_put_att(ncFileID, jVarID, "units", "degrees_north")) + + else !general projection + + call check(nf90_def_dim(ncid = ncFileID, name = "i", len = GIMAX, dimid = iDimID)) + call check(nf90_def_dim(ncid = ncFileID, name = "j", len = GJMAX, dimid = jDimID)) + call check(nf90_def_var(ncFileID, "i", nf90_float, dimids = iDimID, varID = iVarID) ) + call check(nf90_put_att(ncFileID, iVarID, "standard_name", "projection_x_coordinate")) + call check(nf90_put_att(ncFileID, iVarID, "coord_axis", "x")) + call check(nf90_put_att(ncFileID, iVarID, "long_name", "grid x coordinate")) + call check(nf90_put_att(ncFileID, iVarID, "units", "km")) + call check(nf90_def_var(ncFileID, "j", nf90_float, dimids = jDimID, varID = jVarID) ) + call check(nf90_put_att(ncFileID, jVarID, "standard_name", "projection_y_coordinate")) + call check(nf90_put_att(ncFileID, jVarID, "coord_axis", "y")) + call check(nf90_put_att(ncFileID, jVarID, "long_name", "grid y coordinate")) + call check(nf90_put_att(ncFileID, jVarID, "units", "km")) + + + call check(nf90_def_var(ncFileID, "lat", nf90_float, dimids = (/ iDimID, jDimID/), varID = latVarID) ) + call check(nf90_put_att(ncFileID, latVarID, "long_name", "latitude")) + call check(nf90_put_att(ncFileID, latVarID, "units", "degrees_north")) + call check(nf90_put_att(ncFileID, latVarID, "standard_name", "latitude")) + + call check(nf90_def_var(ncFileID, "lon", nf90_float, dimids = (/ iDimID, jDimID/), varID = longVarID) ) + call check(nf90_put_att(ncFileID, longVarID, "long_name", "longitude")) + call check(nf90_put_att(ncFileID, longVarID, "units", "degrees_east")) + call check(nf90_put_att(ncFileID, longVarID, "standard_name", "longitude")) + + endif + + call check(nf90_def_dim(ncid = ncFileID, name = "k", len = KMAXcdf, dimid = kDimID)) + call check(nf90_def_dim(ncid = ncFileID, name = "time", len = nf90_unlimited, dimid = timeDimID)) + + call Date_And_Time(date=created_date,time=created_hour) + write(6,*) 'created_date: ',created_date + write(6,*) 'created_hour: ',created_hour + + ! Write global attributes + call check(nf90_put_att(ncFileID, nf90_global, "Conventions", "CF-1.0" )) +! call check(nf90_put_att(ncFileID, nf90_global, "version", version )) + call check(nf90_put_att(ncFileID, nf90_global, "model", model)) + call check(nf90_put_att(ncFileID, nf90_global, "author_of_run", author_of_run)) + call check(nf90_put_att(ncFileID, nf90_global, "created_date", created_date)) + call check(nf90_put_att(ncFileID, nf90_global, "created_hour", created_hour)) + lastmodified_date = created_date + lastmodified_hour = created_hour + call check(nf90_put_att(ncFileID, nf90_global, "lastmodified_date", lastmodified_date)) + call check(nf90_put_att(ncFileID, nf90_global, "lastmodified_hour", lastmodified_hour)) + + call check(nf90_put_att(ncFileID, nf90_global, "projection",UsedProjection)) + + if(UsedProjection=='Stereographic')then + scale_at_projection_origin=(1.+sin(ref_latitude*PI/180.))/2. + write(projection_params,fmt='(''90.0 '',F5.1,F9.6)')fi,scale_at_projection_origin + call check(nf90_put_att(ncFileID, nf90_global, "projection_params",projection_params)) + +! define coordinate variables + call check(nf90_def_var(ncFileID, "i", nf90_float, dimids = iDimID, varID = iVarID) ) + call check(nf90_put_att(ncFileID, iVarID, "standard_name", "projection_x_coordinate")) + call check(nf90_put_att(ncFileID, iVarID, "coord_axis", "x")) + call check(nf90_put_att(ncFileID, iVarID, "long_name", "EMEP grid x coordinate")) + call check(nf90_put_att(ncFileID, iVarID, "units", "km")) + + call check(nf90_def_var(ncFileID, "i_EMEP", nf90_float, dimids = iDimID, varID = iEMEPVarID) ) + call check(nf90_put_att(ncFileID, iEMEPVarID, "long_name", "official EMEP grid coordinate i")) + call check(nf90_put_att(ncFileID, iEMEPVarID, "units", "gridcells")) + + call check(nf90_def_var(ncFileID, "j", nf90_float, dimids = jDimID, varID = jVarID) ) + call check(nf90_put_att(ncFileID, jVarID, "standard_name", "projection_y_coordinate")) + call check(nf90_put_att(ncFileID, jVarID, "coord_axis", "y")) + call check(nf90_put_att(ncFileID, jVarID, "long_name", "EMEP grid y coordinate")) + call check(nf90_put_att(ncFileID, jVarID, "units", "km")) + + call check(nf90_def_var(ncFileID, "j_EMEP", nf90_float, dimids = jDimID, varID = jEMEPVarID) ) + call check(nf90_put_att(ncFileID, jEMEPVarID, "long_name", "official EMEP grid coordinate j")) + call check(nf90_put_att(ncFileID, jEMEPVarID, "units", "gridcells")) + + call check(nf90_def_var(ncFileID, "lat", nf90_float, dimids = (/ iDimID, jDimID/), varID = latVarID) ) + call check(nf90_put_att(ncFileID, latVarID, "long_name", "latitude")) + call check(nf90_put_att(ncFileID, latVarID, "units", "degrees_north")) + call check(nf90_put_att(ncFileID, latVarID, "standard_name", "latitude")) + + call check(nf90_def_var(ncFileID, "lon", nf90_float, dimids = (/ iDimID, jDimID/), varID = longVarID) ) + call check(nf90_put_att(ncFileID, longVarID, "long_name", "longitude")) + call check(nf90_put_att(ncFileID, longVarID, "units", "degrees_east")) + call check(nf90_put_att(ncFileID, longVarID, "standard_name", "longitude")) + endif + +! call check(nf90_put_att(ncFileID, nf90_global, "vert_coord", vert_coord)) + call check(nf90_put_att(ncFileID, nf90_global, "period_type", trim(period_type))) + call check(nf90_put_att(ncFileID, nf90_global, "run_label", trim(runlabel2))) + + call check(nf90_def_var(ncFileID, "k", nf90_float, dimids = kDimID, varID = kVarID) ) + call check(nf90_put_att(ncFileID, kVarID, "coord_alias", "level")) +!pwsvs for CF-1.0 + call check(nf90_put_att(ncFileID, kVarID, "standard_name", "atmosphere_sigma_coordinate")) + call check(nf90_put_att(ncFileID, kVarID, "formula_terms", trim(vert_coord))) + call check(nf90_put_att(ncFileID, kVarID, "units", "sigma_level")) + call check(nf90_put_att(ncFileID, kVarID, "positive", "down")) + call check(nf90_def_var(ncFileID, "PT", nf90_float, varID = PTVarID) ) + call check(nf90_put_att(ncFileID, PTVarID, "units", "Pa")) + call check(nf90_put_att(ncFileID, PTVarID, "long_name", "Pressure at top")) + + call check(nf90_def_var(ncFileID, "time", nf90_int, dimids = timeDimID, varID = VarID) ) + if(trim(period_type) /= 'instant'.and.trim(period_type) /= 'unknown'.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")) + endif + call check(nf90_put_att(ncFileID, VarID, "units", "seconds since 1970-1-1 00:00:00.0 +00:00")) + + +!CF-1.0 definitions: + if(UsedProjection=='Stereographic')then + call check(nf90_def_var(ncid = ncFileID, name = "Polar_Stereographic", xtype = nf90_int, varID=varID ) ) + call check(nf90_put_att(ncFileID, VarID, "grid_mapping_name", "polar_stereographic")) + call check(nf90_put_att(ncFileID, VarID, "straight_vertical_longitude_from_pole", Fi)) + call check(nf90_put_att(ncFileID, VarID, "latitude_of_projection_origin", 90.0)) + call check(nf90_put_att(ncFileID, VarID, "scale_factor_at_projection_origin", scale_at_projection_origin)) +! call check(nf90_put_att(ncFileID, VarID, "false_easting", )) + elseif(UsedProjection=='lon lat')then + + else + + call check(nf90_def_var(ncid = ncFileID, name = Default_projection_name, xtype = nf90_int, varID=varID ) ) + call check(nf90_put_att(ncFileID, VarID, "grid_mapping_name", trim(UsedProjection))) + + endif + + ! Leave define mode + call check(nf90_enddef(ncFileID)) + + call check(nf90_open(path = trim(fileName), mode = nf90_write, ncid = ncFileID)) + +! Define horizontal distances + + if(UsedProjection=='Stereographic')then + + xcoord(1)=(ISMBEGcdf-xp)*GRIDWIDTH_M/1000. + do i=2,GIMAXcdf + xcoord(i)=xcoord(i-1)+GRIDWIDTH_M/1000. +! print *, i,xcoord(i) + enddo + call check(nf90_put_var(ncFileID, iVarID, xcoord(1:GIMAXcdf)) ) + + ycoord(1)=(JSMBEGcdf-yp)*GRIDWIDTH_M/1000. + do j=2,GJMAXcdf + ycoord(j)=ycoord(j-1)+GRIDWIDTH_M/1000. + enddo + call check(nf90_put_var(ncFileID, jVarID, ycoord(1:GJMAXcdf)) ) + +! Define horizontal coordinates in the official EMEP grid +! xp_EMEP_official=8. +! yp_EMEP_official=110. +! GRIDWIDTH_M_EMEP=50000. +! fi_EMEP=-32. + if(fi==fi_EMEP)then +! Implemented only if fi = fi_EMEP = -32 (Otherwise needs a 2-dimensional mapping) +! uses (i-xp)*GRIDWIDTH_M = (i_EMEP-xp_EMEP)*GRIDWIDTH_M_EMEP + do i=1,GIMAXcdf + xcoord(i)=(i+ISMBEGcdf-1-xp)*GRIDWIDTH_M/GRIDWIDTH_M_EMEP + xp_EMEP_official +! print *, i,xcoord(i) + enddo + do j=1,GJMAXcdf + ycoord(j)=(j+JSMBEGcdf-1-yp)*GRIDWIDTH_M/GRIDWIDTH_M_EMEP + yp_EMEP_official +! print *, j,ycoord(j) + enddo + else + do i=1,GIMAXcdf + xcoord(i)=NF90_FILL_FLOAT + enddo + do j=1,GJMAXcdf + ycoord(j)=NF90_FILL_FLOAT + enddo + endif + call check(nf90_put_var(ncFileID, iEMEPVarID, xcoord(1:GIMAXcdf)) ) + call check(nf90_put_var(ncFileID, jEMEPVarID, ycoord(1:GJMAXcdf)) ) + +!Define longitude and latitude + call GlobalPosition !because this may not yet be done if old version of meteo is used + if(ISMBEGcdf+GIMAXcdf-1<=IIFULLDOM .and. JSMBEGcdf+GJMAXcdf-1<=JJFULLDOM)then + call check(nf90_put_var(ncFileID, latVarID, gb_glob(ISMBEGcdf:ISMBEGcdf+GIMAXcdf-1& + ,JSMBEGcdf:JSMBEGcdf+GJMAXcdf-1)) ) + call check(nf90_put_var(ncFileID, longVarID, gl_glob(ISMBEGcdf:ISMBEGcdf+GIMAXcdf-1& + ,JSMBEGcdf:JSMBEGcdf+GJMAXcdf-1)) ) + endif + + + elseif(UsedProjection=='lon lat') then + do i=1,GIMAXcdf + xcoord(i)= gl_glob(i+ISMBEGcdf-1,1) + enddo + do j=1,GJMAXcdf + ycoord(j)= gb_glob(1,j+JSMBEGcdf-1) + enddo + call check(nf90_put_var(ncFileID, iVarID, xcoord(1:GIMAXcdf)) ) + call check(nf90_put_var(ncFileID, jVarID, ycoord(1:GJMAXcdf)) ) + else + xcoord(1)=(ISMBEGcdf-0.5)*GRIDWIDTH_M/1000. + do i=2,GIMAXcdf + xcoord(i)=xcoord(i-1)+GRIDWIDTH_M/1000. +! print *, i,xcoord(i) + enddo + call check(nf90_put_var(ncFileID, iVarID, xcoord(1:GIMAXcdf)) ) + + ycoord(1)=(JSMBEGcdf-0.5)*GRIDWIDTH_M/1000. + do j=2,GJMAXcdf + ycoord(j)=ycoord(j-1)+GRIDWIDTH_M/1000. + enddo + call check(nf90_put_var(ncFileID, iVarID, xcoord(1:GIMAXcdf)) ) + call check(nf90_put_var(ncFileID, jVarID, ycoord(1:GJMAXcdf)) ) +! write(*,*)'coord written' + +!Define longitude and latitude + + if(ISMBEGcdf+GIMAXcdf-1<=IIFULLDOM .and. JSMBEGcdf+GJMAXcdf-1<=JJFULLDOM)then + call check(nf90_put_var(ncFileID, latVarID, gb_glob(ISMBEGcdf:ISMBEGcdf+GIMAXcdf-1& + ,JSMBEGcdf:JSMBEGcdf+GJMAXcdf-1)) ) + call check(nf90_put_var(ncFileID, longVarID, gl_glob(ISMBEGcdf:ISMBEGcdf+GIMAXcdf-1& + ,JSMBEGcdf:JSMBEGcdf+GJMAXcdf-1)) ) + endif + + endif +! write(*,*)'lon lat written' + +!Define vertical levels + if(KMAXcdf==KMAX_MID)then + do k=1,KMAX_MID + kcoord(k)=sigma_mid(k) + enddo + else + do k=1,KMAXcdf + kcoord(k)=sigma_mid(KMAX_MID-k+1) !REVERSE order of 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)) + + write(*,*)'file created' + +end subroutine CreatenetCDFfile + +!_______________________________________________________________________ + +subroutine Out_netCDF(iotyp,def1,ndim,kmax,dat,scale,CDFtype,ist,jst,ien,jen,ik,fileName_given) + + !The use of fileName_given is probably slower than the implicit filename used by defining iotyp. + + + integer ,intent(in) :: ndim,kmax + type(Deriv), intent(in) :: def1 ! definition of fields + integer, intent(in) :: iotyp + real ,intent(in) :: scale + !real, dimension(:,:,:,:), intent(in) :: dat ! Data arrays + 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. Only level ik is written if defined + integer, optional, intent(in) :: CDFtype != OUTtype. output type (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 + !NB if the file fileName_given exist (also from earlier runs) it will be appended + + character*18 :: varname + character*8 ::lastmodified_date + character*10 ::lastmodified_hour,lastmodified_hour0,created_hour + integer :: varID,new,nrecords,ncFileID=closedID + integer :: nyear,nmonth,nday,nhour,ndate(4) + integer :: info,d,alloc_err,ijk,itag,status,i,j,k,nseconds + integer :: i1,i2,j1,j2 + !real*4 :: buff + real :: buff(MAXLIMAX*MAXLJMAX*KMAX_MID) + real*8 , allocatable,dimension(:,:,:) :: R8data3D + real*4 , allocatable,dimension(:,:,:) :: R4data3D + integer*4, allocatable,dimension(:,:,:) :: Idata3D + integer :: OUTtype !local version of CDFtype + integer :: iotyp_new + integer :: iDimID,jDimID,kDimID,timeDimID,timeVarID + integer :: GIMAX_old,GJMAX_old,KMAX_old + integer :: GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf + integer :: is_leap, nseconds_time(1) + + + i1=1;i2=GIMAX;j1=1;j2=GJMAX !start and end of saved area + if(present(ist))i1=max(ist,i1) + if(present(ien))i2=min(ien,i2) + if(present(jst))j1=max(jst,j1) + if(present(jen))j2=min(jen,j2) + + !Check that that the area is larger than 0 + if((i2-i1)<0.or.(j2-j1)<0.or.kmax<=0)return + + !make variable name + write(varname,fmt='(A)')trim(def1%name) + + !to shorten the output we can save only the components explicitely named here + !if(varname.ne.'D2_NO2'.and.varname.ne.'D2_O3' & + ! .and.varname.ne.'D2_PM10')return + + !do not write 3D fields (in order to shorten outputs) + !if(ndim==3)return + + iotyp_new=0 + if(present(fileName_given))then + !NB if the file already exist (also from earlier runs) it will be appended + if(me==0)then + !try to open the file + status=nf90_open(path = trim(fileName_given), mode = nf90_write, ncid = ncFileID) + ISMBEGcdf=IRUNBEG+i1-1 + JSMBEGcdf=JRUNBEG+j1-1 + GIMAXcdf=i2-i1+1 + GJMAXcdf=j2-j1+1 + if(status /= nf90_noerr) then !the file does not exist yet + write(6,*) 'creating file: ',trim(fileName_given) + period_type = 'unknown' + call CreatenetCDFfile(trim(fileName_given),GIMAXcdf,GJMAXcdf,ISMBEGcdf,JSMBEGcdf,KMAX) + ncFileID=closedID + else !test if the defined dimensions are compatible + ! write(6,*) 'exists: ',trim(fileName_given) + 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(projection=='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 + 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 = "i", dimID = idimID)) +! call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "k", dimID = kdimID)) + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=idimID,len=GIMAX_old)) + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=jdimID,len=GJMAX_old)) + call check(nf90_inquire_dimension(ncid=ncFileID,dimID=kdimID,len=KMAX_old)) + + ! write(6,*)'existing file ', trim(fileName_given),' has dimensions' + ! write(6,*)GIMAX_old,GJMAX_old,KMAX_old + if(GIMAX_old0)then + !The new record may already exist + !use time as record reference, (instead of "numberofrecords") + call secondssince1970(ndate,nseconds,iotyp) + call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = timeVarID)) + call check(nf90_get_var(ncFileID, timeVarID, nseconds_time,start=(/ nrecords /))) + !check if this is a newer time + if((nseconds/=nseconds_time(1)))then + nrecords=nrecords+1 !start a new record + endif + else + !increase nrecords, to define position of new data + nrecords=nrecords+1 + endif + ! print *,'writing on dataset: ',nrecords + + !append new values + if(OUTtype==Int1 .or. OUTtype==Int2 .or. OUTtype==Int4)then + !type Integer + if(ndim==3)then + if(present(ik))then + ! print *, 'write: ',i1,i2, j1,j2,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 + endif + else + call check(nf90_put_var(ncFileID, VarID,& + Idata3D(i1:i2, j1:j2, 1), start = (/ 1, 1, nrecords /)) ) + endif + + deallocate(Idata3D, stat=alloc_err) + call CheckStop(alloc_err, "dealloc failed in NetCDF_ml") + + elseif(OUTtype==Real4)then + !type Real4 + if(ndim==3)then + if(present(ik))then + ! print *, 'write: ',i1,i2, j1,j2,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 + endif + else + call check(nf90_put_var(ncFileID, VarID,& + R4data3D(i1:i2, j1:j2, 1), start = (/ 1, 1, nrecords /)) ) + endif + + deallocate(R4data3D, stat=alloc_err) + call CheckStop(alloc_err, "dealloc failed in NetCDF_ml") + + else + !type Real8 + if(ndim==3)then + if(present(ik))then + ! print *, 'write: ',i1,i2, j1,j2,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 + endif + else + call check(nf90_put_var(ncFileID, VarID,& + R8data3D(i1:i2, j1:j2, 1), start = (/ 1, 1, nrecords /)) ) + endif + + deallocate(R8data3D, stat=alloc_err) + call CheckStop(alloc_err, "dealloc failed in NetCDF_ml") + + endif !type + + + call check(nf90_get_att(ncFileID, nf90_global, "lastmodified_hour", lastmodified_hour0 )) + call check(nf90_get_att(ncFileID, nf90_global, "created_hour", created_hour )) + call Date_And_Time(date=lastmodified_date,time=lastmodified_hour) + ! print *, 'date now: ',lastmodified_hour,' date before ',lastmodified_hour0,' date start ', created_hour + + !write or change attributes NB: strings must be of same length as originally + + call check(nf90_put_att(ncFileID, VarID, "numberofrecords", nrecords)) + + !update dates + call check(nf90_put_att(ncFileID, nf90_global, "lastmodified_date", lastmodified_date)) + call check(nf90_put_att(ncFileID, nf90_global, "lastmodified_hour", lastmodified_hour)) + call check(nf90_put_att(ncFileID, VarID, "current_date_last",ndate )) + + !get variable id + call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = VarID)) + call secondssince1970(ndate,nseconds,iotyp)!middle of period: !NB WORKS ONLY FOR COMPLETE PERIODS + + + + call check(nf90_put_var(ncFileID, VarID, nseconds, start = (/nrecords/) ) ) + + !close file if present(fileName_given) + if(iotyp_new==1)then + call check(nf90_close(ncFileID)) + endif + endif !me=0 + + return +end subroutine Out_netCDF + +!_______________________________________________________________________ + + +subroutine createnewvariable(ncFileID,varname,ndim,ndate,def1,OUTtype) + + !create new netCDF variable + + implicit none + + type(Deriv), intent(in) :: def1 ! definition of fields + character (len = *),intent(in) ::varname + integer ,intent(in) ::ndim,ncFileID,OUTtype + integer, dimension(:) ,intent(in) :: ndate + + integer :: iDimID,jDimID,kDimID,timeDimID + integer :: varID,nrecords + real :: scale + integer :: OUTtypeCDF !NetCDF code for type + character (len = 50) ::tmpstring + + if(OUTtype==Int1)then + OUTtypeCDF=nf90_byte + elseif(OUTtype==Int2)then + OUTtypeCDF=nf90_short + elseif(OUTtype==Int4)then + OUTtypeCDF=nf90_int + elseif(OUTtype==Real4)then + OUTtypeCDF=nf90_float + elseif(OUTtype==Real8)then + OUTtypeCDF=nf90_double + else + call CheckStop("NetCDF_ml:undefined datatype") + endif + + call check(nf90_redef(ncid = ncFileID)) + + !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(projection=='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 + 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)) + + !define new variable + if(ndim==3)then + call check(nf90_def_var(ncid = ncFileID, name = varname, xtype = OUTtypeCDF, & + dimids = (/ iDimID, jDimID, kDimID , timeDimID/), varID=varID ) ) + elseif(ndim==2)then + call check(nf90_def_var(ncid = ncFileID, name = varname, xtype = OUTtypeCDF, & + dimids = (/ iDimID, jDimID , timeDimID/), varID=varID ) ) + else + print *, 'createnewvariable: unexpected ndim ',ndim + endif +! FillValue=0. + scale=1. + !define attributes of new variable + call check(nf90_put_att(ncFileID, varID, "long_name", def1%name )) + call check(nf90_put_att(ncFileID, varID, "coordinates", "lat lon")) + if(trim(projection)=='Stereographic')then + call check(nf90_put_att(ncFileID, varID, "grid_mapping", "Polar_Stereographic")) + elseif(projection=='lon lat') then + + else + call check(nf90_put_att(ncFileID, varID, "grid_mapping",Default_projection_name )) + endif + + nrecords=0 + call check(nf90_put_att(ncFileID, varID, "numberofrecords", nrecords)) + + call check(nf90_put_att(ncFileID, varID, "units", def1%unit)) + call check(nf90_put_att(ncFileID, varID, "class", def1%class)) + + if(OUTtype==Int1)then + call check(nf90_put_att(ncFileID, varID, "_FillValue", nf90_fill_byte )) + call check(nf90_put_att(ncFileID, varID, "scale_factor", scale )) + elseif(OUTtype==Int2)then + call check(nf90_put_att(ncFileID, varID, "_FillValue", nf90_fill_short )) + call check(nf90_put_att(ncFileID, varID, "scale_factor", scale )) + elseif(OUTtype==Int4)then + call check(nf90_put_att(ncFileID, varID, "_FillValue", nf90_fill_int )) + call check(nf90_put_att(ncFileID, varID, "scale_factor", scale )) + elseif(OUTtype==Real4)then + call check(nf90_put_att(ncFileID, varID, "_FillValue", nf90_fill_float )) + elseif(OUTtype==Real8)then + call check(nf90_put_att(ncFileID, varID, "_FillValue", nf90_fill_double )) + endif +! call check(nf90_put_att(ncFileID, varID, "periodlength", "yearly")) + +!25/10/2005 call check(nf90_put_att(ncFileID, varID, "xfelt_ident",ident )) + call check(nf90_put_att(ncFileID, varID, "current_date_first",ndate )) + call check(nf90_put_att(ncFileID, varID, "current_date_last",ndate )) + + call check(nf90_enddef(ncid = ncFileID)) + +end subroutine createnewvariable +!_______________________________________________________________________ + + subroutine check(status) + implicit none + integer, intent ( in) :: status + + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + call CheckStop("NetCDF_ml : error in netcdf routine") + end if + end subroutine check + + subroutine CloseNetCDF +!close open files +!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. + +use Par_ml, only : me + +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 + + subroutine secondssince1970(ndate,nseconds,iotyp) + !calculate how many seconds have passed since the start of the year 1970 + + + integer, intent(in) :: ndate(4) + integer, intent(out) :: nseconds + integer, optional, intent(in):: iotyp + integer :: n,nday,is_leap + + nday=0 + do n=1,ndate(2)-1 + nday=nday+nmdays(n) + enddo + nday=nday+ndate(3) + + nseconds=3600*(ndate(4)+24*(nday-1)) + +!add seconds from each year since 1970 + do n=1970,ndate(1)-1 + is_leap=0 + if (leapyear(n))is_leap=1 + nseconds=nseconds+24*3600*365+24*3600*is_leap + enddo + + if(present(iotyp))then + !middle of period: !NB WORKS ONLY FOR COMPLETE PERIODS + is_leap=0 + if (leapyear(ndate(1)-1))is_leap=1 + if(iotyp==IOU_YEAR)then + !take end of run date + nseconds=nseconds +! nseconds=nseconds-43200*365-43200*is_leap + elseif(iotyp==IOU_MON)then + nseconds=nseconds-43200*nmdays(max(ndate(2)-1,1))!nmdays(jan)=nmdays(dec) + elseif(iotyp==IOU_DAY)then + nseconds=nseconds-43200 !24*3600/2=43200 + elseif(iotyp==IOU_HOUR)then + nseconds=nseconds-1800*FREQ_HOURLY !1800=half hour + elseif(iotyp==IOU_INST)then + nseconds=nseconds + else + nseconds=nseconds + endif + endif + end subroutine secondssince1970 + + +subroutine GetCDF(varname,fileName,var,varGIMAX,varGJMAX,varKMAX,nstart,nfetch,needed) + ! + ! open and reads CDF file + ! + ! The nf90 are functions which return 0 if no error occur. + ! check is only a subroutine which check wether the function returns zero + ! + ! + + character (len=*),intent(in) :: fileName + + character (len = *),intent(in) ::varname + integer, intent(in) :: nstart,varGIMAX,varGJMAX,varKMAX + integer, intent(inout) :: nfetch + real, dimension(*),intent(out) :: var + logical, optional,intent(in) :: needed +! real, dimension(varGIMAX*varGJMAX*varKMAX*NFETCH),intent(out) :: var +! real, dimension(132,111,Nrec),intent(out) :: var + + + logical :: fileneeded + integer :: GIMAX,GJMAX,KMAX_MID,nrecords,period + integer :: status,ndims,alloc_err + integer :: n,KMAX,Nrec,ijn,ijkn,timeVarID + integer :: ncFileID,iDimID,jDimID,kDimID,timeDimID,VarID,iVarID,jVarID,kVarID,i,j,k + integer :: var_date(9000),ndate(4) + real , allocatable,dimension(:,:,:,:) :: values + real ::depsum + character*20::attribute,attribute2 + +! Nrec=size(var,3) + + print *,' reading ',trim(fileName) + !open an existing netcdf dataset + fileneeded=.true.!default + if(present(needed))then + fileneeded=needed + endif + + if(fileneeded)then + call check(nf90_open(path = trim(fileName), mode = nf90_nowrite, ncid = ncFileID)) + else + status=nf90_open(path = trim(fileName), mode = nf90_nowrite, ncid = ncFileID) + if(status/= nf90_noerr)then + write(*,*)trim(fileName),' not found (but not needed)' + nfetch=0 + return + endif + endif + + !get global attributes + + !example: +! call check(nf90_get_att(ncFileID, nf90_global, "lastmodified_hour", attribute )) +! call check(nf90_get_att(ncFileID, nf90_global, "lastmodified_date", attribute2 )) +! print *,'file last modified (yyyymmdd hhmmss.sss) ',attribute2,' ',attribute + + !test if the variable is defined and get varID: + status = nf90_inq_varid(ncid = ncFileID, name = varname, varID = VarID) + + if(status == nf90_noerr) then + print *, 'variable exists: ',trim(varname) + else + print *, 'variable does not exist: ',trim(varname),nf90_strerror(status) + nfetch=0 + call CheckStop(fileneeded, "NetCDF_ml : variable needed but not found") + return + endif + + !get dimensions id + status=nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID) + if(status /= nf90_noerr) then + call check(nf90_inq_dimid(ncid = ncFileID, name = "lon", dimID = idimID)) + endif + status=nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID) + if(status /= nf90_noerr) then + call check(nf90_inq_dimid(ncid = ncFileID, name = "lat", dimID = jdimID)) + endif +! call check(nf90_inq_dimid(ncid = ncFileID, name = "i", dimID = idimID)) +! call check(nf90_inq_dimid(ncid = ncFileID, name = "j", dimID = jdimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "k", dimID = kdimID)) + call check(nf90_inq_dimid(ncid = ncFileID, name = "time", dimID = timeDimID)) + + !get dimensions length + call check(nf90_inquire_dimension(ncid=ncFileID, dimID=idimID, len=GIMAX)) + call check(nf90_inquire_dimension(ncid=ncFileID, dimID=jdimID, len=GJMAX)) + call check(nf90_inquire_dimension(ncid=ncFileID, dimID=kdimID, len=KMAX_MID)) + call check(nf90_inquire_dimension(ncid=ncFileID, dimID=timedimID, len=nrecords)) + Nrec=nrecords + + print *, 'dimensions ',GIMAX,GJMAX,KMAX_MID,nrecords + if(GIMAX>varGIMAX.or.GJMAX>varGJMAX)then + write(*,*)'buffer too small',GIMAX,varGIMAX,GJMAX,varGJMAX + stop + endif + + ndims=4 + if(KMAX_MID==1)ndims=3 + !get variable info +! call check(nf90_inquire_variable(ncFileID, varID, ndims=ndims)) +! print *, 'dimensions ',ndims + if(KMAX_MID>varKMAX)then + write(*,*)'Warning: not reading all levels ',KMAX_MID,varKMAX +! stop + endif + + if(nstart+nfetch-1>nrecords)then + write(*,*)'WARNING: did not find all data' + nfetch=nrecords-nstart+1 + if(nfetch<=0)stop + endif +! if(nfetch>Nrec)then +! write(*,*)'buffer too small. Increase last dimension',nfetch,Nrec +! stop +! endif + if(ndims==3)then + kmax=1 + !allocate a 2D array + allocate(values(GIMAX,GJMAX,nfetch,1), stat=alloc_err) + if ( alloc_err /= 0 ) then + print *, 'alloc failed in ReadCDF_ml: ',alloc_err,ndims + stop + endif + elseif(ndims==4)then + kmax=KMAX_MID + !allocate a 3D array + allocate(values(GIMAX,GJMAX,KMAX_MID,nfetch), stat=alloc_err) + if ( alloc_err /= 0 ) then + print *, 'alloc failed in ReadCDF_ml: ',alloc_err,ndims + stop + endif + + else + print *, 'unexpected number of dimensions: ',ndims + stop + endif + + !get variable attributes + !example: + attribute='' +! call check(nf90_get_att(ncFileID, VarID, "long_name", attribute)) +! print *,'long_name ',attribute + +! call check(nf90_get_att(ncFileID, VarID, "xfelt_ident", xfelt_ident)) + + !get time variable + call check(nf90_inq_varid(ncid = ncFileID, name = "time", varID = timeVarID)) + call check(nf90_get_var(ncFileID, timeVarID, var_date,start=(/ nstart /),count=(/ nfetch /))) + + !get variable + if(ndims==3)then + ! call check(nf90_get_var(ncFileID, VarID, values,start=(/ 1, 1, nstart /),count=(/ 1, 1, nfetch /))) + call check(nf90_get_var(ncFileID, VarID, values,start=(/ 1, 1, nstart /),count=(/ GIMAX,GJMAX,nfetch /))) + elseif(ndims==4)then + call check(nf90_get_var(ncFileID, VarID, values,start=(/1,1,1,nstart/),count=(/GIMAX,GJMAX,KMAX_MID,nfetch /))) + endif + if(Nfetch +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 + ! + ! DUMMY module for now, as the SOA part of the EMEP model is still + ! in research phase, and changes quite frequently. The + ! Calculates the amount of condensible species in the gas and aerosol + ! phases. + ! + ! When implemented, we use the + ! methodology from Andersson-Sk\"old and Simpson, 2000, Secondary Organic + ! Aerosol Formation in Northern Europe: a Model Study, J. Geophys. Res + ! 106(D7), 7357-7374, and + ! Simpson,D., Yttri, K.E.,Klimont, Z. ,Kupiainen, K.,Caseiro, A., + ! Gelencser, A.,Pio, C.,Legrand, M. ,Yttri, K.E., Modeling Carbonaceous + ! Aerosol over Europe. Analysis of the CARBOSOL and EMEP EC/OC campaigns, + ! J. Geophys. Res., 112, D23S14, doi:10.1029/2006JD008158. + ! + ! Usage: call OrganicAerosol from Runchem, after setup of 1d-fields + ! finished. The subroutine initialises itself on the first call + ! and thereafter modifies two external variables: + ! xn(SOA,k) : the concentrations of SOA + ! Fgas(X,k) : The fraction of X which is gas and not aeorosl + ! + ! Dave Simpson, August 2001 - 2007 + !-------------------------------------------------------------------------- + use ModelConstants_ml, only : CHEMTMIN, CHEMTMAX, & + K2 => KMAX_MID, K1 => KCHEMTOP + use PhysicalConstants_ml, only : AVOG + use Setup_1dfields_ml, only : itemp, xn => xn_2d + use GenChemicals_ml, only : species ! for molwts + use GenSpec_tot_ml, A1 => FIRST_SOA , A2 => LAST_SOA + implicit none + + !/-- subroutines + public :: OrganicAerosol + + + !/-- public + real, public, dimension(A1:A2,K1:K2), save :: Fgas ! Fraction in gas-phase + + contains + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + !+ Driver routine for Secondary Organic Aerosol module + + subroutine OrganicAerosol(debug_flag) + logical, intent(in) :: debug_flag ! for debugging purposes only + + ! empty + + end subroutine OrganicAerosol + +end module OrganicAerosol_ml +!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx diff --git a/OutputChem_ml.f90 b/OutputChem_ml.f90 new file mode 100644 index 0000000..64177f1 --- /dev/null +++ b/OutputChem_ml.f90 @@ -0,0 +1,354 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module OutputChem_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + use CheckStop_ml, only: CheckStop + use Derived_ml, only: IOU_INST, IOU_YEAR, IOU_MON, IOU_DAY, & + f_2d, d_2d, LENOUT2D & + ,f_3d, d_3d, nav_3d, nav_2d, LENOUT3D & + , num_deriv2d, num_deriv3d & + ,ResetDerived, Deriv + use My_Outputs_ml, only: NBDATES, wanted_dates_inst, & + Ascii3D_WANTED + use Io_ml, only: IO_WRTCHEM + use ModelConstants_ml, only: nprint, END_OF_EMEPDAY, KMAX_MID + use NetCDF_ml, only: CloseNetCDF, Out_netCDF + use Par_ml, only: MAXLIMAX,MAXLJMAX,GIMAX,GJMAX,me, & + IRUNBEG,JRUNBEG + use TimeDate_ml , only: current_date, max_day ! days in month + + implicit none + + !/* subroutines: + + public :: Wrtchem + public :: Output_fields ! (iotyp) + public :: Output_f2d ! (iotyp, dim, nav, def, dat) + public :: Output_f3d ! (iotyp, dim, nav, def, dat) + + logical, private, parameter :: MY_DEBUG = .false. + + contains + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine Wrtchem(numt) + + !--------------------------------------------------------------------- + ! DESCRIPTION: + ! Writes out data fields as NetCDF + ! + ! END_OF_EMEPDAY = 6am, i.g. EMEP sampling period from 6am to 6am + ! Daily outputs for "EMEP" days (which end between 0 and 6am) are + ! dated by the date of sampling start, i.e. date of the previous day. + ! + ! Thus, the first output should occur just as Jan 2nd starts (e.g. + ! at 6am on 2nd Jan); logical Jan_1st helps dealing with this and + ! it also marks end of a year run. + ! (For runs starting in other months, one partial write-out will + ! occur at 6am of the 1st day, but this should be over-written + ! as soon as a full day of data is available). + !---------------------------------------------------------------------- + + + integer, intent(in) :: numt + + real, dimension(MAXLIMAX, MAXLJMAX) :: local_2d !local 2D array + real, dimension(GIMAX, GJMAX) :: glob_2d !array for whole domain + integer :: i,j,n,k,icmp,msnr1 + integer :: nyear,nmonth,nday,nhour,nmonpr + integer :: mm_out, dd_out + logical :: Jan_1st, End_of_Run + real :: scale + character*30 outfilename + !------------------------------ + + nyear = current_date%year + nmonth = current_date%month + nday = current_date%day + nhour = current_date%hour + + dd_out = nday + mm_out = nmonth + Jan_1st = ( nmonth == 1 .and. nday == 1 ) + End_of_Run = ( mod(numt,nprint) == 0 ) + + if(me==0 .and. MY_DEBUG) write(6,"(a12,i5,5i4)") "DAILY DD_OUT ", & + numt, nmonth, mm_out, nday, dd_out, nhour + + + if ( END_OF_EMEPDAY <= 7 ) then + + !. END_OF_EMEPDAY = 6am - end of EMEP daily sampling period + !. Daily outputs are dated with the start of sampling period + + dd_out = nday - 1 ! only used for daily outputs + + if(me==0 .and. MY_DEBUG) write(6,"(a12,i5,5i4)") "DAILY SET ", & + numt, nmonth, mm_out, nday, dd_out, nhour + + if(dd_out == 0) then + mm_out = nmonth - 1 + + if(nmonth == 1) mm_out = 12 + + dd_out = max_day(mm_out, nyear) ! Last day of month + + if(me==0 .and. MY_DEBUG) write(6,"(a12,i5,4i4)") "DAILY FIX ", & + numt, nmonth, mm_out, nday, dd_out + end if + end if ! for END_OF_EMEPDAY <= 7 + + + !== Instantaneous results output ==== + ! Possible actual array output for specified days and hours + ! is defined in wanted_dates_bi array in My_Outputs + + do n = 1, NBDATES + if ( wanted_dates_inst(n)%month == nmonth .and. & + wanted_dates_inst(n)%day == nday .and. & + wanted_dates_inst(n)%hour == nhour ) then + + call Output_fields(IOU_INST) + + end if + end do + + + !== Daily output ==== + + if (nhour == END_OF_EMEPDAY ) then + + if ( numt > 1 .and. .not. Jan_1st ) then ! Doesn't write out 1 Jan. + + call Output_fields(IOU_DAY) + + end if + + call ResetDerived(IOU_DAY) ! For daily averaging, reset also 1 Jan. + + end if + + !== Output at the end of the run + + if ( End_of_Run ) then + + call Output_fields(IOU_DAY) ! Daily outputs + call Output_fields(IOU_YEAR) ! Yearly outputs + + end if + + + !/ NEW MONTH + + if (nday == 1 .and. nhour == 0) then + nmonpr = nmonth-1 + + if (nmonpr.eq.0) nmonpr=12 + + !== Monthly output ==== + + call Output_fields(IOU_MON) + + !== ASCII output of 3D fields (if wanted) + + if(Ascii3D_WANTED) then + + if (num_deriv3d > 0) then + msnr1 = 2000 + + do n = 1, num_deriv3d + + if( me == 0 ) then + + write(outfilename,fmt='(a,a5,i2.2)') & + trim( f_3d(n)%name ), ".out.", nmonpr + open (IO_WRTCHEM,file=outfilename) + write(IO_WRTCHEM,fmt="(4i4)") IRUNBEG, GIMAX+IRUNBEG-1, & + JRUNBEG, GJMAX+JRUNBEG-1 ! domain + end if + + if (nav_3d(n,IOU_MON) == 0 ) then + write(IO_WRTCHEM,*) "ERROR in 3D ASCII output: nav=0" + else + + do k = 1, KMAX_MID + + local_2d(:,:) = d_3d(n,:,:,k,IOU_MON)/nav_3d(n,IOU_MON) + call local2global(local_2d,glob_2d,msnr1) + + if (me == 0) then + do j=1,GJMAX + do i=1,GIMAX + write(IO_WRTCHEM,"(es10.3)") glob_2d(i,j) + end do + end do + end if ! me loop + + end do ! k + end if ! nav == 0 + + if( me == 0 ) close(IO_WRTCHEM) + + end do ! 3D-variables loop num_deriv3d + end if + + endif ! Ascii3D_WANTED + + call ResetDerived(IOU_MON) + + endif ! End of NEW MONTH + + end subroutine Wrtchem + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine Output_fields(iotyp) + + integer, intent(in) :: 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) + + + + !*** 3D concentration fields, e.g. O3 + !-------------------- + + if(num_deriv3d > 0) call Output_f3d(iotyp,num_deriv3d,nav_3d,f_3d,d_3d) + + call CloseNetCDF + + end subroutine Output_fields + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine Output_f2d (iotyp, dim, nav, def, dat) + + !========================================= + ! Sends fields to NetCDF output routines + !========================================= + + integer, intent(in) :: iotyp + integer, intent(in) :: dim ! No. fields + 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 :: wanted ! Set true for required year, month, day or inst. + integer :: icmp ! component index + real :: scale ! Scaling factor + !-------------------------------------- + + do icmp = 1, dim + + wanted = .false. + if( iotyp == IOU_YEAR) wanted = def(icmp)%year + if( iotyp == IOU_MON ) wanted = def(icmp)%month + if( iotyp == IOU_DAY ) wanted = def(icmp)%day + if( iotyp == IOU_INST) wanted = def(icmp)%inst + + if ( wanted ) then + + scale = def(icmp)%scale + if (iotyp /= IOU_INST ) & + scale = scale / max(1,nav(icmp,iotyp)) + + call Out_netCDF(iotyp,def(icmp),2,1,dat(icmp,:,:,iotyp),scale) + + endif ! wanted + enddo ! component loop + + end subroutine Output_f2d + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + subroutine Output_f3d (iotyp, dim, nav, def, dat) + + !========================================= + ! Sends fields to NetCDF output routines + !========================================= + + use Derived_ml, only: IOU_INST, IOU_YEAR, IOU_MON, IOU_DAY, & + Deriv,LENOUT3D + use ModelConstants_ml, only: KMAX_MID + use NetCDF_ml, only: Out_netCDF + use Par_ml, only: MAXLIMAX, MAXLJMAX + + + implicit none + + integer, intent(in) :: iotyp + integer, intent(in) :: dim ! No. fields + 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 :: wanted ! Set true for required year, month, day or inst. + integer :: icmp ! component index + real :: scale ! Scaling factor + !------------------------------------------------ + + do icmp = 1, dim + + wanted = .false. + if( iotyp == IOU_YEAR) wanted = def(icmp)%year + if( iotyp == IOU_MON ) wanted = def(icmp)%month + if( iotyp == IOU_DAY ) wanted = def(icmp)%day + if( iotyp == IOU_INST) wanted = def(icmp)%inst + + if ( wanted ) then + + 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) + + endif ! wanted + enddo ! component loop + + end subroutine Output_f3d + + end module OutputChem_ml diff --git a/Output_hourly.f90 b/Output_hourly.f90 new file mode 100644 index 0000000..d207683 --- /dev/null +++ b/Output_hourly.f90 @@ -0,0 +1,420 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!*********************************************************************** + subroutine hourly_out() !! spec,ofmt,ix1,ix2,iy1,iy2,unitfac) +!*********************************************************************** +!** DESCRIPTION: +! Calculates and +! Outputs hourly concentration (or met) values for a sub-set of the grid. +! +!** REVISION HISTORY: +! Extended to produce new file, Hourly.mmyy, every month, 10/5/01 ds +! stop_test used instead of stop_all, su, 05/01 +! Extended for variable format, met, xn_adv or xn_shl, ds, and to use +! Asc2D type 19/4/01 +! Corrected for IRUNBEG, etc., su, 4/01 +! New, ds, 5/3/99 +! +!************************************************************************* +! + use My_Outputs_ml, only : NHOURLY_OUT, & ! No. outputs + NLEVELS_HOURLY, & ! ds rv1_8_2 + FREQ_HOURLY, & ! No. hours between outputs + Asc2D, hr_out, & ! Required outputs + Hourly_ASCII ! ASCII output or not + + use CheckStop_ml, only : CheckStop + use Chemfields_ml , only : xn_adv,xn_shl, cfac + use Derived_ml, only : d_2d, IOU_INST,IOU_HOUR,Deriv + use GenSpec_shl_ml , only : NSPEC_SHL ! Maps indices + use GenChemicals_ml , only : species ! Gives names + use GridValues_ml, only : i_fdom, j_fdom ! Gives emep coordinates + use Io_ml, only : IO_HOURLY + use ModelConstants_ml,only : NPROC,KMAX_MID,DEBUG_i,DEBUG_j,identi,runlabel1 + use Met_ml, only : t2_nwp,th, roa, surface_precip, & + Idirect, Idiffuse + use NetCDF_ml, only : Out_netCDF,Init_new_netCDF & + ,Int1,Int2,Int4,Real4,Real8 !Output data type to choose + use Par_ml , only : MAXLIMAX,MAXLJMAX,GIMAX,GJMAX & + ,li0,li1,lj0,lj1 & + ,me,IRUNBEG,JRUNBEG,limax,ljmax + use TimeDate_ml ,only : current_date + + implicit none + + !*.. Components of hr_out + !* character(len=3) :: type ! "ADVp" or "ADVu" or "SHL" or "T2 " + !* integer :: spec ! Species number in xn_adv or xn_shl array + !* character(len=12) :: ofmt ! Output format (e.g. es12.4) + !* integer :: ix1 ! bottom-left x + !* integer :: iy1 ! bottom-left y + !* integer :: ix2 ! upper-right x + !* integer :: iy2 ! upper-right y + !* real :: unitconv ! conv. factor + !* real :: max ! max allowed value + + ! local variables + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + 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) + real :: arrmax ! Maximum value from array + 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 :: ik ! Index for vertical level + integer ist,ien,jst,jen ! start and end coords + character(len=50) :: errmsg = "ok" ! For consistecny check + character(len=20) :: name ! For output file, species names + character(len=120) :: netCDFName ! For netCDF output filename + character(len=4) :: suffix ! For date "mmyy" + integer, save :: prev_month = -99 ! Initialise with non-possible month + logical, parameter :: DEBUG = .false. + integer :: NLEVELS_HOURLYih + type(Deriv) :: def1 !for NetCDF + real :: scale !for NetCDF + integer ::CDFtype,nk,klevel!for NetCDF + + if ( my_first_call ) then + + !/ 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) + + end do ! 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 + end if + end do + end do + end if ! DEBUG + my_first_call = .false. + end if ! first_call + + ! hourly(:,:) = 0.0 ! Initialise (ljmax+1:MAXLJMAX, limax+1:LIMAX + ! ! would have done, but this is simpler) + ! else + ! Mask the edges of the hourly array, so that we can use maxval later + ! This makes the code a bit neater below, but costs some CPU time here, + ! and in evaluating maxval over the whole MAXLIMAX*MAXLJMAX dimension. + + !u7.5vg FIX hourly(limax+1:MAXLIMAX,:) = 0.0 + !u7.5vg FIX hourly(1:limax,ljmax+1:MAXLJMAX) = 0.0 + + hourly(:,:) = 0.0 + + !end if ! first_call + + if(me == 0 .and. current_date%month /= prev_month ) then + + if ( prev_month > 0 .and. Hourly_ASCII) close(IO_HOURLY) ! Close last-months file + + !/.. Open new file for write-out + + write(suffix,fmt="(2i2.2)") current_date%month, & + modulo ( current_date%year, 100 ) + if(Hourly_ASCII)then + name = "Hourly" // "." // suffix + open(file=name,unit=IO_HOURLY,action="write") + endif + + prev_month = current_date%month + +! netCDFName =trim(runlabel1)//"_hour" // "."// suffix // ".nc" +! call Init_new_netCDF(netCDFName,IOU_HOUR) + + if(Hourly_ASCII)then + !ds rv1.6.2: Write summary of outputs to top of Hourly file + ! - remember - with corrected domain limits here + write(IO_HOURLY,*) NHOURLY_OUT, " Outputs" + write(IO_HOURLY,*) FREQ_HOURLY, " Hours betwen outputs" + write(IO_HOURLY,*) NLEVELS_HOURLY, "Max Level(s)" !ds rv1_8_2 + + do ih = 1, NHOURLY_OUT + write(IO_HOURLY,fmt="(a12,a8,a10,i4,5i4,a13,es12.5,es10.3)") hr_out(ih) + end do + endif !Hourly_ASCII + end if + + +!......... Uses concentration/met arrays from Chem_ml or Met_ml .................. +! +! real xn_adv(NSPEC_ADV,MAXLIMAX,MAXLJMAX,KMAX_MID) +! real cfac(NSPEC_ADV,MAXLIMAX,MAXLJMAX) +! or... +! real xn_shl(NSPEC_ADV,MAXLIMAX,MAXLJMAX,KMAX_MID) +! or... +! real temp2m(MAXLIMAX,MAXLJMAX) +! +!.......................................................................... + + + HLOOP: do ih = 1, NHOURLY_OUT + NLEVELS_HOURLYih=hr_out(ih)%nk + KVLOOP: do ik = KMAX_MID, KMAX_MID-NLEVELS_HOURLYih+1, -1 + + msnr = 3475 + ih + ispec = hr_out(ih)%spec + name = hr_out(ih)%name !ds rv1.6.1 + if ( DEBUG .and. debug_flag ) print *, "DEBUG OH ", me, ispec, name, & + hr_out(ih)%type + + if(DEBUG .and. debug_flag ) print *, "INTO HOUR TYPE ",hr_out(ih)%type + + !---------------------------------------------------------------- + ! Multi-layer output. + ! Specify NLEVELS_HOURLY here, and in hr_out defs use either: + ! + ! ADVppbv to get surface concentrations (onyl relevant for + ! layer k=20 of course - gives meaningless number f + ! or higher levels. + ! Or, + ! BCVppbv to get grid-centre concentrations (relevant for + ! all layers. + !---------------------------------------------------------------- + + + OPTIONS: select case ( hr_out(ih)%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. + 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 *, "K-level", ik, name, itot + + case ( "ADVugm3" ) + itot = NSPEC_SHL + ispec + name = species(itot)%name + unit_conv = hr_out(ih)%unitconv * species(itot)%molwt + 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 ( "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 short-lived species + 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 short-lived species + 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 short-lived species + 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" ) ! No cfac for short-lived species + + forall ( i=1:limax, j=1:ljmax) + hourly(i,j) = d_2d(ispec,i,j,IOU_INST) * hr_out(ih)%unitconv + end forall + + if( DEBUG .and. debug_flag) & + write(6,"(a12,2i3,2es12.3)") "HHH DEBUG", ispec, ih, & + hr_out(ih)%unitconv, hourly(i_debug,j_debug) + + case DEFAULT + errmsg = "ERROR-DEF! Hourly_out: " // hr_out(ih)%type + call CheckStop( errmsg // "hourly type not found!") + + end select 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 + end if + + + !ds rv1.6.2 ---- why needed? + hourly(limax+1:MAXLIMAX,:) = 0.0 + hourly(1:limax,ljmax+1:MAXLJMAX) = 0.0 + + !/ Get maximum value of hourly array + + arrmax = maxval(hourly) + if ( arrmax > hr_out(ih)%max ) then + write(6,*) "Hourly value too big!: ", ih, hr_out(ih)%type, arrmax + write(6,*) "Species : ", 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, & + 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 == "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 + + call CheckStop("Error, Output_hourly/hourly_out: too big!") + + endif + +!NetCDF hourly output + def1%name=hr_out(ih)%name + def1%unit=hr_out(ih)%unit + def1%class=hr_out(ih)%type + ist = max(1,hr_out(ih)%ix1-IRUNBEG+1) + jst = max(1,hr_out(ih)%iy1-JRUNBEG+1) + ien = min(GIMAX,hr_out(ih)%ix2-IRUNBEG+1) + jen = min(GJMAX,hr_out(ih)%iy2-JRUNBEG+1) + nk = min(KMAX_MID,hr_out(ih)%nk) + CDFtype=Real4 ! can be choosen as Int1,Int2,Int4,Real4 or Real8 + scale=1. + + if (nk == 1) then !write as 2D + call Out_netCDF(IOU_HOUR,def1,2 & + ,1,hourly(:,:),scale,CDFtype,ist,jst,ien,jen) + + else if( nk > 1 ) then !write as 3D + !CHANGED 23 Mar 2007 klevel=KMAX_MID-ik+1 + klevel=ik + call Out_netCDF(IOU_HOUR,def1,3 & + ,1,hourly(:,:),scale,CDFtype,ist,jst,ien,jen,klevel) + !else nk<1 : no output + endif + + if(Hourly_ASCII)then + + !/ Send to ghourly + + call local2global(hourly,ghourly,msnr) + + if (me == 0) then + + !.... write out for a sub-section of the grid: + + !/** We need to correct for small run-domains and the asked-for + ! output domain. We can only print out the intersection of + ! these two rectangles. + + !ds!/ In emep coordinates we have: + + !dsist = max(IRUNBEG,hr_out(ih)%ix1) + !dsjst = max(JRUNBEG,hr_out(ih)%iy1) + !dsien = min(GIMAX+IRUNBEG-1,hr_out(ih)%ix2) + !dsjen = min(GJMAX+JRUNBEG-1,hr_out(ih)%iy2) + + !ds rv1_8_2 Extra info: + write(IO_HOURLY,"('Spec ',i3,' Var ',i2,' = ',2a12,'Lev: ',i2,' Date:',i5,3i3)") & + ispec, ih, name, hr_out(ih)%name & + ,ik & ! ds rv1_8_2 + ,current_date%year,current_date%month,current_date%day & + ,current_date%hour !ds & + !ds ,ist, ien, jst, jen, & + !ds unit_conv + + if ( DEBUG .and. debug_flag ) print *, "TTTHOUR ISTS", me, ist, ien, jst, jen + + !/ In model coordinates we have: + + ist = max(1,hr_out(ih)%ix1-IRUNBEG+1) + jst = max(1,hr_out(ih)%iy1-JRUNBEG+1) + ien = min(GIMAX,hr_out(ih)%ix2-IRUNBEG+1) + jen = min(GJMAX,hr_out(ih)%iy2-JRUNBEG+1) + + do i = ist,ien + do j = jst,jen + + g = ghourly(i,j) + if ( g /= 0.0 ) then + write(IO_HOURLY, fmt=hr_out(ih)%ofmt ) g + else ! Save disc-space used by thousands of 0.00000 + write(IO_HOURLY, fmt="(i1)" ) 0 + end if + + end do ! j + end do ! i + + end if ! me loop + + endif !Hourly_ASCII + + end do KVLOOP + end do HLOOP + + end subroutine hourly_out diff --git a/Par_ml.f90 b/Par_ml.f90 new file mode 100644 index 0000000..2e035e1 --- /dev/null +++ b/Par_ml.f90 @@ -0,0 +1,383 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +! -*- f90 -*- + module Par_ml + +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! Define parameters and variables specific to each node and +! the parallel data decomposition. +! +!---------------------------------------------------------------------------- +! Erik Berge, DNMI Roar Skaalin, SINTEF Industrial Mathematics +! Modified to use ModelConstants_ml for domain, July 2007, ds +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! +! +! Parameter statements for definition of integration area +! and maximum number of gridpoints per processor +!RESTRI +! we try to run on a smaller domain with the same input +! for this reason we now define additional parameters: +! numbers of points in the 'larger' array iilardom,jjlardom +! and coordinates of the origin of the smaller domain with +! respect to the larger domain ismbeg,jsmbeg +! one can run the large domain by setting +! gimax, gjmax to iilardom,jjlardom +! and ismbeg,jsmbeg to 1 +! also we have now to distinguish mfsize for input and output: +! mfsizeinp,mfsizeout!!! + +use CheckStop_ml, only : CheckStop +use ModelConstants_ml, only : RUNDOMAIN, IIFULLDOM, JJFULLDOM, NPROCX, NPROCY, NPROC +implicit none +private + + + integer, public, parameter :: & + IRUNBEG = RUNDOMAIN(1) & + , JRUNBEG = RUNDOMAIN(3) & + , GIMAX = RUNDOMAIN(2)-RUNDOMAIN(1) + 1 & ! Number of global points in longitude + , GJMAX = RUNDOMAIN(4)-RUNDOMAIN(3) + 1 & ! Number of global points in longitude + , MAXLIMAX = (GIMAX+NPROCX-1)/NPROCX & ! Maximum number of local points in longitude + , MAXLJMAX = (GJMAX+NPROCY-1)/NPROCY & ! Maximum number of local points in latitude + , MFSIZEINP = IIFULLDOM*JJFULLDOM & ! Maximum field size for input + , MFSIZEOUT = GIMAX*GJMAX ! Maximum field size for output +! +! +! Parameter statements for the parameters used to access the tabell +! of neighbor processors (neighbor) +! + integer , public, parameter :: & + NORTH = 1 & ! Neighbor to the north + , SOUTH = 2 & ! Neighbor to the south + , EAST = 3 & ! Neighbor to the east + , WEST = 4 & ! Neighbor to the west + , NOPROC = -1 ! Value in neighbor when there is no neighbor in the + ! actual direction +! +! +! Variables for actual number of local points, to be computed +! + integer , public, save :: & + limax & ! Actual number of local points in longitude + , ljmax ! Actual number of local points in latitude + +! +! Variables for global address of the start and end points +! on each processor +! + integer, public, save :: & + gi0 & ! Global address of longitude start point + , gi1 & ! Global address of longitude end point + , gj0 & ! Global address of latitute start point + , gj1 ! Global address of latitude end point + +! +! Variables used as loop indexes on each processor. The values are +! derived from limax and ljmax and the position of the domain belonging +! to this processor. See PARINIT for assignment of values. +! + integer, public, save :: & + 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 +! +! +! Variables for address of this processor +! + integer , public, save :: & + me & ! Address of processer, numbering starts at 0 in south-west corner of ground level + , mex & ! Longitude address of processor, numbering starts at 0 on the westmost boundary + , mey ! Latitude address of processor, numbering starts at 0 on the southmost boundary + +! +! Variable for the table of local neighbor +! + + integer, public, save, dimension(4) :: neighbor + +! +! Tables of actual number of points and start and end points for +! all processors +! + integer, public, save, dimension(0:NPROC-1) :: & + tlimax, tgi0, tgi1, tljmax, tgj0, tgj1 +! +! + logical, private, parameter :: DEBUG_PAR = .false. + +!------------------------------------------------------------------------------ +! Define parameters used in the communication +!------------------------------------------------------------------------------ +! +! Code for broadcasting information to all nodes +! + integer, public, parameter :: NX_BROADCAST = -1 +! +! The different messages used in the bott version of airpol +! + integer, public, parameter :: & + MSG_INIT0 = 10 & + ,MSG_INIT1 = 11 & + ,MSG_INIT2 = 12 & + ,MSG_INIT3 = 13 & + ,MSG_INIT4 = 14 & + ,MSG_INIT5 = 15 & + ,MSG_INIT6 = 16 & + ,MSG_INIT7 = 17 & + ,MSG_INIT8 = 18 & + ,MSG_INIT9 = 19 & + ,MSG_NORTH1 = 21 & + ,MSG_NORTH2 = 22 & + ,MSG_EAST1 = 31 & + ,MSG_EAST2 = 32 & + ,MSG_SOUTH1 = 41 & + ,MSG_SOUTH2 = 42 & + ,MSG_WEST1 = 51 & + ,MSG_WEST2 = 52 & + ,MSG_TOPO1 = 61 & + ,MSG_TOPO2 = 62 + integer, public, parameter :: & + MSG_MAIN1 = 71 & + ,MSG_MAIN2 = 72 & + ,MSG_READ1 = 81 & + ,MSG_READ2 = 82 & + ,MSG_READ3 = 83 & + ,MSG_READ4 = 84 & + ,MSG_READ5 = 85 & + ,MSG_READ7 = 87 & + ,MSG_FIELD1 = 91 & + ,MSG_MET1 = 101 & + ,MSG_MET2 = 102 & + ,MSG_MET3 = 103 & + ,MSG_MET4 = 104 & + ,MSG_MET5 = 105 & + ,MSG_MET6 = 106 & + ,MSG_PARI = 107 +!-- end of eulnx.inc + + public :: parinit + public :: Topology + + contains + + subroutine parinit(min_grids) +! +!defines size and position of subdomains +! + + implicit none + integer, intent(in) :: min_grids ! u4 + integer i, j, ime, imex, imey, rest + +! +! +! Find the x-, y-, and z-addresses of the domain assigned to the +! processor +! +! Check if the subdomain is large enough +! + mey = me/NPROCX + mex = me - mey*NPROCX +! +! +! Find the number of grid points in each direction for this processor. +! We first try to divide the total number equally among the +! processors. Then the rest is distributed one by one to first processor +! in each direction. Here we also set the global address of the start +! and end point in each direction. +! +! x-direction (longitude) +! + limax = GIMAX/NPROCX + rest = GIMAX - limax*NPROCX + gi0 = mex*limax + 1 + if(rest>0)then + if(mex.eq.NPROCX-1)then + limax = limax+1 + gi0 = gi0+rest-1 + elseif (mex < rest-1) then + limax = limax + 1 + gi0 = gi0 + mex + else + gi0 = gi0 + rest-1 + endif + endif + gi1 = gi0 + limax - 1 +! +! y-direction (latitude) +! + ljmax = GJMAX/NPROCY + rest = GJMAX - ljmax*NPROCY + gj0 = mey*ljmax + 1 + if(rest>0)then + if(mey.eq.NPROCY-1)then + ljmax = ljmax + 1 + gj0 = gj0 + rest-1 + elseif (mey < rest-1) then + ljmax = ljmax + 1 + gj0 = gj0 + mey + else + gj0 = gj0 + rest-1 + endif + endif + gj1 = gj0 + ljmax - 1 + + if ( DEBUG_PAR ) then + write(*,"(a12,10i6)") "DEBUG_PAR ", me, IRUNBEG, JRUNBEG, & + GIMAX, GJMAX, gi0, gi1, limax, ljmax + end if +! +! +! Initialize the tables containing number of gridpoints and +! addresses of start and endpoint in all directions, for all +! processors. This is a repetition of the computations above, +! but now for all processors. +! + do ime = 0, NPROC-1 +! + imey = ime/NPROCX + imex = ime - imey*NPROCX +! +! x-direction (longitude) +! + tlimax(ime) = GIMAX/NPROCX + rest = GIMAX - tlimax(ime)*NPROCX + tgi0(ime) = imex*tlimax(ime) + 1 + if(rest>0)then + if (imex .eq. NPROCX-1) then + tlimax(ime) = tlimax(ime) + 1 + tgi0(ime) = tgi0(ime) + rest-1 + elseif (imex < rest-1) then + tlimax(ime) = tlimax(ime) + 1 + tgi0(ime) = tgi0(ime) + imex + else + tgi0(ime) = tgi0(ime) + rest-1 + endif + endif + tgi1(ime) = tgi0(ime) + tlimax(ime) - 1 +! +! y-direction (latitude) +! + tljmax(ime) = GJMAX/NPROCY + rest = GJMAX - tljmax(ime)*NPROCY + tgj0(ime) = imey*tljmax(ime) + 1 + if(rest > 0)then + if (imey .eq. NPROCY-1) then + tljmax(ime) = tljmax(ime) + 1 + tgj0(ime) = tgj0(ime) + rest-1 + elseif (imey < rest-1) then + tljmax(ime) = tljmax(ime) + 1 + tgj0(ime) = tgj0(ime) + imey + else + tgj0(ime) = tgj0(ime) + rest-1 + endif + endif + tgj1(ime) = tgj0(ime) + tljmax(ime) - 1 +! + enddo + +! The size of the grid cannot be too small. + + call CheckStop( limax < min_grids, & + "Subdomain too small! Limax must be at least min_grids") + call CheckStop( ljmax < min_grids, & + "Subdomain too small! Ljmax must be at least min_grids") + + end subroutine parinit + + + subroutine Topology(cyclicgrid,poles) + +!defines the neighbors and boundaries of (sub)domain +!Boundaries are defined as having coordinates +! between 1 and li0 or between li1 and limax or +! between 1 and lj0 or between lj1 and ljmax + + implicit none + integer, intent(in) :: cyclicgrid ! rv2_4_1 1 if cyclic grid + integer, intent(in) :: poles(2) ! poles(1)=1 if North pole, + ! poles(2)=1 if South pole + integer i, j, ime, imex, imey, rest + +! +! +! Find the x-, y-, and z-addresses of the domain assigned to the +! processor +! +! + mey = me/NPROCX + mex = me - mey*NPROCX +! +! +! Find the neighbors of this processor. +! Allow cyclic map in i direction. +! Do not define north and south poles as outer Boundaries +! + lj0 = 1 + lj1 = ljmax + if (mey > 0) then + neighbor(SOUTH) = me-NPROCX + else + neighbor(SOUTH) = NOPROC + if(poles(2)==0)lj0 = 2 + endif + if (mey < NPROCY-1) then + neighbor(NORTH) = me+NPROCX + else + neighbor(NORTH) = NOPROC + if(poles(1)==0)lj1 = ljmax - 1 + endif + if (mex > 0) then + neighbor(WEST) = me-1 + li0 = 1 + else + neighbor(WEST) = NOPROC + li0 = 2 + if(Cyclicgrid==1)then + neighbor(WEST) = me+NPROCX-1 + li0 = 1 + endif + endif + if (mex < NPROCX-1) then + neighbor(EAST) = me+1 + li1 = limax + else + neighbor(EAST) = NOPROC + li1 = limax - 1 + if(Cyclicgrid==1)then + neighbor(EAST) = me-NPROCX+1 + li1 = limax + endif + endif + + end subroutine topology + +end module Par_ml diff --git a/PhyChem_ml.f90 b/PhyChem_ml.f90 new file mode 100644 index 0000000..2cff933 --- /dev/null +++ b/PhyChem_ml.f90 @@ -0,0 +1,262 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 PhyChem_ml +! +! physical and chemical routine calls within one advection step +! driven from here +! +! Output of hourly data +! +!----------------------------------------------------------------------------- + use My_Outputs_ml , only : NHOURLY_OUT, FREQ_SITE, FREQ_SONDE, FREQ_HOURLY + use My_Timing_ml, only : Code_timer, Add_2timing, tim_before, tim_after + + use Advection_ml, only: advecdiff,advecdiff_poles,adv_int + use Chemfields_ml, only : xn_adv,cfac,xn_shl + use Derived_ml, only : IOU_INST, DerivedProds, Derived, & + num_deriv2d,d_2d, f_2d + use DryDep_ml, only : drydep,init_drydep + use Emissions_ml, only : EmisSet + use GridValues_ml, only : debug_proc, debug_li,debug_lj,& !ds jun2005 + gl, gb, projection, Poles + use Met_ml , only : roa,z_bnd,z_mid,metint, ps, cc3dmax, & + zen,coszen,Idirect,Idiffuse + use ModelConstants_ml, only : KMAX_MID, nmax, nstep & + ,dt_advec & ! time-step for phyche/advection + ,END_OF_EMEPDAY ! (usually 6am) + use Nest_ml, only : readxn, wrtxn + use Par_ml, only : me, MAXLIMAX, MAXLJMAX + use TimeDate_ml, only : date,daynumber,day_of_year, add_secs, & + current_date, timestamp, & + make_timestamp, make_current_date + use Trajectory_ml, only : trajectory_out ! 'Aircraft'-type outputs + use Radiation_ml, only : SolarSetup, &! sets up radn params + ZenithAngle, &! gets zenith angle + ClearSkyRadn, &! Idirect, Idiffuse + CloudAtten ! + use Runchem_ml, only : runchem ! Calls setup subs and runs chemistry + use Sites_ml, only: siteswrt_surf, siteswrt_sondes ! outputs + use Timefactors_ml, only : NewDayFactors +!----------------------------------------------------------------------------- +implicit none +private + +public :: phyche + + +contains +!++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + subroutine phyche(numt) + integer, intent(in) :: numt + + integer :: i,j,k,n + logical, parameter :: DEBUG = .false. + logical, save :: End_of_Day = .false. + + integer :: ndays + real :: thour + + + type(timestamp) :: ts_now !date in timestamp format + + !------------------------------------------------------------------ + ! start of inner time loop which calls the physical and + ! chemical routines. + + + DO_OUTER: do nstep = 1,nmax + + ! Hours since midnight at any time-step + ! using current_date we have already nstep taken into account + + thour = real(current_date%hour) + current_date%seconds/3600.0 & + + 0.5*dt_advec/3600.0 + + if ( DEBUG .and. debug_proc ) then + write(6,*) "PhyChe debug ", me, thour, & + current_date%hour, current_date%seconds + + if ( current_date%hour == 12 ) then + + ndays = day_of_year(current_date%year,current_date%month, & + current_date%day) + write(6,*) 'thour,ndays,nstep,dt', thour,ndays,nstep,dt_advec + endif + + endif + + if (me == 0) write(6,"(a15,i6,f8.3)") 'timestep nr.',nstep,thour + + call wrtxn(current_date,.false.) !Write xn_adv for future nesting + call readxn(current_date) !Read xn_adv from earlier runs + +! ================== + call Code_timer(tim_before) + + call EmisSet(current_date) + call Add_2timing(15,tim_after,tim_before,"phyche:EmisSet") + +! For safety we initialise add instant. values here to zero. +! Usually not needed, but sometimes +! ================== + d_2d(:,:,:,IOU_INST) = 0.0 +! ================== + + + !=================================== + + call SolarSetup(current_date%year,current_date%month, & + current_date%day,thour) + + call ZenithAngle(thour, gb, gl, zen, coszen ) + + if( DEBUG .and. debug_proc ) then + write(*,*) "PhyChem ZenRad ", current_date%day, current_date%hour, & + thour, gl(debug_li,debug_lj),gb(debug_li,debug_lj), & + zen(debug_li,debug_lj),coszen(debug_li,debug_lj) + end if + + call ClearSkyRadn(ps(:,:,1),coszen,Idirect,Idiffuse) + + call CloudAtten(cc3dmax(:,:,KMAX_MID),Idirect,Idiffuse) + + !=================================== + call Add_2timing(16,tim_after,tim_before,"phyche:ZenAng") + + + !================ + if( (Poles(1)==1.or.Poles(2)==1).and. & + trim(projection)==trim('lon lat'))then + call advecdiff_poles + else + call advecdiff + endif + + call Add_2timing(17,tim_after,tim_before,"phyche:advecdiff") + !================ + + call Code_timer(tim_before) + + + !/ See if we are calculating any before-after chemistry productions: + + !============================= + if ( nstep == nmax ) call DerivedProds("Before",dt_advec) + !============================= + + call Add_2timing(26,tim_after,tim_before,"phyche:MACHO-prod") + + !=================================== + call init_drydep() + !=================================== + + !========================================================= + + call runchem(numt) ! calls setup subs and runs chemistry + + call Add_2timing(28,tim_after,tim_before,"Runchem") + + !========================================================= + + + !/ See if we are calculating any before-after chemistry productions: + + !============================= + if ( nstep == nmax ) call DerivedProds("After",dt_advec) + !============================= + + call Code_timer(tim_before) + !============================= + call Add_2timing(34,tim_after,tim_before,"phyche:drydep") + + + + !============================= + ! this output needs the 'old' current_date_hour + + call trajectory_out + !============================= + +! the following partly relates to end of time step - hourly output +! partly not depends on current_date +! => add dt_advec to current_date already here + + + !==================================== + ts_now = make_timestamp(current_date) + + call add_secs(ts_now,dt_advec) + + current_date = make_current_date(ts_now) + + !==================================== + + + + End_of_Day = (current_date%seconds == 0 .and. & + current_date%hour == END_OF_EMEPDAY) + + if( End_of_Day .and. me == 0 ) then + write(*,"(a20,2i4,i6)") "END_OF_EMEPDAY, Hour,seconds=", & + END_OF_EMEPDAY, current_date%hour,current_date%seconds + endif + + call Derived(dt_advec,End_of_Day) + + + ! Hourly Outputs: + if ( current_date%seconds == 0 ) then + + if ( modulo(current_date%hour, FREQ_SITE) == 0 ) & + call siteswrt_surf(xn_adv,cfac,xn_shl) + + if ( modulo(current_date%hour, FREQ_SONDE) == 0 ) & + call siteswrt_sondes(xn_adv,xn_shl) + + if ( NHOURLY_OUT > 0 .and. & + modulo(current_date%hour, FREQ_HOURLY) == 0 ) & + call hourly_out() + + end if + + call Add_2timing(35,tim_after,tim_before,"phyche:outs") + + + call metint + + + call adv_int + + + call Add_2timing(36,tim_after,tim_before,"phyche:ints") + + enddo DO_OUTER + + end subroutine phyche +!----------------------------------------------------------------------------- +end module PhyChem_ml diff --git a/PhysicalConstants_ml.f90 b/PhysicalConstants_ml.f90 new file mode 100644 index 0000000..12418bc --- /dev/null +++ b/PhysicalConstants_ml.f90 @@ -0,0 +1,93 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 PhysicalConstants_ml +!---------------------------------------------------------------------------- +! Defines Physical constants +!---------------------------------------------------------------------------- +implicit none +!F private + +!-- contains no subroutine: + +! + + real , public, parameter :: & + AVOG = 6.023e23 & ! Avogadros number + , ATWAIR = 28.964 & ! mol wt of air, g/mol + , RGAS_ATML = 0.08205 & ! Molar Gas constant (atm M-1 K-1) + , RGAS_KG = 287.0 & ! Molar Gas constant (J K-1 kg-1) + , RGAS_J = 8.3144 ! Molar Gas constant (J mol-1 K-1) + + ! NB. ( J = N m2 = kg m2 s-2 ) + ! M = mol l-1 + + real, public, parameter :: & + GRAV = 9.807 & ! Gravity, m s-2 + , CP = 1004.0 & ! Specific heat at const. pressure + , R = 287.0 & ! Gas constants J K-1 kg-1 = RGAS_KG + , KAPPA = R/CP & + !ds apr2005 , XKAP = R/CP & + , KARMAN = 0.41 & ! Von Karman (=0.35 elsehwere in code!) + , PI = 3.141592653589793238462643383279 & ! www.verbose.net/Pi.html + , DEG2RAD = PI/180.0 & ! COnverts degrees to radians + , RAD2DEG = 180.0/PI & ! COnverts radians to degrees + , ROWATER = 1000.0 & ! pw density of water kg m-3 + , BOLTZMANN = 1.380e-23 & ! Boltzmann'c constant[J/deg/molec] + , FREEPATH = 6.5e-8 & ! Mean Free Path of air [m] + , VISCO = 1.46e-5 ! Air viscosity [m2/s] (was NU) + +! Some definitions for daylight, in terms of zenith angle and cos(zen): +! (calculated from criteria that DAY_COSZEN > 1.0e-10 as daytime) + + real, public, parameter :: & + DAY_ZEN = 89.9999999942704 & ! + ,DAY_COSZEN = 1.0e-10 + +!=================== DEP CODE ================================Y:0 + + ! CHARNOCK is used to calculate the roughness length for the + ! landuse category water + + real, public, parameter :: & + PRANDTL = 0.71, & ! Prandtl number (see Garratt, 1992) + Sc_H20 = 0.6, & ! Schmidt number for water + CHARNOCK = 0.032 ! Charnock's alpha: + ! see Nordeng (1986), p.31, + ! Nordeng(1991), JGR, 96, no. C4, pp. 7167-7174. + ! In the second of these publications, Nordeng uses + ! "m" to denote Charnock's alpha whilst in the first + ! he specifies the value 0.032. + + ! Standard temperature : + + real, public, parameter :: T0 = 273.15 ! zero degrees Celsius in Kelvin + +!=============================================================Y:0 + + +end module PhysicalConstants_ml diff --git a/Radiation_ml.f90 b/Radiation_ml.f90 new file mode 100644 index 0000000..bf58347 --- /dev/null +++ b/Radiation_ml.f90 @@ -0,0 +1,440 @@ +module Radiation_ml + + !+ Collection of routines to calculate radiation terms, also for + ! canopies. IMPORTANT - Most routines expect SolarSetup to + ! have been called first. + ! + ! F-compliant. Module usable by stand-alone deposition code. + + use PhysicalConstants_ml , only: PI, DEG2RAD, RAD2DEG, DAY_ZEN, DAY_COSZEN + use TimeDate_ml , only: julian_date, day_of_year + implicit none + private + + !/ Subroutines: + public :: SolarSetup ! => decl, sindecl, eqt_h, etc., + daytime, solarnoon + public :: ZenithAngle ! => CosZen=cos(Zen), Zen=zenith angle (degrees) + public :: ZenithAngleS ! (simpler version) + public :: ClearSkyRadn ! => irradiance (W/m2), clear-sky + public :: CloudAtten ! => Cloud-Attenuation factor + public :: CanopyPAR ! => sun & shade PAR values, and LAIsunfrac + public :: ScaleRad ! Scales modelled radiation where observed values + ! available. + + !/ Functions: + public :: daytime ! true if zen < 89.9 deg + public :: daylength ! Lenght of day, hours + public :: solarnoon ! time of solarnoon + + + real, public, parameter :: & + PARfrac = 0.45, & ! approximation to fraction (0.45 to 0.5) of total + ! radiation in PAR waveband (400-700nm) + Wm2_uE = 4.57, & ! converts from W/m^2 to umol/m^2/s + Wm2_2uEPAR= PARfrac * Wm2_uE ! converts from W/m^2 to umol/m^2/s PAR + + + ! Some variables which are dependent only on day of year and GMT time + ! - hence they do not vary from grid to grid and can safely be stored here + + real, private, save :: rdecl,sinrdecl,cosrdecl + real, private, save :: eqtime, eqt_h, tan_decl + +logical, private, parameter :: DEBUG = .false. + + + !================== Ashrae/Iqbal stuff -- see ClearSkyRad subroutine + + type, public :: ashrae_tab + integer :: nday + real :: a + real :: b + real :: c + end type ashrae_tab + + type(ashrae_tab), save, public :: Ashrae ! Current values + + type(ashrae_tab), parameter, dimension(14), private :: ASHRAE_REV = (/ & + ! nday a b c + ashrae_tab( 1, 1203.0, 0.141, 0.103 ) & + ,ashrae_tab( 21, 1202.0, 0.141, 0.103 ) & + ,ashrae_tab( 52, 1187.0, 0.142, 0.104 ) & + ,ashrae_tab( 81, 1164.0, 0.149, 0.109 ) & + ,ashrae_tab(112, 1130.0, 0.164, 0.120 ) & + ,ashrae_tab(142, 1106.0, 0.177, 0.130 ) & + ,ashrae_tab(173, 1092.0, 0.185, 0.137 ) & + ,ashrae_tab(203, 1093.0, 0.186, 0.138 ) & + ,ashrae_tab(234, 1107.0, 0.182, 0.134 ) & + ,ashrae_tab(265, 1136.0, 0.165, 0.121 ) & + ,ashrae_tab(295, 1136.0, 0.152, 0.111 ) & + ,ashrae_tab(326, 1190.0, 0.144, 0.106 ) & + ,ashrae_tab(356, 1204.0, 0.141, 0.103 ) & + ,ashrae_tab(366, 1203.0, 0.141, 0.103 ) & + /) + !============================= + + +contains + + !<=========================================================================== + subroutine SolarSetup(year,month,day,hour) + + ! Sets up decelention and related terms, as well as Ashrae coefficients + ! Should be called before other routines. + + integer, intent(in) :: year,month,day + real, intent(in) :: hour + + real :: d,ml,rml,w,wr,ec,epsi,yt,pepsi,cww + real :: sw,ssw, eyt, feqt1, feqt2, feqt3, feqt4, feqt5, & + feqt6, feqt7, feqt,ra,reqt + real :: dayinc + integer :: i + + logical, parameter :: MY_DEBUG = .false. + + +!* count days from dec.31,1973 + + d = julian_date(year,month,day) - julian_date(1973,12,31) + 1 + d = d + hour/24.0 + + +!* calc geom mean longitude + + ml = 279.2801988 + 0.9856473354*d + 2.267e-13*d*d + rml = ml*DEG2RAD + +!* calc equation of time in sec +!* w = mean long of perigee +!* e = eccentricity +!* epsi = mean obliquity of ecliptic + + w = 282.4932328 + 4.70684e-5*d + 3.39e-13*d*d + wr = w*DEG2RAD + ec = 1.6720041e-2 - 1.1444e-9*d - 9.4e-17*d*d + epsi = 23.44266511 - 3.5626e-7*d - 1.23e-15*d*d + pepsi = epsi*DEG2RAD + yt = tan(pepsi/2.0) + yt = yt*yt + cww = cos(wr) + sw = sin(wr) + ssw = sin(2.0*wr) + eyt = 2.0*ec*yt + feqt1 = sin(rml)*(-eyt*cww - 2.0*ec*cww) + feqt2 = cos(rml)*(2.0*ec*sw - eyt*sw) + feqt3 = sin(2.0*rml)*(yt - (5.0*ec*ec/4.0)*(cww*cww-sw*sw)) + feqt4 = cos(2.0*rml)*(5.0*ec*ec*ssw/4.0) + feqt5 = sin(3.0*rml)*(eyt*cww) + feqt6 = cos(3.0*rml)*(-eyt*sw) + feqt7 = -sin(4.0*rml)*(0.5*yt*yt) + feqt = feqt1 + feqt2 + feqt3 + feqt4 + feqt5 + feqt6 + feqt7 + + eqtime = feqt*13751.0 + +!* equation of time in hrs: + + eqt_h = eqtime/3600.0 + +!* convert eq of time from sec to deg + + reqt = eqtime/240.0 + +!* calc right ascension in rads + + ra = ml - reqt + +!* calc declination in rads, deg + + tan_decl = 0.43360*sin( ra * DEG2RAD ) + + rdecl = atan(tan_decl) + sinrdecl = sin(rdecl) + cosrdecl = cos(rdecl) + + !----------------------------------------------------------------- + + ! Find coefficients for Iqbal/Ashrae algorith, used in ClearSkyRadn routine + ! first, perform the table look up + + d = day_of_year(year,month,day) + do i = 1, 14 + if (d <= ASHRAE_REV(i)%nday ) exit + end do + + if ( DEBUG .and. i<1.or.i>14) write(unit=6,fmt=*) "solbio: index err!" + + if ( ASHRAE_REV(i)%nday == 1) then + Ashrae%a = ASHRAE_REV(1)%a + Ashrae%b = ASHRAE_REV(1)%b + Ashrae%c = ASHRAE_REV(1)%c + else + dayinc = real( d-ASHRAE_REV(i-1)%nday ) / & + real( ASHRAE_REV(i)%nday-ASHRAE_REV(i-1)%nday ) + Ashrae%a = ASHRAE_REV(i-1)%a + & + ( ASHRAE_REV(i)%a - ASHRAE_REV(i-1)%a )*dayinc + Ashrae%b = ASHRAE_REV(i-1)%b + & + ( ASHRAE_REV(i)%b - ASHRAE_REV(i-1)%b )*dayinc + Ashrae%c = ASHRAE_REV(i-1)%c + & + ( ASHRAE_REV(i)%c - ASHRAE_REV(i-1)%c )*dayinc + end if + + end subroutine SolarSetup + + + !<=========================================================================== + elemental subroutine ZenithAngle(thour, latitude, longitude, Z, CosZ ) + ! IMPORTANT - Call SolarSetup before use to get decl terms and eqt_H + + real, intent(in) :: thour + real, intent(in) :: latitude + real, intent(in) :: longitude + real, intent(out) :: Z ! Zenith Angle (degrees) + real, intent(out) :: CosZ ! cos(Z) + + real :: rlt,lzgmt,zpt,lbgmt + + rlt = latitude *DEG2RAD + lbgmt = 12.0 - eqt_h - longitude *24.0/360.0 + lzgmt = 15.0*(thour - lbgmt) + zpt = lzgmt*DEG2RAD + CosZ = sin(rlt)*sinrdecl + cos(rlt)*cosrdecl*cos(zpt) + + CosZ = min( 1.0, CosZ) + CosZ = max(-1.0, CosZ) + Z = acos(CosZ)*RAD2DEG + + end subroutine ZenithAngle + ! ====================================================================== + elemental subroutine ZenithAngleS(lon, lat, daynr, nydays, hr, Z, CosZ ) + ! ====================================================================== + ! routine determines (approximate) cos(zen), where "zen" denotes the zenith + ! angle, (in accordance with Iversen and Nordeng (1987, p.28)) + ! dnmi 29-9-95 Hugo Jakobsen, modified Dave, 2002-2004 + ! + ! arguments: + real, intent(in) :: lon ! longitude (degrees), east is positive + real, intent(in) :: lat ! latitude (degrees), north is positive + integer, intent(in) :: daynr ! day nr. (1..366) + integer, intent(in) :: nydays ! number of days per year (365 or 366) + real, intent(in) :: hr ! hour (0-24, gmt) ! ds - was integer + real, intent(out) :: Z ! zenith angle (degrees) + real, intent(out) :: CosZ + + !/ Local.... + real :: lonr, latr, arg, decl, tangle + + lonr=lon*DEG2RAD ! convert to radians + latr=lat*DEG2RAD ! convert to radians + + arg = ((daynr - 80.0)/nydays) * 2.0 * PI + + decl = 23.5 * sin(arg) * DEG2RAD + + tangle = lonr + (hr/12.0-1.0)*PI !no eqtime correction + CosZ =(sin(decl)*sin(latr)+cos(decl)*cos(latr)*cos(tangle)) + Z = acos(CosZ) * RAD2DEG + end subroutine ZenithAngleS + + !============================================================================= + + elemental subroutine ClearSkyRadn(p,CosZ,Idirect,Idiffuse) + + ! Computes the radiation terms needed for stomatal and BVOC calculations. + ! Methodology for this calculation taken from Iqbal, M., 1983, + ! An introduction to solar radiation, Academic Press, New York, + ! pp. 202-210. + ! + ! history: + ! + ! From T. Pierce's SolBio code: + ! Development of this routine was prompted by the need for a + ! horizontal rather than an actinic flux calculation (which had + ! been performed by Soleng). Furthermore, Soleng computed total + ! radiation only out to the near-ir spectrum. This program + ! is designed only for approximate radiation estimates to be used + ! for stomatal calculations. + ! + ! 8/90 initial development of SolBio by T. Pierce + ! 95 modified by Hugo Jakobsen, 29/9-95 + ! 04-05 modified by Dave Simpson for EMEP and DO3SE models + + real, intent(in) :: p ! Pressure, Pa + real, intent(in) :: CosZ ! Cos(Zenith) + + ! Calculates clear-sky values of: + + real, intent(out) :: Idirect ! total direct solar radiation (W/m2) + real, intent(out) :: Idiffuse ! diffuse solar radiation (W/m) + + ! Local: + real :: Idrctn ! direct normal solar radiation (W/m2) + real, parameter :: PRES0 = 101300.0 ! std sea-level pressure (Pa) + + real, parameter :: cn = 1.0 + ! cn - clearness number (defined as the ratio of normal + ! incident radiation, under local mean water vapour, + ! divided by the normal incident radiation, for + ! water vapour in a basic atmosphere) + ! - currently, this value set equal to 1.0, but eventually + ! may vary as a function of latitude and month pending further + ! literature review. + + if ( CosZ > DAY_COSZEN ) then + Idrctn = cn * Ashrae%a * exp(- Ashrae%b * (p/PRES0)/CosZ) + Idiffuse = Ashrae%c * Idrctn + Idirect = Idrctn * CosZ + else + Idirect = 0.0 + Idiffuse = 0.0 + end if + + !X solar = Idirect + Idiffuse ! total solar radiation, diff.+direct (W/m2) + + + end subroutine ClearSkyRadn +!=========================================================================== + elemental subroutine CloudAtten(cl,a,b)!,c) + ! Routine applies a cloud-attenuation factor to arguments, which could + ! be say, Idrctt,Idfuse,solar, or just solar: the last 2 arguments are + ! optional + + ! Agument + real, intent(in) :: cl ! cloud fraction (0-1) + real, intent(inout) :: a + real, intent(inout), optional :: b!,c + + real :: f ! cloud attenuation factor + + f = 1.0 - 0.75*cl**3.4 !(source: Kasten & Czeplak (1980)) + + a = a * f + + if( present(b) ) b = b * f +! if( present(c) ) c = c * f + + end subroutine CloudAtten + +!=========================================================================== + subroutine CanopyPAR(LAI,sinB,Idrctt,Idfuse,& + PARsun,PARshade,LAIsunfrac) +!=========================================================================== +! +! Calculates g_light, using methodology as described in Emberson et +! al. (1998), eqns. 31-35, based upon sun/shade method of Norman (1979,1982) + +! input arguments: + + real, intent(in) :: LAI ! leaf area index (m^2/m^2), one-sided + real, intent(in) :: sinB ! B = solar elevation angle; sinB = CosZen + real, intent(in) :: Idrctt, Idfuse + real, intent(out) :: PARsun, PARshade + real, intent(out) :: LAIsunfrac + + +! internal variables: + + real :: LAIsun ! sunlit LAI + + real, parameter :: cosA = 0.5 ! A = mean leaf inclination (60 deg.), + ! where it is assumed that leaf inclination has a spherical distribution + + + + LAIsun = (1.0 - exp(-0.5*LAI/sinB) ) * sinB/cosA + LAIsunfrac = LAIsun/LAI + +! PAR flux densities evaluated using method of +! Norman (1982, p.79): +! "conceptually, 0.07 represents a scattering coefficient" + + PARshade = Idfuse * exp(-0.5*LAI**0.7) + & + 0.07 * Idrctt * (1.1-0.1*LAI)*exp(-sinB) + + PARsun = Idrctt *cosA/sinB + PARshade + +!.. Convert units, and to PAR fraction + + PARshade = PARshade * Wm2_2uEPAR + PARsun = PARsun * Wm2_2uEPAR + + end subroutine CanopyPAR + +!-------------------------------------------------------------------- + + subroutine ScaleRad(ObsRad, Idrctt,Idfuse) + real, intent(in) :: ObsRad + real, intent(inout) :: Idrctt, Idfuse + + real :: Scale + logical :: MY_DEBUG = .false. + + !----- + ! Observation frequently don't have PAR, but instead have global radiation. + ! We scale the modelled global radiation (solar) by the observed, and + ! distribute Idrctt and Idrctn according to this. + + if ( ObsRad > 0.0 ) Scale = ObsRad/(Idrctt+Idfuse) + + if (MY_DEBUG) then + if (Scale <0.1 .or. Scale>10.0) then + print "(a35,2f10.3)","Obs and Mod Radiation large diff", & + ObsRad,Idrctt+Idfuse + endif + end if + Idrctt=Scale*Idrctt + Idfuse=Scale*Idfuse + end subroutine ScaleRad + + !============================================================================= + ! FUNCTIONS + !============================================================================= + + ! Define function for daytime, to keep definitions consistent throughout code. + ! NB - older code had a check for zen>1.0e-15 --- Why?! + + elemental function daytime(zen) result (day) + real, intent(in) :: zen ! Zenith angle (degrees) + logical :: day + + if( zen < DAY_ZEN ) then + day = .true. + else + day = .false. + end if + end function daytime + + !----------------------------------------------------------------- + ! Calculate length of day, following Jones, Appendix 7: + ! IMPORTANT - Call SolarSetup before use to get tan_decl + + elemental function daylength(lat) result (len) + real, intent(in) :: lat ! Latitude, deg. + real :: len, arg + real, parameter :: TIMEFAC = RAD2DEG * 2.0 /15.0 + + arg = -tan_decl * tan( DEG2RAD*lat ) + + if( arg <= -1.0 ) then + len = 24.0 !! Polar summer + else if( arg >= 1.0 ) then + len = 0.0 !! Polar night + else + len = acos( -tan_decl * tan( DEG2RAD*lat ) ) & + * TIMEFAC ! eqn A7.2, Jones + end if + end function daylength + !----------------------------------------------------------------- + ! Calculate solar noon, following Jones, Appendix 7: + ! IMPORTANT - Call SolarSetup before use to get eqt_t + + elemental function solarnoon(long) result (noon) + real, intent(in) :: long ! Longitude, deg. + real :: noon + + noon = 12.0 - eqt_h - long*24.0/360.0 + + end function solarnoon +!=============================================================== +end module Radiation_ml +!=============================================================== diff --git a/Rb_ml.f90 b/Rb_ml.f90 new file mode 100644 index 0000000..c53ff05 --- /dev/null +++ b/Rb_ml.f90 @@ -0,0 +1,105 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Rb_ml + +use PhysicalConstants_ml, only : KARMAN + +use Wesely_ml, only :Wesely_tab2 & ! Wesely Table 2 for 14 gases + ,Rb_cor ! +implicit none +private + +public :: Rb_gas + +logical, private, parameter :: MY_DEBUG = .false. + + +contains +! ======================================================================= + + subroutine Rb_gas(water,ustar,z0,DRYDEP_CALC,Rb) +! ======================================================================= +! Input: + + logical, intent(in) :: water + real, intent(in) :: ustar, z0 + integer, dimension(:), intent(in) :: & + DRYDEP_CALC ! Array with Wesely indices of gases wanted + +! Output: + + real,dimension(:),intent(out) :: Rb ! Rs for dry surfaces + +! Working values: + + integer :: icmp ! gaseous species + integer :: iwes ! gaseous species, Wesely tables + + real, parameter :: D_H2O = 0.21e-4 ! Diffusivity of H2O, m2/s + real :: D_i ! Diffusivity of gas species, m2/s + + +! START OF PROGRAMME: + + + +!......... Loop over all required gases ................................ + + GASLOOP: do icmp = 1, size( DRYDEP_CALC ) + iwes = DRYDEP_CALC(icmp) + + if ( water ) then + + D_i = D_H2O / Wesely_tab2(1,iwes) ! CORR ! + + Rb(icmp) = log( z0 * KARMAN * ustar/ D_i ) + Rb(icmp) = Rb(icmp)/(ustar*KARMAN) + + ! CORR - Rb can be very large or even negative from this + ! formula. We impose limits: + + Rb(icmp) = min( 1000.0, Rb(icmp) ) ! CORR - - gives min 0.001 m/s! + Rb(icmp) = max( 10.0, Rb(icmp) ) ! CORR - - gives max 0.10 m/s! + + else + + Rb(icmp) = 2.0 * Rb_cor(iwes)/(KARMAN*ustar) + end if + + + end do GASLOOP + + if ( MY_DEBUG ) then + print *, "RB DRYDEP_CALC", size(DRYDEP_CALC), DRYDEP_CALC(1) + print *, "RB water", water, "Rb(1) ", Rb(1) + end if + end subroutine Rb_gas + +!-------------------------------------------------------------------- + +end module Rb_ml diff --git a/ReadField_ml.f90 b/ReadField_ml.f90 new file mode 100644 index 0000000..ff6ee0f --- /dev/null +++ b/ReadField_ml.f90 @@ -0,0 +1,236 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 ReadField_ml +!__________________________________________________________________________ +! +! ----------------------------------------------------------- +! Reads iascii real and integer fields, usually for the whole +! model area, and calls global2local to distribute these to +! the calling processor. Fields initialised +! +! Initialisation to zero included, so we do not need to input an array which +! covers the whole domain. +! +! Written October 2001, HF +! Cleaned, 3-D possibility added, JEJ and DS, April-May 2007 +!------------------------------------------------------------ + use CheckStop_ml, only: CheckStop + use ModelConstants_ml, only : NPROC, IIFULLDOM,JJFULLDOM + use Par_ml, only : IRUNBEG,JRUNBEG & + ,MAXLIMAX,MAXLJMAX & + ,MSG_READ7,MSG_READ5 & + ,me,GIMAX,GJMAX + use Io_ml, only : ios, open_file + implicit none + + integer,private :: i, j, n ! Local variables + + interface ReadField + module procedure ReadField_r + module procedure ReadField_i + module procedure ReadField_3dr + module procedure ReadField_3di + end interface + +contains + + + !>=========================================================================< + subroutine ReadField_r(IO_INFILE,fname,local_field) + + integer, intent(in) :: IO_INFILE ! File no. + character*20, intent(in) :: fname ! File name + real, intent(out) :: local_field(MAXLIMAX,MAXLJMAX)! Local field + character*50 :: errmsg + real :: tmpin ! To allow more than one input line per i,j + + ! Initialisation to zero added, so now we do not need to input an array which + ! covers the whole domain. + + real :: in_field(IIFULLDOM,JJFULLDOM)! Field to be read + + in_field(:,:) = 0.0 + local_field(:,:) = 0.0 + errmsg = "ok" + + if (me==0)then + call open_file(IO_INFILE,"r",fname,needed=.true.) + call CheckStop(ios,"ReadField: ios error in r" // fname ) + + READFIELD : do + read(IO_INFILE,*,iostat=ios) i,j,tmpin + if ( ios /= 0 ) exit READFIELD + if ( i < 1 .or. i > IIFULLDOM .or. & + j < 1 .or. j > JJFULLDOM ) then + errmsg = "error in i,j index in IO_INFILE="!!! ,fname, i,j + exit READFIELD + endif + in_field(i,j) = in_field(i,j) + tmpin + enddo READFIELD + + close(IO_INFILE) + call CheckStop( errmsg ,"ReadField_r: errmsg in ReadField") + + endif !me==0 + + call global2local(in_field,local_field,MSG_READ7 & + ,1,IIFULLDOM,JJFULLDOM,1,IRUNBEG,JRUNBEG) + + end subroutine ReadField_r + + !>=========================================================================< + subroutine ReadField_3dr(IO_INFILE,fname,DIM3,local_field,opened) + + integer, intent(in) :: IO_INFILE ! File no. + character(len=*), intent(in) :: fname ! File name + integer, intent(in) :: DIM3 ! Size of k,z dimension + real, intent(out) :: local_field(MAXLIMAX,MAXLJMAX,DIM3)! Local field + + logical, intent(in),optional :: opened + + real :: in_field(IIFULLDOM,JJFULLDOM,DIM3)! Field to be read + character*50 :: errmsg + real, dimension(DIM3) :: tmpin + + in_field(:,:,:) = 0.0 ! Initialise - ds, 15/1/2005 + local_field(:,:,:) = 0.0 ! Initialise - ds, 15/1/2005 + errmsg = "ok" + + if (me==0)then + if ( present(opened) .and. opened ) then + write(*,*) "file ", fname, " opened before ReadField" + else + call open_file(IO_INFILE,"r",fname,needed=.true.) + call CheckStop(ios,"Readfield_r Error opening " // fname ) + end if + + READFIELD : do + read(IO_INFILE,*,iostat=ios) i,j,tmpin(:) + if ( ios /= 0 ) exit READFIELD + if ( i < 1 .or. i > IIFULLDOM .or. & + j < 1 .or. j > JJFULLDOM ) then + errmsg = "error in i,j index in IO_INFILE="!!! ,fname, i,j + exit READFIELD + endif + in_field(i,j,:) = in_field(i,j,:) + tmpin(:) + enddo READFIELD + close(IO_INFILE) + call CheckStop(errmsg, "ReadField_r: error reading" // fname ) + + endif !me==0 + + call global2local(in_field,local_field,MSG_READ7 & + ,1,IIFULLDOM,JJFULLDOM,DIM3,IRUNBEG,JRUNBEG) + + end subroutine ReadField_3dr + + !>=========================================================================< + + subroutine ReadField_i(IO_INFILE,fname,local_field) + + integer, intent(in) :: IO_INFILE ! File no. + character*20, intent(in) :: fname ! File name + integer, intent(out) :: local_field(MAXLIMAX,MAXLJMAX) + character*50 :: errmsg + integer :: intmp + + integer :: in_field(IIFULLDOM,JJFULLDOM)! Field to be read + + in_field(:,:) = 0.0 ! Initialise - ds, 15/1/2005 + local_field(:,:) = 0.0 ! Initialise - ds, 15/1/2005 + errmsg = "ok" + + if (me==0)then + call open_file(IO_INFILE,"r",fname,needed=.true.) + call CheckStop(ios,"ReadField: ios error " // fname ) + endif !me==0 + + if (me == 0) then + + READFIELD : do + read(IO_INFILE,*,iostat=ios) i,j, intmp + if ( ios /= 0 ) exit READFIELD + if ( i < 1 .or. i > IIFULLDOM .or. & + j < 1 .or. j > JJFULLDOM ) then + errmsg = "error in i,j index in IO_INFILE=" // fname + exit READFIELD + endif + in_field(i,j) = in_field(i,j) + intmp + enddo READFIELD + close(IO_INFILE) + call CheckStop( errmsg ,"ReadField: errmsg in ReadField") + + endif !me==0 + + call global2local_int(in_field,local_field,MSG_READ5 & + ,IIFULLDOM,JJFULLDOM,1,IRUNBEG,JRUNBEG) + + end subroutine ReadField_i + !>=========================================================================< + + subroutine ReadField_3di(IO_INFILE,fname,DIM3,local_field) + + integer, intent(in) :: IO_INFILE ! File no. + character*20, intent(in) :: fname ! File name + integer, intent(in) :: DIM3 ! Size of k,z dimension + integer, intent(out) :: local_field(MAXLIMAX,MAXLJMAX,DIM3) + character*50 :: errmsg + integer, dimension(DIM3) :: intmp + + integer :: in_field(IIFULLDOM,JJFULLDOM,DIM3)! Field to be read + + errmsg = "ok" + + if (me==0)then + call open_file(IO_INFILE,"r",fname,needed=.true.) + call CheckStop(ios," ReadField_i: error opening: " // fname ) + + READFIELD : do + read(IO_INFILE,*,iostat=ios) i,j, intmp(:) + if ( ios /= 0 ) exit READFIELD + if ( i < 1 .or. i > IIFULLDOM .or. & + j < 1 .or. j > JJFULLDOM ) then + errmsg = "error in i,j index in IO_INFILE=" // fname + exit READFIELD + endif + in_field(i,j,:) = in_field(i,j,:) + intmp(:) + enddo READFIELD + close(IO_INFILE) + call CheckStop(errmsg," ReadField_3di: error reading" // fname) + + endif !me==0 + + call global2local_int(in_field,local_field,MSG_READ5 & + ,IIFULLDOM,JJFULLDOM,DIM3,IRUNBEG,JRUNBEG) + + end subroutine ReadField_3di + + !__________________________________________________________________________ +end module ReadField_ml diff --git a/Rsurface_ml.f90 b/Rsurface_ml.f90 new file mode 100644 index 0000000..5124027 --- /dev/null +++ b/Rsurface_ml.f90 @@ -0,0 +1,342 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Rsurface_ml + +use CheckStop_ml, only: CheckStop +use CoDep_ml, only : CoDep_factors, RgsS_dry, RgsS_wet, & + humidity_fac, Rns_NH3 +use DO3SE_ml, only : g_stomatal, do3se + +use LocalVariables_ml, only : iL, L, G => Grid + ! L (local) provides t2C, rh, LAI, SAI, hveg, ustar, + ! PARsun,PARshade,LAIsunfrac, RgsO, RgsS, is_water, is_forest + ! G (Grid) provides snow, so2nh3ratio, + +use Radiation_ml, only : CanopyPAR + +use Wesely_ml, only :Wesely_tab2 & ! Wesely Table 2 for 14 gases + ,WES_HNO3, WES_NH3,DRx ! Indices and Ratio of diffusivities to ozone +implicit none +private + +public :: Rsurface + +real, public, save :: Rinc, RigsO, GnsO +logical, private, parameter :: MY_DEBUG = .false. + + + +contains +! ======================================================================= + + + subroutine Rsurface(DRYDEP_CALC,Rsur_dry,Rsur_wet,errmsg,debug_flag) +! ======================================================================= +! +! Description +! calculates bulk surface resistance (Rsur) for all required gases. +! +! For O3 the methodology is derived from EMEP MSC_W Note 6/00; the +! following pathways apply for the surface resistance for O3: +! +! -- Rinc-- Rgs In-canopy + soil/ground cover +! | +! | +! -------- Rext cuticular+other external surface +! | +! | +! -------- Rsto Stomatal + +! Hence, we have a surface conductance: +! +! Gsur = LAI + SAI + 1 +! ___ ___ ____________ +! Rsto Rext Rinc + Rgs +! +! For SO2 and NH3 we use the CEH suggestion of a simple non-stomatal +! uptake (which is stringly affected by wetness/RH): +! +! -------- Rns Non-stomatal +! | +! -------- Rsto Stomatal +! +! [ Note that the O3 formulation can be written in the same way when we +! define GnsO = SAI/Rext + 1/(Rinc+Rgs) ] +! +! Hence, for all gases, we have a surface conductance: +! +! Gsur = LAI * Gsto + Gns + +! Wesely's method for other gases was based upon deriving resistances for +! ozone and SO2 first (e.g. RgsO, RgsS for Rgs) and then scaling using +! effective Henry coefficients (H*) and reactivity coefficients (f0) for +! each gas. However, here we apply scaling to Gns, not individual resistances. +! +! Structure of routine +! +! 1. Calculate: +! Rlow low-temperature correction +! Rinc in-canopy resistance +! Rsur(HNO3) +! Gsto(O3) stomatal conductance (if LAI > 0) +! +! FOR EACH remaining gas (icmp is used as an index, since cmp is assumed +! to abbreviate "component".): +! 2. Calculate ground surface resistance, Rgs +! if (LAI<0.1) go to 4 (for snow/ice/water...) +! 3. if (LAI>0.1) calculate Gext +! 4. Calculate Rsur(icmp) +! END +! +! ======================================================================= + +!...................................... +! Input: + + integer, dimension(:), intent(in) :: & + DRYDEP_CALC ! Array with Wesely indices of gases wanted + +! Output: + + real,dimension(:),intent(out) :: Rsur_dry ! Rs for dry surfaces + real,dimension(:),intent(out) :: Rsur_wet ! Rs for wet surfaces + character(len=*), intent(out) :: errmsg +! Optional + logical, intent(in), optional :: debug_flag + + + ! external resistance for Ozone + real, parameter :: RextO = 2500.0 ! gives Gext=0.2 cm/s for LAI=5 + + +! Here, "Gext=0.2cm/s" refers to the external conductance, G_ext, where +! G_ext=LAI/R_ext. In many studies, it has been assumed +! that G_ext should be low, particularly relative to stomatal conductance g_s. +! Results from a variety of experiments, however, have made the above +! estimates Rext0 and RextS plausible. The above equation for G_ext has been +! designed on the basis of these experimental results. + +! Notice also that given the equations for the canopy resistance R_sur and the +! deposition velocity V_g, V_g>=LAI/R_ext. The value of G_ext can therefore be +! interpreted as the minimum value for V_g. + + +! Working values: + + integer :: icmp ! gaseous species + integer :: iwes ! gaseous species, Wesely tables + logical :: canopy & ! For SAI>0, .e.g grass, forest, also in winter + ,leafy_canopy ! For LAI>0, only when green + real, parameter :: SMALLSAI= 0.05 ! arbitrary value but small enough + real :: Hstar, f0 ! Wesely tabulated Henry's coeff.'s, reactivity + real :: Rlow ! adjustment for low temperatures (Wesely, + ! 1989, p.1296, left column) +!In Local real :: Rinc ! In-canopy adjustment + real :: Rgs_dry, Rgs_wet ! + + real :: GnsS_dry, GnsS_wet, Gns_dry, Gns_wet + + +! START OF PROGRAMME: + errmsg = "ok" + + canopy = ( L%SAI > SMALLSAI ) ! - can include grass + leafy_canopy = ( L%LAI > SMALLSAI ) ! - can include grass + + !=========================================================================== + !/** Adjustment for low temperatures (Wesely, 1989, p.1296, left column) + + Rlow = 1000.0*exp(-L%t2C - 4.0) + + !=========================================================================== + !/** get CEH humidity factor and RgsS_dry and RgsS_wet: + + call CoDep_factors(G%so2nh3ratio,L%t2C,L%rh,L%is_forest,debug_flag) + + +!############## 1. Calculate In-Canopy Resistance, Rinc ################ + + !/** For canopies: + !/** Calculate stomatal conductance if daytime and LAI > 0 + + + if( leafy_canopy .and. G%Idirect > 0.001 ) then ! Daytime + + call CanopyPAR(L%LAI, G%coszen, G%Idirect, G%Idiffuse, & + L%PARsun, L%PARshade, L%LAIsunfrac) + + + call g_stomatal(iL) + + else + L%g_sun = 0.0 + L%g_sto = 0.0 + + end if ! leafy canopy and daytime + +if ( MY_DEBUG .and. present(debug_flag) ) then + if ( debug_flag ) then + write(*,*) "IN RSUR gsto ", leafy_canopy, G%Idirect, L%g_sto + end if +end if + + + !/** Calculate Rinc, Gext + ! (use multiplication for snow, since snow=0 or 1) + + if( canopy ) then + + Rinc = 14.0 * L%SAI * L%hveg / L%ustar ! Erisman's b.LAI.h/u* + + RgsS_dry = RgsS_dry + Rlow + G%snow * 2000.0 + RgsS_wet = RgsS_wet + Rlow + G%snow * 2000.0 + + ! for now, use CEH stuff for canopies, keep Ggs for non-canopy + + GnsS_dry = 1.0 / RgsS_dry ! For SO2, dry, low NH3 region + GnsS_wet = 1.0 / RgsS_wet ! For SO2, wet, low NH3 region + + else ! No canopy present + + Rinc = 0.0 + + !/ Here we preserve the values from the ukdep_gfac table + ! giving higher deposition to water, less to deserts + + RgsS_dry = do3se(iL)%RgsS + Rlow + G%snow * 2000.0 + RgsS_wet = RgsS_dry ! Hard to know what's best here + + end if ! canopy + + +!#### 2. Calculate Surface Resistance, Rsur, for HNO3 and Ground Surface +!#### Resistance, Rgs, for the remaining Gases of Interest + + !/ Ozone values.... + + !!xRgsO = do3se(lu)%RgsO + Rlow + snow * 2000.0 + !!GnsO = SAI/RextO + 1.0/( xRgsO + Rinc ) ! (SAI=0 if no canopy) + RigsO = Rinc + do3se(iL)%RgsO + Rlow + G%snow * 2000.0 + GnsO = L%SAI/RextO + 1.0/ RigsO ! (SAI=0 if no canopy) + + +!......... Loop over all required gases ................................ + + GASLOOP: do icmp = 1, size( DRYDEP_CALC ) + iwes = DRYDEP_CALC(icmp) + + !------------------------------------------------------------------------- + + ! code obtained from Wesely during 1994 personal communication + ! but changed (ds) to allow Vg(HNO3) to exceed Vg(SO2) + + if ( iwes == WES_HNO3 ) then + Rsur_dry(icmp) = max(1.0,Rlow) + Rsur_wet(icmp) = Rsur_dry(icmp) + cycle GASLOOP + end if + + !------------------------------------------------------------------------- + ! Calculate the Wesely variables Hstar (solubility) and f0 (reactivity) + + Hstar =Wesely_tab2(2,iwes) !Extract H*'s + f0 =Wesely_tab2(5,iwes) !Extract f0's + + !------------------------------------------------------------------------- + + + + ! Use SAI to test for snow, ice, water, urban ... + + if ( canopy ) then + + ! ### 3. Calculate Cuticle conductance, Gext ################ + ! ### and Ground surface conductance Ggs: + + ! Corrected for other species using Wesely's eqn. 7 approach. + ! (We identify leaf surface resistance with Rext/SAI.) + ! but for conductances, not resistances (pragmatic, I know!) + + + + ! ############## 4. Calculate Rsur for canopies ############### + + + if ( DRYDEP_CALC(icmp) == WES_NH3 ) then + + Gns_dry = 1.0/Rns_NH3 !/** r_water from CoDep_ml + Gns_wet = Gns_dry + + else ! Not NH3 + + Gns_dry = 1.0e-5*Hstar*GnsS_dry + f0 * GnsO ! OLD SO2! + Gns_wet = 1.0e-5*Hstar*GnsS_wet + f0 * GnsO + + !.. and allow for partially wet surfaces at high RH, even for Gns_dry + + Gns_dry = Gns_dry * (1.0-humidity_fac) + Gns_wet * humidity_fac + + + end if ! NH3 test + + Rsur_dry(icmp) = 1.0/( L%LAI*DRx(iwes) *L%g_sto + Gns_dry ) + Rsur_wet(icmp) = 1.0/( L%LAI*DRx(iwes) *L%g_sto + Gns_wet ) + + ! write(*,"(a20,2i3,3g12.3)") "RSURFACE Gs (i): ", iL, icmp, GnsO, Gns_dry, Gns_wet + + else ! Non-Canopy modelling: + + Rgs_dry = 1.0/(1.0e-5*Hstar/RgsS_dry + f0/do3se(iL)%RgsO) ! Eqn. (9) + Rgs_wet = 1.0/(1.0e-5*Hstar/RgsS_wet + f0/do3se(iL)%RgsO) ! Eqn. (9) + + Rsur_dry(icmp) = Rgs_dry + Rsur_wet(icmp) = Rgs_wet + ! write(*,"(a20,2i3,3g12.3)") "RSURFACE Rgs (i): ", iL, icmp, Rgs_dry, Rgs_wet + + end if ! end of canopy tests + + ! write(*,"(a20,2i3,3g12.3)") "RSURFACE Rsur(i): ", iL, icmp, Rsur_dry(icmp), Rsur_wet(icmp) + + end do GASLOOP + + + if ( MY_DEBUG ) then + if ( present(debug_flag) ) then + if ( debug_flag ) then + write(*,*) "RSURFACE DRYDEP_CALC", size(DRYDEP_CALC), DRYDEP_CALC(1) + write(*,*) "RSURFACE iL, LAI, SAI, LOGIS ", iL, L%LAI, L%SAI, & + L%is_forest, L%is_water, canopy, leafy_canopy + write(*,"(a20,i3,4g12.3)") "RSURFACE xed Gs", iL, do3se(iL)%RgsO,do3se(iL)%RgsS, Rlow, Rinc + end if + end if + end if + end subroutine Rsurface + +!-------------------------------------------------------------------- + +end module Rsurface_ml diff --git a/Runchem_ml.f90 b/Runchem_ml.f90 new file mode 100644 index 0000000..2d3b902 --- /dev/null +++ b/Runchem_ml.f90 @@ -0,0 +1,221 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module RunChem_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!---------------------------------------------------------------------- +! Calls for routines calculating chemical and physical processes: +! irreversible and equilibrium chemistry, dry and wet deposition, +! sea salt production, particle water etc. +! +!---------------------------------------------------------------------- + use My_Aerosols_ml, only: My_MARS, My_EQSAM, AERO_DYNAMICS, & + EQUILIB_EMEP, EQUILIB_MARS, EQUILIB_EQSAM, & + ORGANIC_AEROSOLS, Aero_water, SEASALT + use My_Timing_ml, only: Code_timer, Add_2timing, & + tim_before, tim_after + + use Ammonium_ml, only: Ammonium + use Aqueous_ml, only: Setup_Clouds, prclouds_present, WetDeposition + 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 DefPhotolysis_ml, only: setup_phot + use DryDep_ml, only : drydep + use GenSpec_tot_ml ! DEBUG ONLY + use GenSpec_adv_ml ! DEBUG ONLY + use GridValues_ml, only: debug_proc, debug_li, debug_lj + use ModelConstants_ml, only : PPB, KMAX_MID, dt_advec, & + nprint, END_OF_EMEPDAY, & + DEBUG_i, DEBUG_j,nstep, NPROC + + use OrganicAerosol_ml, only: OrganicAerosol ! not yet implemented + use Par_ml, only : lj0,lj1,li0,li1 & + ,gi0, gj0, me & !! for testing + ,IRUNBEG, JRUNBEG !! for testing + use SeaSalt_ml, only: SeaSalt_flux + use Setup_1d_ml, only: setup_1d, & + setup_bio, setup_rcemis, reset_3d + use Setup_1dfields_ml, only: first_call & + ,amk , rcemis, rcbio, xn_2d ! DEBUG for testing + use TimeDate_ml, only: current_date + +!-------------------------------- + implicit none + private + + public :: runchem + + logical, private, save :: MYDEBUG = .false. + +contains + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +subroutine runchem(numt) + + integer, intent(in) :: numt + +!/ local + integer :: i, j + integer :: errcode + integer :: nmonth, nday, nhour + logical :: Jan_1st, End_of_Run + logical :: debug_flag ! => Set true for selected i,j + +! ============================= + + nmonth = current_date%month + nday = current_date%day + nhour = current_date%hour + + Jan_1st = ( nmonth == 1 .and. nday == 1 ) + End_of_Run = ( mod(numt,nprint) == 0 ) + + !.... **** processes calls ************************* + + errcode = 0 + + do j = lj0, lj1 + do i = li0, li1 + + call Code_Timer(tim_before) + + !****** debug cell set here ******* + debug_flag = .false. + if ( MYDEBUG .and. debug_proc ) then + + debug_flag = ( debug_li == i .and. debug_lj == j ) + + end if + + ! Prepare some near-surface grid and sub-scale meteorology + ! for MicroMet + call Get_CellMet(i,j,debug_flag) + + call setup_1d(i,j) + + call Add_2timing(27,tim_after,tim_before,& + "Runchem:setup_1d") + + call Setup_Clouds(i,j) + + call setup_bio(i,j) + + call Add_2timing(28,tim_after,tim_before, & + "Runchem:setup_cl/bio") + + call setup_phot(i,j,errcode) + + call CheckStop(errcode,"setup_photerror in Runchem") + call Add_2timing(29,tim_after,tim_before, & + "Runchem:1st setups") + + call setup_rcemis(i,j) + + if ( SEASALT ) & + call SeaSalt_flux(i,j,debug_flag) + + if ( ORGANIC_AEROSOLS ) & + call OrganicAerosol(debug_flag) + + call Add_2timing(30,tim_after,tim_before, & + "Runchem:2nd setups") + + !------------------------------------------------- + call chemistry(i,j) + !_________________________________________________ + + call Add_2timing(31,tim_after,tim_before, & + "Runchem:chemistry") + + !== Alternating Dry Deposition and Equilibrium chemistry + ! Check that one and only one eq is chosen + + if(mod(nstep,2) /= 0 ) then + + if ( EQUILIB_EMEP ) call ammonium() + if ( EQUILIB_MARS ) call My_MARS(debug_flag) + if ( EQUILIB_EQSAM ) call My_EQSAM(debug_flag) + + call DryDep(i,j) + + else !do drydep first, then eq + + call DryDep(i,j) + if ( EQUILIB_EMEP ) call ammonium() + if ( EQUILIB_MARS ) call My_MARS(debug_flag) + if ( EQUILIB_EQSAM ) call My_EQSAM(debug_flag) + endif + !???????????????????????????????????????????????????? + + call Add_2timing(32,tim_after,tim_before, & + "Runchem:ammonium+Drydep") + + if ( MYDEBUG .and. debug_flag ) then + write(6,*) "DEBUG_RUN me pre WetDep", me, prclouds_present + write(6,"(a20,2i3,i5,3es12.3)") "DEBUG_RUN me OH", & + current_date%day, current_date%hour,& + current_date%seconds, & + xn_2d(OH,20), xn_2d(PHNO3,20), xn_2d(HNO3,20) + + end if + + if ( prclouds_present) & + call WetDeposition(i,j) + + !** Modelling PM water at filter equlibration conditions: + !** T=20C and Rh=50% for comparability with gravimetric PM + + if ( nhour == END_OF_EMEPDAY .or. End_of_Run ) & + call Aero_water(i,j) + + call reset_3d(i,j) + + call Add_2timing(33,tim_after,tim_before,& + "Runchem:post stuff") + + first_call = .false. !** end of first call **** ! + + end do ! j + end do ! i + + !.... ************************************************ + + end subroutine runchem + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end module RunChem_ml + diff --git a/SOA_ml.f90 b/SOA_ml.f90 new file mode 100644 index 0000000..3e7729e --- /dev/null +++ b/SOA_ml.f90 @@ -0,0 +1,78 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 +! From BOX3D on 9/8/01 + ! Calculates the amount of condesible species in the gas and aerosol + ! phases. + ! Methodology from Andersson-Sk\"old and Simpson, 2000, Secondary Organic + ! Aerosol Formation in Northern Europe: a Model Study, to be published + ! in JGR. + ! + ! Usage: call OrganicAerosol from Runchem, after setup of 1d-fields + ! finished. The subroutine initialises itself on the first call + ! and thereafter modifies two external variables: + ! xn(SOA,k) : the concentrations of SOA + ! Fgas(X,k) : The fraction of X which is gas and not aeorosl + ! + ! Dave Simpson, August 2001 + !-------------------------------------------------------------------------- + ! nb - we use all of GenSpec_tot_ml since different model versions + ! will have different species names. This module is intended to + ! insensitive to the actual names one day, so this should be + ! revised .. one day - ds. + !-------------------------------------------------------------------------- + use ModelConstants_ml, only : CHEMTMIN, CHEMTMAX, & + K2 => KMAX_MID, K1 => KCHEMTOP + use PhysicalConstants_ml, only : AVOG + use Setup_1dfields_ml, only : itemp, xn => xn_2d + use GenChemicals_ml, only : species ! for molwts + use GenSpec_tot_ml, A1 => FIRST_SOA , A2 => LAST_SOA + implicit none + + !/-- subroutines + public :: OrganicAerosol + + + !/-- public + + real, public, dimension(A1:A2,K1:K2), save :: Fgas ! Fraction in gas-phase + + contains + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + !+ Driver routine for Secondary Organic Aerosol module + + subroutine OrganicAerosol(debug_flag) + logical, intent(in) :: debug_flag ! for debugging purposes only + + ! empty + + end subroutine OrganicAerosol + +end module OrganicAerosol_ml +!xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + diff --git a/SeaSalt_ml.f90 b/SeaSalt_ml.f90 new file mode 100644 index 0000000..320420b --- /dev/null +++ b/SeaSalt_ml.f90 @@ -0,0 +1,317 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module SeaSalt_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +!----------------------------------------------------------------------------- +! Calculates production of sea salt based on: +! Maartinsson et al.(2003) JGR,100,D8 for particles smaller than 1um +! Monahan et al.(1986) J.Phys.Oceanogr,10 for particles 1-10um (and larger) +! Programmed by Svetlana Tsyro +!----------------------------------------------------------------------------- + + use GenSpec_tot_ml, only : SSFI, SSCO + use GenChemicals_ml, only : species + use Landuse_ml, only : LandCover, water_fraction + use LocalVariables_ml, only : Sub, Grid + use Met_ml, only : z_bnd, z_mid, sst, snow, & + nwp_sea, u_ref, foundSST + use MicroMet_ml, only : Wind_at_h + use ModelConstants_ml, only : KMAX_MID, KMAX_BND, DEBUG_i,DEBUG_j + use My_Emis_ml, only : NSS, QSSFI, QSSCO + use Par_ml, only : MAXLIMAX,MAXLJMAX ! => x, y dimensions + use PhysicalConstants_ml, only : CHARNOCK, GRAV, AVOG ,PI + use TimeDate_ml, only : current_date + + !------------------------------------- + + implicit none + private + + public :: SeaSalt_flux ! subroutine + + integer, parameter :: SS_MAAR= 4, SS_MONA= 6, & !Number size ranges for + !Maartinsson's and Monahan's + NFIN= 4, NCOA= 3, & !Number fine&coarse size ranges + SSdens = 2200.0 ! sea salt density [kg/m3] + + real, save, dimension(SS_MAAR) :: log_dp1, log_dp2, dp3, a, b + 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 + + logical, private, save :: my_first_call = .true. + logical, private, parameter :: MY_DEBUG = .false. + + contains + +! <-------------------------------------------------------------------------> + + subroutine SeaSalt_flux (i,j, debug_flag) + + !----------------------------------------------------------------------- + ! Input: Tw - sea surface temperature - # - + ! u10 - wind speed at 10m height + ! 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 :: k, ii, jj, nlu, ilu, lu + real :: invdz, n2m, u10, u10_341, Tw, flux_help + real :: ss_flux(SS_MAAR+SS_MONA), d3(SS_MAAR+SS_MONA) +!//--------------------------------------------------- + + if ( my_first_call ) then + + call init_seasalt + + my_first_call = .false. + + end if ! my_first_call + !.................................... + + SS_prod(:,i,j) = 0.0 + + if ( .not. Grid%is_NWPsea .or. Grid%snow == 1) return ! quick check + + +!// Loop over the land-use types present in the grid + + nlu = LandCover(i,j)%ncodes + do ilu= 1, nlu + lu = LandCover(i,j)%codes(ilu) + +!// only over water +! Obs! All water is assumed here to be salt water for now +! (as fresh water is not distinguished in the input) + + if ( Sub(lu)%is_water ) then + + if(MY_DEBUG .and. debug_flag) then + write(6,'(a20,2i5)') ' Sea-Salt Check ',DEBUG_i,DEBUG_j + write(6,'(a30,3f12.4,f8.2)') '** ustar_nwp, d, Z0, SST ** ',& + Grid%ustar, Sub(lu)%d,Sub(lu)%z0, sst(i,j,1) + end if + + !.. Calculate wind velocity over water at Z10=10m + + u10 = Wind_at_h (Grid%u_ref, Grid%z_ref, Z10, Sub(lu)%d, & + Sub(lu)%z0, Sub(lu)%invL) + + if (u10 <= 0.0) u10 = 1.0e-5 ! to make sure u10!=0 because of LOG(u10) + u10_341=exp(log(u10) * (3.41)) + + if(MY_DEBUG .and. debug_flag) & + write(6,'(a30,2f12.4,es14.4)')'** U*, U10, invL ** ', & + Sub(lu)%ustar, u10,Sub(lu)%invL + + !.. Sea surface temperature is not always available (e.g. pre-2001 at + ! MET.NO), so we need an alternative. As emissions are most + ! sensitive to u* and not T, we ignore differences between Tw and T2 for + ! the default case if SST isn't avialable. + + if ( foundSST ) then + Tw = sst(i,j,1) + else + Tw = Grid%t2 + endif + +! ==== Calculate sea salt fluxes in size bins [part/m2/s] ======== + +!... Fluxes of small aerosols for each size bin (Mårtensson etal,2004) + do ii = 1, SS_MAAR + + flux_help = a(ii) * Tw + b(ii) + + ss_flux(ii) = flux_help * ( log_dp2(ii) - log_dp1(ii) ) & + * u10_341 * 3.84e-6 + d3(ii) = dp3(ii) ! diameter cubed + if(MY_DEBUG .and. debug_flag) write(6,'(a20,i5,es13.4)') & + 'Flux Maarten -> ',ii, ss_flux(jj) + enddo + +!... Fluxes of larger aerosols for each size bin (Monahan etal,1986) + do ii = 1, SS_MONA + jj = ii + SS_MAAR + + ss_flux(jj) = temp_Monah (ii) * u10_341 + + d3(jj) = dSS3(ii) ! diameter cubed + if(MY_DEBUG .and. debug_flag) & + write(6,'(a20,i5,es13.4)') 'Flux Monah -> ',ii, ss_flux(jj) + enddo + + +!.. conversion factor from [part/m2/s] to [molec/cm3/s] + + invdz = 1.0e-6 / Grid%DeltaZ ! 1/dZ [1/cm3] + n2m = n_to_mSS * invdz *AVOG / species(SSFI)%molwt *1.0e-15 + +!.. Fine particles emission [molec/cm3/s] + do ii = 1, NFIN + SS_prod(QSSFI,i,j) = SS_prod(QSSFI,i,j) & + + ss_flux(ii) * d3(ii) * n2m & + * water_fraction(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) & + + ss_flux(ii) * d3(ii) * n2m & + * water_fraction(i,j) + enddo + + if(MY_DEBUG .and. debug_flag) write(6,'(a35,2es15.4)') & + '>> SS production fine/coarse >>', & + SS_prod(QSSFI,i,j), SS_prod(QSSCO,i,j) + + endif ! water + enddo ! LU classes + + end subroutine SeaSalt_flux + + +!<<---------------------------------------------------------------------------<< + + subroutine init_seasalt + + !------------------------------------------------------------ + ! Assignments and calculations of some help-parameters + !------------------------------------------------------------ + + implicit none + + integer :: i, k + real :: a1, a2 + real, dimension(SS_MONA) :: Rrange, rdry + +!//===== Polynomial coeficients from Maartinsson et al. (2004) + real, parameter, dimension(5) :: & + C1 = (/-2.576e35, 5.932e28, -2.867e21, -3.003e13, -2.881e6 /), & + C2 = (/-2.452e33, 2.404e27, -8.148e20, 1.183e14, -6.743e6 /), & + C3 = (/ 1.085e29, -9.841e23, 3.132e18, -4.165e12, 2.181e6 /), & + + D1 = (/ 7.188e37, -1.616e31, 6.791e23, 1.829e16, 7.609e8 /), & + D2 = (/ 7.368e35, -7.310e29, 2.528e23, -3.787e16, 2.279e9 /), & + D3 = (/-2.859e31, 2.601e26, -8.297e20, 1.105e15, -5.800e8 /) + +!=== mikrometer in powers + real, parameter :: MKM = 1.e-6, MKM2 = 1.e-12 , & + MKM3 = 1.e-18, MKM4 = 1.e-24 + +!//.. Size bins for Maartinsson's parameterisation (dry diameters): + real, parameter, dimension(SS_MAAR) :: & + DP = (/0.08, 0.18, 0.36, 0.70 /), & ! centre diameter + DP_1 = (/0.06, 0.12, 0.26, 0.50 /), & ! lower boundary + DP_2 = (/0.12, 0.26, 0.50, 1.0 /) ! upper boundary + +!// Limits of size bins (for dry R) for Monahan parameterisation + real, parameter, dimension(SS_MONA+1) :: & + RLIM = (/0.5, 1.0, 2.0, 5.0, 7.0, 10.0, 20.0 /) + real, parameter :: K1 = 0.7674, K2 = 3.079, K3 = 2.573e-11, K4 = -1.424 + real, parameter :: third = 1.0/3.0 + real :: lim1, lim2 + real, dimension(SS_MAAR) :: dp2, dp4 + !---------------------------------------------------- + + n_to_mSS = PI * SSdens / 6.0 ! number to mass convertion + + log_DP1(:) = log10(DP_1(:)) + log_dp2(:) = log10(DP_2(:)) +!.. powers of diameter + dp2(:) = DP(:) * DP(:) + dp3(:) = dp2(:) * DP(:) + dp4(:) = dp3(:) * DP(:) + +!//====== For Monahan et al. (1986) parameterisation ===== + + rdry(1) = 0.71 ! wet diameter ca. 2.8 + rdry(2) = 1.41 ! wet diameter ca. 5.6 + rdry(3) = 3.16 ! wet diameter ca. 12.6 + ! Up to here is used........ + rdry(4) = 5.60 + rdry(5) = 8.00 + rdry(6) = 16.0 + +! Equilibrium wet radius (Gong&Barrie [1997], JGR,102,D3) + + do i = 1, SS_MONA + radSS(i) = ( K1*rdry(i)**K2 /(K3 *rdry(i)**K4 - & + log10(0.8))+rdry(i)**3) ** third + lim1 = ( K1*RLIM(i+1)**K2 /(K3 *RLIM(i+1)**K4 - & + log10(0.8))+RLIM(i+1)**3) ** third + lim2 = ( K1*RLIM(i)**K2 /(K3 *RLIM(i)**K4 - & + log10(0.8))+RLIM(i)**3) ** third + Rrange(i) = lim1 - lim2 ! bin size intervals + enddo + +!.. Help parameter + do i = 1, SS_MONA + a1 = ( 0.380 - log10(radSS(i)) ) / 0.650 + a2 = 1.19 * exp(-a1*a1) + + temp_Monah(i) = 1.373 * radSS(i)**(-3) * Rrange(i) * & + ( 1.0 + 0.057 * radSS(i)**1.05 )* 10.0**a2 + enddo + +!// D_dry^3 - for production of dry SS mass + dSS3(:) = ( 2.0 * rdry(:) )**3 + +!//===== For Maartinsson et al.(2004) parameterisation ======= + + a(1) = C1(1)*dp4(1)*MKM4 + C1(2)*dp3(1) *MKM3 & + + C1(3)*dp2(1)*MKM2 + C1(4)*DP(1) *MKM + C1(5) + a(2:3) = C2(1)*dp4(2:3)*MKM4 + C2(2)*dp3(2:3)*MKM3 & + + C2(3)*dp2(2:3)*MKM2 + C2(4)*DP(2:3) *MKM + C2(5) + a(4) = C3(1)*dp4(4)*MKM4 + C3(2)*dp3(4) *MKM3 & + + C3(3)*dp2(4)*MKM2 + C3(4)*DP(4) *MKM + C3(5) + + b(1) = D1(1)*dp4(1)*MKM4 + D1(2)*dp3(1) *MKM3 & + + D1(3)*dp2(1)*MKM2 + D1(4)*DP(1) *MKM + D1(5) + b(2:3) = D2(1)*dp4(2:3)*MKM4 + D2(2)*dp3(2:3)*MKM3 & + + D2(3)*dp2(2:3)*MKM2 + D2(4)*DP(2:3) *MKM + D2(5) + b(4)= D3(1)*dp4(4)*MKM4 + D3(2)*dp3(4) *MKM3 & + + D3(3)*dp2(4)*MKM2 + D3(4)*DP(4) *MKM + D3(5) + + + end subroutine init_seasalt +!>>--------------------------------------------------------------------------->> + + end module SeaSalt_ml + diff --git a/Setup_1d_ml.f90 b/Setup_1d_ml.f90 new file mode 100644 index 0000000..963e4a1 --- /dev/null +++ b/Setup_1d_ml.f90 @@ -0,0 +1,399 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Setup_1d_ml + + ! DESCRIPTION + ! Generates arrays for 1-D column , for input to chemical solver. The output + ! fields are stored in the Setup_1dfields_ml module. + + + !-----------------------------------------------------------------------! + use Volcanos_ml + use AirEmis_ml, only : airn, airlig ! airborne NOx emissions + use Biogenics_ml , only : emnat,canopy_ecf, BIO_ISOP, BIO_TERP + use Chemfields_ml, only : xn_adv,xn_bgn,xn_shl + use CheckStop_ml, only : CheckStop + use Emissions_ml, only : gridrcemis, KEMISTOP + use Functions_ml, only : Tpot_2_T + use GenSpec_tot_ml, only : SO4,aNO3,pNO3 + use GenSpec_adv_ml, only : NSPEC_ADV, IXADV_NO2 + use GenSpec_shl_ml, only : NSPEC_SHL + use GenSpec_bgn_ml, only : NSPEC_COL, NSPEC_BGN, xn_2d_bgn + use MyChem_ml, only : Set_2dBgnd + use GenRates_rct_ml, only : NRCT, rcit ! Tabulated rate coeffs + use GenRates_rcmisc_ml, only : NRCMISC, set_rcmisc_rates + use GridValues_ml, only : sigma_mid, xmd, carea, & + debug_proc, debug_li, debug_lj + use LocalVariables_ml, only : Grid + use MassBudget_ml, only : totem ! sum of emissions + use Met_ml, only : roa, th, ps, q, t2_nwp, cc3dmax & + ,zen, Idirect, Idiffuse,z_bnd + use ModelConstants_ml, only : & + ATWAIR & + ,dt_advec & ! time-step + ,PT & ! Pressure at top + ,MFAC & ! converts roa (kg/m3 to M, molec/cm3) + ,KMAX_MID ,KMAX_BND, KCHEMTOP ! Start and upper k for 1d fields + use My_Aerosols_ml, only : SEASALT + use My_Emis_ml, only : NRCEMIS , AIRNOX, QRCAIRNO & + ,QRCAIRNO2, NBVOC& + ,QRCVOL,VOLCANOES & + ,NSS !SeaS + use My_MassBudget_ml, only : N_MASS_EQVS, ixadv_eqv, qrc_eqv + use My_BoundConditions_ml, only : BGN_2D + use Landuse_ml, only : water_fraction, ice_fraction + use N2O5_hydrolysis_ml, only : f_Riemer !weighting factor for N2O5 hydrolysis + use Par_ml, only : me& !!(me for tests) + ,gi0,gi1,gj0,gj1,IRUNBEG,JRUNBEG !hf VOL + use PhysicalConstants_ml, only : AVOG, PI + use Radiation_ml, only : PARfrac, Wm2_uE + use Setup_1dfields_ml, only : & + xn_2d & ! concentration terms + ,rcemis, rcbio & ! emission terms + ,rc_Rn222 & ! for Pb210 + ,rct, rcmisc & ! emission terms + ,rcss & !SeaS - sea salt + ,rh, temp, itemp,pp & ! + ,amk ! Air concentrations + use SeaSalt_ml, only : SS_prod + use Tabulations_ml, only : tab_esat_Pa + use TimeDate_ml, only : current_date, date + implicit none + private + !-----------------------------------------------------------------------! + + + public :: setup_1d ! Extracts results for i,j column from 3-D fields + public :: setup_bio ! Biogenic emissions + public :: setup_rcemis ! Emissions (formerly "poll") + public :: reset_3d ! Exports results for i,j column to 3-D fields + + +contains + !xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx + subroutine setup_1d(i,j) + + !.. extracts data along one vertical column for input to chemical + ! solver concentrations for chemistry...... + ! + ! Outputs, amk, o2k, rcairlig, ... + + integer, intent(in) :: i,j ! coordinates of column + + !/* local + + integer :: k, n, ispec, irc ! loop variables + real :: qsat ! saturation water content + + + real ,dimension(KCHEMTOP:KMAX_MID) :: tinv, & ! Inverse of temp. + h2o, o2k ! water, O2 + + do k = KCHEMTOP, KMAX_MID + + !- MFAC - to scale from density (roa, kg/m3) to molecules/cm3 + ! (kg/m3 = 1000 g/m3 = 0.001 * Avog/Atw molecules/cm3) + + amk(k) = roa(i,j,k,1) * MFAC ! molecules air/cm3 + + + h2o(k) = max( 1.e-5*amk(k), & + q(i,j,k,1)*amk(k)*ATWAIR/18.0) + + ! nb. max function for h2o used as semi-lagrangian scheme used + ! in LAM50 (and HIRLAM) often gives negative H2O.... :-( + + + pp(k) = PT + sigma_mid(k)*(ps(i,j,1) - PT) + + temp(k) = th(i,j,k,1)* Tpot_2_T( pp(k) ) + + itemp(k) = nint( temp(k) -1.E-9) +! the "-1.E-9" is put in order to avoid possible different roundings on different machines. + + qsat = 0.622 * tab_esat_Pa( itemp(k) ) / pp(k) + rh(k) = min( q(i,j,k,1)/qsat , 1.0) + + ! 1)/ Short-lived species - no need to scale with M + + do n = 1, NSPEC_SHL + xn_2d(n,k) = max(0.0,xn_shl(n,i,j,k)) + end do ! ispec + + ! 2)/ Advected species + do n = 1, NSPEC_ADV + ispec = NSPEC_SHL + n + xn_2d(ispec,k) = max(0.0,xn_adv(n,i,j,k)*amk(k)) + end do ! ispec + + ! 3)/ Background species ( * CTM2 with units in mix. ratio) + do n = 1, NSPEC_BGN + xn_2d_bgn(n,k) = max(0.0,xn_bgn(n,i,j,k)*amk(k)) + end do ! ispec + +! setup weighting factor for hydrolysis + f_Riemer(k)=96.*xn_2d(SO4,k)/( (96.*xn_2d(SO4,k))+(62.*xn_2d(aNO3,k)) ) + + end do ! k + +! Check that concentrations are not "contaminated" with NaN + call CheckStop( .not.xn_2d(IXADV_NO2+NSPEC_SHL,KMAX_MID)+1>& + xn_2d(IXADV_NO2+NSPEC_SHL,KMAX_MID) & + ,"Detected non numerical concentrations (NaN)") + + + + o2k(:) = 0.21*amk(:) + tinv(:) = 1./temp(:) + + + ! 5 ) Rates + + rct(:,:) = rcit(:,itemp(:)) + + !old: call set_rctroe_rates(tinv,amk,rctroe) + + call set_rcmisc_rates(itemp,tinv,amk,o2k,h2o,rh,rcmisc) + + + + + end subroutine setup_1d + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine setup_rcemis(i,j) + + !------------------------------------------------------------------- + !** DESCRIPTION: + ! Extracts emissions in column from gridrcemis, for input to chemistry + ! routines. Results in "rcemis" array + !------------------------------------------------------------------- + + !-- arguments + integer, intent(in) :: i,j ! coordinates of column + + ! local + integer :: iqrc,k,n + real :: scaling, scaling_k + real :: eland ! for Pb210 - emissions from land + + integer :: i_help,j_help,i_l,j_l + +! initilize + rcemis(:,:)=0. + rcss(:,:) = 0. !SeaS + + do k=KEMISTOP,KMAX_MID + + do iqrc = 1, NRCEMIS + rcemis(iqrc,k) = gridrcemis(iqrc,k,i,j) + end do ! iqrc + enddo + + !/** Add volcanoe emissions + + if ( VOLCANOES ) then ! for models that include volcanos + !QRCVOL=QRCSO2 for models with volcanos + !For non-volc models it is set to dummy value 1 + !to avoid problems with undefined QRCVOL + do volc_no=1,nvolc + i_help=i_volc(volc_no) !Global coordinates + j_help=j_volc(volc_no) !Global coordinates + if ((i_help >= gi0).and.(i_help<=gi1).and.(j_help>= gj0)& + .and.(j_help<= gj1))then !on the correct processor + i_l=i_help - gi0 +1 + j_l=j_help - gj0 +1 + if((i_l==i).and.(j_l==j))then !i,j have a volcano + k=height_volc(volc_no) + rcemis(QRCVOL,k)=rcemis(QRCVOL,k)+rcemis_volc(volc_no) + !write(*,*)'Adding volc. emissions ',rcemis_volc(volc_no),volc_no,& + ! 'to height=',k,'i,j',i_help,j_help + !write(*,*)'TOT rcemis=',rcemis(QRCVOL,:) + endif + endif + enddo + + endif ! VOLCANOES + + !/** lightning and aircraft ... Airial NOx emissions if required: + + if ( AIRNOX ) then + + !QRCAIRNO is set to QRCNO and QRCAIRNO2 is set to QRCNO2 if + ! AIRNOX is true. Otherwise to a + ! dummy value of 1. Avoids problems with + !undefined QRCNO in non-NOx models. + + do k=KCHEMTOP,KEMISTOP-1 + rcemis(QRCAIRNO,k) = 0.95 * (airn(k,i,j)+airlig(k,i,j)) + rcemis(QRCAIRNO2,k) = 0.05 * (airn(k,i,j)+airlig(k,i,j)) + + enddo + + do k=KEMISTOP,KMAX_MID + rcemis(QRCAIRNO,k) = rcemis(QRCAIRNO,k) & + + 0.95 * (airn(k,i,j)+airlig(k,i,j)) + rcemis(QRCAIRNO2,k) = rcemis(QRCAIRNO2,k) & + + 0.05 * (airn(k,i,j)+airlig(k,i,j)) + + enddo + + end if ! AIRNOX + + !/** Add sea salt production + + if ( SEASALT ) then + + do iqrc = 1, NSS + rcss(iqrc,KMAX_MID) = SS_prod(iqrc,i,j) + enddo + + endif + +!Mass Budget calculations +! Adding up the emissions in each timestep +! use ixadv_eqv, qrc_eqv from My_Emis_ml, e.g. ixadv_eqv(1) = IXADV_SO2, +! qrc_eqv(1) = QRCSO2 + + scaling = dt_advec * xmd(i,j) * (ps(i,j,1) - PT) + + do k = KCHEMTOP,KMAX_MID + + scaling_k = scaling * carea(k)/amk(k) + + do n = 1, N_MASS_EQVS + totem( ixadv_eqv(n) ) = totem( ixadv_eqv(n) ) + & + rcemis( qrc_eqv(n),k) * scaling_k + 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_fraction(i,j) - ice_fraction(i,j) + +! initialize, needed in My_Reactions + rc_Rn222(:)=0.0 + +! z_bnd is in m, not cm, so need to divide by 100. + rc_Rn222(KMAX_MID) = & + ( 0.00182 * water_fraction(i,j) + eland ) / & + ((z_bnd(i,j,KMAX_BND-1) - z_bnd(i,j,KMAX_BND))*100.) + + end subroutine setup_rcemis + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine setup_bio(i,j) + ! + !---- assign isoprene rates ------------------------------------------------ + ! + ! So far, assigns isoprene using surface (2m) temperature, and for all + ! zenith angles <90. Should include light dependance at some stage + ! + ! Output : rcbio - isoprene emissions for 1d column + ! + ! Called from setup_ml, every advection step. + !---------------------------------------------------------------------------- + +! input + integer, intent(in) :: i,j + +! local + logical, parameter :: DEBUG_BIO = .false. + integer la,it2m,n,k,base,top,iclcat + real clear + + ! Light effects added for isoprene emissions + + real :: par ! Photosynthetically active radiation + real :: cL ! Factor for light effects + real, parameter :: & + CL1 = 1.066 , & ! Guenther et al's params + ALPHA = 0.0027 ! Guenther et al's params + + if ( NBVOC == 0 ) return ! e.g. for ACID only + + + + it2m = nint(t2_nwp(i,j,1)-273.15-1.E-9) +! the "-1.E-9" is put in order to avoid possible different roundings on different machines. + it2m = max(it2m,1) + it2m = min(it2m,40) + + rcbio(BIO_TERP,KMAX_MID) = emnat(i,j,BIO_TERP)*canopy_ecf(BIO_TERP,it2m) + + ! Isoprene has emissions in daytime only: + rcbio(BIO_ISOP,:) = 0.0 + if ( Grid%izen <= 90) then + + ! Light effects from Guenther G93 + par = (Idirect(i,j) + Idiffuse(i,j)) * PARfrac * Wm2_uE + cL = ALPHA * CL1 * par/ sqrt( 1 + ALPHA*ALPHA * par*par) + + rcbio(BIO_ISOP,KMAX_MID) = emnat(i,j,BIO_ISOP) & + * canopy_ecf(BIO_ISOP,it2m) * cL + endif + if ( DEBUG_BIO .and. debug_proc .and. i==debug_li .and. j==debug_lj .and. & + current_date%seconds == 0 ) then + write(*,"(a5,2i4,4es12.3)") "DBIO ", current_date%day, & + current_date%hour, par, cL, emnat(i,j,BIO_ISOP), rcbio(BIO_ISOP,KMAX_MID) + end if + + end subroutine setup_bio + + !---------------------------------------------------------------------------- + subroutine reset_3d(i,j) + + integer, intent(in) :: i,j + integer :: k, n, ispec, irc ! loop variables + + + do k = KCHEMTOP, KMAX_MID + + + ! 1)/ Short-lived species - no need to scale with M + + do n = 1, NSPEC_SHL + xn_shl(n,i,j,k) = xn_2d(n,k) + end do ! ispec + + ! 2)/ Advected species + + do n = 1, NSPEC_ADV + ispec = NSPEC_SHL + n + xn_adv(n,i,j,k) = xn_2d(ispec,k)/amk(k) + end do ! ispec + + end do ! k + + end subroutine reset_3d + !--------------------------------------------------------------------------- + +end module Setup_1d_ml +!_____________________________________________________________________________! diff --git a/Setup_1dfields_ml.f90 b/Setup_1dfields_ml.f90 new file mode 100644 index 0000000..57c74a5 --- /dev/null +++ b/Setup_1dfields_ml.f90 @@ -0,0 +1,75 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Setup_1dfields_ml + + ! 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 + use My_Emis_ml, only : NRCEMIS, NSS, NBVOC !NSS=SeaS + use GenSpec_tot_ml, only : NSPEC_TOT + use GenSpec_bgn_ml, only : NSPEC_COL + use GenRates_rct_ml, only : NRCT + use GenRates_rcmisc_ml, only : NRCMISC + implicit none + private + + + !/ variables to keep track of which call + + logical, public, save :: first_call = .true. + integer, public, save :: ncalls = 0 + + !/-- the chemistry is calculated for arrays of size: + + integer, public, parameter :: CHEMSIZE = KMAX_MID-KCHEMTOP+1 ! + + real, public, dimension(NSPEC_TOT,KCHEMTOP:KMAX_MID), save :: & + xn_2d ! Concentrations [molecules/cm3] + + real, public, dimension(NRCEMIS,KCHEMTOP:KMAX_MID), save :: rcemis !emissions + real, public, dimension(NRCT ,KCHEMTOP:KMAX_MID), save :: rct ! T-dependant + real, public, dimension(NRCMISC,KCHEMTOP:KMAX_MID), save :: rcmisc ! T,M,H2O-dependant + real, public, dimension(NBVOC ,KCHEMTOP:KMAX_MID), save :: rcbio ! Biogenic emissions + real, public, dimension(KCHEMTOP:KMAX_MID), save :: rc_Rn222 ! 210Pb emissions, ds Pb210 + real, public, dimension(NSS,KCHEMTOP:KMAX_MID), save :: rcss ! Sea salt emissions + + real, public, dimension(KCHEMTOP:KMAX_MID), save :: & + rh & ! RH (fraction, 0-1) + ,amk & ! M - atmospheric conc. + ,temp & ! temperature + ,pp !pressure + integer, public, dimension(KCHEMTOP:KMAX_MID), save :: & + itemp ! int of temperature + + end module Setup_1dfields_ml diff --git a/Sites_ml.f90 b/Sites_ml.f90 new file mode 100644 index 0000000..17b7bc4 --- /dev/null +++ b/Sites_ml.f90 @@ -0,0 +1,727 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Sites_ml + +! ----------------------------------------------------------------------- +! Contains subroutines to read in list of measurement stations and/or +! radiosonde locations. Locations should be specified in the input +! files "sites.dat" and "sondes.dat" +! +! ----------------------------------------------------------------------- + +use CheckStop_ml, only : CheckStop +use My_Outputs_ml, only : & ! for sitesout + NSITES_MAX, & + NADV_SITE, NSHL_SITE, NXTRA_SITE, & + SITE_ADV, SITE_SHL, SITE_XTRA, SITE_XTRA_INDEX, & + FREQ_SITE, NSONDES_MAX, NLEVELS_SONDE, & + NADV_SONDE, NSHL_SONDE, NXTRA_SONDE, N_NOy, & + SONDE_ADV, SONDE_SHL, SONDE_XTRA, SONDE_XTRA_INDEX, & + FREQ_SONDE, NOy_SPEC + +use Derived_ml, only : d_2d, d_3d, IOU_INST ! for deriv system +use Functions_ml, only : Tpot_2_T ! Conversion function +use GridValues_ml, only : sigma_bnd, sigma_mid, lb2ij, i_fdom, j_fdom & + , i_local, j_local +use Io_ml, only : check_file,open_file,ios & + , fexist, IO_SITES, IO_SONDES & + , Read_Headers,read_line +use GenSpec_adv_ml +use GenSpec_shl_ml, only : NSPEC_SHL +use GenChemicals_ml, only : species ! for species names +use GenSpec_tot_ml, only : SO4, HCHO, CH3CHO & ! for mol. wts. + ,aNO3, pNO3, aNH4, PM25, PMCO & + ,SSfi, SSco !SeaS +use Met_ml, only : t2_nwp, th, pzpbl & ! Output with concentrations + , z_bnd, z_mid, roa, xksig, u, v, ps, q +use ModelConstants_ml, only : NMET,PPBINV,PPTINV, KMAX_MID & + ,KMAX_BND,PT,ATWAIR, NPROC & + ,DomainName, RUNDOMAIN +use Par_ml, only : li0,lj0,li1,lj1 & + ,GIMAX,GJMAX & + ,GI0,GI1,GJ0,GJ1,me,MAXLIMAX,MAXLJMAX +use Tabulations_ml, only : tab_esat_Pa +use TimeDate_ml, only : current_date +use KeyValue_ml, only : KeyVal, KeyValue, LENKEYVAL + +implicit none +private ! stops variables being accessed outside + + +! subroutines made available + +public :: sitesdef ! Calls Init_sites for sites and sondes +public :: siteswrt_surf ! Gets site data ready for siteswrt_out +public :: siteswrt_sondes ! Gets sonde data ready for siteswrt_out +private :: Init_sites ! reads locations, species +private :: set_species ! Sets species/variable names for output +private :: siteswrt_out ! Collects output from all nodes and prints + + +! some variables used in following subroutines + +INCLUDE 'mpif.h' +INTEGER STATUS(MPI_STATUS_SIZE),INFO +integer, private, save :: nglobal_sites, nlocal_sites +integer, private, save :: nglobal_sondes, nlocal_sondes + +! 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, dimension (NSITES_MAX) :: & + site_gx, site_gy, site_gz & ! global coordinates + , site_x, site_y, site_z & ! local coordinates + , site_n ! number in global +integer, private, save, dimension (NSONDES_MAX) :: & + sonde_gx, sonde_gy & ! global coordinates + , sonde_x, sonde_y & ! local coordinates + , sonde_n ! number in global + +! Values from My_Outputs_ml gives ... => + +integer, public, parameter :: & + NOUT_SITE = NADV_SITE + NSHL_SITE + NXTRA_SITE & ! Total No. + ,NOUT_SONDE = NLEVELS_SONDE * ( NADV_SONDE + NSHL_SONDE+ NXTRA_SONDE ) + +character(len=50), private, save, dimension (NSITES_MAX) :: site_name +character(len=50), private, save, dimension (NSONDES_MAX):: sonde_name +character(len=20), private, save, & + dimension (NADV_SITE+NSHL_SITE+NXTRA_SITE) :: site_species +character(len=20), private, save, & + dimension (NADV_SONDE+NSHL_SONDE+NXTRA_SONDE) :: sonde_species + +character(len=40), private :: errmsg ! Message text +integer, private :: d ! processor index +integer, private :: i, n, nloc, ioerr ! general integers + +! Debugging parameter: +logical, private, parameter :: MY_DEBUG = .false. + +contains + + +!==================================================================== > + subroutine sitesdef() + + ! ------------------------------------------------------------------------- + ! reads in sites.dat and sondes.dat (if present), assigns sites to + ! local domains, and collects lists of sites/species/variables for output. + ! ------------------------------------------------------------------------- + + ! Dummy arrays + integer, save, dimension (NSONDES_MAX) :: & + sonde_gz, sonde_z ! global coordinates + sonde_gz(:) = 0 + sonde_z(:) = 0 + + call Init_sites("sites",IO_SITES,NSITES_MAX, & + nglobal_sites,nlocal_sites, & + site_gindex, site_gx, site_gy, site_gz, & + site_x, site_y, site_z, site_n, & + site_name) + + call Init_sites("sondes",IO_SONDES,NSONDES_MAX, & + nglobal_sondes,nlocal_sondes, & + sonde_gindex, sonde_gx, sonde_gy, sonde_gz, & + sonde_x, sonde_y, sonde_z, sonde_n, & + sonde_name) + + call set_species(SITE_ADV,SITE_SHL,SITE_XTRA,site_species) + call set_species(SONDE_ADV,SONDE_SHL,SONDE_XTRA,sonde_species) + + if ( MY_DEBUG ) then + write(6,*) "sitesdef After nlocal ", nlocal_sites, " on me ", me + do i = 1, nlocal_sites + write(6,*) "sitesdef After set_species x,y ", & + site_x(i), site_y(i),site_z(i), " on me ", me + end do + end if ! DEBUG + + end subroutine sitesdef + + +!==================================================================== > + subroutine set_species(adv,shl,xtra,s) + + ! --------------------------------------------------------------------- + ! Makes a character array "s" containg the names of the species or + ! meteorological parameters to be output. Called for sites and sondes. + ! --------------------------------------------------------------------- + + integer, intent(in), dimension(:) :: adv, shl ! Arrays of indices wanted + character(len=*), intent(in), & + dimension(:) :: xtra !Names of extra params + character(len=*),intent(out), dimension(:) :: s + + integer :: nadv, nshl, n2, nout ! local sizes + nadv = size(adv) + nshl = size(shl) + n2 = nadv + nshl + nout = size(s) ! Size of array to be returned + + s(1:nadv) = species( NSPEC_SHL + adv(:) )%name + s(nadv+1:n2) = species( shl(:) )%name + s(n2+1:nout) = xtra(:) + + end subroutine set_species + + +!==================================================================== > + subroutine Init_sites(fname,io_num,NMAX, nglobal,nlocal, & + s_gindex, s_gx, s_gy, s_gz, s_x, s_y, s_z, s_n, s_name) + + ! ---------------------------------------------------------------------- + ! Reads the file "sites.dat" and "sondes.dat" to get coordinates of + ! surface measurement stations or locations where vertical profiles + ! or extra output are required. (These files may be empty, but this is + ! not recommended - the sites data provide good diagnostics). + ! + ! define whether a certain output site belongs to the given processor + ! and assign the local coordinates + ! ---------------------------------------------------------------------- + ! NB. global below refers to all nodes (full-domain) + ! local below refers to the local node + + character(len=*), intent(in) :: fname + integer, intent(in) :: io_num + integer, intent(in) :: NMAX ! Max no. sites + integer, intent(out) :: nglobal, nlocal ! No. sites + integer, intent(out), dimension (0:,:) :: s_gindex ! index, starts at me=0 + integer, intent(out), dimension (:) :: & + s_gx, s_gy, s_gz & ! global coordinates + , s_x, s_y, s_z & ! local coordinates + , s_n ! number in global + character(len=*), intent(out), dimension (:) :: s_name + + !-- Local: + integer, dimension (NMAX) :: s_n_recv ! number in global + + integer :: nin ! loop index + integer :: ix, iy ! coordinates read in + integer :: lev ! vertical coordinate (20=ground) + character(len=20) :: s ! Name of site read in + character(len=30) :: comment ! comment on site location + character(len=40) :: infile, errmsg + real :: lat,lon,x,y + + character(len=20), dimension(4) :: Headers + type(KeyVal), dimension(20) :: KeyValues ! Info on units, coords, etc. + integer :: NHeaders, NKeys, Nlines + character(len=80) :: txtinput ! Big enough to contain + ! one full input record + + ios = 0 ! zero indicates no errors + errmsg = "ios error" // infile + + if (me == 0) then + infile = fname // ".dat" + call check_file(infile,fexist,needed=.false.,errmsg=errmsg) + if ( .not. fexist ) return + call open_file(io_num,"r",infile,needed=.true.) + call CheckStop(ios,"ios error on "//trim(infile)) + end if + + call CheckStop(NMAX,size(s_name), & + "Error in Sites_ml/Init_sites: sitesdefNMAX problem") + + call Read_Headers(io_num,errmsg,NHeaders,NKeys,Headers,Keyvalues) + + + ! First, see which sites are within full domain: + + n = 0 ! Number of sites found within domain + SITELOOP: do nin = 1, NMAX + + if (trim(KeyValue(KeyValues,"Coords"))=='LatLong') then + call read_line(io_num,txtinput,ios) + if ( ios /= 0 ) exit ! End of file + read(unit=txtinput,fmt=*) s, lat, lon, lev + call lb2ij(lon,lat,x,y) + ix=nint(x) + iy=nint(y) + else + call read_line(io_num,txtinput,ios) + if ( ios /= 0 ) exit ! End of file + read(unit=txtinput,fmt=*) s, ix, iy, lev + endif + + if (ioerr < 0) then + write(6,*) "sitesdef : end of file after ", nin-1, infile + exit SITELOOP + end if ! ioerr + + + if ( ix < RUNDOMAIN(1) .or. ix > RUNDOMAIN(2) .or. & + iy < RUNDOMAIN(3) .or. iy > RUNDOMAIN(4) ) then + if(me==0) write(6,*) "sitesdef: ", s, ix, iy, & + " outside computational domain" + else if ( ix == RUNDOMAIN(1) .or. ix == RUNDOMAIN(2) .or. & + iy == RUNDOMAIN(3) .or. iy == RUNDOMAIN(4) ) then + if(me==0) write(6,*) "sitesdef: ", s, ix, iy, & + " on computational domain" + else + comment = " ok - inside domain " + n = n + 1 + s_gx(n) = ix + s_gy(n) = iy + s_gz(n) = lev + + s_name(n) = s // comment + + endif + + end do SITELOOP + + nglobal = n + + ! NSITES/SONDES_MAX must be _greater_ than the number used, for safety + + call CheckStop(n >= NMAX, & + "Error in Sites_ml/Init_sites: increaseNGLOBAL_SITES_MAX!") + + if(me==0) close(unit=io_num) + + nlocal = 0 + + do n = 1, nglobal + + ix = s_gx(n) ! global-domain coords + iy = s_gy(n) + + if ( i_local(ix) >= li0 .and. i_local(ix) <= li1 .and. & + j_local(iy) >= lj0 .and. j_local(iy) <= lj1 ) then + + nlocal = nlocal + 1 + s_x(nlocal) = i_local(ix) + s_y(nlocal) = j_local(iy) + s_z(nlocal) = s_gz(n) + s_n(nlocal) = n + + if (MY_DEBUG) then + write(6,*) "sitesdef Site on me : ", me, " No. ", nlocal, & + s_gx(n), s_gy(n) , s_gz(n), " => ", & + s_x(nlocal), s_y(nlocal), s_z(nlocal) + end if + + endif + + end do ! nglobal + + ! inform me=0 of local array indices: + if (MY_DEBUG) write(6,*) "sitesdef ", fname, " before gc NLOCAL_SITES", & + me, nlocal + + if ( me /= 0 ) then + CALL MPI_SEND(nlocal, 4*1, MPI_BYTE, 0, 333, MPI_COMM_WORLD, INFO) + if (nlocal > 0) & + CALL MPI_SEND(s_n, 4*nlocal, MPI_BYTE, 0, 334, MPI_COMM_WORLD, INFO) + else + if (MY_DEBUG) write(6,*) "sitesdef for me =0 OCAL_SITES", me, nlocal + do n = 1, nlocal + s_gindex(me,n) = s_n(n) + end do + do d = 1, NPROC-1 + CALL MPI_RECV(nloc, 4*1, MPI_BYTE, d, & + 333, MPI_COMM_WORLD,STATUS, INFO) + if (nloc > 0) & + CALL MPI_RECV(s_n_recv, 4*nloc, MPI_BYTE, d, & + 334, MPI_COMM_WORLD,STATUS, INFO) + if (MY_DEBUG) write(6,*) "sitesdef: recv d ", fname, d, & + " zzzz nloc : ", nloc, " zzzz me0 nlocal", nlocal + do n = 1, nloc + s_gindex(d,n) = s_n_recv(n) + if ( MY_DEBUG ) write(6,*) "sitesdef: for d =", fname, d, & + " nloc = ", nloc, " n: ", n, " gives nglob ", s_gindex(d,n) + end do ! n + end do ! d + end if ! me + + if ( MY_DEBUG ) write(6,*) 'sitesdef on me', me, ' = ', nlocal + +end subroutine Init_sites + + +!==================================================================== > + subroutine siteswrt_surf(xn_adv,cfac,xn_shl) + + ! --------------------------------------------------------------------- + ! writes out just simple concentrations for now.... + ! will be improved later to allow choice of output parameter + ! should look at chemint also - seems similar for somethings + ! --------------------------------------------------------------------- + + ! arguments + real, dimension(NSPEC_ADV,MAXLIMAX,MAXLJMAX,KMAX_MID), intent(in) :: xn_adv + real, dimension(NSPEC_ADV,MAXLIMAX,MAXLJMAX), intent(in) :: cfac + real, dimension(NSPEC_SHL,MAXLIMAX,MAXLJMAX,KMAX_MID), intent(in) :: xn_shl + + ! Local + integer :: nglob, nloc, ix, iy,iz, ispec ! Site indices + integer :: nn ! species index + logical, save :: my_first_call = .true. ! for debugging + integer :: d2index ! index for d_2d field access + + real,dimension(NOUT_SITE,NSITES_MAX) :: out ! for output, local node + + if ( MY_DEBUG ) then + write(6,*) "sitesdef Into surf nlocal ", nlocal_sites, " on me ", me + do i = 1, nlocal_sites + write(6,*) "sitesdef Into surf x,y ",site_x(i),site_y(i),& + site_z(i)," me ", me + end do + + if ( me == 0 ) then + write(6,*) "======= site_gindex ======== sitesdef ============" + do n = 1, nglobal_sites + write(6,'(a12,i4, 2x, 8i4)') "sitesdef ", n, & + (site_gindex(d,n),d=0, NPROC-1) + end do + write(6,*) "======= site_end ======== sitesdef ============" + end if ! me = 0 + end if ! MY_DEBUG + + ! assign local data to out + + do i = 1, nlocal_sites + ix = site_x(i) + iy = site_y(i) + iz = site_z(i) + + do ispec = 1, NADV_SITE + if (iz == KMAX_MID ) then ! corrected to surface + out(ispec,i) = xn_adv( SITE_ADV(ispec) ,ix,iy,KMAX_MID ) * & + cfac( SITE_ADV(ispec),ix,iy) * PPBINV + else ! Mountain sites not corrected to surface + out(ispec,i) = xn_adv( SITE_ADV(ispec) ,ix,iy,iz ) * PPBINV + end if + end do + + my_first_call = .false. + + do ispec = 1, NSHL_SITE + out(NADV_SITE+ispec,i) = xn_shl( SITE_SHL(ispec) ,ix,iy,iz ) + end do + + ! then print out XTRA stuff, usually the temmp + ! or pressure + ! SITE_XTRA=(/ "th ", "hmix", "Vg_ref", "Vg_1m", "Vg_sto", "Flux_ref", "Flux_sto" /) + + do ispec = 1, NXTRA_SITE + nn = NADV_SITE + NSHL_SITE + ispec + select case ( SITE_XTRA(ispec) ) + case ( "T2" ) + out(nn,i) = t2_nwp(ix,iy,1) - 273.15 + case ( "th" ) + out(nn,i) = th(ix,iy,iz,1) + case ( "hmix" ) + out(nn,i) = pzpbl(ix,iy) + + case ( "D2D" ) + d2index = SITE_XTRA_INDEX(ispec) + out(nn,i) = d_2d(d2index,ix,iy,IOU_INST) + end select + call CheckStop( abs( out(nn,i) ) > 1.0e99, "ABS(SITES OUT) TOO BIG" ) + end do + end do + + ! collect data into gout on me=0 t + + call siteswrt_out("sites",IO_SITES,NOUT_SITE,NSITES_MAX, FREQ_SITE, & + nglobal_sites,nlocal_sites, & + site_gindex,site_name,site_gx,site_gy,site_gz,& + site_species,out) + +end subroutine siteswrt_surf + + +!==================================================================== > + subroutine siteswrt_sondes(xn_adv,xn_shl) + + ! ------------------------------------------------------------------- + ! Writes vertical concentration data to files. + ! IO_SONDES is set in io_ml to be 30 + ! ------------------------------------------------------------------- + + real, dimension(:,:,:,:), intent(in) :: xn_adv + real, dimension(:,:,:,:), intent(in) :: xn_shl + + ! Output variables - none + + ! Local variables + integer :: n, i, ii, k, ix, iy, nn, ispec ! Site and chem indices + integer :: d3index !ds index for d_3d field access + integer, parameter :: KTOP_SONDE = KMAX_MID - NLEVELS_SONDE + 1 + integer, dimension(NLEVELS_SONDE) :: itemp + real, dimension(KMAX_MID) :: pp, temp, qsat, rh, sum_PM25 & + , sum_PMco, sum_NOy + real, dimension(NOUT_SONDE,NSONDES_MAX) :: out + + ! Consistency check + + do ispec = 1, NXTRA_SONDE + select case ( SONDE_XTRA(ispec) ) + case ( "PM25 " ,"PMco " , "NOy ", "RH ","z_mid", "p_mid", & + "xksig ", "th ", "U ", "V " ) + errmsg = "ok" + case default + call CheckStop("Error, Sites_ml/siteswrt_sondes: SONDE_XTRA:"& + // SONDE_XTRA(ispec)) + end select + end do + + do i = 1, nlocal_sondes + n = sonde_n(i) + ix = sonde_x(i) + iy = sonde_y(i) + nn = 0 + + ! collect and print out with ground-level (KMAX_MID) first, hence & + ! KMAX_MID:KTOP_SONDE:-1 in arrays + ! first the advected and short-lived species + + do ispec = 1, NADV_SONDE !/ xn_adv in ppb + out(nn+1:nn+NLEVELS_SONDE,i) = PPBINV * & + xn_adv( SONDE_ADV(ispec) , ix,iy,KMAX_MID:KTOP_SONDE:-1) + nn = nn + NLEVELS_SONDE + end do + + do ispec = 1, NSHL_SONDE !/ xn_shl in molecules/cm3 + out(nn+1:nn+NLEVELS_SONDE,i) = xn_shl( SONDE_SHL(ispec) , & + ix,iy,KMAX_MID:KTOP_SONDE:-1) + nn = nn + NLEVELS_SONDE + end do + + ! then print out XTRA stuff first, + ! usually the height or pressure + + do ispec = 1, NXTRA_SONDE + + select case ( SONDE_XTRA(ispec) ) + + case ( "PM25" ) !! PM data converted to ug m-3 + sum_PM25(:) = 0. + do k = 1, KMAX_MID + sum_PM25(k) = & + ( xn_adv(IXADV_SO4,ix,iy,k) *species(SO4)%molwt & + + xn_adv(IXADV_aNO3,ix,iy,k)*species(aNO3)%molwt & + + xn_adv(IXADV_aNH4,ix,iy,k)*species(aNH4)%molwt & + + xn_adv(IXADV_PM25,ix,iy,k)*species(PM25)%molwt & + + xn_adv(IXADV_SSfi,ix,iy,k)*species(SSfi)%molwt ) & !SeaS + * roa(ix,iy,k,1) /ATWAIR + end do + out(nn+1:nn+KMAX_MID,i) = PPBINV & + * sum_PM25(KMAX_MID:1:-1) + + case ( "PMco" ) !! PM data converted to ug m-3 + sum_PMco(:) = 0. + do k = 1, KMAX_MID + sum_PMco(k) = & + ( xn_adv(IXADV_pNO3,ix,iy,k) * species(pNO3)%molwt & + + xn_adv(IXADV_PMco,ix,iy,k) * species(PMCO)%molwt & + + xn_adv(IXADV_SSco,ix,iy,k) * species(SSco)%molwt ) & !SeaS + * roa(ix,iy,k,1) /ATWAIR + end do + out(nn+1:nn+KMAX_MID,i) = PPBINV & + * sum_PMco(KMAX_MID:1:-1) + + case ( "NOy" ) + sum_NOy(:) = 0. + do k = 1, KMAX_MID + do ii = 1, N_NOy + sum_NOy(k) = sum_NOy(k) + xn_adv(NOy_SPEC(ii),ix,iy,k) + end do + end do + out(nn+1:nn+KMAX_MID,i) = PPBINV & + * sum_NOy(KMAX_MID:1:-1) + + case ( "RH " ) + do k = 1,KMAX_MID + pp(k) = PT + sigma_mid(k)*(ps(ix,iy,1) - PT) + temp(k) = th(ix,iy,k,1)* Tpot_2_T( pp(k) ) + itemp(k) = nint( temp(k) ) + qsat(k) = 0.622 * tab_esat_Pa( itemp(k) ) / pp(k) + rh(k) = min( q(ix,iy,k,1)/qsat(k) , 1.0) + end do + out(nn+1:nn+NLEVELS_SONDE,i) = rh(KMAX_MID:KTOP_SONDE:-1) + + case ( "z_mid" ) + out(nn+1:nn+NLEVELS_SONDE,i) = z_mid(ix,iy,KMAX_MID:KTOP_SONDE:-1) + + case ( "p_mid" ) + out(nn+1:nn+NLEVELS_SONDE,i) = PT + sigma_mid(KMAX_MID:KTOP_SONDE:-1) & + *(ps(ix,iy,1) - PT) + + case ( "xksig" ) + out(nn+1:nn+NLEVELS_SONDE,i) = xksig(ix,iy,KMAX_MID:KTOP_SONDE:-1) + + case ( "th" ) + out(nn+1:nn+NLEVELS_SONDE,i) = th(ix,iy,KMAX_MID:KTOP_SONDE:-1,1) + + case ( "U" ) + out(nn+1:nn+NLEVELS_SONDE,i) = 0.5*( u(ix,iy,KMAX_MID:KTOP_SONDE:-1,1) & + +u(ix-1,iy,KMAX_MID:KTOP_SONDE:-1,1) ) + + case ( "V" ) + out(nn+1:nn+NLEVELS_SONDE,i) = 0.5*( v(ix,iy,KMAX_MID:KTOP_SONDE:-1,1) & + +v(ix,iy-1,KMAX_MID:KTOP_SONDE:-1,1) ) + + case ( "D3D" ) + d3index = SONDE_XTRA_INDEX(ispec) + out(nn+1:nn+NLEVELS_SONDE,i)= & + d_3d(d3index,ix,iy,KMAX_MID:KTOP_SONDE:-1,IOU_INST) + + end select + + nn = nn + NLEVELS_SONDE + + end do ! ispec (NXTRA_SONDE) + + end do ! i (nlocal_sondes) + + + ! collect data into gout on me=0 t + + call siteswrt_out("sondes",IO_SONDES,NOUT_SONDE,NSONDES_MAX, FREQ_SONDE, & + nglobal_sondes,nlocal_sondes, & + sonde_gindex,sonde_name,sonde_gx,sonde_gy,sonde_gy, & + sonde_species,out) + +end subroutine siteswrt_sondes + + +!==================================================================== > + subroutine siteswrt_out(fname,io_num,nout,nsites,f,nglobal,nlocal, & + s_gindex,s_name,s_gx,s_gy,s_gz,s_species,out) + + ! ------------------------------------------------------------------- + ! collects data from local nodes and writes out to sites/sondes.dat + ! ------------------------------------------------------------------- + + character(len=*), intent(in) :: fname + integer, intent(in) :: io_num, nout, nsites + integer, intent(in) :: f ! Frequency of write-out (hours) + integer, intent(in) :: nglobal, nlocal + integer, intent(in), dimension (0:,:) :: s_gindex ! index, starts at me=0 + character(len=*), intent(in), dimension (:) :: s_name ! site/sonde name + integer, intent(in), dimension (:) :: s_gx, s_gy, s_gz ! coordinates + character(len=*), intent(in), dimension (:) :: s_species ! Variable names + real, intent(in), dimension(:,:) :: out ! outputs, local node + + ! Local + real,dimension(nout,nglobal) :: g_out ! for output, collected + integer :: nglob, nloc, ix, iy ! Site indices + character(len=40) :: outfile + character(len=4) :: suffix + integer, parameter :: NTYPES = 2 ! No. types, now 2 (sites, sondes) + integer :: type ! = 1 for sites, 2 for sondes + integer, save, dimension(NTYPES):: prev_month = (/ -99, -99 /) ! Initialise + + select case (fname) + case ("sites" ) + type = 1 + case ("sondes" ) + type = 2 + case default + write(6,*) "non-possible tpye in siteswrt_out for ", fname + return + end select + + if (me == 0 .and. current_date%month /= prev_month(type) ) then + + if ( prev_month(type) > 0 ) close(io_num) ! Close last-months file + + ! Open new file for write-out + + write(suffix,fmt="(2i2.2)") current_date%month, modulo ( current_date%year, 100 ) + outfile = fname // "." // suffix + open(file=outfile,unit=io_num,action="write") + prev_month(type) = current_date%month + + 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,3i4)") s_name(n), s_gx(n), s_gy(n),s_gz(n) + end do ! nglobal + + write(io_num,"(i3,a)") size(s_species), " Variables:" + do n = 1, size(s_species) + write(io_num,"(i3,2x,a)") n, s_species(n) + end do + + endif ! New month + + if ( me /= 0 ) then ! send data to me=0 + + CALL MPI_SEND(nlocal, 4*1, MPI_BYTE, 0, 346, MPI_COMM_WORLD, INFO) + CALL MPI_SEND(out, 8*nout*nlocal, MPI_BYTE, 0, 347, MPI_COMM_WORLD, INFO) + + else ! me = 0 + + ! first, assign me=0 local data to g_out + if ( MY_DEBUG ) print *, "ASSIGNS ME=0 NLOCAL_SITES", me, nlocal + + do n = 1, nlocal + nglob = s_gindex(0,n) + g_out(:,nglob) = out(:,n) + end do ! n + + do d = 1, NPROC-1 + CALL MPI_RECV(nloc, 4*1, MPI_BYTE, d, & + 346, MPI_COMM_WORLD,STATUS, INFO) + CALL MPI_RECV(out, 8*nout*nloc, MPI_BYTE, d, 347, MPI_COMM_WORLD, STATUS, INFO) + do n = 1, nloc + nglob = s_gindex(d,n) + g_out(:,nglob) = out(:,n) + end do ! n + end do ! d + + ! some computers print out e.g. "2.23-123" instead of "2.23e-123" + ! when numbes get too small. Here we make a correction for this: + where( abs(g_out) > 0.0 .and. abs(g_out) < 1.0e-99 ) + g_out = 0.0 + end where + + ! Final output + do n = 1, nglobal + write(unit=io_num, fmt="(a20,i5,3i3,i5)" ) & + s_name(n), current_date + write(unit=io_num, fmt="(5es11.3)" ) g_out(:,n) + end do ! n + + end if ! me + + end subroutine siteswrt_out + + +!==================================================================== > +end module Sites_ml diff --git a/SmallUtils_ml.f90 b/SmallUtils_ml.f90 new file mode 100644 index 0000000..6706492 --- /dev/null +++ b/SmallUtils_ml.f90 @@ -0,0 +1,291 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 SmallUtils_ml + +!_____________________________________________________________________________ +! -- small utility provides routines to process text strings, +! find array indices, write arrays. +! +! Dave Simpson, 1999-2007 +! Language: F-complaint, except system calls in Self_Test +! (Can be run with F is test-input file created manually +! and system calls commented out, as here) +!_____________________________________________________________________________ + implicit none + + ! -- subroutines in this module: + + public :: wordsplit ! Splits input text into words + public :: LenArray ! count No. set strings in array + public :: AddArray ! Adds new char array to old + public :: WriteArray ! Writes out char array, one element per line + public :: find_index ! Finds index of item in list + public :: find_indices ! Finds indices of arrays of items in list + public :: Self_Test ! For testing + + private :: find_index_c, find_index_i + + integer, public, parameter :: NOT_FOUND = -999 + character(len=*), public, parameter :: NOT_SET_STRING = "NOT_SET" + + interface find_index + module procedure find_index_c ! For character arrays + module procedure find_index_i ! For integer arrays + end interface find_index + +contains + + !=========================================================================== + + subroutine wordsplit(text,nword_max,wordarray,nwords,errcode) + !************************************************************** + ! Subroutine takes in a character string and splits it into + ! a word-array, of length nwords + ! Both spaces and commas are treated as seperators + !************************************************************** + + !-- arguments + character(len=*), intent(in) :: text ! to be split + integer, intent(in) :: nword_max ! Max. no. words expected + + character(len=*), dimension(:), intent(out) :: wordarray + integer, intent(out) :: nwords ! No. words found + integer, intent(out) :: errcode ! No. words found + + !-- local + logical :: wasinword ! true if we are in or have just left a word + integer :: i, is, iw + character(len=1) :: c + + errcode = 0 + wasinword = .false. !To be safe, with spaces at start of line + is = 0 ! string index + iw = 1 ! Word index + wordarray(1) = "" + + do i = 1, len_trim(text) + c = text(i:i) + if( c /= " " .and. c /= "," ) then + is = is + 1 + wordarray(iw)(is:is) = c + wasinword = .true. + else + if ( wasinword ) then + iw = iw + 1 + wordarray(iw) = "" + wasinword = .false. + is = 0 + endif + endif + enddo + nwords = iw + if ( nwords >= nword_max ) then + errcode = 2 + print *, "ERROR in WORDSPLIT : Problem at ", text + print *,"Too many words" + endif + + end subroutine wordsplit + + !============================================================================ + function LenArray(a,notset) result (N) + !+ Counts number of elements in a which are not equal to notset string + character(len=*), dimension(:), intent(in) :: a + character(len=*), intent(in) :: notset + integer :: N, i + + N=0 + do i = 1, size(a) + if ( index(a(i),notset) > 0 ) then + exit + end if + N=N+1 + end do + end function LenArray + !============================================================================ + subroutine AddArray(new,old,notset) + !+ Adds elements from new array to old array + character(len=*), dimension(:), intent(in) :: new + character(len=*), dimension(:), intent(inout) :: old + character(len=*), intent(in) :: notset + integer :: N, i + + N = LenArray(old,notset) ! Find last set element + do i = 1, size(new) + N = N + 1 + !print *, "ADDING A ", i, N, new(i) + old(N) = new(i) + end do + end subroutine AddArray + !============================================================================ + subroutine WriteArray(list,NList,txt,io_num) + character(len=*), dimension(:), intent(in) :: list + integer, intent(in) :: Nlist + character(len=*), intent(in) :: txt ! Some descriptive text + integer, intent(in), optional :: io_num + integer :: io, i + + io = 6 + if ( present(io_num) ) then + io = io_num + end if + + if ( NList > size(list) ) then + write(unit=*,fmt=*) "WRITEARRAY PROBLEM Nlist, size(List) ", & + Nlist, size(list) + return + end if + do i = 1, Nlist + write(unit=io,fmt=*) txt, i, list(i) + end do + end subroutine WriteArray + !============================================================================ + ! A series of find_index routines, for character (c) and integer (i) arrays: + !============================================================================ + function find_index_c(wanted, list) result(Index) + character(len=*), intent(in) :: wanted + character(len=*), dimension(:), intent(in) :: list +! Output: + integer :: Index + + integer :: n_match ! Count for safety + integer :: n + + n_match = 0 + Index = NOT_FOUND + + do n = 1, size(list) + + if ( wanted == list(n) ) then + Index = n + n_match = n_match + 1 + end if + end do + + if ( n_match > 1 ) then !! Too many! + n_match = -1 * n_match + end if + end function find_index_c + + !============================================================================ + function find_index_i(wanted, list) result(Index) + integer, intent(in) :: wanted + integer, dimension(:), intent(in) :: list +! Output: + integer :: Index ! + + integer :: n_match ! Count for safety + integer :: n + + n_match = 0 + Index = NOT_FOUND + + do n = 1, size(list) + + if ( wanted == list(n) ) then + Index = n + n_match = n_match + 1 + end if + end do + + if ( n_match > 1 ) then !! Too many! + n_match = -1 * n_match + end if + + end function find_index_i + +!======================================================================= + function find_indices(wanted, list) result(Indices) + character(len=*), dimension(:), intent(in) :: wanted + character(len=*), dimension(:), intent(in) :: list +! Output: + integer, dimension(size(wanted)) :: Indices + + integer :: w, n + + Indices(:) = NOT_FOUND + + do w = 1, size(wanted) + do n = 1, size(list) + + if ( trim ( wanted(w) ) == trim ( list(n) ) ) then + Indices(w) = n + end if + end do + end do + + end function find_indices + + !============================================================================ + subroutine Self_test() + + character(len=100) :: text = "Here is a line,split by spaces: note, commas don't work" + character(len=5), dimension(5) :: headers = (/ "yy", "mm", & + "dd", "x1", "zz" /) + character(len=5), dimension(3) :: wanted1 = (/ "yy", "x1", "zz" /) + character(len=6), dimension(2) :: wanted2 = (/ " yy", "x1 " /) + character(len=6), dimension(2) :: wanted3 = (/ "zz ", "yy " /) + character(len=16), dimension(6) :: wantedx = NOT_SET_STRING + integer, parameter :: NWORD_MAX = 99 + character(len=20), dimension(NWORD_MAX) :: words + integer :: nwords, errcode + + print "(/,a)", "1) Self-test - wordsplit =================================" + call wordsplit(text,NWORD_MAX,words,nwords,errcode) + + print *, "Found ", nwords, "words" + print *, "Words: ", words(1:nwords) + + print "(a)", "Note - need exact text:" + print *, "Index of spaces is ", find_index("spaces",words) + print *, "Index of spaces: is ", find_index("spaces:",words) + + print "(/,a)", "2) Self-test - find_indices =================================" + + print *, wanted1, " Indices => ", find_indices(wanted1,headers) + print "(a)", "Note - trailing blanks ok, leading blanks cause error:" + print *, wanted2, " Indices => ", find_indices(wanted2,headers) + print *, wanted3, " Indices => ", find_indices(wanted3,headers) + + print "(/,a)", "2) Self-test - WriteArray =================================" + + call WriteArray(wanted1,size(wanted1),"Testing wanted1 array") + print "(a)", " (Should write headers array (first 4 elements) to fort.77) " + call WriteArray(headers,4,"Testing headers array",77) + + print "(/,a)", "4) Self-test - AddArray =================================" + + !call AddArray(wanted1,wanted2) + wantedx(1) = "first " + wantedx(2) = "second " + call AddArray(wanted1,wantedx,NOT_SET_STRING) + call WriteArray(wantedx,size(wantedx),"Testing AddArray") + + + end subroutine Self_test +end module SmallUtils_ml diff --git a/SoilWater_ml.f90 b/SoilWater_ml.f90 new file mode 100644 index 0000000..02b6f99 --- /dev/null +++ b/SoilWater_ml.f90 @@ -0,0 +1,41 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 SoilWater_ml + + real, dimension(366), public, save :: SWP = 0.0 ! daily soil water potential + ! in MPa + +end module SoilWater_ml + + + + + + + + diff --git a/Solver.f90 b/Solver.f90 new file mode 100644 index 0000000..dde456d --- /dev/null +++ b/Solver.f90 @@ -0,0 +1,293 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module Chemsolver_ml +! MOD OD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + + !=======================================================================! + ! 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", + ! Aplied Numerical Mathematics 18 (1995) 413. + ! + ! Note that the exact formula used have been re-arranged for greater + ! efficiency (Steffen Unger). + ! Variable Dchem is used to keep track of changes from call to call. + ! 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 CheckStop_ml, only: CheckStop + use DefPhotolysis_ml ! => IDHNO3, etc. + use Emissions_ml, only: KEMISTOP + use GenSpec_tot_ml ! => NSPEC_TOT, O3, NO2, etc. + use GenSpec_bgn_ml ! => IXBGN_ indices and xn_2d_bgn values + use GenRates_rct_ml, only: set_night_rct, ONLY_NIGHT + use ModelConstants_ml, only: KMAX_MID, KCHEMTOP, dt_advec,dt_advec_inv + use My_Aerosols_ml, only: SEASALT + use My_Emis_ml ! => QRCNO, etc. + use OrganicAerosol_ml, only: Fgas + use Par_ml, only: me, MAXLIMAX, MAXLJMAX ! me for TEST + use Setup_1dfields_ml, only: rcemis, & ! photolysis, emissions + rcbio, & ! biogenic emis + rc_Rn222, & ! Pb210 + rct, rcmisc, & ! reaction rate coeffients + xn_2d, & + rh, & + rcss,amk ! Sea salt emission rate + use N2O5_hydrolysis_ml, only :VOLFACSO4,VOLFACNO3,VOLFACNH4,& + f_Riemer! to weight the hydrolysis of N2O5 with NO3,SO4 mass + implicit none + + private + public :: chemistry ! Runs chemical solver + + INCLUDE 'mpif.h' + + integer:: STATUS(MPI_STATUS_SIZE),INFO + integer, parameter:: nchemMAX=12 + +contains + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + + subroutine chemistry(i,j) + + !.. In + integer, intent(in) :: i,j ! Coordinates (needed for Dchem) + + real, dimension(NSPEC_TOT,KCHEMTOP:KMAX_MID,MAXLIMAX,MAXLJMAX), save :: & + Dchem=0.0 ! Concentration increments due to chemistry + + logical, save :: first_call = .true. + + real, parameter :: CPINIT = 0.0 ! 1.0e-30 ! small value for init + + ! Local + integer, dimension(KCHEMTOP:KMAX_MID) :: toiter + integer :: k, ichem, iter,n ! Loop indices + integer, save :: nchem ! No chem time-steps + real :: dt2 + real :: P, L ! Production, loss terms + real :: psd_h2o2 ! Pseudo H2O2 concentration (lower when high so2) + real :: xextrapol, L1,L2,P1,P2,C1,C2,DIVID !help variable + + ! Concentrations : xold=old, x=current, xnew=predicted + ! - dimensioned to have same size as "x" + + real, dimension(NSPEC_TOT) :: & + x, xold ,xnew ! Working array [molecules/cm3] + real, dimension(nchemMAX), save :: & + dti ! variable timestep*(c+1)/(c+2) + real, dimension(nchemMAX), save :: & + coeff1,coeff2,cc ! coefficients for variable timestep + integer :: nextraiter + +!====================================================== + + if ( first_call ) then + call makedt(dti,nchem,coeff1,coeff2,cc,dt_advec) + first_call = .false. + endif + +!====================================================== + + + !** 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(KEMISTOP:KMAX_MID) = 3 ! Near-ground, emis levels + + + + !** Comments: Only NO2+O3->H+ +NO3- at night time + ! and in the8 lowest layers and if rh>0.5 + + if (ONLY_NIGHT) call set_night_rct(rct,rh,i,j) ! Only for ACID version + + + !** Establishment of initial conditions: + ! Previous concentrations are estimated by the current + ! minus Dchem because the current may be changed by + ! processes outside the chemistry: + + do k = 2, KMAX_MID + + xnew(:) = xn_2d(:,k) + + x(:) = xn_2d(:,k) - Dchem(:,k,i,j)*dti(1)*1.5 + x(:) = max (x(:), 0.0) + + + !************************************* + ! Start of integration loop * + !************************************* + + + do ichem = 1, nchem + + do n=1,NSPEC_TOT + + xextrapol = xnew(n) + (xnew(n)-x(n)) *cc(ichem) + xold(n) = coeff1(ichem)*xnew(n) - coeff2(ichem)*x(n) + x(n) = xnew(n) + xnew(n) = xextrapol + + enddo + + dt2 = dti(ichem) !*(1.0+cc(ichem))/(1.0+2.0*cc(ichem)) + + where ( xnew(:) < CPINIT ) + xnew(:) = CPINIT + end where + + !== Here comes all chemical reactions + + include 'My_Reactions.inc' + + end do + + !************************************* + ! End of integration loop * + !************************************* + + + !** Saves tendencies Dchem and returns the new concentrations: + + Dchem(:,k,i,j) = (xnew(:) - xn_2d(:,k))*dt_advec_inv + xn_2d(:,k) = xnew(:) + + enddo ! End of vertical k-loop + + end subroutine chemistry + +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + +subroutine makedt(dti,nchem,coeff1,coeff2,cc,dt_tot) + +!===================================================================== +! Makes coefficients for two-step (written by Peter Wind, Febr. 2003) +! The formulas for coeff1, coeff2 and dti can be found in: +! J.G. Verwer and D. Simpson, "Explicit methods for stiff ODEs from +! atmospheric chemistry", Aplied Numerical Mathematics 18 (1995) 413 +! +! Note: It is better to take first some small steps, and then +! larger steps, than to increase the timestep gradually. +!===================================================================== + + implicit none + + real, intent(in) :: dt_tot + real, dimension(nchemMAX),intent(out) :: dti,coeff1,coeff2,cc + integer, intent(out) :: nchem + + real :: ttot,dt_first,dt_max,dtleft,tleft,step,dt(nchemMAX) + integer :: i,j +!_________________________ + + nchem=12 !number of chemical timesteps inside dt_advec + +!/ Used only for 50km resolution and dt_advec=1200 seconds: +!.. timesteps from 6 to 12 + dt=(dt_advec-100.0)/(nchem-5) +!.. first five timesteps + dt(1)=20.0 + dt(2)=20.0 + dt(3)=20.0 + dt(4)=20.0 + dt(5)=20.0 + +!/ ** For smaller scales, but not tested + if(dt_advec<520.0)then + nchem=5+int((dt_advec-100.0)/60.0) + dt=(dt_advec-100.0)/(nchem-5) + dt(1)=20.0 + dt(2)=20.0 + dt(3)=20.0 + dt(4)=20.0 + dt(5)=20.0 + endif + if(dt_advec<=100.)then + nchem=int(dt_advec/20.0)+1 + dt=(dt_advec)/(nchem) + endif +!/ ** + + call CheckStop(dt_advec<20.0,"Error in Solver/makedt: dt_advec too small!") + + call CheckStop(nchem>nchemMAX,"Error in Solver/makedt: nchemMAX too small!") + + nchem=min(nchemMAX,nchem) + + if(me == 0) then + + write(*,*)'Number of timesteps in Solver: ',nchem + 27 format('timestep ',I,F13.6,' total: ',F13.6) + + ttot=0.0 + do i=1,nchem + ttot=ttot+dt(i) + write(*,27)i,dt(i),ttot + enddo + + !check that we are using consistent timesteps + call CheckStop(abs(ttot-dt_advec)>1.E-5, & + "Error in Solver/makedt: dt_advec and dt not compatible") + + endif + +!.. 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) + dti(1)=((cc(1)+1)/(cc(1)+2))*dt(1) + + do i=2,nchem + cc(i)=dt(i-1)/dt(i) + coeff2(i)=1.0/(cc(i)**2+2.0*cc(i)) + coeff1(i)=((cc(i)+1.0)**2)*coeff2(i) + dti(i)=((cc(i)+1.0)/(cc(i)+2.0))*dt(i) + cc(i)=1.0/cc(i) + enddo + +end subroutine makedt +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end module Chemsolver_ml diff --git a/StoFlux_ml.f90 b/StoFlux_ml.f90 new file mode 100644 index 0000000..e2ee7df --- /dev/null +++ b/StoFlux_ml.f90 @@ -0,0 +1,182 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 StoFlux_ml + use DO3SE_ml, only : do3se + use LandDefs_ml, only : LandType, STUBBLE + use LocalVariables_ml, only : L, Grid + use MicroMet_ml, only : AerRes, Wind_at_h + use ModelConstants_ml, only : NLANDUSE, dt_advec + use Par_ml, only : MAXLIMAX, MAXLJMAX + use PhysicalConstants_ml, only : AVOG, KARMAN + use TimeDate_ml, only : current_date + implicit none + private + + public :: Init_StoFlux + public :: Setup_StoFlux + public :: Calc_StoFlux + + logical, public, parameter :: STO_FLUXES = .true. + logical, private, parameter :: DEBUG_FLUX = .false. + logical, public, dimension(NLANDUSE), save :: luflux_wanted + + real, private :: c_hveg, u_hveg ! Values at canopy top, for fluxes + real, public, dimension(NLANDUSE), save :: & + lai_flux, & ! Fluxes to total LAI + unit_flux, & ! Fluxes per m2 of leaf area + leaf_flux, & ! Flag-leaf Fluxes per m2 of leaf area + c_hvegppb ! Conc. to of canop + + + real, public,save,dimension(MAXLIMAX,MAXLJMAX) :: & + SumVPD , & ! For critical VPD calcs, reset each day + old_gsun ! + + real, private, save :: nmole_o3, ppb_o3 ! O3 in nmole/m3, ppb + real, private, save :: gext_leaf = 1.0/2500.0 + real, private :: rc_leaf, rb_leaf, Fst + +! Converts from mol/cm3 to nmole/m3 + real, private, parameter :: NMOLE_M3 = 1.0e6*1.0e9/AVOG + + + + +contains + subroutine Init_StoFlux() + integer :: iL + + luflux_wanted(:) = .false. + do iL = 1, NLANDUSE + if ( LandType(iL)%is_iam ) luflux_wanted(iL) = .true. + end do + + end subroutine Init_StoFlux + + subroutine Setup_StoFlux(jd,xo3,xm) + ! xo3 is in #/cm3. xo3/xm gives mixing ratio, and 1.0e9*xo3/xm = ppb + real, intent(in) :: xo3 ! O3 mixing ratio + real, intent(in) :: xm ! Air mixing ratio + integer, intent(in) :: jd ! daynumber + integer, save :: old_daynumber + + ppb_o3 = 1.0e9* xo3/xm + nmole_o3 = xo3 * NMOLE_M3 + + c_hvegppb(:) = 0.0 + leaf_flux(:) = 0.0 + + + ! resets whole grid on 1st day change + if ( jd /= old_daynumber ) then + SumVPD = 0.0 ! For Critical VPD stuff, wheat + old_gsun = 1.0e99 ! " " + old_daynumber = jd + end if + + + end subroutine Setup_StoFlux + + + subroutine Calc_StoFlux(iL,Vg_ref,debug_flag) + integer, intent(in) :: iL + real, intent(in) :: Vg_ref + logical, intent(in) :: debug_flag + + real :: loss,sto_frac + real :: Ra_diff,tmp_gsun + integer :: i,j + + i = Grid%i + j = Grid%j + +! take care of temperate crops, outside growing season + if ( L%hveg < 1.1 * L%z0 ) then + leaf_flux(iL) = 0.0 + if ( DEBUG_FLUX .and. debug_flag ) & + write(6,"(a15,f8.3,a8,f8.3)") "FST - too low ", & + L%hveg, " < 1.1*", L%z0 + + else + !======================= + ! The fraction going to the stomata = g_sto/g_sur = g_sto * R_sur. + ! Vg*nmole_o3 is the total deposition flux of ozone, but + ! we calculate the actual flux later (once we know DepLoss(O3)). + ! For now we just calculate the g_sto*R_sur bit: + ! (Caution - g_sto is for O3 only) + + + Ra_diff = AerRes(max( L%hveg-L%d, STUBBLE) , Grid%z_ref-L%d,& + L%ustar,L%invL,KARMAN) + c_hveg = nmole_o3 * ( 1.0 - Ra_diff * Vg_ref ) + c_hvegppb(iL) = ppb_o3 * ( 1.0 - Ra_diff * Vg_ref ) + + + !Could be coded faster with Ra.... + u_hveg = Wind_at_h( Grid%u_ref, Grid%z_ref, L%hveg, & + L%d, L%z0, L%invL ) + + rc_leaf = 1.0/(L%g_sto+ gext_leaf) + + !McNaughton + van den Hurk: + + if ( do3se(iL)%Lw > 0 ) then + rb_leaf = 1.3 * 150.0 * sqrt(do3se(iL)%Lw/u_hveg) + else ! default (CAREFUL!) + rb_leaf = 1.3 * 150.0 * sqrt(0.05/u_hveg) + end if + + ! VPD limitation for wheat + + if ( LandType(iL)%is_iam .and. LandType(iL)%is_crop ) then + if( L%g_sun > 0.0 ) SumVPD(i,j) = SumVPD(i,j) + L%vpd*dt_advec/3600.0 + tmp_gsun = L%g_sun + if ( SumVPD(i,j) > 8.0 ) L%g_sun = min( L%g_sun, old_gsun(i,j) ) + if( DEBUG_FLUX .and. debug_flag ) & + write(6,"(a8,3i3,4f8.3,4es10.2)") "SUMVPD ", & + current_date%month, current_date%day, current_date%hour, & + L%rh, L%t2C, L%vpd, SumVPD(i,j), & + old_gsun(i,j), tmp_gsun, L%g_sun , L%g_sto + old_gsun(i,j) = L%g_sun + end if + + ! Flux in nmole/m2/s: + leaf_flux(iL) = c_hveg * rc_leaf/(rb_leaf+rc_leaf) * L%g_sun + + if ( DEBUG_FLUX .and. debug_flag ) then + write(6,"(a8,3i3,i4,f6.2,2f8.1,2es10.2,f6.2,es12.3)") "FST ",& + iL, current_date%month, current_date%day, current_date%hour, & + L%LAI, nmole_o3, c_hveg, L%g_sto, L%g_sun, u_hveg,& + leaf_flux(iL) + end if + + end if + + end subroutine Calc_StoFlux +!.............................................................................. +end module StoFlux_ml diff --git a/SubMet_ml.f90 b/SubMet_ml.f90 new file mode 100644 index 0000000..568bca4 --- /dev/null +++ b/SubMet_ml.f90 @@ -0,0 +1,333 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 SubMet_ml +!============================================================================= +!+ +! Description +! Module for setting some local grid-cell data (mainly from NWP) +! and for calculating sub-grid meteorology for each land-use. +! The sub-grid part of this module is also undergoing constant change!! +!============================================================================= + + +use CheckStop_ml, only : CheckStop +use LandDefs_ml, only: LandType +use Landuse_ml, only: LandCover +use LocalVariables_ml, only: Grid, Sub +use MicroMet_ml, only : PsiM, AerRes !functions +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 + + + logical, private, parameter :: DEBUG_SUB = .false. ! for extra tests/printouts + +contains +!======================================================================= + + subroutine Get_Submet(iL, debug_flag ) + +!--------------------------------------------------------------- +! Sub-grid calculations of stability, Ra and ustar for this landuse +!--------------------------------------------------------------- +! +!..The profile manipulation is introduced to calculate different Ra and Rb +!..values for different landuse types (e.g. from SEI). Thus, different z0, +!..are assumed within each EMEP square, from which one averaged value is +!..available as the basic input from the NWP-model. Therefore, we first have a +!..grid square average for u*, T*, L and z0 (i.e. from the NWP-model). Then, +!..we calculate the wind speed u from the wind profile (according to the +!..M-O similarity) and the NWP-model data, and from this u we calculate +!..new u* values for each z0, i.e. landuse, within each grid square. Here, +!..we have to use the old L, even although L=f(u*), since the new u* is +!..unknown before it is calculated. (An iteration process is possible.) +!..Anyway, by using the new u*'s, we obtain +!..new T*'s, L's for each landuse type and finally Ra's and ustars for each +!..subgrid area. +! +!.. For further details, see EMEP report 1/2003 (and before that 3/95 ...) +! +! The subroutine Get_Submet also generates output for +! two terms utilized in Rsurface, namely rh (the relative humidity +! term required for the evaluation of the stomatal compensation point +! point for NH_3) and vpd (the vapour pressure deficit term required +! for the evaluation of stomatal conductance). + +!----------------------------------------------------------------- +!..In + + integer, intent(in) :: iL ! lu index + logical, intent(in) :: debug_flag ! set true for wanted grid square + + ! IMPORTANT - ASSUMES INITIAL VALUES SET FOR USTAR, INVL, .... + +!.. Local + real :: rho_surf ! Density at surface (2 m), kg/m3 + real :: z_1m ! 1m above vegetation + real :: z_3m ! 3m above ground, or top of trees + real :: z_3md ! minus displacemt ht. + + + logical, save :: my_first_call = .true. + integer, parameter :: NITER = 1 ! no. iterations to be performed + + integer :: iter ! iteration variable + + ! For vapour pressure calculations + + real, parameter :: ESAT0=611.0 ! saturation vapour pressure at + ! T=0 deg. C (Pa) + + real :: qw ! specific humidity (kg/kg) corrected + ! down to z_0+d metres above the ground + real :: esat ! saturation vapour pressure (Pa) + real :: e ! vapour pressure at surface + real :: Ra_2m ! to get 2m qw + + + ! initial guesses for u*, t*, 1/L + Sub(iL)%ustar = Grid%ustar ! First guess = NWP value + Sub(iL)%invL = Grid%invL ! First guess = NWP value + Sub(iL)%Hd = Grid%Hd ! First guess = NWP value + Sub(iL)%LE = Grid%LE ! First guess = NWP value + Sub(iL)%t2 = Grid%t2 ! First guess = NWP value + Sub(iL)%t2C = Grid%t2C ! First guess = NWP value + + Sub(iL)%is_water = LandType(iL)%is_water + Sub(iL)%is_forest = LandType(iL)%is_forest + + ! 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 + ! situations. + if( 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 +! needs to be added in order to make the profile theories +! work over a tall vegetation (see e.g. Stull (1988), p.381). +! This corresponds to moving our co-ordinate system upwards +! by a distance d. +! +! by definition: u(z0+d) = 0 +! +! it has been observed that d is approximately 0.7 times +! the mean height of the vegetation (h) and z0=h/10 +! (see e.g. Stull, 1998, Garratt, 1992.). +! The reference height for u* transformation is then +! taken arbitrarily at about 45m, the height of the +! centre of the EMEP grid cell. + + +!.. For water, we introduce a new zero plane +! displacement and use the Charnock relation to calculate the z0-values +! nb - addded max 1cm limit for z0 over sea, because of problems +! caused by z0>1m. Garratt (section 4.1, Fig 4.2) suggested that Charnock's +! 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 + Sub(iL)%z0 = max( Sub(iL)%z0 ,0.01) + z_1m = 1.0 ! 1m above sea surface + z_3m = 3.0 ! 3m above sea surface + else + Sub(iL)%d = 0.7 * Sub(iL)%hveg + Sub(iL)%z0 = max( 0.1 * Sub(iL)%hveg, 0.001) ! Fix for deserts, + ! ice, snow (where, for bare ground, h=0 and hence z0=0) + + !Heights relative to displacement height, d: + + z_1m = (Sub(iL)%hveg + 1.0) - Sub(iL)%d + z_3m = max(3.0,Sub(iL)%hveg) +!CHECK!!!! z_3m z_3md.... + + end if + + Sub(iL)%z_refd = Grid%z_ref - Sub(iL)%d ! minus displacement height + z_3md = z_3m - Sub(iL)%d ! minus displacement height + + + do iter = 1, NITER + + ! **** + ! PsiM calculates the stability functions for momentum + ! at heights z_ref (about 45m) & z0 + ! **** + !..calculate friction velocity based first on NWP-model PsiM-values + !..and u_ref. The NWP-model PsiM-values are used despite the fact that + !..L=F(u*), since we do not know the EMEP subgrid averaged + !..z0-values ... + + if ( DEBUG_SUB .and. debug_flag ) then !! .and. & + write(6,"(a12,i2,5f8.3,f12.3)") "UKDEP SUBI", iter, & + Sub(iL)%hveg, Sub(iL)%z0, Sub(iL)%d, & + Sub(iL)%z_refd, z_3md, Sub(iL)%invL + end if + + 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 = max( Sub(iL)%ustar, 1.0e-2) + + ! We must use L (the Monin-Obukhov length) to calculate deposition, + ! Thus, we calculate T* and then L, based on sub-grid data. + + + rho_surf = Grid%psurf/(RGAS_KG * Sub(iL)%t2 ) + + + ! New 1/L value .... + + + Sub(iL)%invL = -KARMAN * GRAV * Sub(iL)%Hd / & + ( CP*rho_surf*Sub(iL)%ustar*Sub(iL)%ustar*Sub(iL)%ustar * Sub(iL)%t2) + + !.. we limit the range of 1/L to prevent numerical and printout problems + ! This range is very wide anyway. + + Sub(iL)%invL = max( -1.0, Sub(iL)%invL ) !! limit very unstable + Sub(iL)%invL = min( 1.0, Sub(iL)%invL ) !! limit very stable + + end do ! iter + + + if ( DEBUG_SUB .and. debug_flag ) then !! .and. & + 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 + end if + + if ( DEBUG_SUB .and. debug_flag ) then + if ( my_first_call ) then ! title line + + write(unit=*, fmt="(a6,3a3, a6, 3a8,2a7, 2a6)") & + "STAB ", "mm", "dd", "hh", "t2_C", "Hd", & + "L_nwp", "L ", "z/L_nwp", "z/L ", "u*_nwp", "u*" + my_first_call = .false. + end if + + write(unit=*, & + fmt="(a6,4i3, f6.1, 3f8.2, 2f7.2, 2f6.2)") "SUBB", iL, & + 999, & !SUBcurrent_date%month, & + 999, & !SUBcurrent_date%day, & + 999, & !SUBcurrent_date%hour, & + Sub(iL)%t2C, Sub(iL)%Hd, Grid%invL, Sub(iL)%invL, & + Sub(iL)%z_refd*Grid%invL, Sub(iL)%z_refd*Sub(iL)%invL, & + Grid%ustar, Sub(iL)%ustar + end if + + + +! *** Aerodynamic resistances for each landuse type k *** +! Ra_ref is used to estimate the aerodynamic resistance to latent +! heat transfer from height z_ref to z0+d and from height h+3 to +! z0+d, respectively. +! Only Ra_ref and Ra_3m are used in main code. + + Sub(iL)%Ra_ref = AerRes(Sub(iL)%z0,Sub(iL)%z_refd,Sub(iL)%ustar,& + Sub(iL)%invL,KARMAN) + Sub(iL)%Ra_3m = AerRes(Sub(iL)%z0,z_3md,Sub(iL)%ustar,Sub(iL)%invL,KARMAN) + Ra_2m = AerRes(Sub(iL)%z0,1.0+z_1m,Sub(iL)%ustar,Sub(iL)%invL,KARMAN) + + if ( DEBUG_SUB ) then + if ( Sub(iL)%Ra_ref < 0 .or. Sub(iL)%Ra_3m < 0 & + .or. Ra_2m < 0 ) call CheckStop("RAREF NEG ") + if ( Sub(iL)%Ra_3m > Sub(iL)%Ra_ref ) & + call CheckStop("ERROR!!! Ra_ref1.0 - + ! probably due to mismatches between the assumptions used for the stability + ! profile here and in HIRLAM. Here we set crude limits on e to prevent + ! impossible rh values at least: + + + e = max(0.001*esat,e) ! keeps rh >= 0.1% + !e = min(esat,e) ! keeps rh <= 1 + Sub(iL)%rh = e/esat + Sub(iL)%rh = min(1.0,Sub(iL)%rh)! keeps rh <= 1 + +! **** leaf sat. vapour pressure + + Sub(iL)%vpd = 0.001*(esat-e) ! gives vpd in kPa ! + Sub(iL)%vpd = max(Sub(iL)%vpd,0.0) + + + if ( DEBUG_SUB .and. debug_flag ) then !! .and. & + write(6,"(a22,2f12.4)") "UKDEP SUB7 e/esat, rh", e/esat, Sub(iL)%rh + end if + + end subroutine Get_Submet +! ===================================================================== + +end module SubMet_ml diff --git a/Tabulations_ml.f90 b/Tabulations_ml.f90 new file mode 100644 index 0000000..7cdfb59 --- /dev/null +++ b/Tabulations_ml.f90 @@ -0,0 +1,206 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Tabulations_ml + !+ + ! Tabulates miscellaneous functions and reaction rates which depend on + ! temperature: + ! + ! exner function (tpi), sat. vapour pressure, rh deliq. + ! Mozurk. parameters. + ! + ! For gas-phase chemistry, only the "simple" temperature dependant rates + ! are tabulated here. + ! + !---------------------------------------------------------------------------- + use PhysicalConstants_ml, only : RGAS_J, CP, T0, KAPPA + use ModelConstants_ml, only : CHEMTMIN, CHEMTMAX ! temperature range + !u3 use GenRates_rct_ml, only : & ! From GenOut_ml + !u3 NRCT, & ! No. temperature dependant coefficients + !u3 rcvt, & ! Temperature dependant coefficients + !u3 set_rct_rates ! Gives RCT as function of temp t + implicit none + private + + + !/- subroutines: + + public :: tabulate ! Sets up most tables, and calls tab_rct_rates + !u3 private :: tab_rct_rates ! Subroutine to tabulate rct to rcit rates + + + !/- Outputs: + + real, public, parameter :: & + PINC=1000.0 & + , PBAS=-PINC + + real, save, public, dimension(131) :: tpi ! Exner function of pressure? + + real, save, public, dimension(CHEMTMIN:CHEMTMAX) :: & + tab_esat_Pa !& ! saturated vapour pressure (Pa) +! ,tab_rhdel & ! RH of deliquescence for ammonium nitrate +! ,tab_Kp_amni & ! Equil. constant, nh3 + hno3 <--> nh4no3 +! ,tab_MozP1 & ! Mozurkewich P1 value for Kaq +! ,tab_MozP2 & ! Mozurkewich P2 value for Kaq +! ,tab_MozP3 & ! Mozurkewich P3 value for Kaq +! ,tab_vav_n2o5 ! avg. molecular speed N2O5 + +!u3 !/ Output gas-phase chemical rates: +!u3 +!u3 real, save, public, & +!u3 dimension(NRCT,CHEMTMIN:CHEMTMAX) :: rcit ! rate-coefficients + + + contains + + subroutine tabulate() + ! + + real, dimension(CHEMTMIN:CHEMTMAX) :: temp + real :: p, a + integer :: i + + ! Exner function + !------------------------------------------------------------------- + ! define the exner-function for every 1000 pa from zero to 1.3e+5 pa + ! in a table for efficient interpolation (same procedure as used in + ! the nwp-model, see mb1e.f) + ! + + do i = 1,131 + p = PBAS + i*PINC + tpi(i) = CP*(p/1.0e+5)**KAPPA + enddo + + ! Temperature-dependant rates + !------------------------------------------------------------------- + + temp = (/ (real(i),i=CHEMTMIN,CHEMTMAX) /) ! temp = 148..333 + + !u3 call tab_rct_rates() ! = > gives gas-phase rates + + ! Tabulation of other rates: + !------------------------------------------------------------------- + ! Saturation vapour pressure + ! Clausius-Clapyron, as given by Jakobsen, eqn 2.55 (now in Pa): + + ! T0 = 273.15 + ! tab_esat_Pa(:) = 611.2*exp( 6816.0*(1.0/T0 + 1.0/temp(:)) & + ! + 5.1309 * (T0/temp(:) ) + + ! where T0 is standrard temperature 273.15 + ! Ref: Bolton's formula - really only valid for -35C < T < 35C + ! Units: Pa + ! (MADE/MACHO notes : was miscrcit(ICES,it) + ! Corrected to Pa, 30/10/01 + ! + !tab_esat_Pa(:) = 611.2*exp(17.67*(temp(:)-273.15)/ (temp(:) - 29.65)) + + ! From Bohren+Albrecht, Atmospheric Thermodynamics, 1998 + ! ln e/es = 6808(1/T0-1/T) - 5.09 ln(T/T0) + !=> e = es * exp( 6808(1/T0-1/T)) * (T/T0)**5.09 + ! + ! tab_ba(:) = 611.2* ( exp( 6808.0*(1.0/T0 - 1.0/temp(:)) ) & + ! * ( T0/temp(:) )**5.09 ) + + ! But, for now I chose the formula used by HIRLAM; as provided + ! by Anna, May 2002 + ! with eps*zxl/Rd in Clausius-Clapyron + + a = 0.622*2.5e6/287.0 ! = 5418 + + tab_esat_Pa(:) = 611.2* exp( a *(1.0/T0 - 1.0/temp(:)) ) + + ! + ! An alternative would be to use + !------------------------------------------------------------------- + ! relative humidity of deliquescence for ammonium nitrate + ! Ref: Mozurkewich (1993) - Journal??? + ! Units : fraction 0-1 + ! (MADE/MACHO notes : was miscrcit(ICRHD,it) + +! tab_rhdel(:) = exp( 618.3/temp(:) - 2.551 ) + + !------------------------------------------------------------------- + ! Equilibrium constant (Kp): NH3 + HNO3 <-------> NH4NO3 + ! Ref: Mozurkewich (1993) + ! Units : (molecule/cm3)^2 for Kp + ! (MADE/MACHO notes : was miscrcit(ICRS,it) + ! + ! lnKp = 118.87 - 24084.0/T - 6.025* ln(T) + ! + +! tab_Kp_amni(:) = exp( 118.87 - 24084.0/temp(:)-6.025*log(temp(:)) ) + + !------------------------------------------------------------------- + ! temp. dependant constrants for calcolating dissos. rate + ! for the formation of ammonium nitrate + ! Ref: Mozurkewich (1993) + ! (MADE/MACHO notes : was miscrcit(ICXK1,it)..miscrcit(ICXK_3,it) + ! n.b. EMEP report 2/98 had 2446 in P3, but 24.46 is correct + +! tab_MozP1(:) = exp( -135.94 + 8763.0/temp(:) + 19.12*log( temp(:) ) ) +! tab_MozP2(:) = exp( -122.65 + 9969.0/temp(:) + 16.22*log( temp(:) ) ) +! tab_MozP3(:) = exp( -182.61 + 13875.0/temp(:) + 24.46*log( temp(:) ) ) + + !------------------------------------------------------------------- + ! vav_n2o5 is the mean molecular speed for n2o5 + ! - calculated as v = sqrt(3RT/atw) + ! Units: m/s + ! + ! (MADE/MACHO: was miscrcit(IC42H,it), with units of cm/s, calculated + ! as sqrt(3.0 * 8.314e7 * temp(:) / 108.0) + ! RGAS_J = 8.314 J mol-1 K-1 = 8.314 kg m2 s-2 mol-1 K-1 + ! nb. Seinfeld+Pandis (1998), p.453, use v = sqrt( 8RT/(pi*atw) ) + ! + ! Note: atwn2o5 = 108 g = 0.108 kg + +! tab_vav_n2o5(:) = sqrt(3.0 * RGAS_J * temp(:) / 0.108) ! m/s ! + + + !------------------------------------------------------------------- + end subroutine tabulate + + !u3 !---------------------------------------------------------------------- + !u3 subroutine tab_rct_rates() + !u3 !+1) Temperature-dependant rates (rct). Only needs to be called once + !u3 ! at beginning of simulations to set up table + !u3 + !u3 integer :: it ! Local loop variable + !u3 real :: tinv ! temperature in K + !u3 + !u3 do it = CHEMTMIN, CHEMTMAX + !u3 tinv = 1./real(it) + !u3 call set_rct_rates(tinv) + !u3 rcit(:,it) = rcvt(:) + !u3 end do + !u3 + !u3 end subroutine tab_rct_rates + !u3 !---------------------------------------------------------------------- + +end module Tabulations_ml diff --git a/TimeDate_ml.f90 b/TimeDate_ml.f90 new file mode 100644 index 0000000..dcaea10 --- /dev/null +++ b/TimeDate_ml.f90 @@ -0,0 +1,384 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 TimeDate_ml + IMPLICIT NONE + +! Originally timedate.f90 from Paul Curtis, found on web, 31/8/04: +! Removed some Windows-specific or un-needed routines, +! and converted to F. Some routines given longer names, eg. dow -> day_in_week, +! ndiy -> day_of_year. Change IFIX to INT, FLOAT to REAL, MAX0 to MAX, etc. +!===================Routines ================================================= + + !/ Functions ............... + public :: make_current_date ! convert timestamp to current_date + public :: make_timestamp ! convert current_date(yyyy,mon,day,hour, + ! secs) to timestamp(jdate,secs) + public :: Init_nmdays ! sets number of days per month, year + + public :: tdif_secs ! t2-t1 -> dif (s) + public :: ts_earlier ! gets first ts from ts1, ts2 + public :: ts_later ! gets later ts from ts1, ts2 + public :: InInterval ! -1 == earlier, 0 == in, +1 == later + public :: julian_date ! yyyy,mm,dd -> julian + public :: day_of_week ! yyyy, mm, dd -> day of week (0=SUN) + public :: day_of_year ! yyyy,mm,dd -> Day count in year + public :: max_day ! month,year -> maxd, e.g. 31 for July + public :: leapyear ! year -> true, false + public :: y2dig ! year -> 2-digit yy + public :: y4dig ! year -> 4-digit yyyy + public :: get_ymd ! jd -> yyyy, mm, dd + public :: get_hms ! secs -> hour,minute,second + !/ Subroutines............... + public :: dup_timestamp ! ts2=ts1 + public :: add_secs ! ts+seconds -> new ts. fixit option + public :: add_month ! jdate+month, force_day option +!===================TIMESTAMP TYPES & DEFINES================================= + +!========================================================================= +integer, public, save :: daynumber ! Day no. (1st jan=1). + ! (Could be done locally?) +integer, public, save :: nydays ! No. days per year +integer, public, dimension(12), save :: nmdays ! No. days per month + +type, public :: date + integer :: year + integer :: month + integer :: day + integer :: hour + integer :: seconds + end type date + + + type(date), public, save :: current_date + +!============================================================================== + + + TYPE, public :: timestamp + INTEGER :: jdate + REAL :: secs + END TYPE timestamp + + REAL,private,PARAMETER :: spd = 86400.0 + REAL,private,PARAMETER :: sph = 3600.0 + REAL,private,PARAMETER :: spm = 60.0 + + TYPE(timestamp),private,PARAMETER :: ts_null = timestamp(0, 0.0) + TYPE(timestamp),public, save :: ts_now ! current local time + TYPE(timestamp),public, save :: ts_next ! next inp + + CHARACTER(LEN=3),DIMENSION(12), public :: short_month = & + (/"Jan","Feb","Mar","Apr","May","Jun", & + "Jul","Aug","Sep","Oct","Nov","Dec"/) + + CHARACTER(LEN=10),DIMENSION(12), public :: long_month = & + (/"January ", "February ", "March ", & + "April ", "May ", "June ", & + "July ", "August ", "September ", & + "October ", "November ", "December " /) + CHARACTER(LEN=3),DIMENSION(0:6), public :: short_day = & + (/"Sun","Mon","Tue","Wed","Thu","Fri","Sat" /) + +CONTAINS + + + FUNCTION make_timestamp (cd) RESULT (ts) + TYPE(timestamp) :: ts + TYPE(date),INTENT(IN) :: cd + INTEGER :: yyyy, mon, dd, hh, ss + yyyy=cd%year + mon=cd%month + dd=cd%day + hh=cd%hour + ss=cd%seconds + ts%jdate = julian_date (yyyy, mon, dd) + ts%secs = sph*REAL(hh) + REAL(ss) + END FUNCTION make_timestamp + + + FUNCTION make_current_date (ts) RESULT (cd) + TYPE(timestamp),INTENT(IN) :: ts + TYPE(date) :: cd + INTEGER :: yy,mm,dd,hh,min,sc,jd + REAL :: ss + jd=ts%jdate + ss=ts%secs + call get_ymd(jd,yy,mm,dd) + call get_hms(ss,hh,min,sc) + cd%year=yy + cd%month=mm + cd%day=dd + cd%hour=hh + cd%seconds=min*60.0 + sc + END FUNCTION make_current_date + + + + SUBROUTINE dup_timestamp (ts1,ts2) + TYPE(timestamp),INTENT(IN) :: ts1 + TYPE(timestamp),INTENT(OUT) :: ts2 + ts2%jdate = ts1%jdate + ts2%secs = ts1%secs + END SUBROUTINE dup_timestamp + + + FUNCTION tdif_secs (ts1, ts2) RESULT (dif) + TYPE(timestamp),INTENT(IN) :: ts1, ts2 + REAL :: dif + dif = spd*REAL(ts2%jdate - ts1%jdate) + ts2%secs - ts1%secs + END FUNCTION tdif_secs + + + FUNCTION ts_earlier (ts1, ts2) RESULT (ts_first) + TYPE(timestamp),INTENT(IN) :: ts1, ts2 + TYPE(timestamp) :: ts_first + IF (tdif_secs (ts1, ts2) > 0.0) THEN + ts_first = ts1 + ELSE + ts_first = ts2 + END IF + END FUNCTION ts_earlier + + + FUNCTION ts_later (ts1, ts2) RESULT (ts_last) + TYPE(timestamp),INTENT(IN) :: ts1, ts2 + TYPE(timestamp) :: ts_last + IF (tdif_secs (ts1, ts2) > 0.0) THEN + ts_last = ts2 + ELSE + ts_last = ts1 + END IF + END FUNCTION ts_later + + ! returns: -1 == earlier, 0 == contained, +1 == later + FUNCTION InInterval (t1, t2, t3) RESULT(In) + TYPE(timestamp), INTENT(IN) :: t1, t2, t3 + INTEGER :: In + In = -1 + IF (tdif_secs (t1, t2) >= 0.0) THEN + IF (tdif_secs (t2, t3) >= 0.0) THEN + In = 0 + ELSE + In = 1 + END IF + END IF + END FUNCTION InInterval + + + SUBROUTINE add_secs (ts, seconds, fixit) + TYPE(timestamp), INTENT(INOUT) :: ts + REAL, INTENT(IN) :: seconds + LOGICAL, INTENT(IN), OPTIONAL :: fixit + INTEGER :: hour, minute, sec + + ts%secs = ts%secs + seconds + IF (seconds >= 0) THEN + DO + IF (ts%secs >= spd) THEN + ts%jdate = ts%jdate + 1 + ts%secs = ts%secs - spd + ENDIF + if ( ts%secs < spd) exit + END DO + ELSE + DO + ts%jdate = ts%jdate - 1 + ts%secs = ts%secs + spd + if ( ts%secs > 0) exit + END DO + END IF + + ! adjust to nearest half-hour + IF (PRESENT(fixit)) THEN + CALL get_hms (ts%secs, hour, minute, sec) + SELECT CASE (minute) + CASE(:29) + minute = 0 + CASE(30:) + minute = 30 + END SELECT + ts%secs = sph*REAL(hour) + spm*REAL(minute) + END IF + + END SUBROUTINE add_secs + + + SUBROUTINE add_month (jdate, force_day) + INTEGER,INTENT(INOUT) :: jdate + INTEGER, INTENT(IN), OPTIONAL :: force_day + INTEGER :: year, month, day + CALL get_ymd (jdate, year, month, day) + IF (PRESENT(force_day)) day = force_day + month = month + 1 + IF (month > 12) THEN + year = year + 1 + month = 1 + END IF + jdate = julian_date (year,month,MIN(MAX(day, 1),max_day(month, year))) + END SUBROUTINE add_month + + + FUNCTION julian_date (yyyy, mm, dd) RESULT (julian) + ! converts calendar date to Julian date + ! cf Fliegel & Van Flandern, CACM 11(10):657, 1968 + ! example: julian_date(1970,1,1)=2440588 + INTEGER,INTENT(IN) :: yyyy,mm,dd + INTEGER :: julian + julian = dd - 32075 + 1461*(yyyy + 4800 + (mm - 14)/12)/4 + & + 367*(mm - 2 - ((mm - 14)/12)*12)/12 - & + 3*((yyyy + 4900 + (mm - 14)/12)/100)/4 + END FUNCTION julian_date + + + SUBROUTINE get_ymd (jd, yyyy, mm, dd) + ! expands a Julian date into a calendar date + ! cf Fliegel & Van Flandern, CACM 11(10):657, 1968 + INTEGER,INTENT(IN) :: jd + INTEGER,INTENT(OUT) :: yyyy,mm,dd + INTEGER :: l,n + l = jd + 68569 + n = 4*l/146097 + l = l - (146097*n + 3)/4 + yyyy = 4000*(l + 1)/1461001 + l = l - 1461*yyyy/4 + 31 + mm = 80*l/2447 + dd = l - 2447*mm/80 + l = mm/11 + mm = mm + 2 - 12*l + yyyy = 100*(n - 49) + yyyy + l + END SUBROUTINE get_ymd + + + + FUNCTION day_of_week (yyyy,mm,dd) RESULT (dow) + ! Day_Of_Week: (0=Sunday,1=Monday...6=Saturday) + ! cf J.D.Robertson, CACM 15(10):918 + ! renamed dow->day_of_week, keep dow as internal, DSF + INTEGER,INTENT(IN) :: yyyy,mm,dd + INTEGER :: dow + dow = MODULO((13*(mm+10-(mm+10)/13*12)-1)/5+dd+77 & + +5*(yyyy+(mm-14)/12-(yyyy+(mm-14)/12)/100*100)/4 & + +(yyyy+(mm-14)/12)/400-(yyyy+(mm-14)/12)/100*2,7) + END FUNCTION day_of_week + + + FUNCTION day_of_year (yyyy,mm,dd) result (ndiy) + ! day count in year + ! cf J.D.Robertson, CACM 15(10):918 + ! renamed ndiy->day_of_year, keep ndiy as internal, DSF + INTEGER,INTENT(IN) :: yyyy,mm,dd + INTEGER :: ndiy + ndiy = 3055*(mm+2)/100-(mm+10)/13*2-91 & + +(1-(MODULO(yyyy,4)+3)/4+(MODULO(yyyy,100)+99)/100 & + -(MODULO(yyyy,400)+399)/400)*(mm+10)/13+dd + END FUNCTION day_of_year + + + FUNCTION max_day (month,year) RESULT (maxd) + INTEGER,INTENT(IN) :: month,year + INTEGER :: maxd + INTEGER,DIMENSION(12),PARAMETER :: daycount = & + (/31,28,31,30,31,30,31,31,30,31,30,31/) + ! table lookup for most months + maxd = daycount(month) + ! correct February in a leap year + IF (month == 2) THEN + IF (leapyear(year)) maxd = maxd + 1 + END IF + END FUNCTION max_day + + + FUNCTION leapyear (year) result (leap) + INTEGER,INTENT(IN) :: year + logical :: leap + IF (day_of_year(year, 12, 31) > 365) THEN + leap = .TRUE. + ELSE + leap = .FALSE. + END IF + END FUNCTION leapyear + + + FUNCTION y2dig (year) result(y2) + INTEGER,INTENT(IN) :: year + integer :: y2 + SELECT CASE (year) + CASE (1900:1999) + y2 = year - 1900 + CASE (2000:2099) + y2 = year - 2000 + CASE DEFAULT + y2 = 0 + END SELECT + END FUNCTION y2dig + + + FUNCTION y4dig (year) result(y4) + INTEGER,INTENT(IN) :: year + integer :: y4 + SELECT CASE (year) + CASE (:90) + y4 = year + 2000 + CASE (91:99) + y4 = year + 1900 + CASE (1990:) + y4 = year + END SELECT + END FUNCTION y4dig + + + SUBROUTINE get_hms (secs,hour,minute,second) + REAL,INTENT(IN) :: secs + INTEGER,INTENT(OUT) :: hour,minute,second + hour = INT(secs/sph) + minute = INT((secs - sph*REAL(hour))/spm) + second = INT(secs - sph*REAL(hour) - spm*REAL(minute)) + END SUBROUTINE get_hms + + SUBROUTINE Init_nmdays (indate) + TYPE(date),INTENT(IN) :: indate + INTEGER :: month,maxd,yy + INTEGER,DIMENSION(12),PARAMETER :: daycount = & + (/31,28,31,30,31,30,31,31,30,31,30,31/) + ! table lookup for most months + + yy = indate%year + nydays=0 + do month=1,12 + maxd = daycount(month) + ! correct February in a leap year + IF (month == 2) THEN + IF (leapyear(yy)) maxd = maxd + 1 + END IF + nmdays(month)=maxd + nydays=nydays+maxd + enddo + END SUBROUTINE Init_nmdays + +END MODULE TimeDate_ml diff --git a/Timefactors_ml.f90 b/Timefactors_ml.f90 new file mode 100644 index 0000000..3f6c0dc --- /dev/null +++ b/Timefactors_ml.f90 @@ -0,0 +1,363 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +!_____________________________________________________________________________ +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD + + module Timefactors_ml + +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +!....................................................................... +!** DESCRIPTION: +! Calculates emissions temporal variation. +! Reads monthly and daily (GENEMIS) factors for all emissions from files +! Monthly.sox, Daily.sox, Monthly.nox, etc., -> in fac_emm, fac_edd arrays +! For every day, calculates emission factor "timefac" per country, emission +! sector, emission component +! +! Sets the day/night emissions variation in day_factor +! +! D. Simpson, 3/2/99 +!_____________________________________________________________________________ + use CheckStop_ml, only : CheckStop + use Country_ml, only : NLAND + use My_Emis_ml, only : NEMIS, EMIS_NAME + use EmisDef_ml, only : NSECTORS + use TimeDate_ml, only: & ! subroutine, sets: + date, & ! date-type definition + nmdays, nydays, & ! days per month (12), days per year + day_of_week,& ! weekday, 0=sun, 1=thuesday... + 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 + + !-- subroutines: + + public :: NewDayFactors + public :: timefactors + + !-- time factor stuff: + + real, public, save, & + dimension(NLAND,NSECTORS,NEMIS) :: timefac ! overall emission timefactor + ! calculated daily + real, public, save, & + dimension(NLAND,12,NSECTORS,NEMIS) :: fac_emm ! Monthly factors + real, public, save, & + dimension(NLAND, 7,NSECTORS,NEMIS) :: fac_edd ! Daily factors + + real, public, save, dimension(NSECTORS,0:1):: day_factor ! Day/night factor + + logical, private, parameter :: DEBUG = .false. + + !/** used for general file calls and mpi routines below **/ + + character(len=30), private :: fname2 ! input filename - do not change + +contains + + + ! <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine timefactors(year) + + !....................................................................... + !** DESCRIPTION: + ! Read in monthly and daily factors, -> fac_emm, fac_edd arrays + ! The input files are Monthly.sox, Daily.sox, Monthly.nox, etc. + ! Sets the day/night variation in day_factor + ! + ! D. Simpson, 3/2/99 + !....................................................................... + + !--Input + integer, intent(in) :: year + + !-- Outputs - module's fac_emm, fac_edd, day_factor, etc. + + !-- 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 :: iemis ! emission count variables + + integer :: weekday ! 1=monday, 2=tuesday etc. + real :: xday, sumfac ! used in interpolation, testing + character(len=100) :: errmsg + + +!/** Factor giving nighttime emission ratio. +! ** note this is hard-coded with NSECTORS=11. Checked in code + + 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 + , 1.0 &! 10. Agriculture + , 1.0 &! 11. Nature + /) + + if (DEBUG) write(unit=6,fmt=*) "into timefactors.f " + + call CheckStop( nydays < 365, & + "Timefactors: ERR:Call set_nmdays before timefactors?") + + call CheckStop( NSECTORS /= 11 , & + "Timefactors: ERR:Day-Night dimension wrong!") + + +! ################################# +! *** 1) Read in Monthly factors + + fac_emm(:,:,:,:) = 1.0 + + do iemis = 1, NEMIS + + fname2 = "MonthlyFac." // trim ( EMIS_NAME(iemis) ) + call open_file(IO_TIMEFACS,"r",fname2,needed=.true.) + + call CheckStop( ios, & + "Timefactors: IOS error in Monthlyfac") + + n = 0 + do + read(IO_TIMEFACS,fmt=*,iostat=ios) inland, insec, & + (fac_emm(inland,mm,insec,iemis),mm=1,12) + if ( ios < 0 ) exit ! End of file + + call CheckStop( ios, "Timefactors: Read error in Monthlyfac") + + n = n + 1 + enddo + + close(IO_TIMEFACS) + + if (DEBUG) write(unit=6,fmt=*) "Read ", n, " records from ", fname2 + enddo ! iemis + + +! ################################# +!CCC*** 2) Read in Daily factors + + fac_edd(:,:,:,:) = 1.0 + + do iemis = 1, NEMIS + + fname2 = "DailyFac." // trim ( EMIS_NAME(iemis) ) + call open_file(IO_TIMEFACS,"r",fname2,needed=.true.) + + call CheckStop( ios, & + "Timefactors: Opening error in Dailyfac") + + n = 0 + do + read(IO_TIMEFACS,fmt=*,iostat=ios) inland, insec, & + (fac_edd(inland,i,insec,iemis),i=1,7) + if ( ios < 0 ) exit ! End of file + + call CheckStop( ios, "Timefactors: Read error in Dailyfac") + + n = n + 1 + + !-- Sum over days 1-7 + xday = sum( fac_edd(inland,1:7,insec,iemis) ) / 7.0 + + call CheckStop( xday > 1.001 .or. xday < 0.999, & + "Timefactors: ERROR: Dailyfac - not normalised") + + enddo + + close(IO_TIMEFACS) + if (DEBUG) write(unit=6,fmt=*) "Read ", n, " records from ", fname2 + + enddo ! NEMIS + +! ####################################################################### +!cccc 3) 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 +! in "NewDayFactors", and scale efac_mm if necessary + + + write(unit=6,fmt=*) "Time factor interpolation " + write(unit=6,fmt=*) "for nmdays(2) = ", nmdays(2), " gives nydays= ", nydays + + do iemis = 1, NEMIS + n = 0 + do isec = 1, NSECTORS + do ic = 1, NLAND + iday = 0 + sumfac = 0.0 + + do mm = 1, 12 ! Jan - Dec + do idd = 1, nmdays(mm) + + weekday=day_of_week (year,mm,idd) + + if ( weekday == 0 ) weekday = 7 ! restores sunday to 7 + + mm2 = mm + 1 + if( mm2 > 12 ) mm2 = 1 ! December+1 => January + + xday = real(idd-1) /real(nmdays(mm)) + + sumfac = sumfac + & ! timefac + ( fac_emm(ic,mm,isec,iemis) + & + ( fac_emm(ic,mm2,isec,iemis) & + - fac_emm(ic,mm,isec,iemis) ) * xday ) & + * fac_edd(ic,weekday,isec,iemis) + + end do ! idd + end do ! mm + + sumfac = real(nydays)/sumfac + + + if ( sumfac < 0.97 .or. sumfac > 1.03 ) then + write(unit=errmsg,fmt=*) & + "Time-factor error! for ",iemis, isec, ic," sumfac ",sumfac + call CheckStop(errmsg) + end if + + if ( sumfac < 0.999 .or. sumfac > 1.001 ) then + n = n+1 + ! Slight adjustment of monthly factors + do mm = 1, 12 + fac_emm(ic,mm,isec,iemis) = & + fac_emm(ic,mm,isec,iemis) * sumfac + end do ! mm + end if + + end do ! ic + enddo ! isec + + if ( n == 0 ) & + write(unit=6,fmt=*) & + "Correction not needed for iemis, sumfac = " ,iemis, sumfac + + enddo ! iemis + + +!######################################################################### +! +! 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: " + do mm = 1, 12 + print "(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) + end if ! DEBUG + + end subroutine timefactors + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + + !>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine NewDayFactors(newdate) + ! + ! Calculates the monthly and daily factors for emission temporal variation + ! for each country, emission, and sector. Called at midnight every day. + ! + ! Uses arays: + ! fac_emm(NLAND,NM,NSECTORS,NEMIS) ! Jan - Dec. + ! fac_edd(NLAND,7,NSECTORS,NEMIS) ! Monday=1, Sunday=7 + ! + ! Outputs: + ! real timefac(NLAND,NSECTORS,NEMIS) + ! + !........................................................................... + !nyear(1) - year of simulation + !........................................................................... + + type(date), intent(in) :: newdate + integer :: isec ! index over emission sectors + integer :: iemis ! index over emissions (so2,nox,..) + integer :: iland ! index over countries + integer :: nmnd, nmnd2 ! this month, next month. + integer :: weekday,nday,n ! 1=monday, 2=tuesday etc. + real :: xday ! used in interpolation + integer :: yyyy,dd + + !----------------------------- + + yyyy=newdate%year + nmnd=newdate%month + dd=newdate%day + + weekday = day_of_week(yyyy,nmnd,dd) + if ( weekday == 0 ) weekday = 7 ! restores sunday to 7 + +! Parameters for time interpolation + + nmnd2 = nmnd + 1 ! Next month + if( nmnd2 > 12 ) nmnd2 = 1 ! December+1 => January + + xday = real( newdate%day - 1 ) / real( nmdays(nmnd) ) + +! Calculate monthly and daily factors for emissions + + do iemis = 1, NEMIS + do isec = 1, NSECTORS + do iland = 1, NLAND + + timefac(iland,isec,iemis) = & + ( fac_emm(iland,nmnd,isec,iemis) + & + ( fac_emm(iland,nmnd2,isec,iemis) - & + fac_emm(iland,nmnd,isec,iemis ) ) * xday ) & + * fac_edd(iland,weekday,isec,iemis) + + enddo ! iland + enddo ! isec + enddo ! iemis + end subroutine NewDayFactors + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end module Timefactors_ml + diff --git a/Timing_ml.f90 b/Timing_ml.f90 new file mode 100644 index 0000000..249d52a --- /dev/null +++ b/Timing_ml.f90 @@ -0,0 +1,133 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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_Timing_ml + !---------------------------------------------------------------------------- + !+ + ! Timing code, Variables and text array for CPU-timing + ! + ! This module may be used to collect information on either system time or + ! CPU time. Calling Code_timer from the external routines is the standard + ! interface. If system time is required then modify Code_timer below to + ! use system_clock, and declare the time variables (tim_before, tim_after, etc.) + ! as integers. If CPU time is required modify Code_timer to call + ! CPU_TIME and declare the time variables as real. + ! + ! Code commented out or marked with !SYS is intended for system_clock + ! Code commented out or marked with !CPU is intended for cpu_time + !---------------------------------------------------------------------------- + implicit none !6z addition + + public :: Init_timing + public :: Add_2timing ! Calls Code_timer, adds times and descriptions + ! to arrays + public :: Output_timing ! Outputs + + integer, public, parameter :: NTIMING=39 + real, public, dimension(NTIMING), save :: mytimm ! stores CPU-s + real, public, dimension(NTIMING), save :: lastptim ! for final CPU-s + character(len=30), public, & + dimension(NTIMING), save :: timing = "" ! description + + real, private, save :: rclksec ! rate-of-clock + + +!/--- MAKE CHANGE HERE TO SWAP FROM SYSTEM_CLOCK TO SYSTEM_TIME + + logical, parameter, private :: IS_CPU_TIME = .true. + +!SYS integer, public, save :: & !SYS + real, public, save :: & !CPU + tim_before,tim_before0,tim_after,tim_after0,tim_before1 + + + contains + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine Init_timing() + + integer :: iclktck,iclksec,ierr + +!SYS call system_clock(iclktck,iclksec) ! SYS +!SYS rclksec = 1./float(iclksec) ! SYS + + mytimm(:) = 0.0 !CPU and SYS + + end subroutine Init_timing + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + subroutine Add_2timing(n,after,before,txt) + !+ calculates CPU time and resets "before" to "after" + + integer, intent(in) :: n ! No (1..NTIMING) +!SYS integer, intent(inout) :: before ! SYS +!SYS integer, intent(out) :: after ! SYS + real, intent(inout) :: before ! CPU + real, intent(out) :: after ! CPU + character(len=*), intent(in), optional :: txt + + call Code_Timer(after) +!SYS mytimm(n) = mytimm(n) + (after-before)*rclksec ! SYS + mytimm(n) = mytimm(n) + after-before ! CPU + + if ( present(txt) ) timing(n) = txt ! Descriptive text if wanted + if ( after +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Trajectory_ml + + !----------------------------------------------------------------! + ! The purpose of this module is to provide output along a ! + ! trajectory. The trajectory, defined in i,j (should be ! + ! LAt LONG), height in m and time in UTC ! + ! has to be given as in input file. The trajectory could be an ! + ! an air parcel trajectory or a flight track for comparison with ! + ! aircraft measurements (MOZAIC etc) ! + ! WARNING!! This module has not been used for a very long time ! + ! and should be updated before use. ! + !----------------------------------------------------------------! + + + use My_Outputs_ml, only : NADV_FLIGHT, FLIGHT_ADV !ds - added + use Chemfields_ml , only : xn_adv + use GenSpec_adv_ml + use GridValues_ml , only : gl, gb + use Io_ml, only : IO_AIRCR + use Met_ml, only : z_bnd,z_mid + use ModelConstants_ml , only : dt_advec,PPBINV,KMAX_BND,NPROC + use Par_ml , only : gi0,gi1,gj0,gj1,IRUNBEG,JRUNBEG,me + use TimeDate_ml, only : current_date + implicit none + private + + public trajectory_init + public trajectory_in + public trajectory_out + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + integer, private, save :: iimax, iii + integer, private, save :: fapos(2,999) + real, private, save :: kfalc(999), rhour(999) + + contains + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine trajectory_init + implicit none + + iii = 1 + rhour(1) = 1. + rhour(2) = 0. + + end subroutine trajectory_init + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine trajectory_in + + character*20 falc + logical tra_exist + + integer ii,info + + + ! Here month and day where trajectory is expected is hardcoded. + if(current_date%month == 6) then + if(current_date%day == 1 .or. current_date%day == 16 ) then + if(me == 0)then + write(falc,fmt='(''tra9606'',i2.2,''.pos'')') & + current_date%day + inquire(file=falc,exist=tra_exist) + write(6,*)'trajectory exists?',tra_exist + if(.not.tra_exist)goto 912 + open(IO_AIRCR,file=falc,status='unknown') + ii = 0 + do while (.true.) + ii = ii + 1 + read(IO_AIRCR,*,end=701) rhour(ii), fapos(1,ii), & + fapos(2,ii), kfalc(ii) + end do +701 continue + iimax = ii + rhour(iimax+1) = 0. + write(6,*) 'falcon positions ',iimax + write(6,*) (rhour(ii), & + fapos(1,ii), fapos(2,ii),kfalc(ii),ii=1,5) + close(IO_AIRCR) + open(IO_AIRCR,file='aircraft.dat',position='append') + write(IO_AIRCR,*) 'month and day ',current_date%month & + ,current_date%day + close(IO_AIRCR) + endif + iii = 1 +!su read on node 0 + +912 continue + +!su 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 + endif + endif + + return + end subroutine trajectory_in + + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + + subroutine trajectory_out + + real ttt, dtmil + + integer ii,jj,k,jjj,info + integer :: i + +! trajectory positions +! if(me == 0) write(6,*) 'for tidsjekk',current_date%hour & +! ,dt_advec,(rhour(ii),ii=1,5) + + dtmil = dt_advec/60./60. + ttt = current_date%hour+current_date%seconds/3600. + if (rhour(2) > rhour(1) & + .and. ttt+dtmil > rhour(1)) then + do jjj = 1,10 + if(me == 0) write(6,*) 'inne i tidsjekk', & + iii,jjj,ttt,rhour(iii),rhour(iii+1),dt_advec,dtmil + + 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 !!!! + + CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) + + if(me == 0) write(6,*) 'inne i tidsjekk2' & + ,fapos(1,iii),fapos(1,iii), ttt + if(gi0+IRUNBEG-1 <= fapos(1,iii) .and. & + gi1+IRUNBEG-1 >= fapos(1,iii) .and. & + gj0+JRUNBEG-1 <= fapos(2,iii) .and. & + gj1+JRUNBEG-1 >= fapos(2,iii)) then + write(6,*) 'inne i tidsjekk3',me,kfalc(iii) + ii = fapos(1,iii) - gi0-IRUNBEG+2 + jj = fapos(2,iii) - gj0-JRUNBEG+2 + do k = 1,KMAX_BND-1 + if(z_bnd(ii,jj,k) > kfalc(iii) .and. & + z_bnd(ii,jj,k+1) < kfalc(iii)) then + 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), gb(ii,jj),gl(ii,jj) + close(IO_AIRCR) + end if + end do + end if + iii = iii + 1 + end if + ttt = ttt + dtmil*0.1 + end do + end if + + return + end subroutine trajectory_out + !<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +end module Trajectory_ml + + diff --git a/Unimod.f90 b/Unimod.f90 new file mode 100644 index 0000000..7865f22 --- /dev/null +++ b/Unimod.f90 @@ -0,0 +1,457 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! +program myeul + ! + ! This is the main program for the off-line regional scale multilayer + ! eulerian model at emep/msc-w. the main program contains the outer + ! time-loop which runs through all time-levels a new meteorological + ! data-set is read into the model from file. the inner time-loop + ! runs through the physical time-step. + ! + !------------------------------------------------------------------------ + + use My_Emis_ml, only : NBVOC, AIRNOX + use My_Outputs_ml, only : set_output_defs + use My_Timing_ml, only : lastptim,mytimm,Output_timing, & + Init_timing, Add_2timing, Code_timer, & + tim_before,tim_before0,tim_before1, & + tim_after,tim_after0 + use My_WetDep_ml, only : Init_WetDep + use MyChem_ml, only : Init_mychem + + use Advection_ml, only : vgrid,adv_var, assign_nmax,assign_dtadvec + use Aqueous_ml, only : init_aqueous ! Initialises & tabulates + use AirEmis_ml, only : aircraft_nox, lightning + use Biogenics_ml, only : Init_BVOC + use BoundaryConditions_ml, only : BoundaryConditions + use CheckStop_ml, only : CheckStop + use Chemfields_ml , only : xn_adv + use DefPhotolysis_ml, only : readdiss + use Derived_ml, only : Init_Derived & + ,IOU_INST,IOU_HOUR, IOU_YEAR,IOU_MON, IOU_DAY + use Emissions_ml, only : Emissions ,newmonth ! subroutines + use GenChemicals_ml, only : define_chemicals + use GenSpec_adv_ml , only : NSPEC_ADV + use GridValues_ml, only : MIN_ADVGRIDS,GRIDWIDTH_M,Poles + use Io_ml , only : IO_MYTIM,IO_RES,IO_LOG,IO_TMP + use Io_Progs_ml , only : read_line + use Landuse_ml, only : InitLandUse + use MassBudget_ml, only : Init_massbudget,massbudget + use Met_ml , only : metvar,MetModel_LandUse,& + tiphys,Meteoread,MeteoGridRead,& + startdate + use ModelConstants_ml,only : KMAX_MID & ! No. vertical layers + ,RUNDOMAIN & ! + ,NPROC & ! No. processors + ,METSTEP & ! Hours between met input + ,runlabel1 & ! explanatory text + ,runlabel2 & ! explanatory text + ,nprint,nass,nterm,iyr_trend, PT + use NetCDF_ml, only : Init_new_netCDF + use OutputChem_ml, only : WrtChem + use Par_ml, only : me,GIMAX,GJMAX ,MSG_MAIN1,MSG_MAIN2& + ,Topology, parinit & + ,li0,li1,lj0,lj1,tgi0,tgj0 & ! FOR TESTING + ,limax, ljmax, MAXLIMAX, MAXLJMAX, gi0, gj0 + use PhyChem_ml, only : phyche ! Calls phys/chem routines each dt_advec + use Sites_ml, only : sitesdef ! to get output sites + use Tabulations_ml, only : tabulate + use TimeDate_ml, only : date, current_date, day_of_year,daynumber + use Trajectory_ml, only : trajectory_init,trajectory_in + use Nest_ml, only : wrtxn + + !-------------------------------------------------------------------- + ! + ! Variables. There are too many to list here. Still, here are a + ! few key variables that might help: + + ! dt_advec - length of advection (phyche) time-step + ! GRIDWIDTH_M - grid-distance + ! gb - latitude (sorry, still Norwegian influenced..) + ! NPROC - number of processors used + ! me - number of local processor, e.g. me=0 is host + ! processor where many read/writes are done + ! NSPEC_ADV - number of chemical components transport in the model + ! NSPEC_SHL - number of chemical components not-transport in the model + ! NSPEC_BGN - number of specified chemical components + ! ndays - number of days since 1 january (max 365 or 366) + ! thour - utc-time in hours every time-step + ! xm(i,j) - map factor + ! xm2(i,j) - xm**2 + ! xmd(i,j) - 1./xm2 + ! xn_adv(NSPEC_ADV,i,j,k) - chemical component (1 = so2, 2 = so4) + ! . + ! . + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! + ! + ! + ! +---------------------------------------------------------+ + ! + + + ! + + + ! + start main programme + + ! + + + ! +_________________________________________________________+ + ! + ! + ! + ! declarations in main programme. + ! + implicit none + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + + logical, parameter :: DEBUG_UNI = .false. + integer n, numt, nadd, oldseason,newseason + integer iupw, i, j, ii, k, iotyp, d + integer :: mm, mm_old ! month and old-month + integer :: nproc_mpi,cyclicgrid + character (len=130) :: fileName, errmsg,txt + + ! + ! initialize the parallel topology + ! + nproc_mpi = NPROC + CALL MPI_INIT(INFO) + CALL MPI_COMM_RANK(MPI_COMM_WORLD, ME, INFO) + CALL MPI_COMM_SIZE(MPI_COMM_WORLD, nproc_mpi, INFO) + + ! some checks + ! + if(nproc_mpi /= NPROC)then + write(unit=errmsg,fmt=*)"Wrong processor number!", & + "program was compiled with NPROC = ",NPROC, & + " but linked with ", nproc_mpi + call CheckStop( errmsg ) + end if + call CheckStop( digits(1.0) < 50, & + "COMPILED WRONGLY: Need double precision, e.g. f90 -r8") + + if (me == 0) then + open(IO_RES,file='eulmod.res') + open(IO_LOG,file='RunLog.out') + open(IO_TMP,file='INPUT.PARA') + endif + + call read_line(IO_TMP,txt,status(1)) + read(txt,*) nterm + call read_line(IO_TMP,txt,status(1)) + read(txt,*) nass + call read_line(IO_TMP,txt,status(1)) + read(txt,*) iyr_trend + + call read_line(IO_TMP,runlabel1,status(1))! explanation text short + call read_line(IO_TMP,runlabel2,status(1))! explanation text long + do i=1,3 + call read_line(IO_TMP,txt,status(1)) + read(txt,*)startdate(i)! meteo year,month,day to start the run + enddo + startdate(4)=0!meteo hour to start the run + + if( me == 0 ) then + close(IO_TMP) + write(unit=IO_LOG,fmt=*)trim(runlabel1) + write(unit=IO_LOG,fmt=*)trim(runlabel2) + write(unit=IO_LOG,fmt=*)startdate(1) + write(unit=IO_LOG,fmt=*)startdate(2) + write(unit=IO_LOG,fmt=*)startdate(3) + write(unit=IO_LOG,fmt=*)"iyr_trend= ", iyr_trend + write(unit=IO_LOG,fmt="(a12,4i4)")"RunDomain: ", RUNDOMAIN + endif + + if( me == 0 ) print *, "read standard input" + if( me == 0 ) print *, "RUNLABEL INPUT ", trim(runlabel1),' ',trim(runlabel2) + if( me == 0 ) print *, " Trend Year is ", iyr_trend + + + !*** Timing ******** + + call Init_timing() + call Code_Timer(tim_before0) + tim_before = tim_before0 + + call parinit(MIN_ADVGRIDS) !define subdomains sizes and position + call MeteoGridRead(cyclicgrid) !define grid projection and parameters + call Topology(cyclicgrid,Poles) !define GlobalBoundaries + !and subdomains neighbors + call assign_dtadvec(GRIDWIDTH_M)! set dt_advec + + + + ! Decide the frequency of print-out + ! + nadd = 0 + nprint = nterm + if (nterm > nprint) nadd = 1 + + if (me == 0) write(6,*)'nterm, nprint',nterm, nprint + + !------------------------------------------------------------------- + ! + !++ parameters and initial fields. + ! + + call Add_2timing(1,tim_after,tim_before,"Before define_Chemicals") + + call define_chemicals() ! sets up species details + + call Init_Derived() ! Derived field defs. + + call set_output_defs() ! Initialises outputs + + call assign_nmax(METSTEP) ! No. timesteps in inner loop + + call trajectory_init + + call Add_2timing(2,tim_after,tim_before,"After define_Chems, readpar") + + + call MeteoRead(1) + + call Add_2timing(3,tim_after,tim_before,"After infield") + + if ( me == 0 .and. DEBUG_UNI) write(6,*)"Calling emissions with year" ,current_date%year + + 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 + + + if ( NBVOC > 0 ) call Init_BVOC() + + call tabulate() ! => sets up tab_esat, etc. + + call Init_mychem() ! tabulates rct to rctit + + call Init_WetDep() ! sets up scavenging ratios + + call sitesdef() !--- see if any output for specific sites is wanted + ! (read input files "sites.dat" and "sondes.dat" ) + + call vgrid ! initialisation of constants used in vertical advection + if ( me == 0 .and. DEBUG_UNI) write(6,*)"vgrid fifniseh" + + if ( me == 0 ) then + fileName=trim(runlabel1)//'_inst.nc' + iotyp=IOU_INST + call Init_new_netCDF(fileName,iotyp) + !netCDF hourly is initiated in Output_hourly + fileName=trim(runlabel1)//'_hour.nc' + iotyp=IOU_HOUR + call Init_new_netCDF(fileName,iotyp) + fileName=trim(runlabel1)//'_day.nc' + iotyp=IOU_DAY + call Init_new_netCDF(fileName,iotyp) + fileName=trim(runlabel1)//'_month.nc' + iotyp=IOU_MON + + ! The fullrun file contains the accumulated or average results + ! over the full run period, often a year, but even just for + ! a few timesteps if that is all that is run: + + call Init_new_netCDF(fileName,iotyp) + fileName=trim(runlabel1)//'_fullrun.nc' + iotyp=IOU_YEAR + call Init_new_netCDF(fileName,iotyp) + + endif + + call metvar(1) + + call adv_var(1) + + call Add_2timing(4,tim_after,tim_before,"After tabs, defs, adv_var") + ! + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! + ! performance of physical and chemical calculations + ! + ! three-hourly time loop starts here. + ! + + mm_old = 0 + oldseason = 0 + + tim_before = tim_before0 + call Add_2timing(5,tim_after,tim_before,"Total until numt loop") + call Code_timer(tim_before1) + + + do numt = 2, nterm + nadd + + mm = current_date%month + + if (mm == 12 .or. mm < 3) then + newseason = 1 + else if(mm < 6) then + newseason = 2 + else if(mm < 9) then + newseason = 3 + else if(mm < 12) then + newseason = 4 + end if + + ! - daynumber needed for BCs, so call here to be safe + + daynumber=day_of_year(current_date%year,current_date%month,& + current_date%day) + + if (mm_old /= mm) then ! START OF NEW MONTH !!!!! + + call Code_timer(tim_before) + + !subroutines/data that must be updated every month + + call readdiss(newseason) + + if ( AIRNOX ) call aircraft_nox(newseason) + + if (me == 0 .and. DEBUG_UNI ) write(6,*) 'maaned og sesong', & + numt,mm,mm_old,newseason,oldseason + + call Add_2timing(6,tim_after,tim_before,"readdiss, aircr_nox") + + call MetModel_LandUse(2) ! e.g. gets snow + if ( me == 0 .and. DEBUG_UNI) write(6,*)"vnewmonth start" + + call newmonth + + call Add_2timing(7,tim_after,tim_before,"newmonth") + + if ( AIRNOX ) call lightning() + + call init_aqueous() + + + call Add_2timing(9,tim_after,tim_before,"init_aqueous") + + end if ! mm_old.ne.mm + + ! - we add a monthly call to BoundaryConditions. Can re-code later for + ! possibly shorter call intervals + + call Code_timer(tim_before) + + if (mm_old /= mm) then ! START OF NEW MONTH !!!!! + if( DEBUG_UNI ) print *, "Into BCs" , me + + ! We set BCs using the specified iyr_trend + ! which may or may not equal the meteorology year + + call BoundaryConditions(current_date%year,iyr_trend,mm) + if( DEBUG_UNI ) print *, "Finished BCs" , me + if(numt == 2) call Init_massbudget() + if( DEBUG_UNI ) print *, "Finished Initmass" , me + + end if + + oldseason = newseason + mm_old = mm + + call Add_2timing(8,tim_after,tim_before,"BoundaryConditions") + + if( DEBUG_UNI ) print *, "1st Infield" , me, " numu ", numt + + + call Meteoread(numt) + + call Add_2timing(10,tim_after,tim_before,"infield") + + daynumber=day_of_year(current_date%year,current_date%month,& + current_date%day) + if ( me == 0) write(6,*) 'TIME TEST ', 'current date ',current_date, & + "day number ", daynumber + + + call Code_timer(tim_before) + + call metvar(numt) + + call adv_var(numt) + + call Add_2timing(11,tim_after,tim_before,"metvar") + + call Code_timer(tim_before) + + call phyche(numt) + + call Add_2timing(18,tim_after,tim_before,"phyche") + + call WrtChem(numt) + + call trajectory_in + + + call Add_2timing(37,tim_after,tim_before,"massbud,wrtchem,trajectory_in") + + + end do ! end 3-hourly time-loop. + + call Code_timer(tim_after0) + call Add_2timing(38,tim_after0,tim_before1,"total within loops") + call Add_2timing(39,tim_after0,tim_before0,"total") + + !++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! + ! + call wrtxn(current_date,.true.) + + call massbudget() + + if(me == 0)then + write(6,*) 'programme is finished' + ! Gather timing info: + if(NPROC-1 > 0)then + CALL MPI_RECV( lastptim, 8*39, MPI_BYTE, NPROC-1 & + ,765, MPI_COMM_WORLD, STATUS, INFO) + else + lastptim(:) = mytimm(:) + endif + + call Output_timing(IO_MYTIM,me,NPROC,nterm,GIMAX,GJMAX) + + else if(me == NPROC-1) then + CALL MPI_SEND( mytimm, 8*39, MPI_BYTE, 0, 765, MPI_COMM_WORLD, INFO) + endif + !cccccccccccccccccccccccccccccccccc + + CALL MPI_BARRIER(MPI_COMM_WORLD, INFO) + CALL MPI_FINALIZE(INFO) + +end program myeul diff --git a/Volcanos_ml.f90 b/Volcanos_ml.f90 new file mode 100644 index 0000000..e2a1ef1 --- /dev/null +++ b/Volcanos_ml.f90 @@ -0,0 +1,239 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Volcanos_ml +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! +! module Volcanos_ml +! +! MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD MOD +! >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + !-----------------------------------------------------------------------! + ! Processes SOx emission heights from volcanoes + ! In volcanos_ml, only the height of the volcanos are read from volcanos.dat, + ! the emissions themselves comes from gridSOx, so this is to ensure that if + ! suddenly e.g. Iceland starts to report volcano emissions and these are in + ! gridSOx, the program will discover this. + ! Note that nvolc is set according to the emission input from the gridSOx + ! files. It counts the number of grids with the "country code" for volcanoes + ! that are in the gridSOx file. + ! + ! Note - EmisGet and other routines use "restricted" coords, which introduces + ! some complications here. Hopefully we can tidy up one day. + !-----------------------------------------------------------------------! + + use CheckStop_ml, only : CheckStop + use My_Emis_ml, only : QRCVOL,molwt + use EmisDef_ml, only : NSECTORS,ISNAP_NAT + use GridValues_ml, only : sigma_bnd, i_fdom, j_fdom,i_local, j_local + use Io_ml, only : ios, open_file, check_file, IO_VOLC + use ModelConstants_ml, only : KMAX_BND,KMAX_MID,PT, NPROC + use Met_ml, only : ps, roa + use Par_ml, only : IRUNBEG, JRUNBEG, me, li0,lj0,li1,lj1 & + ,gi0, gi1, gj0, gj1 !TEST + use PhysicalConstants_ml, only : GRAV, AVOG + + implicit none + private + + + !/* subroutines: + + public :: VolcGet + public :: Set_Volc + public :: Scale_Volc + + + integer, public, parameter :: NMAX_VOLC = 3 ! Max number of volcanoes + integer, public, save :: nvolc = 0 & ! No. grids with volcano + ! emissions in gridSOx + ,volc_no = 0 + integer, public, save, dimension(NMAX_VOLC):: & + height_volc, & ! Height of volcanoes + i_volc, j_volc ! Volcano's EMEP coordinates + real, private, save, dimension(NMAX_VOLC):: & + rcemis_volc0 ! Emissions part varying every hour + real, public, save, dimension(NMAX_VOLC) :: & + rcemis_volc, & ! Emissions part varying every time-step + emis_volc = 0.0 ! Volcanoes' emissions + + logical, private, parameter :: DEBUG_VULC = .false. + +contains + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine VolcGet(height_volc) +!*********************************************************************** + !-----------------------------------------------------------------------! + ! Reads volcanoes' coorinates (i,j) and height level(height) + ! Returns to EmisSet with height of volcanos (height_volc) + ! Input file: Volcanoes.dat + !-----------------------------------------------------------------------! + + integer, intent(out), dimension(NMAX_VOLC) :: height_volc + integer :: nvolc_read,height,i,j ! Local variables + character (len=13) :: fname + logical :: fexist + + fname = "Volcanoes.dat" + + ios=0 ! Start with assumed ok status + + call open_file(IO_VOLC,"r",fname,needed=.true.,skip=1) + + call CheckStop(ios,"VolcGet: problems with Volcanoes.dat ") + + + height_volc(:)=0.0 + nvolc_read=0 + + READVOLC: do + read(IO_VOLC,*,iostat=ios) i,j,height + + if (DEBUG_VULC) write(*,*)'found i,j,heigh',i,j,height + if ( ios /= 0 ) exit READVOLC + + !/** Read (i,j) are given for the full EMEP polar-stereographic domain + ! Convert them to actual run domain + i = i -IRUNBEG+1 + j = j -JRUNBEG+1 + + !/** Set the volcano number to be the same as in emission data (gridSOx) + + do volc_no=1,nvolc + if ((i_volc(volc_no)==i) .and. (j_volc(volc_no)==j)) then + height_volc(volc_no)=height + nvolc_read=nvolc_read+1 + if (DEBUG_VULC) write(*,*)'Found volcano with height k=',height + endif + enddo + enddo READVOLC + + write(6,*) nvolc_read,' volcanos on volcanos.dat & + & match volcanos on emislist.sox' + write(6,*) nvolc,' volcanos found in emislist.sox' + + call CheckStop(nvolc_read < nvolc, "Volc missing in Volcanos.dat") + + close(IO_VOLC) + + end subroutine VolcGet +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine Set_Volc + + !-----------------------------------------------------------------------! + ! Starts converting emission units from kg/m2/s to.... (hourly) + !-----------------------------------------------------------------------! + + !**Local variables + integer :: k,i,j, i1,i2,j1,j2 + real :: unit_conv1 + + rcemis_volc0(:) = 0.0 + unit_conv1 = 0.0 + + !/** Set volcano + do volc_no=1,nvolc + k=height_volc(volc_no) + i=i_volc(volc_no) +IRUNBEG-1 !NEW + j=j_volc(volc_no) +JRUNBEG-1 !NEW + + if ( DEBUG_VULC ) & + write(6,'(a20/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, & + 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 + + unit_conv1 = GRAV* 0.001*AVOG/ & + (sigma_bnd(KMAX_BND-k+1) - sigma_bnd(KMAX_BND-k)) + + rcemis_volc0(volc_no) = emis_volc(volc_no) & + * unit_conv1 / molwt(QRCVOL) + + if ( DEBUG_VULC ) & + write(*,*)'rc_emis_volc is ',rcemis_volc(volc_no) + + endif + enddo ! volc_no + end subroutine Set_Volc +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< + +!>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> + subroutine Scale_Volc + + !-----------------------------------------------------------------------! + ! Finishing converting volcano emissions to molecules/cm3/s + ! (every advection timestep) + !-----------------------------------------------------------------------! + + integer i,j,k,i_l,j_l, i1,i2,j1,j2 + real unit_conv2 + + + do volc_no=1,nvolc + + k=height_volc(volc_no) + i=i_volc(volc_no) +IRUNBEG-1 !NEW + j=j_volc(volc_no) +JRUNBEG-1 !NEW + ! i=i_volc(volc_no) + ! j=j_volc(volc_no) + + if ( DEBUG_VULC ) & + write(6,'(a20/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, & + 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 + + i_l = i_local(i) !local i + j_l = j_local(j) !local j + + + if ( DEBUG_VULC ) & + write(6,'(a30,4i8)')'Volcan: check 3: ', & + i_l, j_l, i_volc(volc_no)-gi0+1, j_volc(volc_no)-gj0+1 + + unit_conv2 = roa(i_l,j_l,KMAX_BND-k,1) / (ps(i_l,j_l,1)-PT) + + rcemis_volc(volc_no) = rcemis_volc0(volc_no) * unit_conv2 + + if ( DEBUG_VULC ) & + write(*,*)'rc_emis_volc is ',rcemis_volc(volc_no) + + endif + enddo ! volc_no + + end subroutine Scale_Volc +!<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< +end module Volcanos_ml diff --git a/Wesely_ml.f90 b/Wesely_ml.f90 new file mode 100644 index 0000000..c2b89dc --- /dev/null +++ b/Wesely_ml.f90 @@ -0,0 +1,129 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 Wesely_ml +!.............................................................................. +! specifies data for deposition modelling using procedures recommended by +! Wesely, 1989, Atmos. Environ., 23, No.6, pp. 1293-1304 +! +!.............................................................................. + + +! includes Wesely_tab2 for 14 gases +! specifies Henry's coefficients, reactivities for gases +! +use PhysicalConstants_ml, only : PRANDTL, Sc_H20 +implicit none +private + + + +!------------------------------------------------------------------------- +! Table2: (variable, igas) +! Variable: +! 1 = DH2O/Dx ! ratio of diffusivities +! 2 = H* M atm^-1 ! effective Henry coeff. +! 3 = pe ! +! 4 = k (M s)**(-1) ! +! 5 = f0 ! +! +public :: Init_GasCoeff + + +integer, public, parameter :: NWESELY = 14 ! no. of gases in Wesely tables + + real, public, parameter, & ! Wesely Table 2 + dimension(5,NWESELY) :: Wesely_tab2 = & + reshape ( & + (/ & +! D H* pe k f0 + 1.9, 1.0e5, -5.0, 9999.0, 0.0, &! 1 = SO2 Sulphur dioxide + 1.6, 1.0e-2, 28.0, 6.0e8, 1.0, &! 2 = O3 Ozone + 1.6, 1.0e-2, 9999.0, 2.0e6, 0.1, &! 3 = NO2 Nitrogen dioxide + 1.3, 2.0e-3, 9999.0, 1.0e-2, 0.0, &! 4 = NO Nitric oxide + 1.9, 1.0e14, 7.0, 1.0e-2, 0.0, &! 5 = HNO3 Nitric acid vapour + 1.4, 1.0e5, 23.0, 7.0, 1.0, &! 6 = H2O2 Hydrogen peroxide + 1.6, 1.5e1, -1.0, 9999.0, 0.0, &! 7 = (ALD) Acetaldehyde + 1.3, 6.0e3, -3.0, 9999.0, 0.0, &! 8 = HCHO Formaldehyde + 1.6, 2.4e2, 9999.0, 2.0, 0.1, &! 9 = (OP) Methyl hydroperoxide + 2.0, 5.4e2, 9999.0, 6.0e2, 0.1, &! 10 = PAA Peroxyacetic acid + 1.6, 4.0e6, -8.0, 9999.0, 0.0, &! 11 = (ORA) Formic acid + ! followed CEH recommendation and set H* NH3 equal to sulphur + ! (actually, CEH would have set it much higher than SO2!) + !orig: 2.0e4, 9999.0, 9999.0, 0.0, &! 12 = NH3 Ammonia + 1.0, 1.0e5, 9999.0, 9999.0, 0.0, &! 12 = NH3 Ammonia + 2.6, 3.6e0, 9999.0, 3.0e3, 0.1, &! 13 = PAN Peroxyacetyl nitrate + 1.6, 1.0e5, 6.0, 4.0e-4, 0.1 &! 14 = HNO2 Nitrous acid + /), & + (/5,NWESELY/) ) + + +!/ Ratio of diffusivites compared to ozone.. + +real, public, dimension(NWESELY), save :: DRx ! Ratio D(O3)/D(x) + +!/ and for the calculation of Rb we need: + +real, public, dimension(NWESELY), save :: Rb_cor ! two-thirds power of the + ! 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 + + + +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 + + !========================================================== + ! -> Calculated Rb_cor + + !Declaration of local variables + + integer :: icmp, iallwes + real :: Schmidt !.. number + + + 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 + + end subroutine Init_GasCoeff +end module Wesely_ml diff --git a/global2local.f90 b/global2local.f90 new file mode 100644 index 0000000..90a3290 --- /dev/null +++ b/global2local.f90 @@ -0,0 +1,269 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! + subroutine global2local(gloarr,locarr,msnr& + ,dim0,dimi,dimj,diml,ibeg,jbeg) +! +! distribute a 'real' array gloarr among the processors to get locarr +! the array may have maximum 4 dimensions (i.e. snapemis) +! , where the dimensions to be distributed, are dimi,dimj +! the input array gloarr may be already restricted or not +! + use ModelConstants_ml, only : NPROC ! Actual total number of processors + use PAR_ML , only : & + MAXLIMAX& ! Maximum number of local points in longitude& + ,MAXLJMAX& ! Maximum number of local points in latitude& + ,tgi0 & ! start points for all processors in longitude& + ,tgj0 & ! start points for all processors in latitude& + ,tlimax & ! number of points for all processors in longitude& + ,tljmax & ! number of points for all processors in latitude& + ,me ! Address of processor, numbering starts at 0 in south-west corner of ground level +! + implicit none +! + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO + +! input + integer msnr ! message number + integer dim0& ! first dimension, possibly = 1 (= NSECTORS for snapemis)& + ,dimi& ! dimension in longitude (= GIMAX or IIFULLDOM)& + ,dimj& ! dimension in latitude (= GJMAX or JJFULLDOM)& + ,diml& ! 4th dimension, possibly = 1 (= NCMAX for snapemis)& + ,ibeg& ! start point of the array in longitude, = 1 for dimi = GIMAX or = IRUNBEG for dimi = IIFULLDOM& + ,jbeg ! start point of the array in latitude, = 1 for dimj = GJMAX or = JRUNBEG for dimj = JJFULLDOM + real gloarr(dim0,dimi,dimj,diml) ! Global array +! +! output + real locarr(dim0,MAXLIMAX,MAXLJMAX,diml) ! Local array +! +! local + integer i,j,d,n0,nl +! + if (me .ne. 0) then +! +! receive from host +! + CALL MPI_RECV( locarr, 8*dim0*MAXLIMAX*MAXLJMAX*diml, & + MPI_BYTE, 0, msnr, MPI_COMM_WORLD, STATUS, INFO) + +! + else ! me = 0 +! +! first send to the others +! + do d = 1, NPROC-1 + do nl = 1,diml + do j = 1, tljmax(d) + do i = 1, tlimax(d) + do n0 = 1,dim0 + locarr(n0,i,j,nl) = gloarr(n0,tgi0(d)+ibeg-2+i& + ,tgj0(d)+jbeg-2+j,nl) + enddo + enddo + enddo + enddo + CALL MPI_SEND(locarr,8*dim0*MAXLIMAX*MAXLJMAX*diml, MPI_BYTE, & + d, msnr, MPI_COMM_WORLD, INFO) + enddo +! +! now assign processor 0 itself +! + do nl = 1,diml + do j = 1, tljmax(0) + do i = 1, tlimax(0) + do n0 = 1,dim0 + locarr(n0,i,j,nl) = gloarr(n0,i+ibeg-1,j+jbeg-1,nl) + enddo + enddo + enddo + enddo +! + endif ! me=? +! + return + end +! +! + subroutine global2local_int(gloarr,locarr,msnr& + ,dimi,dimj,diml,ibeg,jbeg) +! +! distribute an 'integer' array gloarr among the processors to get locarr +! the array may have maximum 3 dimensions (i.e. landcode) +! , where the dimensions to be distributed, are dimi,dimj +! the input array gloarr may be already restricted or not +! + use ModelConstants_ml, only : NPROC ! Actual total number of processors + use PAR_ML , only : & + MAXLIMAX& ! Maximum number of local points in longitude& + ,MAXLJMAX& ! Maximum number of local points in latitude& + ,tgi0 & ! start points for all processors in longitude& + ,tgj0 & ! start points for all processors in latitude& + ,tlimax & ! number of points for all processors in longitude& + ,tljmax & ! number of points for all processors in latitude& + ,me ! Address of processor, numbering starts at 0 in south-west corner of ground level +! + implicit none + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO +! +! input + integer msnr ! message number + integer dimi & ! dimension in longitude (= GIMAX or IIFULLDOM)& + ,dimj& ! dimension in latitude (= GJMAX or JJFULLDOM)& + ,diml & ! 3rd dimension, possibly = 1 (= NCMAX for landcode)& + ,ibeg & ! start point of the array in longitude, = 1 for dimi = GIMAX or = IRUNBEG for dimi = IIFULLDOM& + ,jbeg ! start point of the array in latitude, = 1 for dimj = GJMAX or = JRUNBEG for dimj = JJFULLDOM + integer gloarr(dimi,dimj,diml) ! Global array +! +! output + integer locarr(MAXLIMAX,MAXLJMAX,diml) ! Local array +! +! local + integer i,j,d,nl +! + if (me .ne. 0) then +! +! receive from host +! + CALL MPI_RECV(locarr, 4*MAXLIMAX*MAXLJMAX*diml, MPI_BYTE, 0, & + msnr, MPI_COMM_WORLD,STATUS, INFO) +! + else ! me = 0 +! +! first send to the others +! + do d = 1, NPROC-1 + do nl = 1,diml + do j = 1, tljmax(d) + do i = 1, tlimax(d) + locarr(i,j,nl)=gloarr(tgi0(d)+ibeg-2+i& + ,tgj0(d)+jbeg-2+j,nl) + enddo + enddo + enddo + CALL MPI_SEND( locarr, 4*MAXLIMAX*MAXLJMAX*diml, & + MPI_BYTE, d, msnr, MPI_COMM_WORLD, INFO) + enddo +! +! now assign processor 0 itself +! + do nl = 1,diml + do j = 1, tljmax(0) + do i = 1, tlimax(0) + locarr(i,j,nl) = gloarr(i+ibeg-1,j+jbeg-1,nl) + enddo + enddo + enddo +! + endif ! me = ? +! + return + end +! + subroutine global2local_short(gloarr,locarr,msnr& + ,dimi,dimj,diml,ibeg,jbeg) +! +! distribute a 'short integer' (integer *2) array gloarr among the processors to get locarr +! the array may have maximum 3 dimensions (i.e. landcode) +! , where the dimensions to be distributed, are dimi,dimj +! the input array gloarr may be already restricted or not +! + + use ModelConstants_ml, only : NPROC ! Actual total number of processors + use PAR_ML , only : & + MAXLIMAX& ! Maximum number of local points in longitude& + ,MAXLJMAX& ! Maximum number of local points in latitude& + ,tgi0 & ! start points for all processors in longitude& + ,tgj0 & ! start points for all processors in latitude& + ,tlimax & ! number of points for all processors in longitude& + ,tljmax & ! number of points for all processors in latitude& + ,me ! Address of processor, numbering starts at 0 in south-west corner of ground level +! + implicit none + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO +! +! input + integer msnr ! message number + integer dimi & ! dimension in longitude (= GIMAX or IIFULLDOM)& + ,dimj & ! dimension in latitude (= GJMAX or JJFULLDOM)& + ,diml & ! 3rd dimension, possibly = 1 (= NCMAX for landcode)& + ,ibeg & ! start point of the array in longitude, = 1 for dimi = GIMAX or = IRUNBEG for dimi = IIFULLDOM& + ,jbeg ! start point of the array in latitude, = 1 for dimj = GJMAX or = JRUNBEG for dimj = JJFULLDOM + integer*2 gloarr(dimi,dimj,diml) ! Global array +! +! output + integer*2 locarr(MAXLIMAX,MAXLJMAX,diml) ! Local array +! +! local + integer i,j,d,nl +! + if (me .ne. 0) then +! +! receive from host +! + + CALL MPI_RECV(locarr, 2*MAXLIMAX*MAXLJMAX*diml, MPI_BYTE, 0,msnr,& + MPI_COMM_WORLD, STATUS, INFO) +! + else ! me = 0 +! +! first send to the others +! + do d = 1, NPROC-1 + do nl = 1,diml + do j = 1, tljmax(d) + do i = 1, tlimax(d) + locarr(i,j,nl)=gloarr(tgi0(d)+ibeg-2+i& + ,tgj0(d)+jbeg-2+j,nl) + enddo + enddo + enddo + + CALL MPI_SEND(locarr, MAXLIMAX*MAXLJMAX*diml*2, MPI_BYTE, & + d, msnr,MPI_COMM_WORLD, info) + + enddo +! +! now assign processor 0 itself +! + do nl = 1,diml + do j = 1, tljmax(0) + do i = 1, tlimax(0) + locarr(i,j,nl) = gloarr(i+ibeg-1,j+jbeg-1,nl) + enddo + enddo + enddo +! + endif ! me = ? +! + return + end + diff --git a/local2global.f90 b/local2global.f90 new file mode 100644 index 0000000..c142349 --- /dev/null +++ b/local2global.f90 @@ -0,0 +1,92 @@ +! +!*****************************************************************************! +!* +!* Copyright (C) 2007 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 . +!*****************************************************************************! + subroutine local2global(locarr,gloarr,msnr) +! +! gather a 2D 'real' array from the processors at the host me=0 +! + use ModelConstants_ml, only : NPROC ! Actual total number of processors + use Par_ml , only : & + MAXLIMAX & ! Maximum number of local points in longitude + ,MAXLJMAX& ! Maximum number of local points in latitude + ,GIMAX & ! Number of global points in longitude + ,GJMAX & ! Number of global points in latitude + ,tgi0 & ! start points for all processors in longitude + ,tgj0 & ! start points for all processors in latitude + ,tlimax & ! number of points for all processors in longitude + ,tljmax & ! number of points for all processors in latitude + ,me ! Address of processor, numbering starts at 0 in south-west corner of ground level +! + implicit none + + INCLUDE 'mpif.h' + INTEGER STATUS(MPI_STATUS_SIZE),INFO +! +! input +! + integer msnr ! message number + real locarr(MAXLIMAX,MAXLJMAX) ! Local array +! +! output +! + real gloarr(GIMAX,GJMAX) ! Global array +! +! local + integer i,j,d +! + if (me .ne. 0) then +! +! send to host +! + CALL MPI_SEND( locarr, 8*MAXLIMAX*MAXLJMAX, MPI_BYTE,& + 0, msnr, MPI_COMM_WORLD, INFO) +! + else ! me = 0 +! +! copy first local array +! + do j = 1, tljmax(0) + do i = 1, tlimax(0) + gloarr(i,j) = locarr(i,j) + enddo + enddo +! +! now get from the others +! + do d = 1, NPROC-1 + CALL MPI_RECV(locarr, 8*MAXLIMAX*MAXLJMAX, MPI_BYTE, & + d, msnr, MPI_COMM_WORLD, STATUS, INFO) + do j = 1, tljmax(d) + do i = 1, tlimax(d) + gloarr(tgi0(d)-1+i,tgj0(d)-1+j)=locarr(i,j) + enddo + enddo + enddo +! + endif ! me = ? +! + end diff --git a/modrun.pl b/modrun.pl new file mode 100755 index 0000000..00ad67f --- /dev/null +++ b/modrun.pl @@ -0,0 +1,717 @@ +#!/usr/bin/env perl +#___________________________________________________________________ +# Script to run EMEP Unimod on MET.NO supercomputing system. +# +# This script was originally written for computers available to the Norwegian +# Meteorological Institute. Details of user, Makefile, disc-locations, etc, +# need to be checked and modified for different users and computers. +# The program source is here assumed to reside in a directory Unify/Unimod.rv3. +# Sorry, we have no resources to automate this ! +#___________________________________________________________________ +#Queue system commands start with #PBS ( +# lnodes= number of nodes +#PBS -lnodes=6 +# wall time limit of run +#PBS -lwalltime=0:30:00 +# lpmeme=memory to reserve per processor +# (ca 200MB for lnodes=32, 2GB for lnodes=1) +#PBS -lpmem=500MB +#___________________________________________________________________ +###################################################################### +#Tips: +# submit with >qsub srun.pl +# check queue status with >qstat -a +# kill with >qdel 3456 +###################################################################### + +use 5.6.0; # perl version +use strict; +use warnings; +use File::Copy qw(); + +$| = 1; # autoflush STDOUT + +# -j2 parallel make with 2 threads +my @MAKE = ("gmake", "-j2", "--makefile=Makefile_snow"); +# CHANGE Makefile as appropriate! + +my $SR= 0; # Set to 1 if source-receptor calculation + # see also variables in package EMEP::Sr below!! + + +# <----------! Start of user-changeable section !-----------------> + +# --- Here, the main changeable parameters are given. The variables +# are explained below, and derived variables set later + +my $year = "2005"; +( my $yy = $year ) =~ s/\d\d//; # Gets e.g. 95 from 1995 + +# iyr_trend: +# :can be set to meteorology year or arbitrary year, say 2050 + +my $iyr_trend = $year; +$iyr_trend = "2020" if $SR ; # 2020 assumed for SR runs here + +print "Year is $yy YEAR $year Trend year $iyr_trend\n"; + +#--- User-specific directories (changeable) + +my $MYNAME = "Fred"; #-- CHANGE as appropriate!!!, e.g. = "fred"; +my $USER = $MYNAME; + + +# DataDir = Main general input data directory --- CHANGE as appropriate!!! + +my $DataDir = "/home/$USER/input_data"; +my $COMMON = "$DataDir/Common"; # Grid-independent data +my $GRID_DATA = "$DataDir/EMEP_GriddedData"; # Grid specific data + +# We define a USER_DATA directory where own-defined files can be kept. Used +# below just for femis.dat so far, bit e.g. sites.dat, sondes.dat can also +# be located here. +my $USER_DATA = "$DataDir/Common"; # Set to common as default. + + +my $MetDir = "$DataDir/EMEP_metdata/$year" ; # Meteorology directory +my $emisdir = "$GRID_DATA/Emissions"; # Emissions directory + + +my $METformat="cdf"; # For netcdf-style meteorology + +my @emislist = qw ( sox nox nh3 co voc pm25 pmco ); +my $testv = "rv3"; # revision number of Unimod. We assume code + # resides in e.g. Unimod.rv3 below! + +# User directories +my $ProgDir = "/home/$USER/Unify/Unimod.$testv"; # input of source-code +my $WORKDIR = "/home/$USER/work/$testv.$year"; # working and result directory + +my $Split = "BASE_MAR2004" ; +my $NOxSplit = "2000" ; # Have CLE2020, MFR2020, 2000 +my $timeseries = "$DataDir"; + +my $version = "Unimod" ; +my $PROGRAM = "$ProgDir/$version"; # programme +my $subv = "$testv" ; # sub-version (to track changes) + +# New system. For "normal runs", we just put one run-name into the array @runs. +# For SR runs we can add many scenarios - dealt with later. +# The effect is to choose the approproate femis file + +my $scenario = "Base"; # Reset later if SR +my @runs = ( $scenario ); + + + +my $RESET = 0 ; # usually 0 (false) is ok, but set to 1 for full restart +my $COMPILE_ONLY = 0 ; # usually 0 (false) is ok, but set to 1 for compile-only +my $INTERACTIVE = 0 ; # usually 0 (false), but set to 1 to make program stop +my $DRY_RUN = 0 ; # Test script without running model (but compiling) + +# just before execution - so code can be run interactivel. + +# NDX, NDY now set in ModelConstants_ml - use perl to extract these +# values and check against submission: + +open(IN,"<$ProgDir/ModelConstants_ml.f90"); +my ( $NDX, $NDY ); # Processors in x-, y-, direction +while(my $line = ){ + $line=~ s/!.*//; # Get rid of comment lines + $NDX = $1 if $line =~ /\W+ NPROCX \W+ (\d+) /x ; + $NDY = $1 if $line =~ /\W+ NPROCY \W+ (\d+) /x ; +} +close(IN); +my $NPROC = $NDX * $NDY ; +print "ModelConstants has: NDX = $NDX NDY = $NDY => NPROC = $NPROC\n"; + +if ( $ENV{PBS_NODEFILE} ) { + $_ = `wc -l $ENV{PBS_NODEFILE}`; + my $RUN_NPROC; + ( $RUN_NPROC, undef ) = split; + print "Qsub has: lnodes $RUN_NPROC\n"; + die "Error: Wrong number of lnodes!\n" unless $NPROC == $RUN_NPROC; +} else { + print "skip nodefile check on interactive runs\n"; +} + + + +my @month_days = (0,31,28,31,30,31,30,31,31,30,31,30,31); +$month_days[2] += leap_year($year); + +my $mm1 = "01"; # first month, use 2-digits! +my $mm2 = "03"; # last month, use 2-digits! +my $NTERM_CALC = calc_nterm($mm1,$mm2); + +my $NTERM = $NTERM_CALC; # sets NTERM for whole time-period +# -- or -- +$NTERM = 2; # for testing, simply reset here + +print "NTERM_CALC = $NTERM_CALC, Used NTERM = $NTERM\n"; + +# <-------------- End of normal use section ----------------------> +# <-------------- End of user-changeable section -----------------> + + + +if ($SR) { + print "SR is true\n"; + @runs = EMEP::Sr::initRuns(); +} + + +#--- Verify data directories +mkdir_p($WORKDIR); +foreach my $d ( $WORKDIR, $GRID_DATA, $DataDir, $ProgDir) { + unless ( -d "$d" && -x _ && -r _ ) { + die "*** ERROR *** directory $d not accessible. Exiting.\n"; + } +} + + +# --- Calendar stuff +@month_days = (0,31,28,31,30,31,30,31,31,30,31,30,31); + + +# --- Adjust for leap year +$month_days[2] += leap_year($year); + +# --- Start new compilations if needed + +chdir "$ProgDir"; + + +if ( $RESET ) { ########## Recompile everything! + + # For now, we simply recompile everything! + system(@MAKE, "clean"); + system(@MAKE, "depend"); + system(@MAKE, "all"); +} +system "pwd"; +print "Check last files modified:\n"; +system "ls -lt | head -6 "; + +# To be sure that we don't use an old version (recommended while developing) +# unlink($PROGRAM); + +system (@MAKE, "depend") ; +system (@MAKE, "all"); + +die "Done. COMPILE ONLY\n" if $COMPILE_ONLY; ## exit after make ## + + +my @list_of_files = (); # Keep list of data-files + + + +########################### START OF RUNS ########################## +########################### START OF RUNS ########################## +########################### START OF RUNS ########################## + + +foreach my $scenflag ( @runs ) { + if ($SR) { + $scenario = EMEP::Sr::getScenario($scenflag); + } else { + $scenario = $scenflag; + } + print "STARTING RUN $scenario \n"; + + my $runlabel1 = "$scenario"; # NO SPACES! SHORT name (used in CDF names) + my $runlabel2 = "${testv}_${scenario}_$year\_$iyr_trend"; # NO SPACES! LONG (written into CDF files) + + my $RESDIR = "$WORKDIR/$scenario"; + mkdir_p($RESDIR); + + chdir $RESDIR; ############ ------ Change to RESDIR + print "Working in directory: $RESDIR\n"; + +# Meteorology in felt-format + if ($METformat eq "felt") { + my $nnn = 1; + for (my $mm = $mm1; $mm <= $mm2; $mm++) { + + # Assign met files to fil001...etc. + for (my $n = 1; $n <= $month_days[$mm]; $n++) { + $nnn = metlink($n, $nnn, $mm); + last if $nnn > $NTERM; + } + } + + my $mmlast = $mm2 + 1; + my $yylast = $year; + if ( $mmlast > 12 && $NTERM > 200 ) { # Crude check that we aren't testing with NTERM=5 + $yylast = $yylast + 1; + $mmlast = 1; + } + my $old = sprintf "$MetDir/f00.%04d%02d01", $yylast, $mmlast; + my $new = sprintf "fil%04d", $nnn; + mylink( "LAST RECORD SET: ", $old,$new ) ; + + }else{ + +# Meteorology in NetCDF + for (my $mm = $mm1; $mm <= $mm2; $mm++) { + for (my $n = 1; $n <= $month_days[$mm]; $n++) { + my $old = sprintf "$MetDir/meteo${year}%02d%02d.nc", $mm,$n; + my $new = sprintf "meteo${year}%02d%02d.nc", $mm,$n; + mylink( "Linking:", $old,$new ) ; + } + } + my $mmlast = $mm2 + 1; + my $yylast = $year; + if ( $mmlast > 12 && $NTERM > 200 ) { # Crude check that we aren't testing with NTERM=5 + $yylast = $yylast + 1; + $mmlast = 1; + } + my $old = sprintf "$MetDir/meteo%02d%02d01.nc", $yylast, $mmlast; + my $new = sprintf "meteo%02d%02d01.nc", $yylast, $mmlast; + mylink( "LAST RECORD SET: ", $old,$new ) ; + } + +#=================== INPUT FILES ========================================= +# ToDo Change noxsplit.default to defaults, as with voc (also in Unimod) + + my %ifile = (); # List of input data-files + +# First, emission files are labelled e.g. gridSOx, which we assign to +# emislist.sox to ensure compatability with the names (sox,...) used +# in the model. + +my %gridmap = ( "co" => "CO", "nh3" => "NH3", "voc" => "NMVOC", "sox" => "SOx", + "nox" => "NOx" , "pm10" => "PM10", "pm25" => "PM25", "pmco" => "PMco" ) ; + + foreach my $poll ( @emislist ) { + my $dir = $emisdir; + $ifile{"$dir/grid$gridmap{$poll}"} = "emislist.$poll"; + $ifile{"$COMMON/MonthlyFac.$poll"} = "MonthlyFac.$poll"; + $ifile{"$COMMON/DailyFac.$poll"} = "DailyFac.$poll"; + } + + foreach my $mmm ( $mm1 .. $mm2 ) { + my $mm = sprintf "%2.2d", $mmm ; + $ifile{"$GRID_DATA/snowc$mm.dat.170"} = "snowc$mm.dat"; + $ifile{"$GRID_DATA/natso2$mm.dat.170"} = "natso2$mm.dat"; + $ifile{"$COMMON/lt21-nox.dat$mm"} = "lightn$mm.dat"; + } + +# Emissions setup: + $ifile{"$USER_DATA/femis.dat"} = "femis.dat"; + $ifile{"$COMMON/vocsplit.defaults.$Split"} = "vocsplit.defaults"; + $ifile{"$COMMON/vocsplit.special.$Split"} = "vocsplit.special"; + $ifile{"$COMMON/noxsplit.default.$NOxSplit"} = "noxsplit.defaults"; + $ifile{"$COMMON/noxsplit.special.$Split"} = "noxsplit.special"; + $ifile{"$GRID_DATA/Boundary_and_Initial_Conditions.nc"} = + "Boundary_and_Initial_Conditions.nc"; + $ifile{"$COMMON/amilt42-nox.dat"} = "ancatmil.dat"; + +# new inputs style with compulsory headers: + $ifile{"$COMMON/Inputs_LandDefs.csv"} = "Inputs_LandDefs.csv"; + $ifile{"$COMMON/Inputs_DO3SE.csv"} = "Inputs_DO3SE.csv"; + + $ifile{"$GRID_DATA/Inputs.BVOC"} = "Inputs.BVOC"; + $ifile{"$GRID_DATA/Inputs.Landuse"} = "Inputs.Landuse"; + $ifile{"$GRID_DATA/sites.dat"} = "sites.dat"; + $ifile{"$GRID_DATA/sondes.dat"} = "sondes.dat"; + + +# Seasonal stuff + my %seasons = ( "jan" => "01", "apr" => "02", "jul" => "03" , "oct"=> "04"); + + foreach my $s ( keys(%seasons) ) { + $ifile{"$COMMON/a${s}t42-nox.dat"} = "ancat$seasons{$s}.dat"; + $ifile{"$COMMON/jclear.$s"} = "jclear$seasons{$s}.dat"; + $ifile{"$COMMON/jcl1.$s"} = "jcl1km$seasons{$s}.dat"; + $ifile{"$COMMON/jcl3.$s"} = "jcl3km$seasons{$s}.dat"; + } + + $ifile{"$GRID_DATA/rough.170"} = "rough.170"; + $ifile{"$GRID_DATA/Volcanoes.dat"} = "Volcanoes.dat"; + + + foreach my $old ( sort keys %ifile ) { # CHECK and LINK + if ( -r $old ) { + my $new = $ifile{$old}; + mylink( "Inputs: ", $old,$new ) ; + } else { + print "Missing Input $old !!!\n"; + die "ERROR: Missing OLD $old\n" unless $old =~ /special/; + } + } + + if ($SR) { + EMEP::Sr::generate_updated_femis(@$scenflag); + } + +#=================== INPUT FILES ========================================= + + + my @exclus = (9 ); # NBOUND + + +#------------ Run model ------------------------------------------ +#------------ Run model ------------------------------------------ +#------------ Run model ------------------------------------------ + + print "\n"; + + + my $LPROG = "prog.exe"; + cp ($PROGRAM, $LPROG) or die "cannot copy $PROGRAM to $LPROG\n"; + push(@list_of_files , $LPROG); # For later deletion + +# Write out list of linked files to a shell-script, useful in case the program +# hangs or crashes: + + open(RMF,">Remove.sh"); + foreach my $f ( @list_of_files ) { print RMF "rm $f \n"; } + print RMF "rm $LPROG\n"; # Delete executable also + close(RMF); + + my $startyear = $year; + my $startmonth = $mm1; + my $startday = 1; + + my $NASS = 0; # Set to one if "dump" of all concentrations wanted at end + +# Make file with input parameters (to be read by Unimod.f90) + unlink("INPUT.PARA"); + open(TMP,">INPUT.PARA"); + print TMP "$NTERM\n$NASS\n$iyr_trend\n${runlabel1}\n${runlabel2}\n${startyear}\n${startmonth}\n${startday}\n"; + close(TMP); + + foreach my $exclu ( @exclus) { + print "starting $PROGRAM with + NTERM $NTERM\nNASS $NASS\nEXCLU $exclu\nIYR_TREND $iyr_trend\nLABEL1 $runlabel1\nLABEL2 $runlabel2\n startyear ${startyear}\nstartmonth ${startmonth}\nstartday ${startday}\n"; + + + my $PRERUN = "scampiexec "; # Might be "mpiexec" on other computers + if ($DRY_RUN) { + print "DRY_RUN: not running '| $PRERUN ./$LPROG'\n"; + } else { + open (PROG, "| $PRERUN ./$LPROG") || + die "Unable to execute $LPROG. Exiting.\\n" ; + close(PROG); + } + + } #foreach $exclu + system("pwd"); +#------------ End of Run model ------------------------------------- +#------------ End of Run model ------------------------------------- +#------------ End of Run model ------------------------------------- + + if ( -r "core" ) { + die "Error somewhere - Core dumped !!!!\n"; + } elsif ( -r "Timing.out" ) { + print "\n Eulmod: Successful exit at" . `date '+%Z %Y-%m-%d %T %j'` ." \n"; + } else { + print "\n The program stopped abnormally!! \n" unless $DRY_RUN; + } + +#move RunLog + rename "RunLog.out", "${runlabel1}_RunLog" + or warn "cannot mv RunLog.out ${runlabel1}_RunLog\n" unless $DRY_RUN; + open RUNLOG, ">> ${runlabel1}_RunLog" + or die "cannot append ${runlabel1}_RunLog: $!\n"; + print RUNLOG <<"EOT"; +Emission units: Gg/year +------------------------------ +Emissions: $emisdir +Version: $testv +Processors $NDX $NDY +SR? $SR +iyr_trend: $iyr_trend +------------------------------ +femis: femis.$scenario +------------------------------ +EOT + close RUNLOG; + +# Clean up work directories and links + if ($DRY_RUN) { # keep femis.dat + @list_of_files = grep {$_ ne 'femis.dat'} @list_of_files; + } + unlink ( @list_of_files ); + +# Tar sites and sondes. Use sondes to check as these are produced less frequently. + my $last_sondes = sprintf "sondes.%02d%02d", $mm2, $yy; + print "LOOKING FOR LAST SITES $last_sondes\n"; + if ( -r $last_sondes ) { + print "FOUND LAST sondes $last_sondes\n"; + system("tar cvf ${runlabel1}.sites sites.*"); + system("tar cvf ${runlabel1}.sondes sondes.*"); + } + + +################################## END OF RUNS ###################### +} ############################### END OF RUNS ###################### +################################## END OF RUNS ###################### + + +exit 0; + + +### SUBPROGRAMS ################################################################ + +sub leap_year { + my ($y) = ($_[0]); + + if ($y < 20) { + $y += 2000; + } elsif ($y < 100) { + $y += 1900; + } + + if ($y % 400 == 0) { + return 1; + } elsif ($y % 100 == 0) { + return 0; + } else { + return ($y % 4 == 0) ? 1 : 0; + } +} + +sub metlink { #---- meteorological data + my ($dd,$nnn,$mm) = ($_[0], $_[1], $_[2]); + + for (my $hh = 0; $hh <= 21; $hh += 3) { + my $old = sprintf "$MetDir/f%02d.%04d%02d%02d", $hh, $year, $mm, $dd; + my $new = sprintf "fil%04d", $nnn; + mylink("Met:", $old, $new); + $nnn++; + } + return $nnn; +} + + +sub mylink { + # links files from the original location (old) to + # the new location (new) - generally the working directory. + # Keeps track of all such linked files in list_of_files. + + my ($text, $old,$new) = ($_[0], $_[1], $_[2]); + + symlink $old,$new || die "symlink $old $new failed : $!"; + + print "$text $old => $new \n"; + push(@list_of_files , $new); # For later deletion +} + +sub touch { + # simple touch -c implementation + my (@fileGlobs) = @_; + my @files; + foreach my $fileGlob (@fileGlobs) { + push @files, glob($fileGlob); + } + utime undef, undef, @files; +} + +sub cp { + # copy, preserving permissions + my ($from, $to, @extraArgs) = @_; + my $retVal = File::Copy::cp($from, $to, @extraArgs); + my $perm = (stat $from)[2] & 07777; + chmod($perm, $to); + return $retVal; +} + +sub mkdir_p { + # mkdir -p on unix platforms + # does NOT fail on existing directories! + my ($dir) = @_; + $dir =~ s:/$::; # remove final / + my $curdir = './'; + if ($dir =~ s:^/::) { + $curdir = '/'; + } + my @path = split ('/', $dir); + while (my $next = shift(@path)) { + $curdir .= $next . '/'; + if (! -d $curdir) { + mkdir $curdir or die "cannot mkdir $curdir: $!\n"; + } + } + return 1; +} + +sub calc_nterm { + # Calculates the number of 3-hourly steps from month mm1 to + # mm2. Leap-years should already have been dealt with through + # the global month_days array which is used. + # $NTERM = 2921; # works for non-leap year (365*8+1) + + my ($mm1,$mm2) = ($_[0], $_[1]) ; + my $ndays=0; + foreach my $i ( $mm1..$mm2 ) { + $ndays += $month_days[$i] ; + } + my $nterm = 1 + 8*$ndays ; + + print "Calculated NTERM = $nterm\n"; + return $nterm; +} + + +############################################################## +##### Stuff for Source receptor matrisses ######## +############################################################## +package EMEP::Sr; + +my (%country_nums, @eu15, @euNew04, @eu25, @euNew06, @eu27, @sea, @noneu, @emep, @external); +our ($base, $Split, $NOxSplit, $rednflag, $redn, @countries, @polls); + +INIT { +######################################## +# Define all countries and nums here: ## +######################################## +%country_nums = ( + AL => 1, AT => 2, BE => 3, BG => 4, FCS => 5, + DK => 6, FI => 7, FR => 8, + GR => 11, HU => 12, IS => 13, IE => 14, IT => 15, + LU => 16, NL => 17, NO => 18, PL => 19, PT => 20, + RO => 21, ES => 22, SE => 23, CH => 24, TR => 25, + FSU => 26, GB => 27, REM => 29, BAS => 30, + NOS => 31, ATL => 32, MED => 33, BLS => 34, NAT => 35, + RUO => 36, RUP => 37, RUA => 38, BY => 39, UA => 40, + MD => 41, RUR => 42, EE => 43, LV => 44, LT => 45, + CZ => 46, SK => 47, SI => 48, HR => 49, BA => 50, + RS => 72, ME => 73, MK => 52, KZ => 53, GE => 54, CY => 55, + AM => 56, MT => 57, ASI => 58, LI => 59, DE => 60, RU => 61, + MC => 62, NOA => 63, EU => 64, US => 65, + CA => 66, BIC => 67, KG => 68, AZ => 69, + RUX => 71, ATX => 70, + BA2 => 302, BA3 => 303, BA4 => 304, BA5 => 305, BA6 => 306, # Baltic sep. + BA7 => 307, BA8 => 308, BA9 => 309, + NS2 => 312, NS3 => 313, NS4 => 314, NS5 => 315, NS6 => 316, # N. Sea sep. + NS7 => 317, NS8 => 318, NS9 => 319, + AT2 => 322, AT3 => 323, AT4 => 324, AT5 => 325, AT6 => 326, # Atlant. sep. + AT7 => 327, AT8 => 328, AT9 => 329, + ME2 => 332, ME3 => 333, ME4 => 334, ME5 => 335, ME6 => 336, # Medit. sep. + ME7 => 337, ME8 => 338, ME9 => 339, + BL2 => 342, BL3 => 343, BL4 => 344, BL5 => 345, BL6 => 346, # Bl. Sea sep. + BL7 => 347, BL8 => 348, BL9 => 349 +); + +# EU countries: +@eu15 = qw ( AT BE DK FI FR DE GR IE IT NL PT ES SE GB LU ); +@euNew04 = qw ( HU PL CY CZ EE LT LV MT SK SI ); +@eu25 = ( @eu15, @euNew04 ); +@euNew06 = qw(BG RO); +@eu27 = (@eu25, @euNew06); +@sea = qw ( NOS ATL MED BAS BLS ); +@noneu = qw ( NO CH IS ); +@emep = qw ( RS ME BY BA HR TR RU UA KZ MD MK GE AM AL AZ KG NOA ASI REM) ; +@external =qw ( RUX ATX ); + +######################################## +# End of country definitions ## +######################################## + + +################################ +#### start of SR parameters #### +################################ +$base = "CLE"; +$Split = "CLE_MAR2004"; # Defualt (IER-based) VOC splits +$NOxSplit = "CLE2020_ver2"; # Default scenario (IER-based) VOC splits +$rednflag = "P15"; # 15% reduction label +$redn = "0.85"; # 15% reduction + +# modify those to fill up your queues for SR effectively!!! +@countries = (@eu27, @sea, @noneu, @emep); +@polls = qw (BASE NP A V S ); # (any, all, at least 1) +################################ +#### end of SR parameters #### +################################ +} + + +sub initRuns { + my @runs; + foreach my $cc (@countries) { + foreach my $poll (@polls) { + push @runs, [$cc, $poll, $redn]; + if ($poll eq 'BASE') { + # run BASE only once (for exactly one cc)!!! + @polls = grep {'BASE' ne $_} @polls; + } + } + } + return @runs; +} + + +sub getScenario { + my ($scenflag) = @_; + my $cc = $scenflag->[0]; + my $pollut = $scenflag->[1]; + my $scenario = "${base}_${cc}_${pollut}_${rednflag}"; + $scenario = "${base}" if $pollut eq "BASE" ; + return $scenario; +} + +sub generate_updated_femis { + my ($cc, $pollut, $redn) = @_; + # Initialise to 1.0: + my( $sox,$nox,$voc,$nh3,$testp,$co,$pm25,$pmco ) = ("1.0") x 8 ; + if( $pollut eq "AV" ) { $voc = $nh3 = $redn }; + if( $pollut eq "A" ) { $nh3 = $redn }; + if( $pollut eq "V" ) { $voc = $redn }; + if( $pollut eq "S" ) { $sox = $redn }; + if( $pollut eq "N" ) { $nox = $redn }; + if( $pollut eq "NP" ) { $nox = $pm25 = $pmco = $redn }; + if( $pollut eq "SNP" ) { $sox = $nox = $pm25 = $pmco = $redn }; + if( $pollut eq "AN" ) { $nh3 = $nox = $redn }; + if( $pollut eq "SNAV" ) { $sox = $nox = $nh3 = $voc = $redn }; + #if( $pollut eq BASE ) then no change! + + my $femisdat = slurp("$USER_DATA/femis.dat"); + + my $ccnum = $country_nums{$cc} || die "ERROR!! No country Num for $cc!\n"; + + # using 0 here as long as emissions are guaranteed to contain either + # only anthropogenic or only natural emissions perl 'country' + my $ss = 0; # 100 = antropogenic sectors (1..10) + # 0 = all sectors + $femisdat .= "$ccnum $ss $sox $nox $voc $nh3 $testp $co $pm25 $pmco\n"; + if ( $cc eq "DE" ) { # Add splitted countries + foreach my $cx (9, 10) { + $femisdat .= "$cx $ss $sox $nox $voc $nh3 $testp $co $pm25 $pmco\n"; + } + } + if ( $cc eq "RU" ) { # Add splitted and external RU + foreach my $cx (36..38, 42, 71) { + $femisdat .= "$cx $ss $sox $nox $voc $nh3 $testp $co $pm25 $pmco\n"; + } + } + if ( $cc eq "ATL" ) { # Add ATL outside EMEP + foreach my $cx (70) { + $femisdat .= "$cx $ss $sox $nox $voc $nh3 $testp $co $pm25 $pmco\n"; + } + } + if ( 30 <= $ccnum and $ccnum <= 34) { # add splitted sea areas + for (my $cx = 10 * $ccnum + 2; $cx <= 10 * $ccnum + 9; $cx++) { + $femisdat .= "$cx $ss $sox $nox $voc $nh3 $testp $co $pm25 $pmco\n"; + } + } + unlink "femis.dat" if -l "femis.dat"; + open FEMIS, ">femis.dat" or die "Cannot write femis.dat: $!\n"; + print FEMIS $femisdat; + close FEMIS; + + # and to the logfile + print "NEW FEMIS\n", $femisdat; +} + +sub slurp { + # read the complete content of a file + my ($file) = @_; + local $/ = undef; + open F, $file or die "Cannot read $file: $!\n"; + my $data = ; + close F; + return $data; +}