Skip to content
GitLab
Commit 6985a986 authored by Sabine's avatar Sabine
Browse files

compiles after merge scavenging into test dev

parents d9f0585f d1a87077
Show whitespace changes
Inline Side-by-side
options/SPECIES/spec_overview 100644 → 100755
View file @ 6985a986
File mode changed from 100644 to 100755
src/advance.f90
View file @ 6985a986
......@@ -116,6 +116,7 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
real :: dcwsave
real :: usigold,vsigold,wsigold,r,rs
real :: uold,vold,wold,vdepo(maxspec)
real :: h1(2)
!real uprof(nzmax),vprof(nzmax),wprof(nzmax)
!real usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax)
!real rhoprof(nzmax),rhogradprof(nzmax)
......@@ -222,6 +223,25 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
jyp=jy+1
! Determine the lower left corner and its distance to the current position
!*************************************************************************
ddx=xt-real(ix)
ddy=yt-real(jy)
rddx=1.-ddx
rddy=1.-ddy
p1=rddx*rddy
p2=ddx*rddy
p3=rddx*ddy
p4=ddx*ddy
! Calculate variables for time interpolation
!*******************************************
dt1=real(itime-memtime(1))
dt2=real(memtime(2)-itime)
dtt=1./(dt1+dt2)
! Compute maximum mixing height around particle position
!*******************************************************
......@@ -229,11 +249,18 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
if (ngrid.le.0) then
do k=1,2
mind=memind(k) ! eso: compatibility with 3-field version
if (interpolhmix) then
h1(k)=p1*hmix(ix ,jy ,1,mind) &
+ p2*hmix(ixp,jy ,1,mind) &
+ p3*hmix(ix ,jyp,1,mind) &
+ p4*hmix(ixp,jyp,1,mind)
else
do j=jy,jyp
do i=ix,ixp
if (hmix(i,j,1,mind).gt.h) h=hmix(i,j,1,mind)
end do
end do
endif
end do
tropop=tropopause(nix,njy,1,1)
else
......@@ -248,6 +275,7 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
tropop=tropopausen(nix,njy,1,1,ngrid)
endif
if (interpolhmix) h=(h1(1)*dt2+h1(2)*dt1)*dtt
zeta=zt/h
......@@ -445,6 +473,14 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
delz=wp*dtf
endif
if (turboff) then
!sec switch off turbulence
up=0.0
vp=0.0
wp=0.0
delz=0.
endif
!****************************************************
! Compute turbulent vertical displacement of particle
!****************************************************
......@@ -646,6 +682,12 @@ subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
nrand=nrand+1
endif
if (turboff) then
!sec switch off turbulence
ux=0.0
vy=0.0
wp=0.0
endif
! If particle represents only a single species, add gravitational settling
! velocity. The settling velocity is zero for gases
......
src/com_mod.f90
View file @ 6985a986
......@@ -576,8 +576,10 @@ module com_mod
integer :: numxgridn,numygridn
real :: dxoutn,dyoutn,outlon0n,outlat0n,xoutshiftn,youtshiftn
!real outheight(maxzgrid),outheighthalf(maxzgrid)
logical :: DEP,DRYDEP,DRYDEPSPEC(maxspec),WETDEP,WETDEPSPEC(maxspec),&
& OHREA,ASSSPEC
logical :: DRYBKDEP,WETBKDEP
! numxgrid,numygrid number of grid points in x,y-direction
! numxgridn,numygridn number of grid points in x,y-direction for nested output grid
......@@ -597,6 +599,7 @@ module com_mod
! WETDEPSPEC .true., if wet deposition is switched on for that species
! OHREA .true., if OH reaction is switched on
! ASSSPEC .true., if there are two species asscoiated
! DRYBKDEP,WETBKDEP .true., for bkwd runs, where mass deposited and source regions is calculated - either for dry or for wet deposition
! (i.e. transfer of mass between these two occurs
......@@ -667,6 +670,7 @@ module com_mod
real(kind=dp), allocatable, dimension(:) :: xtra1, ytra1
real, allocatable, dimension(:) :: ztra1
real, allocatable, dimension(:,:) :: xmass1
real, allocatable, dimension(:,:) :: xscav_frac1
! eso: Moved from timemanager
real, allocatable, dimension(:) :: uap,ucp,uzp,us,vs,ws
......@@ -687,6 +691,7 @@ module com_mod
! numparticlecount counts the total number of particles that have been released
! xtra1,ytra1,ztra1 spatial positions of the particles
! xmass1 [kg] particle masses
! xscav_frac1 fraction of particle masse which has been scavenged at receptor
......@@ -750,6 +755,11 @@ module com_mod
integer :: mpi_mode=0 ! .gt. 0 if running MPI version
logical :: lroot=.true. ! true if serial version, or if MPI .and. root process
logical :: usekernel=.false. ! true if the output kernel shall be switched on
logical :: interpolhmix=.false. ! true if the hmix shall be interpolated
logical :: turboff=.false. ! true if the turbulence shall be switched off
contains
subroutine com_mod_allocate_part(nmpart)
!*******************************************************************************
......
src/conccalc.f90
View file @ 6985a986
......@@ -58,13 +58,13 @@ subroutine conccalc(itime,weight)
real :: rhoprof(2),rhoi
real :: xl,yl,wx,wy,w
real,parameter :: factor=.596831, hxmax=6.0, hymax=4.0, hzmax=150.
! integer xscav_count
! For forward simulations, make a loop over the number of species;
! for backward simulations, make an additional loop over the
! releasepoints
!***************************************************************************
! xscav_count=0
do i=1,numpart
if (itra1(i).ne.itime) goto 20
......@@ -75,6 +75,7 @@ subroutine conccalc(itime,weight)
end do
33 continue
! if (xscav_frac1(i,1).lt.0) xscav_count=xscav_count+1
! For special runs, interpolate the air density to the particle position
!************************************************************************
......@@ -171,7 +172,6 @@ subroutine conccalc(itime,weight)
jy=int(yl)
if (yl.lt.0.) jy=jy-1
! if (i.eq.10000) write(*,*) itime,xtra1(i),ytra1(i),ztra1(i),xl,yl
! For particles aged less than 3 hours, attribute particle mass to grid cell
......@@ -182,15 +182,23 @@ subroutine conccalc(itime,weight)
if (lnokernel.or.(itage.lt.10800).or.(xl.lt.0.5).or.(yl.lt.0.5).or. &
(xl.gt.real(numxgrid-1)-0.5).or. &
(yl.gt.real(numygrid-1)-0.5)) then ! no kernel, direct attribution to grid cell
(yl.gt.real(numygrid-1)-0.5))) then ! no kernel, direct attribution to grid cell
if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
(jy.le.numygrid-1)) then
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight
end do
endif
endif
else ! attribution via uniform kernel
......@@ -219,15 +227,30 @@ subroutine conccalc(itime,weight)
if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
if ((jy.ge.0).and.(jy.le.numygrid-1)) then
w=wx*wy
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w
end do
endif
endif
if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
w=wx*(1.-wy)
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
......@@ -235,20 +258,36 @@ subroutine conccalc(itime,weight)
end do
endif
endif
endif !ix ge 0
if ((ixp.ge.0).and.(ixp.le.numxgrid-1)) then
if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
w=(1.-wx)*(1.-wy)
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w
end do
endif
endif
if ((jy.ge.0).and.(jy.le.numygrid-1)) then
w=(1.-wx)*wy
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
gridunc(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
......@@ -256,10 +295,9 @@ subroutine conccalc(itime,weight)
end do
endif
endif
endif !ixp ge 0
endif
!************************************
! Do everything for the nested domain
!************************************
......@@ -281,15 +319,23 @@ subroutine conccalc(itime,weight)
if ((itage.lt.10800).or.(xl.lt.0.5).or.(yl.lt.0.5).or. &
(xl.gt.real(numxgridn-1)-0.5).or. &
(yl.gt.real(numygridn-1)-0.5)) then ! no kernel, direct attribution to grid cell
(yl.gt.real(numygridn-1)-0.5).or.(.not.usekernel)) then ! no kernel, direct attribution to grid cell
if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
(jy.le.numygridn-1)) then
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight
end do
endif
endif
else ! attribution via uniform kernel
......@@ -318,15 +364,30 @@ subroutine conccalc(itime,weight)
if ((ix.ge.0).and.(ix.le.numxgridn-1)) then
if ((jy.ge.0).and.(jy.le.numygridn-1)) then
w=wx*wy
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ix,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w
end do
endif
endif
if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
w=wx*(1.-wy)
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ix,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
......@@ -334,20 +395,36 @@ subroutine conccalc(itime,weight)
end do
endif
endif
endif
if ((ixp.ge.0).and.(ixp.le.numxgridn-1)) then
if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
w=(1.-wx)*(1.-wy)
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ixp,jyp,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w
end do
endif
endif
if ((jy.ge.0).and.(jy.le.numygridn-1)) then
w=(1.-wx)*wy
if (DRYBKDEP.or.WETBKDEP) then
do ks=1,nspec
griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
xmass1(i,ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0)
end do
else
do ks=1,nspec
griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)= &
griduncn(ixp,jy,kz,ks,nrelpointer,nclass(i),nage)+ &
......@@ -356,11 +433,12 @@ subroutine conccalc(itime,weight)
endif
endif
endif
endif
endif
endif
20 continue
end do
! write(*,*) 'xscav count:',xscav_count
!***********************************************************************
! 2. Evaluate concentrations at receptor points, using the kernel method
......
src/concoutput.f90
View file @ 6985a986
......@@ -245,6 +245,16 @@ subroutine concoutput(itime,outnum,gridtotalunc,wetgridtotalunc, &
do ks=1,nspec
write(anspec,'(i3.3)') ks
if (DRYBKDEP.or.WETBKDEP) then !scavdep output
if (DRYBKDEP) &
open(unitoutgrid,file=path(2)(1:length(2))//'grid_drydep_'//adate// &
atime//'_'//anspec,form='unformatted')
if (WETBKDEP) &
open(unitoutgrid,file=path(2)(1:length(2))//'grid_wetdep_'//adate// &
atime//'_'//anspec,form='unformatted')
write(unitoutgrid) itime
else
if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
if (ldirect.eq.1) then
open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//adate// &
......@@ -255,13 +265,12 @@ subroutine concoutput(itime,outnum,gridtotalunc,wetgridtotalunc, &
endif
write(unitoutgrid) itime
endif
if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//adate// &
atime//'_'//anspec,form='unformatted')
write(unitoutgridppt) itime
endif
endif ! if deposition output
do kp=1,maxpointspec_act
do nage=1,nageclass
......@@ -341,7 +350,7 @@ subroutine concoutput(itime,outnum,gridtotalunc,wetgridtotalunc, &
! Concentration output
!*********************
if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5).or.(iout.eq.6)) then
! Wet deposition
sp_count_i=0
......
src/drydepokernel.f90
View file @ 6985a986
......@@ -101,12 +101,15 @@ subroutine drydepokernel(nunc,deposit,x,y,nage,kp)
if ((abs(deposit(ks)).gt.0).and.DRYDEPSPEC(ks)) then
if (.not.usekernel) then
drygridunc(ix,jy,ks,kp,nunc,nage)= &
drygridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)
else
if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
(jy.le.numygrid-1)) then
w=wx*wy
drygridunc(ix,jy,ks,kp,nunc,nage)= &
drygridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
continue
endif
if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgrid-1).and. &
......@@ -130,7 +133,8 @@ subroutine drydepokernel(nunc,deposit,x,y,nage,kp)
drygridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
endif
endif
endif ! kernel
endif ! deposit>0
end do
end if
......
src/ecmwf_mod.f90
View file @ 6985a986
......@@ -43,7 +43,9 @@ module wind_mod
! integer,parameter :: nxmax=361,nymax=181,nuvzmax=92,nwzmax=92,nzmax=92 !ECMWF new
integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138 !ECMWF new
! integer,parameter :: nxmax=721,nymax=361,nuvzmax=138,nwzmax=138,nzmax=138 !ECMWF new 0.5
integer,parameter :: nxshift=359
! integer,parameter :: nxshift=718
! integer,parameter :: nxshift=0
!*********************************************
......
src/get_vdep_prob.f90 0 → 100644
View file @ 6985a986
!**********************************************************************
! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 *
! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, *
! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann *
! *
! This file is part of FLEXPART. *
! *
! FLEXPART 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. *
! *
! FLEXPART 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 FLEXPART. If not, see <http://www.gnu.org/licenses/>. *
!**********************************************************************
subroutine get_vdep_prob(itime,xt,yt,zt,prob)
! i i i i o
!*****************************************************************************
! *
! Calculation of the probability for dyr deposition *
! *
! Particle positions are read in - prob returned *
! *
!*****************************************************************************
! *
! Variables: *
! itime [s] time at which this subroutine is entered *
! itimec [s] actual time, which is incremented in this subroutine *
! href [m] height for which dry deposition velocity is calculated *
! ldirect 1 forward, -1 backward *
! ldt [s] Time step for the next integration *
! lsynctime [s] Synchronisation interval of FLEXPART *
! ngrid index which grid is to be used *
! prob probability of absorption due to dry deposition *
! vdepo Deposition velocities for all species *
! xt,yt,zt Particle position *
! *
!*****************************************************************************
use point_mod
use par_mod
use com_mod
use interpol_mod
implicit none
real(kind=dp) :: xt,yt
real :: zt,xtn,ytn
integer :: itime,i,j,k,memindnext
integer :: nix,njy,ks
real :: prob(maxspec),vdepo(maxspec)
real,parameter :: eps=nxmax/3.e5
if (DRYDEP) then ! reset probability for deposition
do ks=1,nspec
depoindicator(ks)=.true.
prob(ks)=0.
end do
endif
! Determine whether lat/long grid or polarstereographic projection
! is to be used
! Furthermore, determine which nesting level to be used
!*****************************************************************
if (nglobal.and.(yt.gt.switchnorthg)) then
ngrid=-1
else if (sglobal.and.(yt.lt.switchsouthg)) then
ngrid=-2
else
ngrid=0
do j=numbnests,1,-1
if ((xt.gt.xln(j)+eps).and.(xt.lt.xrn(j)-eps).and. &
(yt.gt.yln(j)+eps).and.(yt.lt.yrn(j)-eps)) then
ngrid=j
goto 23
endif
end do
23 continue
endif
!***************************
! Interpolate necessary data
!***************************
if (abs(itime-memtime(1)).lt.abs(itime-memtime(2))) then
memindnext=1
else
memindnext=2
endif
! Determine nested grid coordinates
!**********************************
if (ngrid.gt.0) then
xtn=(xt-xln(ngrid))*xresoln(ngrid)
ytn=(yt-yln(ngrid))*yresoln(ngrid)
ix=int(xtn)
jy=int(ytn)
nix=nint(xtn)
njy=nint(ytn)
else
ix=int(xt)
jy=int(yt)
nix=nint(xt)
njy=nint(yt)
endif
ixp=ix+1
jyp=jy+1
! Determine probability of deposition
!************************************
if ((DRYDEP).and.(zt.lt.2.*href)) then
do ks=1,nspec
if (DRYDEPSPEC(ks)) then
if (depoindicator(ks)) then
if (ngrid.le.0) then
call interpol_vdep(ks,vdepo(ks))
else
call interpol_vdep_nests(ks,vdepo(ks))
endif
endif
! correction by Petra Seibert, 10 April 2001
! this formulation means that prob(n) = 1 - f(0)*...*f(n)
! where f(n) is the exponential term
prob(ks)=vdepo(ks)
! prob(ks)=vdepo(ks)/2./href
! instead of prob - return vdepo -> result kg/m2/s
endif
end do
endif
end subroutine get_vdep_prob