advance.f90
----------------------------------------------
1,877c1,933
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine advance(itime,nrelpoint,ldt,up,vp,wp, &
< usigold,vsigold,wsigold,nstop,xt,yt,zt,prob,icbt)
< ! i i i/oi/oi/o
< ! i/o i/o i/o o i/oi/oi/o i/o i/o
< !*****************************************************************************
< ! *
< ! Calculation of turbulent particle trajectories utilizing a *
< ! zero-acceleration scheme, which is corrected by a numerically more *
< ! accurate Petterssen scheme whenever possible. *
< ! *
< ! Particle positions are read in, incremented, and returned to the calling *
< ! program. *
< ! *
< ! In different regions of the atmosphere (PBL vs. free troposphere), *
< ! different parameters are needed for advection, parameterizing turbulent *
< ! velocities, etc. For efficiency, different interpolation routines have *
< ! been written for these different cases, with the disadvantage that there *
< ! exist several routines doing almost the same. They all share the *
< ! included file 'interpol_mod'. The following *
< ! interpolation routines are used: *
< ! *
< ! interpol_all(_nests) interpolates everything (called inside the PBL) *
< ! interpol_misslev(_nests) if a particle moves vertically in the PBL, *
< ! additional parameters are interpolated if it *
< ! crosses a model level *
< ! interpol_wind(_nests) interpolates the wind and determines the *
< ! standard deviation of the wind (called outside *
< ! PBL) also interpolates potential vorticity *
< ! interpol_wind_short(_nests) only interpolates the wind (needed for the *
< ! Petterssen scheme) *
< ! interpol_vdep(_nests) interpolates deposition velocities *
< ! *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 December 1997 *
< ! *
< ! Changes: *
< ! *
< ! 8 April 2000: Deep convection parameterization *
< ! *
< ! May 2002: Petterssen scheme introduced *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! icbt 1 if particle not transferred to forbidden state, *
< ! else -1 *
< ! dawsave accumulated displacement in along-wind direction *
< ! dcwsave accumulated displacement in cross-wind direction *
< ! dxsave accumulated displacement in longitude *
< ! dysave accumulated displacement in latitude *
< ! h [m] Mixing height *
< ! lwindinterv [s] time interval between two wind fields *
< ! 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 *
< ! ladvance [s] Total integration time period *
< ! 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 *
< ! nrand index for a variable to be picked from rannumb *
< ! nstop if > 1 particle has left domain and must be stopped *
< ! prob probability of absorption due to dry deposition *
< ! rannumb(maxrand) normally distributed random variables *
< ! rhoa air density *
< ! rhograd vertical gradient of the air density *
< ! up,vp,wp random velocities due to turbulence (along wind, cross *
< ! wind, vertical wind *
< ! usig,vsig,wsig mesoscale wind fluctuations *
< ! usigold,vsigold,wsigold like usig, etc., but for the last time step *
< ! vdepo Deposition velocities for all species *
< ! xt,yt,zt Particle position *
< ! *
< !*****************************************************************************
<
< use point_mod
< use par_mod
< use com_mod
< use interpol_mod
< use hanna_mod
< use cmapf_mod
<
< implicit none
<
< real(kind=dp) :: xt,yt
< real :: zt,xts,yts,weight
< integer :: itime,itimec,nstop,ldt,i,j,k,nrand,loop,memindnext
< integer :: ngr,nix,njy,ks,nsp,nrelpoint
< real :: dz,dz1,dz2,xlon,ylat,xpol,ypol,gridsize
< real :: ru,rv,rw,dt,ux,vy,cosfact,xtn,ytn,tropop
< real :: prob(maxspec),up,vp,wp,dxsave,dysave,dawsave
< real :: dcwsave
< real :: usigold,vsigold,wsigold,r,rs
< real :: uold,vold,wold,vdepo(maxspec)
< !real uprof(nzmax),vprof(nzmax),wprof(nzmax)
< !real usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax)
< !real rhoprof(nzmax),rhogradprof(nzmax)
< real :: rhoa,rhograd,ran3,delz,dtf,rhoaux,dtftlw,uxscale,wpscale
< integer(kind=2) :: icbt
< real,parameter :: eps=nxmax/3.e5,eps2=1.e-9
<
<
< !!! CHANGE: TEST OF THE WELL-MIXED CRITERION
< ! integer,parameter :: iclass=10
< ! real(kind=dp) :: zacc,tacc,t(iclass),th(0:iclass),hsave
< ! logical dump
< ! save zacc,tacc,t,th,hsave,dump
< !!! CHANGE
<
< integer :: idummy = -7
< real :: settling = 0.
<
<
< !!! CHANGE: TEST OF THE WELL-MIXED CRITERION
< !if (idummy.eq.-7) then
< !open(550,file='WELLMIXEDTEST')
< !do 17 i=0,iclass
< !7 th(i)=real(i)/real(iclass)
< !endif
< !!! CHANGE
<
<
< nstop=0
< do i=1,nmixz
< indzindicator(i)=.true.
< end do
<
<
< if (DRYDEP) then ! reset probability for deposition
< do ks=1,nspec
< depoindicator(ks)=.true.
< prob(ks)=0.
< end do
< endif
<
< dxsave=0. ! reset position displacements
< dysave=0. ! due to mean wind
< dawsave=0. ! and turbulent wind
< dcwsave=0.
<
< itimec=itime
<
< nrand=int(ran3(idummy)*real(maxrand-1))+1
<
<
< ! 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
<
<
< ! Compute maximum mixing height around particle position
< !*******************************************************
<
< h=0.
< if (ngrid.le.0) then
< do k=1,2
< do j=jy,jyp
< do i=ix,ixp
< if (hmix(i,j,1,k).gt.h) h=hmix(i,j,1,k)
< end do
< end do
< end do
< tropop=tropopause(nix,njy,1,1)
< else
< do k=1,2
< do j=jy,jyp
< do i=ix,ixp
< if (hmixn(i,j,1,k,ngrid).gt.h) h=hmixn(i,j,1,k,ngrid)
< end do
< end do
< end do
< tropop=tropopausen(nix,njy,1,1,ngrid)
< endif
<
< zeta=zt/h
<
<
<
< !*************************************************************
< ! If particle is in the PBL, interpolate once and then make a
< ! time loop until end of interval is reached
< !*************************************************************
<
< if (zeta.le.1.) then
<
< ! BEGIN TIME LOOP
< !================
<
< loop=0
< 100 loop=loop+1
< if (method.eq.1) then
< ldt=min(ldt,abs(lsynctime-itimec+itime))
< itimec=itimec+ldt*ldirect
< else
< ldt=abs(lsynctime)
< itimec=itime+lsynctime
< endif
< dt=real(ldt)
<
< zeta=zt/h
<
<
< if (loop.eq.1) then
< if (ngrid.le.0) then
< xts=real(xt)
< yts=real(yt)
< call interpol_all(itime,xts,yts,zt)
< else
< call interpol_all_nests(itime,xtn,ytn,zt)
< endif
<
< else
<
<
< ! Determine the level below the current position for u,v,rho
< !***********************************************************
<
< do i=2,nz
< if (height(i).gt.zt) then
< indz=i-1
< indzp=i
< goto 6
< endif
< end do
< 6 continue
<
< ! If one of the levels necessary is not yet available,
< ! calculate it
< !*****************************************************
<
< do i=indz,indzp
< if (indzindicator(i)) then
< if (ngrid.le.0) then
< call interpol_misslev(i)
< else
< call interpol_misslev_nests(i)
< endif
< endif
< end do
< endif
<
<
< ! Vertical interpolation of u,v,w,rho and drhodz
< !***********************************************
<
< ! Vertical distance to the level below and above current position
< ! both in terms of (u,v) and (w) fields
< !****************************************************************
<
< dz=1./(height(indzp)-height(indz))
< dz1=(zt-height(indz))*dz
< dz2=(height(indzp)-zt)*dz
<
< u=dz1*uprof(indzp)+dz2*uprof(indz)
< v=dz1*vprof(indzp)+dz2*vprof(indz)
< w=dz1*wprof(indzp)+dz2*wprof(indz)
< rhoa=dz1*rhoprof(indzp)+dz2*rhoprof(indz)
< rhograd=dz1*rhogradprof(indzp)+dz2*rhogradprof(indz)
<
<
< ! Compute the turbulent disturbances
< ! Determine the sigmas and the timescales
< !****************************************
<
< if (turbswitch) then
< call hanna(zt)
< else
< call hanna1(zt)
< endif
<
<
< !*****************************************
< ! Determine the new diffusivity velocities
< !*****************************************
<
< ! Horizontal components
< !**********************
<
< if (nrand+1.gt.maxrand) nrand=1
< if (dt/tlu.lt..5) then
< up=(1.-dt/tlu)*up+rannumb(nrand)*sigu*sqrt(2.*dt/tlu)
< else
< ru=exp(-dt/tlu)
< up=ru*up+rannumb(nrand)*sigu*sqrt(1.-ru**2)
< endif
< if (dt/tlv.lt..5) then
< vp=(1.-dt/tlv)*vp+rannumb(nrand+1)*sigv*sqrt(2.*dt/tlv)
< else
< rv=exp(-dt/tlv)
< vp=rv*vp+rannumb(nrand+1)*sigv*sqrt(1.-rv**2)
< endif
< nrand=nrand+2
<
<
< if (nrand+ifine.gt.maxrand) nrand=1
< rhoaux=rhograd/rhoa
< dtf=dt*fine
<
< dtftlw=dtf/tlw
<
< ! Loop over ifine short time steps for vertical component
< !********************************************************
<
< do i=1,ifine
<
< ! Determine the drift velocity and density correction velocity
< !*************************************************************
<
< if (turbswitch) then
< if (dtftlw.lt..5) then
< wp=((1.-dtftlw)*wp+rannumb(nrand+i)*sqrt(2.*dtftlw) &
< +dtf*(dsigwdz+rhoaux*sigw))*real(icbt)
< else
< rw=exp(-dtftlw)
< wp=(rw*wp+rannumb(nrand+i)*sqrt(1.-rw**2) &
< +tlw*(1.-rw)*(dsigwdz+rhoaux*sigw))*real(icbt)
< endif
< delz=wp*sigw*dtf
< else
< rw=exp(-dtftlw)
< wp=(rw*wp+rannumb(nrand+i)*sqrt(1.-rw**2)*sigw &
< +tlw*(1.-rw)*(dsigw2dz+rhoaux*sigw**2))*real(icbt)
< delz=wp*dtf
< endif
<
< !****************************************************
< ! Compute turbulent vertical displacement of particle
< !****************************************************
<
< if (abs(delz).gt.h) delz=mod(delz,h)
<
< ! Determine if particle transfers to a "forbidden state" below the ground
< ! or above the mixing height
< !************************************************************************
<
< if (delz.lt.-zt) then ! reflection at ground
< icbt=-1
< zt=-zt-delz
< else if (delz.gt.(h-zt)) then ! reflection at h
< icbt=-1
< zt=-zt-delz+2.*h
< else ! no reflection
< icbt=1
< zt=zt+delz
< endif
<
< if (i.ne.ifine) then
< zeta=zt/h
< call hanna_short(zt)
< endif
<
< end do
< nrand=nrand+i
<
< ! Determine time step for next integration
< !*****************************************
<
< if (turbswitch) then
< ldt=int(min(tlw,h/max(2.*abs(wp*sigw),1.e-5), &
< 0.5/abs(dsigwdz))*ctl)
< else
< ldt=int(min(tlw,h/max(2.*abs(wp),1.e-5))*ctl)
< endif
< ldt=max(ldt,mintime)
<
<
< ! If particle represents only a single species, add gravitational settling
< ! velocity. The settling velocity is zero for gases, or if particle
< ! represents more than one species
< !*************************************************************************
<
< if (mdomainfill.eq.0) then
< do nsp=1,nspec
< if (xmass(nrelpoint,nsp).gt.eps2) goto 887
< end do
< 887 nsp=min(nsp,nspec)
< !!$ if (density(nsp).gt.0.) &
< !!$ call get_settling(itime,xts,yts,zt,nsp,settling) !old
< if (density(nsp).gt.0.) &
< call get_settling(itime,real(xt),real(yt),zt,nsp,settling) !bugfix
< w=w+settling
< endif
<
< ! Horizontal displacements during time step dt are small real values compared
< ! to the position; adding the two, would result in large numerical errors.
< ! Thus, displacements are accumulated during lsynctime and are added to the
< ! position at the end
< !****************************************************************************
<
< dxsave=dxsave+u*dt
< dysave=dysave+v*dt
< dawsave=dawsave+up*dt
< dcwsave=dcwsave+vp*dt
< zt=zt+w*dt*real(ldirect)
<
< if (zt.gt.h) then
< if (itimec.eq.itime+lsynctime) goto 99
< goto 700 ! complete the current interval above PBL
< endif
<
<
< !!! CHANGE: TEST OF THE WELL-MIXED CRITERION
< !!! These lines may be switched on to test the well-mixed criterion
< !if (zt.le.h) then
< ! zacc=zacc+zt/h*dt
< ! hsave=hsave+h*dt
< ! tacc=tacc+dt
< ! do 67 i=1,iclass
< ! if ((zt/h.gt.th(i-1)).and.(zt/h.le.th(i)))
< ! + t(i)=t(i)+dt
< !7 continue
< !endif
< !if ((mod(itime,10800).eq.0).and.dump) then
< ! dump=.false.
< ! write(550,'(i6,12f10.3)') itime,hsave/tacc,zacc/tacc,
< ! + (t(i)/tacc*real(iclass),i=1,iclass)
< ! zacc=0.
< ! tacc=0.
< ! do 68 i=1,iclass
< !8 t(i)=0.
< ! hsave=0.
< !endif
< !if (mod(itime,10800).ne.0) dump=.true.
< !!! CHANGE
<
<
< ! 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)=1.+(prob(ks)-1.)* &
< exp(-vdepo(ks)*abs(dt)/(2.*href))
< endif
< end do
< endif
<
< if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
<
< if (itimec.eq.(itime+lsynctime)) then
< usig=0.5*(usigprof(indzp)+usigprof(indz))
< vsig=0.5*(vsigprof(indzp)+vsigprof(indz))
< wsig=0.5*(wsigprof(indzp)+wsigprof(indz))
< goto 99 ! finished
< endif
< goto 100
<
< ! END TIME LOOP
< !==============
<
<
< endif
<
<
<
< !**********************************************************
< ! For all particles that are outside the PBL, make a single
< ! time step. Only horizontal turbulent disturbances are
< ! calculated. Vertical disturbances are reset.
< !**********************************************************
<
<
< ! Interpolate the wind
< !*********************
<
< 700 continue
< if (ngrid.le.0) then
< xts=real(xt)
< yts=real(yt)
< call interpol_wind(itime,xts,yts,zt)
< else
< call interpol_wind_nests(itime,xtn,ytn,zt)
< endif
<
<
< ! Compute everything for above the PBL
<
< ! Assume constant, uncorrelated, turbulent perturbations
< ! In the stratosphere, use a small vertical diffusivity d_strat,
< ! in the troposphere, use a larger horizontal diffusivity d_trop.
< ! Turbulent velocity scales are determined based on sqrt(d_trop/dt)
< !******************************************************************
<
< ldt=abs(lsynctime-itimec+itime)
< dt=real(ldt)
<
< if (zt.lt.tropop) then ! in the troposphere
< uxscale=sqrt(2.*d_trop/dt)
< if (nrand+1.gt.maxrand) nrand=1
< ux=rannumb(nrand)*uxscale
< vy=rannumb(nrand+1)*uxscale
< nrand=nrand+2
< wp=0.
< else if (zt.lt.tropop+1000.) then ! just above the tropopause: make transition
< weight=(zt-tropop)/1000.
< uxscale=sqrt(2.*d_trop/dt*(1.-weight))
< if (nrand+2.gt.maxrand) nrand=1
< ux=rannumb(nrand)*uxscale
< vy=rannumb(nrand+1)*uxscale
< wpscale=sqrt(2.*d_strat/dt*weight)
< wp=rannumb(nrand+2)*wpscale+d_strat/1000.
< nrand=nrand+3
< else ! in the stratosphere
< if (nrand.gt.maxrand) nrand=1
< ux=0.
< vy=0.
< wpscale=sqrt(2.*d_strat/dt)
< wp=rannumb(nrand)*wpscale
< nrand=nrand+1
< endif
<
<
< ! If particle represents only a single species, add gravitational settling
< ! velocity. The settling velocity is zero for gases
< !*************************************************************************
<
<
<
< if (mdomainfill.eq.0) then
< do nsp=1,nspec
< if (xmass(nrelpoint,nsp).gt.eps2) goto 888
< end do
< 888 nsp=min(nsp,nspec)
< !!$ if (density(nsp).gt.0.) &
< !!$ call get_settling(itime,xts,yts,zt,nsp,settling) !old
< if (density(nsp).gt.0.) &
< call get_settling(itime,real(xt),real(yt),zt,nsp,settling) !bugfix
< w=w+settling
< endif
<
< ! Calculate position at time step itime+lsynctime
< !************************************************
<
< dxsave=dxsave+(u+ux)*dt
< dysave=dysave+(v+vy)*dt
< zt=zt+(w+wp)*dt*real(ldirect)
< if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
<
< 99 continue
<
<
<
< !****************************************************************
< ! Add mesoscale random disturbances
< ! This is done only once for the whole lsynctime interval to save
< ! computation time
< !****************************************************************
<
<
< ! Mesoscale wind velocity fluctuations are obtained by scaling
< ! with the standard deviation of the grid-scale winds surrounding
< ! the particle location, multiplied by a factor turbmesoscale.
< ! The autocorrelation time constant is taken as half the
< ! time interval between wind fields
< !****************************************************************
<
< r=exp(-2.*real(abs(lsynctime))/real(lwindinterv))
< rs=sqrt(1.-r**2)
< if (nrand+2.gt.maxrand) nrand=1
< usigold=r*usigold+rs*rannumb(nrand)*usig*turbmesoscale
< vsigold=r*vsigold+rs*rannumb(nrand+1)*vsig*turbmesoscale
< wsigold=r*wsigold+rs*rannumb(nrand+2)*wsig*turbmesoscale
<
< dxsave=dxsave+usigold*real(lsynctime)
< dysave=dysave+vsigold*real(lsynctime)
<
< zt=zt+wsigold*real(lsynctime)
< if (zt.lt.0.) zt=-1.*zt ! if particle below ground -> refletion
<
< !*************************************************************
< ! Transform along and cross wind components to xy coordinates,
< ! add them to u and v, transform u,v to grid units/second
< ! and calculate new position
< !*************************************************************
<
< call windalign(dxsave,dysave,dawsave,dcwsave,ux,vy)
< dxsave=dxsave+ux
< dysave=dysave+vy
< if (ngrid.ge.0) then
< cosfact=dxconst/cos((yt*dy+ylat0)*pi180)
< xt=xt+real(dxsave*cosfact*real(ldirect),kind=dp)
< yt=yt+real(dysave*dyconst*real(ldirect),kind=dp)
< else if (ngrid.eq.-1) then ! around north pole
< xlon=xlon0+xt*dx
< ylat=ylat0+yt*dy
< call cll2xy(northpolemap,ylat,xlon,xpol,ypol)
< gridsize=1000.*cgszll(northpolemap,ylat,xlon)
< dxsave=dxsave/gridsize
< dysave=dysave/gridsize
< xpol=xpol+dxsave*real(ldirect)
< ypol=ypol+dysave*real(ldirect)
< call cxy2ll(northpolemap,xpol,ypol,ylat,xlon)
< xt=(xlon-xlon0)/dx
< yt=(ylat-ylat0)/dy
< else if (ngrid.eq.-2) then ! around south pole
< xlon=xlon0+xt*dx
< ylat=ylat0+yt*dy
< call cll2xy(southpolemap,ylat,xlon,xpol,ypol)
< gridsize=1000.*cgszll(southpolemap,ylat,xlon)
< dxsave=dxsave/gridsize
< dysave=dysave/gridsize
< xpol=xpol+dxsave*real(ldirect)
< ypol=ypol+dysave*real(ldirect)
< call cxy2ll(southpolemap,xpol,ypol,ylat,xlon)
< xt=(xlon-xlon0)/dx
< yt=(ylat-ylat0)/dy
< endif
<
<
< ! If global data are available, use cyclic boundary condition
< !************************************************************
<
< if (xglobal) then
< if (xt.ge.real(nxmin1)) xt=xt-real(nxmin1)
< if (xt.lt.0.) xt=xt+real(nxmin1)
< if (xt.le.eps) xt=eps
< if (abs(xt-real(nxmin1)).le.eps) xt=real(nxmin1)-eps
< endif
<
<
< ! Check position: If trajectory outside model domain, terminate it
< !*****************************************************************
<
< if ((xt.lt.0.).or.(xt.ge.real(nxmin1)).or.(yt.lt.0.).or. &
< (yt.ge.real(nymin1))) then
< nstop=3
< return
< endif
<
< ! If particle above highest model level, set it back into the domain
< !*******************************************************************
<
< if (zt.ge.height(nz)) zt=height(nz)-100.*eps
<
<
< !************************************************************************
< ! Now we could finish, as this was done in FLEXPART versions up to 4.0.
< ! However, truncation errors of the advection can be significantly
< ! reduced by doing one iteration of the Petterssen scheme, if this is
< ! possible.
< ! Note that this is applied only to the grid-scale winds, not to
< ! the turbulent winds.
< !************************************************************************
<
< ! The Petterssen scheme can only applied with long time steps (only then u
< ! is the "old" wind as required by the scheme); otherwise do nothing
< !*************************************************************************
<
< if (ldt.ne.abs(lsynctime)) return
<
< ! The Petterssen scheme can only be applied if the ending time of the time step
< ! (itime+ldt*ldirect) is still between the two wind fields held in memory;
< ! otherwise do nothing
< !******************************************************************************
<
< if (abs(itime+ldt*ldirect).gt.abs(memtime(2))) return
<
< ! Apply it also only if starting and ending point of current time step are on
< ! the same grid; otherwise do nothing
< !*****************************************************************************
< if (nglobal.and.(yt.gt.switchnorthg)) then
< ngr=-1
< else if (sglobal.and.(yt.lt.switchsouthg)) then
< ngr=-2
< else
< ngr=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
< ngr=j
< goto 43
< endif
< end do
< 43 continue
< endif
<
< if (ngr.ne.ngrid) return
<
< ! 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)
< else
< ix=int(xt)
< jy=int(yt)
< endif
< ixp=ix+1
< jyp=jy+1
<
<
< ! Memorize the old wind
< !**********************
<
< uold=u
< vold=v
< wold=w
<
< ! Interpolate wind at new position and time
< !******************************************
<
< if (ngrid.le.0) then
< xts=real(xt)
< yts=real(yt)
< call interpol_wind_short(itime+ldt*ldirect,xts,yts,zt)
< else
< call interpol_wind_short_nests(itime+ldt*ldirect,xtn,ytn,zt)
< endif
<
< if (mdomainfill.eq.0) then
< do nsp=1,nspec
< if (xmass(nrelpoint,nsp).gt.eps2) goto 889
< end do
< 889 nsp=min(nsp,nspec)
< !!$ if (density(nsp).gt.0.) &
< !!$ call get_settling(itime+ldt,xts,yts,zt,nsp,settling) !old
< if (density(nsp).gt.0.) &
< call get_settling(itime+ldt,real(xt),real(yt),zt,nsp,settling) !bugfix
< w=w+settling
< endif
<
<
< ! Determine the difference vector between new and old wind
< ! (use half of it to correct position according to Petterssen)
< !*************************************************************
<
< u=(u-uold)/2.
< v=(v-vold)/2.
< w=(w-wold)/2.
<
<
< ! Finally, correct the old position
< !**********************************
<
< zt=zt+w*real(ldt*ldirect)
< if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
< if (ngrid.ge.0) then
< cosfact=dxconst/cos((yt*dy+ylat0)*pi180)
< xt=xt+real(u*cosfact*real(ldt*ldirect),kind=dp)
< yt=yt+real(v*dyconst*real(ldt*ldirect),kind=dp)
< else if (ngrid.eq.-1) then ! around north pole
< xlon=xlon0+xt*dx
< ylat=ylat0+yt*dy
< call cll2xy(northpolemap,ylat,xlon,xpol,ypol)
< gridsize=1000.*cgszll(northpolemap,ylat,xlon)
< u=u/gridsize
< v=v/gridsize
< xpol=xpol+u*real(ldt*ldirect)
< ypol=ypol+v*real(ldt*ldirect)
< call cxy2ll(northpolemap,xpol,ypol,ylat,xlon)
< xt=(xlon-xlon0)/dx
< yt=(ylat-ylat0)/dy
< else if (ngrid.eq.-2) then ! around south pole
< xlon=xlon0+xt*dx
< ylat=ylat0+yt*dy
< call cll2xy(southpolemap,ylat,xlon,xpol,ypol)
< gridsize=1000.*cgszll(southpolemap,ylat,xlon)
< u=u/gridsize
< v=v/gridsize
< xpol=xpol+u*real(ldt*ldirect)
< ypol=ypol+v*real(ldt*ldirect)
< call cxy2ll(southpolemap,xpol,ypol,ylat,xlon)
< xt=(xlon-xlon0)/dx
< yt=(ylat-ylat0)/dy
< endif
<
< ! If global data are available, use cyclic boundary condition
< !************************************************************
<
< if (xglobal) then
< if (xt.ge.real(nxmin1)) xt=xt-real(nxmin1)
< if (xt.lt.0.) xt=xt+real(nxmin1)
< if (xt.le.eps) xt=eps
< if (abs(xt-real(nxmin1)).le.eps) xt=real(nxmin1)-eps
< endif
<
< ! Check position: If trajectory outside model domain, terminate it
< !*****************************************************************
<
< if ((xt.lt.0.).or.(xt.ge.real(nxmin1)).or.(yt.lt.0.).or. &
< (yt.ge.real(nymin1))) then
< nstop=3
< return
< endif
<
< ! If particle above highest model level, set it back into the domain
< !*******************************************************************
<
< if (zt.ge.height(nz)) zt=height(nz)-100.*eps
<
<
< end subroutine advance
<
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine advance(pj, itime,nrelpoint,ldt,up,vp,wp, &
> usigold,vsigold,wsigold,nstop,xt,yt,zt,prob,icbt)
> ! i i i/oi/oi/o
> ! i/o i/o i/o o i/oi/oi/o i/o i/o
> !*****************************************************************************
> ! *
> ! Calculation of turbulent particle trajectories utilizing a *
> ! zero-acceleration scheme, which is corrected by a numerically more *
> ! accurate Petterssen scheme whenever possible. *
> ! *
> ! Particle positions are read in, incremented, and returned to the calling *
> ! program. *
> ! *
> ! In different regions of the atmosphere (PBL vs. free troposphere), *
> ! different parameters are needed for advection, parameterizing turbulent *
> ! velocities, etc. For efficiency, different interpolation routines have *
> ! been written for these different cases, with the disadvantage that there *
> ! exist several routines doing almost the same. They all share the *
> ! included file 'interpol_mod'. The following *
> ! interpolation routines are used: *
> ! *
> ! interpol_all(_nests) interpolates everything (called inside the PBL) *
> ! interpol_misslev(_nests) if a particle moves vertically in the PBL, *
> ! additional parameters are interpolated if it *
> ! crosses a model level *
> ! interpol_wind(_nests) interpolates the wind and determines the *
> ! standard deviation of the wind (called outside *
> ! PBL) also interpolates potential vorticity *
> ! interpol_wind_short(_nests) only interpolates the wind (needed for the *
> ! Petterssen scheme) *
> ! interpol_vdep(_nests) interpolates deposition velocities *
> ! *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 December 1997 *
> ! *
> ! Changes: *
> ! *
> ! 8 April 2000: Deep convection parameterization *
> ! *
> ! May 2002: Petterssen scheme introduced *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! icbt 1 if particle not transferred to forbidden state, *
> ! else -1 *
> ! dawsave accumulated displacement in along-wind direction *
> ! dcwsave accumulated displacement in cross-wind direction *
> ! dxsave accumulated displacement in longitude *
> ! dysave accumulated displacement in latitude *
> ! h [m] Mixing height *
> ! lwindinterv [s] time interval between two wind fields *
> ! 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 *
> ! ladvance [s] Total integration time period *
> ! 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 *
> ! nrand index for a variable to be picked from rannumb *
> ! nstop if > 1 particle has left domain and must be stopped *
> ! prob probability of absorption due to dry deposition *
> ! rannumb(maxrand) normally distributed random variables *
> ! rhoa air density *
> ! rhograd vertical gradient of the air density *
> ! up,vp,wp random velocities due to turbulence (along wind, cross *
> ! wind, vertical wind *
> ! usig,vsig,wsig mesoscale wind fluctuations *
> ! usigold,vsigold,wsigold like usig, etc., but for the last time step *
> ! vdepo Deposition velocities for all species *
> ! xt,yt,zt Particle position *
> ! *
> !*****************************************************************************
>
> use point_mod
> use par_mod
> use com_mod
> use interpol_mod
> use hanna_mod
> use cmapf_mod
> use random_mod, only : ran3_advance
> ! reads: ran3_advance
> ! writes:
>
> implicit none
>
> real(kind=dp) :: xt,yt
> real :: zt,xts,yts,weight
> integer, intent(in) :: pj
> integer :: itime,itimec,nstop,ldt,i,j,k,nrand,loop,memindnext
> integer :: ngr,nix,njy,ks,nsp,nrelpoint
> real :: dz,dz1,dz2,xlon,ylat,xpol,ypol,gridsize
> real :: ru,rv,rw,dt,ux,vy,cosfact,xtn,ytn,tropop
> real :: prob(maxspec),up,vp,wp,dxsave,dysave,dawsave
> real :: dcwsave
> real :: usigold,vsigold,wsigold,r,rs
> real :: uold,vold,wold,vdepo(maxspec)
> !real uprof(nzmax),vprof(nzmax),wprof(nzmax)
> !real usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax)
> !real rhoprof(nzmax),rhogradprof(nzmax)
> real :: rhoa,rhograd,delz,dtf,rhoaux,dtftlw,uxscale,wpscale
> integer(kind=2) :: icbt
> real,parameter :: eps=nxmax/3.e5,eps2=1.e-9
>
> ! vars for well mixed test
> #ifdef WELL_MIXED_TEST
> integer,parameter :: iclass=20
> real(kind=dp) :: zacc,tacc,t(iclass),th(0:iclass),hsave, ol_wmxd
> real :: dens_corr, drift_corr
> real(kind=dp) :: rho_wmxd(iclass)
> real(kind=dp) :: rhograd_wmxd(iclass)
> real(kind=dp) :: dens_corr_wmxd(iclass)
> real(kind=dp) :: drift_corr_wmxd(iclass)
> real(kind=dp) :: sigw_wmxd(iclass)
> logical dump
> character(len=256) :: frmt
> save zacc,tacc,t,th,hsave,dump
> #endif
>
> integer :: idummy = -7
> real :: settling = 0.
>
>
> ! init vars for well mixed test
> #ifdef WELL_MIXED_TEST
> if (idummy.eq.-7) then
> open(550,file=trim(path(2))//'WELLMIXEDTEST')
> do i=0,iclass
> th(i)=real(i)/real(iclass)
> end do
> ol_wmxd = 0._dp
> tacc = 0._dp
> zacc = 0._dp
> t(:) = 0._dp
> rho_wmxd(:) = 0._dp
> rhograd_wmxd(:) = 0._dp
> dens_corr_wmxd(:) = 0._dp
> drift_corr_wmxd(:) = 0._dp
> sigw_wmxd(:) = 0._dp
> hsave = 0._dp
> end if
> #endif
>
>
> nstop=0
> do i=1,nmixz
> indzindicator(i)=.true.
> end do
>
>
> if (DRYDEP) then ! reset probability for deposition
> do ks=1,nspec
> depoindicator(ks)=.true.
> prob(ks)=0.
> end do
> endif
>
> dxsave=0. ! reset position displacements
> dysave=0. ! due to mean wind
> dawsave=0. ! and turbulent wind
> dcwsave=0.
>
> itimec=itime
>
> nrand=int(ran3_advance(pj) * real(maxrand-1)) + 1
>
>
> ! 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
>
>
> ! Compute maximum mixing height around particle position
> !*******************************************************
>
> h=0.
> if (ngrid.le.0) then
> do k=1,2
> do j=jy,jyp
> do i=ix,ixp
> if (hmix(i,j,1,k).gt.h) h=hmix(i,j,1,k)
> end do
> end do
> end do
> tropop=tropopause(nix,njy,1,1)
> else
> do k=1,2
> do j=jy,jyp
> do i=ix,ixp
> if (hmixn(i,j,1,k,ngrid).gt.h) h=hmixn(i,j,1,k,ngrid)
> end do
> end do
> end do
> tropop=tropopausen(nix,njy,1,1,ngrid)
> endif
>
> zeta=zt/h
>
>
>
> !*************************************************************
> ! If particle is in the PBL, interpolate once and then make a
> ! time loop until end of interval is reached
> !*************************************************************
>
> if (zeta.le.1.) then
>
> ! BEGIN TIME LOOP
> !================
>
> loop=0
> 100 loop=loop+1
> if (method.eq.1) then
> ldt=min(ldt,abs(lsynctime-itimec+itime))
> itimec=itimec+ldt*ldirect
> else
> ldt=abs(lsynctime)
> itimec=itime+lsynctime
> endif
> dt=real(ldt)
>
> zeta=zt/h
>
>
> if (loop.eq.1) then
> if (ngrid.le.0) then
> xts=real(xt)
> yts=real(yt)
> call interpol_all(itime,xts,yts,zt)
> else
> call interpol_all_nests(itime,xtn,ytn,zt)
> endif
>
> else
>
>
> ! Determine the level below the current position for u,v,rho
> !***********************************************************
>
> do i=2,nz
> if (height(i).gt.zt) then
> indz=i-1
> indzp=i
> goto 6
> endif
> end do
> 6 continue
>
> ! If one of the levels necessary is not yet available,
> ! calculate it
> !*****************************************************
>
> do i=indz,indzp
> if (indzindicator(i)) then
> if (ngrid.le.0) then
> call interpol_misslev(i)
> else
> call interpol_misslev_nests(i)
> endif
> endif
> end do
> endif
>
>
> ! Vertical interpolation of u,v,w,rho and drhodz
> !***********************************************
>
> ! Vertical distance to the level below and above current position
> ! both in terms of (u,v) and (w) fields
> !****************************************************************
>
> dz=1./(height(indzp)-height(indz))
> dz1=(zt-height(indz))*dz
> dz2=(height(indzp)-zt)*dz
>
> u=dz1*uprof(indzp)+dz2*uprof(indz)
> v=dz1*vprof(indzp)+dz2*vprof(indz)
> w=dz1*wprof(indzp)+dz2*wprof(indz)
> rhoa=dz1*rhoprof(indzp)+dz2*rhoprof(indz)
> rhograd=dz1*rhogradprof(indzp)+dz2*rhogradprof(indz)
>
>
> ! Compute the turbulent disturbances
> ! Determine the sigmas and the timescales
> !****************************************
>
> if (turbswitch) then
> call hanna(zt)
> else
> call hanna1(zt)
> endif
>
>
> !*****************************************
> ! Determine the new diffusivity velocities
> !*****************************************
>
> ! Horizontal components
> !**********************
>
> if (nrand+1.gt.maxrand) nrand=1
> if (dt/tlu.lt..5) then
> up=(1.-dt/tlu)*up+rannumb(nrand)*sigu*sqrt(2.*dt/tlu)
> else
> ru=exp(-dt/tlu)
> up=ru*up+rannumb(nrand)*sigu*sqrt(1.-ru**2)
> endif
> if (dt/tlv.lt..5) then
> vp=(1.-dt/tlv)*vp+rannumb(nrand+1)*sigv*sqrt(2.*dt/tlv)
> else
> rv=exp(-dt/tlv)
> vp=rv*vp+rannumb(nrand+1)*sigv*sqrt(1.-rv**2)
> endif
> nrand=nrand+2
>
>
> if (nrand+ifine.gt.maxrand) nrand=1
> rhoaux=rhograd/rhoa
> dtf=dt*fine
>
> dtftlw=dtf/tlw
>
> ! Loop over ifine short time steps for vertical component
> !********************************************************
>
> do i=1,ifine
>
> ! Determine the drift velocity and density correction velocity
> !*************************************************************
>
> if (turbswitch) then
> if (dtftlw.lt..5) then
> wp=((1.-dtftlw)*wp+rannumb(nrand+i)*sqrt(2.*dtftlw) &
> +dtf*(dsigwdz+rhoaux*sigw))*real(icbt)
> #ifdef WELL_MIXED_TEST
> drift_corr = dsigwdz
> dens_corr = rhoaux*sigw
> #endif
> else
> rw=exp(-dtftlw)
> wp=(rw*wp+rannumb(nrand+i)*sqrt(1.-rw**2) &
> +tlw*(1.-rw)*(dsigwdz+rhoaux*sigw))*real(icbt)
> endif
> delz=wp*sigw*dtf
> else
> rw=exp(-dtftlw)
> wp=(rw*wp+rannumb(nrand+i)*sqrt(1.-rw**2)*sigw &
> +tlw*(1.-rw)*(dsigw2dz+rhoaux*sigw**2))*real(icbt)
> delz=wp*dtf
> endif
>
> !****************************************************
> ! Compute turbulent vertical displacement of particle
> !****************************************************
>
> if (abs(delz).gt.h) delz=mod(delz,h)
>
> ! Determine if particle transfers to a "forbidden state" below the ground
> ! or above the mixing height
> !************************************************************************
>
> if (delz.lt.-zt) then ! reflection at ground
> icbt=-1
> zt=-zt-delz
> else if (delz.gt.(h-zt)) then ! reflection at h
> icbt=-1
> zt=-zt-delz+2.*h
> else ! no reflection
> icbt=1
> zt=zt+delz
> endif
>
> if (i.ne.ifine) then
> zeta=zt/h
> call hanna_short(zt)
> endif
>
> end do
> nrand=nrand+i
>
> ! Determine time step for next integration
> !*****************************************
>
> if (turbswitch) then
> ldt=int(min(tlw,h/max(2.*abs(wp*sigw),1.e-5), &
> 0.5/abs(dsigwdz))*ctl)
> else
> ldt=int(min(tlw,h/max(2.*abs(wp),1.e-5))*ctl)
> endif
> ldt=max(ldt,mintime)
>
>
> ! If particle represents only a single species, add gravitational settling
> ! velocity. The settling velocity is zero for gases, or if particle
> ! represents more than one species
> !*************************************************************************
>
> if (mdomainfill.eq.0) then
> do nsp=1,nspec
> if (xmass(nrelpoint,nsp).gt.eps2) goto 887
> end do
> 887 nsp=min(nsp,nspec)
> !!$ if (density(nsp).gt.0.) &
> !!$ call get_settling(itime,xts,yts,zt,nsp,settling) !old
> if (density(nsp).gt.0.) &
> call get_settling(itime,real(xt),real(yt),zt,nsp,settling) !bugfix
> w=w+settling
> endif
>
> ! Horizontal displacements during time step dt are small real values compared
> ! to the position; adding the two, would result in large numerical errors.
> ! Thus, displacements are accumulated during lsynctime and are added to the
> ! position at the end
> !****************************************************************************
>
> #ifndef WELL_MIXED_TEST
> dxsave=dxsave+u*dt
> dysave=dysave+v*dt
> dawsave=dawsave+up*dt
> dcwsave=dcwsave+vp*dt
> zt=zt+w*dt*real(ldirect)
> #endif
>
> if (zt.gt.h) then
> if (itimec.eq.itime+lsynctime) goto 99
> goto 700 ! complete the current interval above PBL
> endif
>
>
> !!! TEST OF THE WELL-MIXED CRITERION
> !!! These lines may be switched on to test the well-mixed criterion
> #ifdef WELL_MIXED_TEST
> if (zt.le.h) then
> zacc=zacc+zt/h*dt
> hsave=hsave+h*dt
> tacc=tacc+dt
> ol_wmxd = ol_wmxd + ol * dt
> do i=1,iclass
> if ((zt/h.gt.th(i-1)).and.(zt/h.le.th(i))) then
> t(i)=t(i)+dt
> rho_wmxd(i) = rho_wmxd(i) + rhoa*dt
> rhograd_wmxd(i) = rhograd_wmxd(i) + rhograd*dt
> dens_corr_wmxd(i) = dens_corr_wmxd(i) + dens_corr * dt
> drift_corr_wmxd(i) = drift_corr_wmxd(i) + drift_corr * dt
> sigw_wmxd(i) = sigw_wmxd(i) + sigw * dt
> exit
> endif
> end do
> end if
> if ((mod(itime,10800).eq.0).and.dump) then
> dump=.false.
> write(frmt, '(a,i2,a,i2,a)') '(i8,', 2*iclass+2, 'f10.3,', 4*iclass, 'e12.4)'
> write(550, trim(frmt)) itime,hsave/tacc,zacc/tacc, &
> (t(i)/tacc*real(iclass),i=1,iclass), &
> (rho_wmxd(i)/t(i), i=1, iclass), &
> (rhograd_wmxd(i)/t(i), i=1, iclass), &
> (dens_corr_wmxd(i)/t(i), i=1, iclass), &
> (drift_corr_wmxd(i)/t(i), i=1, iclass), &
> (sigw_wmxd(i)/t(i), i=1, iclass)
> write(*,*) "ol", ol_wmxd/tacc
> zacc = 0.
> tacc = 0.
> ol_wmxd = 0._dp
> do i=1,iclass
> t(i) = 0.
> rho_wmxd(i) = 0._dp
> rhograd_wmxd(i) = 0._dp
> drift_corr_wmxd(i) = 0._dp
> dens_corr_wmxd(i) = 0._dp
> sigw_wmxd(i) = 0._dp
> end do
> hsave=0.
> end if
> if (mod(itime,10800).ne.0) dump=.true.
>
> #endif
>
>
> ! 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)=1.+(prob(ks)-1.)* &
> exp(-vdepo(ks)*abs(dt)/(2.*href))
> endif
> end do
> endif
>
> if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
>
> if (itimec.eq.(itime+lsynctime)) then
> usig=0.5*(usigprof(indzp)+usigprof(indz))
> vsig=0.5*(vsigprof(indzp)+vsigprof(indz))
> wsig=0.5*(wsigprof(indzp)+wsigprof(indz))
> goto 99 ! finished
> endif
> goto 100
>
> ! END TIME LOOP
> !==============
>
>
> endif
>
>
>
> !**********************************************************
> ! For all particles that are outside the PBL, make a single
> ! time step. Only horizontal turbulent disturbances are
> ! calculated. Vertical disturbances are reset.
> !**********************************************************
>
>
> ! Interpolate the wind
> !*********************
>
> 700 continue
> if (ngrid.le.0) then
> xts=real(xt)
> yts=real(yt)
> call interpol_wind(itime,xts,yts,zt)
> else
> call interpol_wind_nests(itime,xtn,ytn,zt)
> endif
>
>
> ! Compute everything for above the PBL
>
> ! Assume constant, uncorrelated, turbulent perturbations
> ! In the stratosphere, use a small vertical diffusivity d_strat,
> ! in the troposphere, use a larger horizontal diffusivity d_trop.
> ! Turbulent velocity scales are determined based on sqrt(d_trop/dt)
> !******************************************************************
>
> ldt=abs(lsynctime-itimec+itime)
> dt=real(ldt)
>
> if (zt.lt.tropop) then ! in the troposphere
> uxscale=sqrt(2.*d_trop/dt)
> if (nrand+1.gt.maxrand) nrand=1
> ux=rannumb(nrand)*uxscale
> vy=rannumb(nrand+1)*uxscale
> nrand=nrand+2
> wp=0.
> else if (zt.lt.tropop+1000.) then ! just above the tropopause: make transition
> weight=(zt-tropop)/1000.
> uxscale=sqrt(2.*d_trop/dt*(1.-weight))
> if (nrand+2.gt.maxrand) nrand=1
> ux=rannumb(nrand)*uxscale
> vy=rannumb(nrand+1)*uxscale
> wpscale=sqrt(2.*d_strat/dt*weight)
> wp=rannumb(nrand+2)*wpscale+d_strat/1000.
> nrand=nrand+3
> else ! in the stratosphere
> if (nrand.gt.maxrand) nrand=1
> ux=0.
> vy=0.
> wpscale=sqrt(2.*d_strat/dt)
> wp=rannumb(nrand)*wpscale
> nrand=nrand+1
> endif
>
>
> ! If particle represents only a single species, add gravitational settling
> ! velocity. The settling velocity is zero for gases
> !*************************************************************************
>
>
>
> if (mdomainfill.eq.0) then
> do nsp=1,nspec
> if (xmass(nrelpoint,nsp).gt.eps2) goto 888
> end do
> 888 nsp=min(nsp,nspec)
> !!$ if (density(nsp).gt.0.) &
> !!$ call get_settling(itime,xts,yts,zt,nsp,settling) !old
> if (density(nsp).gt.0.) &
> call get_settling(itime,real(xt),real(yt),zt,nsp,settling) !bugfix
> w=w+settling
> endif
>
> ! Calculate position at time step itime+lsynctime
> !************************************************
>
> #ifndef WELL_MIXED_TEST
> dxsave=dxsave+(u+ux)*dt
> dysave=dysave+(v+vy)*dt
> zt=zt+(w+wp)*dt*real(ldirect)
> #endif
> if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
>
> 99 continue
>
>
>
> !****************************************************************
> ! Add mesoscale random disturbances
> ! This is done only once for the whole lsynctime interval to save
> ! computation time
> !****************************************************************
>
>
> ! Mesoscale wind velocity fluctuations are obtained by scaling
> ! with the standard deviation of the grid-scale winds surrounding
> ! the particle location, multiplied by a factor turbmesoscale.
> ! The autocorrelation time constant is taken as half the
> ! time interval between wind fields
> !****************************************************************
>
> r=exp(-2.*real(abs(lsynctime))/real(lwindinterv))
> rs=sqrt(1.-r**2)
> if (nrand+2.gt.maxrand) nrand=1
> usigold=r*usigold+rs*rannumb(nrand)*usig*turbmesoscale
> vsigold=r*vsigold+rs*rannumb(nrand+1)*vsig*turbmesoscale
> wsigold=r*wsigold+rs*rannumb(nrand+2)*wsig*turbmesoscale
>
> #ifndef WELL_MIXED_TEST
> dxsave=dxsave+usigold*real(lsynctime)
> dysave=dysave+vsigold*real(lsynctime)
> zt=zt+wsigold*real(lsynctime)
> #endif
> if (zt.lt.0.) zt=-1.*zt ! if particle below ground -> refletion
>
> !*************************************************************
> ! Transform along and cross wind components to xy coordinates,
> ! add them to u and v, transform u,v to grid units/second
> ! and calculate new position
> !*************************************************************
>
> call windalign(dxsave,dysave,dawsave,dcwsave,ux,vy)
> dxsave=dxsave+ux
> dysave=dysave+vy
> if (ngrid.ge.0) then
> cosfact=dxconst/cos((yt*dy+ylat0)*pi180)
> xt=xt+real(dxsave*cosfact*real(ldirect),kind=dp)
> yt=yt+real(dysave*dyconst*real(ldirect),kind=dp)
> else if (ngrid.eq.-1) then ! around north pole
> xlon=xlon0+xt*dx
> ylat=ylat0+yt*dy
> call cll2xy(northpolemap,ylat,xlon,xpol,ypol)
> gridsize=1000.*cgszll(northpolemap,ylat,xlon)
> dxsave=dxsave/gridsize
> dysave=dysave/gridsize
> xpol=xpol+dxsave*real(ldirect)
> ypol=ypol+dysave*real(ldirect)
> call cxy2ll(northpolemap,xpol,ypol,ylat,xlon)
> xt=(xlon-xlon0)/dx
> yt=(ylat-ylat0)/dy
> else if (ngrid.eq.-2) then ! around south pole
> xlon=xlon0+xt*dx
> ylat=ylat0+yt*dy
> call cll2xy(southpolemap,ylat,xlon,xpol,ypol)
> gridsize=1000.*cgszll(southpolemap,ylat,xlon)
> dxsave=dxsave/gridsize
> dysave=dysave/gridsize
> xpol=xpol+dxsave*real(ldirect)
> ypol=ypol+dysave*real(ldirect)
> call cxy2ll(southpolemap,xpol,ypol,ylat,xlon)
> xt=(xlon-xlon0)/dx
> yt=(ylat-ylat0)/dy
> endif
>
>
> ! If global data are available, use cyclic boundary condition
> !************************************************************
>
> if (xglobal) then
> if (xt.ge.real(nxmin1)) xt=xt-real(nxmin1)
> if (xt.lt.0.) xt=xt+real(nxmin1)
> if (xt.le.eps) xt=eps
> if (abs(xt-real(nxmin1)).le.eps) xt=real(nxmin1)-eps
> endif
>
>
> ! Check position: If trajectory outside model domain, terminate it
> !*****************************************************************
>
> if ((xt.lt.0.).or.(xt.ge.real(nxmin1)).or.(yt.lt.0.).or. &
> (yt.ge.real(nymin1))) then
> nstop=3
> return
> endif
>
> ! If particle above highest model level, set it back into the domain
> !*******************************************************************
>
> if (zt.ge.height(nz)) zt=height(nz)-100.*eps
>
>
> !************************************************************************
> ! Now we could finish, as this was done in FLEXPART versions up to 4.0.
> ! However, truncation errors of the advection can be significantly
> ! reduced by doing one iteration of the Petterssen scheme, if this is
> ! possible.
> ! Note that this is applied only to the grid-scale winds, not to
> ! the turbulent winds.
> !************************************************************************
>
> ! The Petterssen scheme can only applied with long time steps (only then u
> ! is the "old" wind as required by the scheme); otherwise do nothing
> !*************************************************************************
>
> if (ldt.ne.abs(lsynctime)) return
>
> ! The Petterssen scheme can only be applied if the ending time of the time step
> ! (itime+ldt*ldirect) is still between the two wind fields held in memory;
> ! otherwise do nothing
> !******************************************************************************
>
> if (abs(itime+ldt*ldirect).gt.abs(memtime(2))) return
>
> ! Apply it also only if starting and ending point of current time step are on
> ! the same grid; otherwise do nothing
> !*****************************************************************************
> if (nglobal.and.(yt.gt.switchnorthg)) then
> ngr=-1
> else if (sglobal.and.(yt.lt.switchsouthg)) then
> ngr=-2
> else
> ngr=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
> ngr=j
> goto 43
> endif
> end do
> 43 continue
> endif
>
> if (ngr.ne.ngrid) return
>
> ! 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)
> else
> ix=int(xt)
> jy=int(yt)
> endif
> ixp=ix+1
> jyp=jy+1
>
>
> ! Memorize the old wind
> !**********************
>
> uold=u
> vold=v
> wold=w
>
> ! Interpolate wind at new position and time
> !******************************************
>
> if (ngrid.le.0) then
> xts=real(xt)
> yts=real(yt)
> call interpol_wind_short(itime+ldt*ldirect,xts,yts,zt)
> else
> call interpol_wind_short_nests(itime+ldt*ldirect,xtn,ytn,zt)
> endif
>
> if (mdomainfill.eq.0) then
> do nsp=1,nspec
> if (xmass(nrelpoint,nsp).gt.eps2) goto 889
> end do
> 889 nsp=min(nsp,nspec)
> !!$ if (density(nsp).gt.0.) &
> !!$ call get_settling(itime+ldt,xts,yts,zt,nsp,settling) !old
> if (density(nsp).gt.0.) &
> call get_settling(itime+ldt,real(xt),real(yt),zt,nsp,settling) !bugfix
> w=w+settling
> endif
>
>
> ! Determine the difference vector between new and old wind
> ! (use half of it to correct position according to Petterssen)
> !*************************************************************
>
> u=(u-uold)/2.
> v=(v-vold)/2.
> w=(w-wold)/2.
>
>
> ! Finally, correct the old position
> !**********************************
>
> zt=zt+w*real(ldt*ldirect)
> if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection
> if (ngrid.ge.0) then
> cosfact=dxconst/cos((yt*dy+ylat0)*pi180)
> xt=xt+real(u*cosfact*real(ldt*ldirect),kind=dp)
> yt=yt+real(v*dyconst*real(ldt*ldirect),kind=dp)
> else if (ngrid.eq.-1) then ! around north pole
> xlon=xlon0+xt*dx
> ylat=ylat0+yt*dy
> call cll2xy(northpolemap,ylat,xlon,xpol,ypol)
> gridsize=1000.*cgszll(northpolemap,ylat,xlon)
> u=u/gridsize
> v=v/gridsize
> xpol=xpol+u*real(ldt*ldirect)
> ypol=ypol+v*real(ldt*ldirect)
> call cxy2ll(northpolemap,xpol,ypol,ylat,xlon)
> xt=(xlon-xlon0)/dx
> yt=(ylat-ylat0)/dy
> else if (ngrid.eq.-2) then ! around south pole
> xlon=xlon0+xt*dx
> ylat=ylat0+yt*dy
> call cll2xy(southpolemap,ylat,xlon,xpol,ypol)
> gridsize=1000.*cgszll(southpolemap,ylat,xlon)
> u=u/gridsize
> v=v/gridsize
> xpol=xpol+u*real(ldt*ldirect)
> ypol=ypol+v*real(ldt*ldirect)
> call cxy2ll(southpolemap,xpol,ypol,ylat,xlon)
> xt=(xlon-xlon0)/dx
> yt=(ylat-ylat0)/dy
> endif
>
> ! If global data are available, use cyclic boundary condition
> !************************************************************
>
> if (xglobal) then
> if (xt.ge.real(nxmin1)) xt=xt-real(nxmin1)
> if (xt.lt.0.) xt=xt+real(nxmin1)
> if (xt.le.eps) xt=eps
> if (abs(xt-real(nxmin1)).le.eps) xt=real(nxmin1)-eps
> endif
>
> ! Check position: If trajectory outside model domain, terminate it
> !*****************************************************************
>
> if ((xt.lt.0.).or.(xt.ge.real(nxmin1)).or.(yt.lt.0.).or. &
> (yt.ge.real(nymin1))) then
> nstop=3
> return
> endif
>
> ! If particle above highest model level, set it back into the domain
> !*******************************************************************
>
> if (zt.ge.height(nz)) zt=height(nz)-100.*eps
>
>
> end subroutine advance
>
assignland.f90
----------------------------------------------
1,239c1,239
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine assignland
<
< !*****************************************************************************
< ! *
< ! This routine assigns fractions of the 13 landuse classes to each ECMWF *
< ! grid point. *
< ! The landuse inventory of *
< ! *
< ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
< ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
< ! A Project Overview: Photogrammetric Engineering and Remote Sensing , *
< ! v. 65, no. 9, p. 1013-1020 *
< ! *
< ! if there are no data in the inventory *
< ! the ECMWF land/sea mask is used to distinguish *
< ! between sea (-> ocean) and land (-> grasslands). *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 5 December 1996 *
< ! 8 February 1999 Additional use of nests, A. Stohl *
< ! 29 December 2006 new landuse inventory, S. Eckhardt *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! xlanduse fractions of numclass landuses for each model grid point *
< ! landinvent landuse inventory (0.3 deg resolution) *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: ix,jy,k,l,li,nrefine,iix,jjy
< integer,parameter :: lumaxx=1200,lumaxy=600
< integer,parameter :: xlon0lu=-180,ylat0lu=-90
< real,parameter :: dxlu=0.3
< real :: xlon,ylat,sumperc,p,xi,yj
< real :: xlandusep(lumaxx,lumaxy,numclass)
< ! character*2 ck
<
< do ix=1,lumaxx
< do jy=1,lumaxy
< do k=1,numclass
< xlandusep(ix,jy,k)=0.
< end do
< sumperc=0.
< do li=1,3
< sumperc=sumperc+landinvent(ix,jy,li+3)
< end do
< do li=1,3
< k=landinvent(ix,jy,li)
< if (sumperc.gt.0) then
< p=landinvent(ix,jy,li+3)/sumperc
< else
< p=0
< endif
< ! p has values between 0 and 1
< xlandusep(ix,jy,k)=p
< end do
< end do
< end do
<
< ! do 13 k=1,11
< ! write (ck,'(i2.2)') k
< ! open(4,file='xlandusetest'//ck,form='formatted')
< ! do 11 ix=1,lumaxx
< !11 write (4,*) (xlandusep(ix,jy,k),jy=1,lumaxy)
< !11 write (4,*) (landinvent(ix,jy,k),jy=1,lumaxy)
< !13 close(4)
<
< ! write (*,*) xlon0,ylat0,xlon0n(1),ylat0n(1),nxmin1,nymin1
< ! write (*,*) dx, dy, dxout, dyout, ylat0, xlon0
< nrefine=10
< do ix=0,nxmin1
< do jy=0,nymin1
< do k=1,numclass
< sumperc=0.
< xlanduse(ix,jy,k)=0.
< end do
< do iix=1, nrefine
< xlon=(ix+(iix-1)/real(nrefine))*dx+xlon0 ! longitude, should be between -180 and 179
< if (xlon.ge.(xlon0lu+lumaxx*dxlu)) then
< xlon=xlon-lumaxx*dxlu
< endif
< do jjy=1, nrefine
< ylat=(jy+(jjy-1)/real(nrefine))*dy+ylat0 ! and lat. of each gridpoint
< xi=int((xlon-xlon0lu)/dxlu)+1
< yj=int((ylat-ylat0lu)/dxlu)+1
< if (xi.gt.lumaxx) xi=xi-lumaxx
< if (yj.gt.lumaxy) yj=yj-lumaxy
< if (xi.lt.0) then
< write (*,*) 'problem with landuseinv sampling: ', &
< xlon,xlon0lu,ix,iix,xlon0,dx,nxmax
< stop
< endif
< do k=1,numclass
< xlanduse(ix,jy,k)= &
< xlanduse(ix,jy,k)+xlandusep(int(xi),int(yj),k)
< sumperc=sumperc+xlanduse(ix,jy,k) ! just for the check if landuseinv. is available
< end do
< end do
< end do
< if (sumperc.gt.0) then ! detailed landuse available
< sumperc=0.
< do k=1,numclass
< xlanduse(ix,jy,k)= &
< xlanduse(ix,jy,k)/real(nrefine*nrefine)
< sumperc=sumperc+xlanduse(ix,jy,k)
< end do
< !cc the sum of all categories should be 1 ... 100 percent ... in order to get vdep right!
< if (sumperc.lt.1-1E-5) then
< do k=1,numclass
< xlanduse(ix,jy,k)= &
< xlanduse(ix,jy,k)/sumperc
< end do
< endif
< else
< if (lsm(ix,jy).lt.0.1) then ! over sea -> ocean
< xlanduse(ix,jy,3)=1.
< else ! over land -> rangeland
< xlanduse(ix,jy,7)=1.
< endif
< endif
<
<
< end do
< end do
<
< !***********************************
< ! for test: write out xlanduse
<
< ! open(4,file='landusetest',form='formatted')
< ! do 56 k=1,13
< ! do 55 ix=0,nxmin1
< !55 write (4,*) (xlanduse(ix,jy,k),jy=0,nymin1)
< !56 continue
< ! close(4)
< ! write (*,*) 'landuse written'
< !stop
< ! open(4,file='landseatest'//ck,form='formatted')
< ! do 57 ix=0,nxmin1
< !57 write (4,*) (lsm(ix,jy),jy=0,nymin1)
< ! write (*,*) 'landseamask written'
<
< !****************************************
< ! Same as above, but for the nested grids
< !****************************************
<
< !************** TEST ********************
< ! dyn(1)=dyn(1)/40
< ! dxn(1)=dxn(1)/40
< ! xlon0n(1)=1
< ! ylat0n(1)=50
< !************** TEST ********************
<
< do l=1,numbnests
< do ix=0,nxn(l)-1
< do jy=0,nyn(l)-1
< do k=1,numclass
< sumperc=0.
< xlandusen(ix,jy,k,l)=0.
< end do
< do iix=1, nrefine
< xlon=(ix+(iix-1)/real(nrefine))*dxn(l)+xlon0n(l)
< do jjy=1, nrefine
< ylat=(jy+(jjy-1)/real(nrefine))*dyn(l)+ylat0n(l)
< xi=int((xlon-xlon0lu)/dxlu)+1
< yj=int((ylat-ylat0lu)/dxlu)+1
< if (xi.gt.lumaxx) xi=xi-lumaxx
< if (yj.gt.lumaxy) yj=yj-lumaxy
< do k=1,numclass
< xlandusen(ix,jy,k,l)=xlandusen(ix,jy,k,l)+ &
< xlandusep(int(xi),int(yj),k)
< sumperc=sumperc+xlandusen(ix,jy,k,l)
< end do
< end do
< end do
< if (sumperc.gt.0) then ! detailed landuse available
< sumperc=0.
< do k=1,numclass
< xlandusen(ix,jy,k,l)= &
< xlandusen(ix,jy,k,l)/real(nrefine*nrefine)
< sumperc=sumperc+xlandusen(ix,jy,k,l)
< end do
< !cc the sum of all categories should be 1 ... 100 percent ... in order to get vdep right!
< if (sumperc.lt.1-1E-5) then
< do k=1,numclass
< xlandusen(ix,jy,k,l)=xlandusen(ix,jy,k,l)/sumperc
< end do
< endif
< else ! check land/sea mask
< if (lsmn(ix,jy,l).lt.0.1) then ! over sea -> ocean
< xlandusen(ix,jy,3,l)=1.
< else ! over land -> grasslands
< xlandusen(ix,jy,7,l)=1.
< endif
< endif
< end do
< end do
< end do
<
< !***********************************
< ! for test: write out xlanduse
<
< ! do 66 k=1,11
< ! write (ck,'(i2.2)') k
< ! open(4,file='nlandusetest'//ck,form='formatted')
< ! do 65 ix=0,nxn(1)-1
< !65 write (4,*) (xlandusen(ix,jy,k,1),jy=0,nyn(1)-1)
< !66 close(4)
<
< ! write (*,*) 'landuse nested written'
<
<
< end subroutine assignland
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine assignland
>
> !*****************************************************************************
> ! *
> ! This routine assigns fractions of the 13 landuse classes to each ECMWF *
> ! grid point. *
> ! The landuse inventory of *
> ! *
> ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
> ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
> ! A Project Overview: Photogrammetric Engineering and Remote Sensing , *
> ! v. 65, no. 9, p. 1013-1020 *
> ! *
> ! if there are no data in the inventory *
> ! the ECMWF land/sea mask is used to distinguish *
> ! between sea (-> ocean) and land (-> grasslands). *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 5 December 1996 *
> ! 8 February 1999 Additional use of nests, A. Stohl *
> ! 29 December 2006 new landuse inventory, S. Eckhardt *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! xlanduse fractions of numclass landuses for each model grid point *
> ! landinvent landuse inventory (0.3 deg resolution) *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: ix,jy,k,l,li,nrefine,iix,jjy
> integer,parameter :: lumaxx=1200,lumaxy=600
> integer,parameter :: xlon0lu=-180,ylat0lu=-90
> real,parameter :: dxlu=0.3
> real :: xlon,ylat,sumperc,p,xi,yj
> real :: xlandusep(lumaxx,lumaxy,numclass)
> ! character*2 ck
>
> do ix=1,lumaxx
> do jy=1,lumaxy
> do k=1,numclass
> xlandusep(ix,jy,k)=0.
> end do
> sumperc=0.
> do li=1,3
> sumperc=sumperc+landinvent(ix,jy,li+3)
> end do
> do li=1,3
> k=landinvent(ix,jy,li)
> if (sumperc.gt.0) then
> p=landinvent(ix,jy,li+3)/sumperc
> else
> p=0
> endif
> ! p has values between 0 and 1
> xlandusep(ix,jy,k)=p
> end do
> end do
> end do
>
> ! do 13 k=1,11
> ! write (ck,'(i2.2)') k
> ! open(4,file='xlandusetest'//ck,form='formatted')
> ! do 11 ix=1,lumaxx
> !11 write (4,*) (xlandusep(ix,jy,k),jy=1,lumaxy)
> !11 write (4,*) (landinvent(ix,jy,k),jy=1,lumaxy)
> !13 close(4)
>
> ! write (*,*) xlon0,ylat0,xlon0n(1),ylat0n(1),nxmin1,nymin1
> ! write (*,*) dx, dy, dxout, dyout, ylat0, xlon0
> nrefine=10
> do ix=0,nxmin1
> do jy=0,nymin1
> do k=1,numclass
> sumperc=0.
> xlanduse(ix,jy,k)=0.
> end do
> do iix=1, nrefine
> xlon=(ix+(iix-1)/real(nrefine))*dx+xlon0 ! longitude, should be between -180 and 179
> if (xlon.ge.(xlon0lu+lumaxx*dxlu)) then
> xlon=xlon-lumaxx*dxlu
> endif
> do jjy=1, nrefine
> ylat=(jy+(jjy-1)/real(nrefine))*dy+ylat0 ! and lat. of each gridpoint
> xi=int((xlon-xlon0lu)/dxlu)+1
> yj=int((ylat-ylat0lu)/dxlu)+1
> if (xi.gt.lumaxx) xi=xi-lumaxx
> if (yj.gt.lumaxy) yj=yj-lumaxy
> if (xi.lt.0) then
> write (*,*) 'problem with landuseinv sampling: ', &
> xlon,xlon0lu,ix,iix,xlon0,dx,nxmax
> stop
> endif
> do k=1,numclass
> xlanduse(ix,jy,k)= &
> xlanduse(ix,jy,k)+xlandusep(int(xi),int(yj),k)
> sumperc=sumperc+xlanduse(ix,jy,k) ! just for the check if landuseinv. is available
> end do
> end do
> end do
> if (sumperc.gt.0) then ! detailed landuse available
> sumperc=0.
> do k=1,numclass
> xlanduse(ix,jy,k)= &
> xlanduse(ix,jy,k)/real(nrefine*nrefine)
> sumperc=sumperc+xlanduse(ix,jy,k)
> end do
> !cc the sum of all categories should be 1 ... 100 percent ... in order to get vdep right!
> if (sumperc.lt.1-1E-5) then
> do k=1,numclass
> xlanduse(ix,jy,k)= &
> xlanduse(ix,jy,k)/sumperc
> end do
> endif
> else
> if (lsm(ix,jy).lt.0.1) then ! over sea -> ocean
> xlanduse(ix,jy,3)=1.
> else ! over land -> rangeland
> xlanduse(ix,jy,7)=1.
> endif
> endif
>
>
> end do
> end do
>
> !***********************************
> ! for test: write out xlanduse
>
> ! open(4,file='landusetest',form='formatted')
> ! do 56 k=1,13
> ! do 55 ix=0,nxmin1
> !55 write (4,*) (xlanduse(ix,jy,k),jy=0,nymin1)
> !56 continue
> ! close(4)
> ! write (*,*) 'landuse written'
> !stop
> ! open(4,file='landseatest'//ck,form='formatted')
> ! do 57 ix=0,nxmin1
> !57 write (4,*) (lsm(ix,jy),jy=0,nymin1)
> ! write (*,*) 'landseamask written'
>
> !****************************************
> ! Same as above, but for the nested grids
> !****************************************
>
> !************** TEST ********************
> ! dyn(1)=dyn(1)/40
> ! dxn(1)=dxn(1)/40
> ! xlon0n(1)=1
> ! ylat0n(1)=50
> !************** TEST ********************
>
> do l=1,numbnests
> do ix=0,nxn(l)-1
> do jy=0,nyn(l)-1
> do k=1,numclass
> sumperc=0.
> xlandusen(ix,jy,k,l)=0.
> end do
> do iix=1, nrefine
> xlon=(ix+(iix-1)/real(nrefine))*dxn(l)+xlon0n(l)
> do jjy=1, nrefine
> ylat=(jy+(jjy-1)/real(nrefine))*dyn(l)+ylat0n(l)
> xi=int((xlon-xlon0lu)/dxlu)+1
> yj=int((ylat-ylat0lu)/dxlu)+1
> if (xi.gt.lumaxx) xi=xi-lumaxx
> if (yj.gt.lumaxy) yj=yj-lumaxy
> do k=1,numclass
> xlandusen(ix,jy,k,l)=xlandusen(ix,jy,k,l)+ &
> xlandusep(int(xi),int(yj),k)
> sumperc=sumperc+xlandusen(ix,jy,k,l)
> end do
> end do
> end do
> if (sumperc.gt.0) then ! detailed landuse available
> sumperc=0.
> do k=1,numclass
> xlandusen(ix,jy,k,l)= &
> xlandusen(ix,jy,k,l)/real(nrefine*nrefine)
> sumperc=sumperc+xlandusen(ix,jy,k,l)
> end do
> !cc the sum of all categories should be 1 ... 100 percent ... in order to get vdep right!
> if (sumperc.lt.1-1E-5) then
> do k=1,numclass
> xlandusen(ix,jy,k,l)=xlandusen(ix,jy,k,l)/sumperc
> end do
> endif
> else ! check land/sea mask
> if (lsmn(ix,jy,l).lt.0.1) then ! over sea -> ocean
> xlandusen(ix,jy,3,l)=1.
> else ! over land -> grasslands
> xlandusen(ix,jy,7,l)=1.
> endif
> endif
> end do
> end do
> end do
>
> !***********************************
> ! for test: write out xlanduse
>
> ! do 66 k=1,11
> ! write (ck,'(i2.2)') k
> ! open(4,file='nlandusetest'//ck,form='formatted')
> ! do 65 ix=0,nxn(1)-1
> !65 write (4,*) (xlandusen(ix,jy,k,1),jy=0,nyn(1)-1)
> !66 close(4)
>
> ! write (*,*) 'landuse nested written'
>
>
> end subroutine assignland
boundcond_domainfill.f90
----------------------------------------------
1,588c1,589
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine boundcond_domainfill(itime,loutend)
< ! i i
< !*****************************************************************************
< ! *
< ! Particles are created by this subroutine continuously throughout the *
< ! simulation at the boundaries of the domain-filling box. *
< ! All particles carry the same amount of mass which alltogether comprises the*
< ! mass of air within the box, which remains (more or less) constant. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 October 2002 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! nx_we(2) grid indices for western and eastern boundary of domain- *
< ! filling trajectory calculations *
< ! ny_sn(2) grid indices for southern and northern boundary of domain- *
< ! filling trajectory calculations *
< ! *
< !*****************************************************************************
<
< use point_mod
< use par_mod
< use com_mod
<
< implicit none
<
< real :: dz,dz1,dz2,ran1,dt1,dt2,dtt,ylat,xm,cosfact,accmasst
< integer :: itime,in,indz,indzp,i,loutend
< integer :: j,k,ix,jy,m,indzh,indexh,minpart,ipart,mmass
< integer :: numactiveparticles
<
< real :: windl(2),rhol(2)
< real :: windhl(2),rhohl(2)
< real :: windx,rhox
< real :: deltaz,boundarea,fluxofmass
<
< integer :: ixm,ixp,jym,jyp,indzm,mm
< real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2),yh1(2)
<
< integer :: idummy = -11
<
<
< ! If domain-filling is global, no boundary conditions are needed
< !***************************************************************
<
< if (gdomainfill) return
<
< accmasst=0.
< numactiveparticles=0
<
< ! Terminate trajectories that have left the domain, if domain-filling
< ! trajectory calculation domain is not global
< !********************************************************************
<
< do i=1,numpart
< if (itra1(i).eq.itime) then
< if ((ytra1(i).gt.real(ny_sn(2))).or. &
< (ytra1(i).lt.real(ny_sn(1)))) itra1(i)=-999999999
< if (((.not.xglobal).or.(nx_we(2).ne.(nx-2))).and. &
< ((xtra1(i).lt.real(nx_we(1))).or. &
< (xtra1(i).gt.real(nx_we(2))))) itra1(i)=-999999999
< endif
< if (itra1(i).ne.-999999999) numactiveparticles= &
< numactiveparticles+1
< end do
<
<
< ! Determine auxiliary variables for time interpolation
< !*****************************************************
<
< dt1=real(itime-memtime(1))
< dt2=real(memtime(2)-itime)
< dtt=1./(dt1+dt2)
<
< ! Initialize auxiliary variable used to search for vacant storage space
< !**********************************************************************
<
< minpart=1
<
< !***************************************
< ! Western and eastern boundary condition
< !***************************************
<
< ! Loop from south to north
< !*************************
<
< do jy=ny_sn(1),ny_sn(2)
<
< ! Loop over western (index 1) and eastern (index 2) boundary
< !***********************************************************
<
< do k=1,2
<
< ! Loop over all release locations in a column
< !********************************************
<
< do j=1,numcolumn_we(k,jy)
<
< ! Determine, for each release location, the area of the corresponding boundary
< !*****************************************************************************
<
< if (j.eq.1) then
< deltaz=(zcolumn_we(k,jy,2)+zcolumn_we(k,jy,1))/2.
< else if (j.eq.numcolumn_we(k,jy)) then
< ! deltaz=height(nz)-(zcolumn_we(k,jy,j-1)+
< ! + zcolumn_we(k,jy,j))/2.
< ! In order to avoid taking a very high column for very many particles,
< ! use the deltaz from one particle below instead
< deltaz=(zcolumn_we(k,jy,j)-zcolumn_we(k,jy,j-2))/2.
< else
< deltaz=(zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))/2.
< endif
< if ((jy.eq.ny_sn(1)).or.(jy.eq.ny_sn(2))) then
< boundarea=deltaz*111198.5/2.*dy
< else
< boundarea=deltaz*111198.5*dy
< endif
<
<
< ! Interpolate the wind velocity and density to the release location
< !******************************************************************
<
< ! Determine the model level below the release position
< !*****************************************************
<
< do i=2,nz
< if (height(i).gt.zcolumn_we(k,jy,j)) then
< indz=i-1
< indzp=i
< goto 6
< endif
< end do
< 6 continue
<
< ! Vertical distance to the level below and above current position
< !****************************************************************
<
< dz1=zcolumn_we(k,jy,j)-height(indz)
< dz2=height(indzp)-zcolumn_we(k,jy,j)
< dz=1./(dz1+dz2)
<
< ! Vertical and temporal interpolation
< !************************************
<
< do m=1,2
< indexh=memind(m)
< do in=1,2
< indzh=indz+in-1
< windl(in)=uu(nx_we(k),jy,indzh,indexh)
< rhol(in)=rho(nx_we(k),jy,indzh,indexh)
< end do
<
< windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
< rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
< end do
<
< windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
< rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
<
< ! Calculate mass flux
< !********************
<
< fluxofmass=windx*rhox*boundarea*real(lsynctime)
<
<
< ! If the mass flux is directed into the domain, add it to previous mass fluxes;
< ! if it is out of the domain, set accumulated mass flux to zero
< !******************************************************************************
<
< if (k.eq.1) then
< if (fluxofmass.ge.0.) then
< acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+fluxofmass
< else
< acc_mass_we(k,jy,j)=0.
< endif
< else
< if (fluxofmass.le.0.) then
< acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+abs(fluxofmass)
< else
< acc_mass_we(k,jy,j)=0.
< endif
< endif
< accmasst=accmasst+acc_mass_we(k,jy,j)
<
< ! If the accumulated mass exceeds half the mass that each particle shall carry,
< ! one (or more) particle(s) is (are) released and the accumulated mass is
< ! reduced by the mass of this (these) particle(s)
< !******************************************************************************
<
< if (acc_mass_we(k,jy,j).ge.xmassperparticle/2.) then
< mmass=int((acc_mass_we(k,jy,j)+xmassperparticle/2.)/ &
< xmassperparticle)
< acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)- &
< real(mmass)*xmassperparticle
< else
< mmass=0
< endif
<
< do m=1,mmass
< do ipart=minpart,maxpart
<
< ! If a vacant storage space is found, attribute everything to this array element
< !*****************************************************************************
<
< if (itra1(ipart).ne.itime) then
<
< ! Assign particle positions
< !**************************
<
< xtra1(ipart)=real(nx_we(k))
< if (jy.eq.ny_sn(1)) then
< ytra1(ipart)=real(jy)+0.5*ran1(idummy)
< else if (jy.eq.ny_sn(2)) then
< ytra1(ipart)=real(jy)-0.5*ran1(idummy)
< else
< ytra1(ipart)=real(jy)+(ran1(idummy)-.5)
< endif
< if (j.eq.1) then
< ztra1(ipart)=zcolumn_we(k,jy,1)+(zcolumn_we(k,jy,2)- &
< zcolumn_we(k,jy,1))/4.
< else if (j.eq.numcolumn_we(k,jy)) then
< ztra1(ipart)=(2.*zcolumn_we(k,jy,j)+ &
< zcolumn_we(k,jy,j-1)+height(nz))/4.
< else
< ztra1(ipart)=zcolumn_we(k,jy,j-1)+ran1(idummy)* &
< (zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))
< endif
<
< ! Interpolate PV to the particle position
< !****************************************
< ixm=int(xtra1(ipart))
< jym=int(ytra1(ipart))
< ixp=ixm+1
< jyp=jym+1
< ddx=xtra1(ipart)-real(ixm)
< ddy=ytra1(ipart)-real(jym)
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
< do i=2,nz
< if (height(i).gt.ztra1(ipart)) then
< indzm=i-1
< indzp=i
< goto 26
< endif
< end do
< 26 continue
< dz1=ztra1(ipart)-height(indzm)
< dz2=height(indzp)-ztra1(ipart)
< dz=1./(dz1+dz2)
< do mm=1,2
< indexh=memind(mm)
< do in=1,2
< indzh=indzm+in-1
< y1(in)=p1*pv(ixm,jym,indzh,indexh) &
< +p2*pv(ixp,jym,indzh,indexh) &
< +p3*pv(ixm,jyp,indzh,indexh) &
< +p4*pv(ixp,jyp,indzh,indexh)
< end do
< yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
< end do
< pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
< ylat=ylat0+ytra1(ipart)*dy
< if (ylat.lt.0.) pvpart=-1.*pvpart
<
<
< ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
< !*****************************************************************************
<
< if (((ztra1(ipart).gt.3000.).and. &
< (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
< nclass(ipart)=min(int(ran1(idummy)* &
< real(nclassunc))+1,nclassunc)
< numactiveparticles=numactiveparticles+1
< numparticlecount=numparticlecount+1
< npoint(ipart)=numparticlecount
< idt(ipart)=mintime
< itra1(ipart)=itime
< itramem(ipart)=itra1(ipart)
< itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
< xmass1(ipart,1)=xmassperparticle
< if (mdomainfill.eq.2) xmass1(ipart,1)= &
< xmass1(ipart,1)*pvpart*48./29.*ozonescale/10.**9
< else
< goto 71
< endif
<
<
< ! Increase numpart, if necessary
< !*******************************
<
< numpart=max(numpart,ipart)
< goto 73 ! Storage space has been found, stop searching
< endif
< end do
< if (ipart.gt.maxpart) &
< stop 'boundcond_domainfill.f: too many particles required'
< 73 minpart=ipart+1
< 71 continue
< end do
<
<
< end do
< end do
< end do
<
<
< !*****************************************
< ! Southern and northern boundary condition
< !*****************************************
<
< ! Loop from west to east
< !***********************
<
< do ix=nx_we(1),nx_we(2)
<
< ! Loop over southern (index 1) and northern (index 2) boundary
< !*************************************************************
<
< do k=1,2
< ylat=ylat0+real(ny_sn(k))*dy
< cosfact=cos(ylat*pi180)
<
< ! Loop over all release locations in a column
< !********************************************
<
< do j=1,numcolumn_sn(k,ix)
<
< ! Determine, for each release location, the area of the corresponding boundary
< !*****************************************************************************
<
< if (j.eq.1) then
< deltaz=(zcolumn_sn(k,ix,2)+zcolumn_sn(k,ix,1))/2.
< else if (j.eq.numcolumn_sn(k,ix)) then
< ! deltaz=height(nz)-(zcolumn_sn(k,ix,j-1)+
< ! + zcolumn_sn(k,ix,j))/2.
< ! In order to avoid taking a very high column for very many particles,
< ! use the deltaz from one particle below instead
< deltaz=(zcolumn_sn(k,ix,j)-zcolumn_sn(k,ix,j-2))/2.
< else
< deltaz=(zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))/2.
< endif
< if ((ix.eq.nx_we(1)).or.(ix.eq.nx_we(2))) then
< boundarea=deltaz*111198.5/2.*cosfact*dx
< else
< boundarea=deltaz*111198.5*cosfact*dx
< endif
<
<
< ! Interpolate the wind velocity and density to the release location
< !******************************************************************
<
< ! Determine the model level below the release position
< !*****************************************************
<
< do i=2,nz
< if (height(i).gt.zcolumn_sn(k,ix,j)) then
< indz=i-1
< indzp=i
< goto 16
< endif
< end do
< 16 continue
<
< ! Vertical distance to the level below and above current position
< !****************************************************************
<
< dz1=zcolumn_sn(k,ix,j)-height(indz)
< dz2=height(indzp)-zcolumn_sn(k,ix,j)
< dz=1./(dz1+dz2)
<
< ! Vertical and temporal interpolation
< !************************************
<
< do m=1,2
< indexh=memind(m)
< do in=1,2
< indzh=indz+in-1
< windl(in)=vv(ix,ny_sn(k),indzh,indexh)
< rhol(in)=rho(ix,ny_sn(k),indzh,indexh)
< end do
<
< windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
< rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
< end do
<
< windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
< rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
<
< ! Calculate mass flux
< !********************
<
< fluxofmass=windx*rhox*boundarea*real(lsynctime)
<
< ! If the mass flux is directed into the domain, add it to previous mass fluxes;
< ! if it is out of the domain, set accumulated mass flux to zero
< !******************************************************************************
<
< if (k.eq.1) then
< if (fluxofmass.ge.0.) then
< acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+fluxofmass
< else
< acc_mass_sn(k,ix,j)=0.
< endif
< else
< if (fluxofmass.le.0.) then
< acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+abs(fluxofmass)
< else
< acc_mass_sn(k,ix,j)=0.
< endif
< endif
< accmasst=accmasst+acc_mass_sn(k,ix,j)
<
< ! If the accumulated mass exceeds half the mass that each particle shall carry,
< ! one (or more) particle(s) is (are) released and the accumulated mass is
< ! reduced by the mass of this (these) particle(s)
< !******************************************************************************
<
< if (acc_mass_sn(k,ix,j).ge.xmassperparticle/2.) then
< mmass=int((acc_mass_sn(k,ix,j)+xmassperparticle/2.)/ &
< xmassperparticle)
< acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)- &
< real(mmass)*xmassperparticle
< else
< mmass=0
< endif
<
< do m=1,mmass
< do ipart=minpart,maxpart
<
< ! If a vacant storage space is found, attribute everything to this array element
< !*****************************************************************************
<
< if (itra1(ipart).ne.itime) then
<
< ! Assign particle positions
< !**************************
<
< ytra1(ipart)=real(ny_sn(k))
< if (ix.eq.nx_we(1)) then
< xtra1(ipart)=real(ix)+0.5*ran1(idummy)
< else if (ix.eq.nx_we(2)) then
< xtra1(ipart)=real(ix)-0.5*ran1(idummy)
< else
< xtra1(ipart)=real(ix)+(ran1(idummy)-.5)
< endif
< if (j.eq.1) then
< ztra1(ipart)=zcolumn_sn(k,ix,1)+(zcolumn_sn(k,ix,2)- &
< zcolumn_sn(k,ix,1))/4.
< else if (j.eq.numcolumn_sn(k,ix)) then
< ztra1(ipart)=(2.*zcolumn_sn(k,ix,j)+ &
< zcolumn_sn(k,ix,j-1)+height(nz))/4.
< else
< ztra1(ipart)=zcolumn_sn(k,ix,j-1)+ran1(idummy)* &
< (zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))
< endif
<
<
< ! Interpolate PV to the particle position
< !****************************************
< ixm=int(xtra1(ipart))
< jym=int(ytra1(ipart))
< ixp=ixm+1
< jyp=jym+1
< ddx=xtra1(ipart)-real(ixm)
< ddy=ytra1(ipart)-real(jym)
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
< do i=2,nz
< if (height(i).gt.ztra1(ipart)) then
< indzm=i-1
< indzp=i
< goto 126
< endif
< end do
< 126 continue
< dz1=ztra1(ipart)-height(indzm)
< dz2=height(indzp)-ztra1(ipart)
< dz=1./(dz1+dz2)
< do mm=1,2
< indexh=memind(mm)
< do in=1,2
< indzh=indzm+in-1
< y1(in)=p1*pv(ixm,jym,indzh,indexh) &
< +p2*pv(ixp,jym,indzh,indexh) &
< +p3*pv(ixm,jyp,indzh,indexh) &
< +p4*pv(ixp,jyp,indzh,indexh)
< end do
< yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
< end do
< pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
< if (ylat.lt.0.) pvpart=-1.*pvpart
<
<
< ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
< !*****************************************************************************
<
< if (((ztra1(ipart).gt.3000.).and. &
< (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
< nclass(ipart)=min(int(ran1(idummy)* &
< real(nclassunc))+1,nclassunc)
< numactiveparticles=numactiveparticles+1
< numparticlecount=numparticlecount+1
< npoint(ipart)=numparticlecount
< idt(ipart)=mintime
< itra1(ipart)=itime
< itramem(ipart)=itra1(ipart)
< itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
< xmass1(ipart,1)=xmassperparticle
< if (mdomainfill.eq.2) xmass1(ipart,1)= &
< xmass1(ipart,1)*pvpart*48./29.*ozonescale/10.**9
< else
< goto 171
< endif
<
<
< ! Increase numpart, if necessary
< !*******************************
< numpart=max(numpart,ipart)
< goto 173 ! Storage space has been found, stop searching
< endif
< end do
< if (ipart.gt.maxpart) &
< stop 'boundcond_domainfill.f: too many particles required'
< 173 minpart=ipart+1
< 171 continue
< end do
<
<
< end do
< end do
< end do
<
<
< xm=0.
< do i=1,numpart
< if (itra1(i).eq.itime) xm=xm+xmass1(i,1)
< end do
<
< !write(*,*) itime,numactiveparticles,numparticlecount,numpart,
< ! +xm,accmasst,xm+accmasst
<
<
< ! If particles shall be dumped, then accumulated masses at the domain boundaries
< ! must be dumped, too, to be used for later runs
< !*****************************************************************************
<
< if ((ipout.gt.0).and.(itime.eq.loutend)) then
< open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
< form='unformatted')
< write(unitboundcond) numcolumn_we,numcolumn_sn, &
< zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
< close(unitboundcond)
< endif
<
< end subroutine boundcond_domainfill
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine boundcond_domainfill(itime,loutend)
> ! i i
> !*****************************************************************************
> ! *
> ! Particles are created by this subroutine continuously throughout the *
> ! simulation at the boundaries of the domain-filling box. *
> ! All particles carry the same amount of mass which alltogether comprises the*
> ! mass of air within the box, which remains (more or less) constant. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 October 2002 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! nx_we(2) grid indices for western and eastern boundary of domain- *
> ! filling trajectory calculations *
> ! ny_sn(2) grid indices for southern and northern boundary of domain- *
> ! filling trajectory calculations *
> ! *
> !*****************************************************************************
>
> use point_mod
> use par_mod
> use com_mod
> use random_mod, only: ran1
>
> implicit none
>
> real :: dz,dz1,dz2,dt1,dt2,dtt,ylat,xm,cosfact,accmasst
> integer :: itime,in,indz,indzp,i,loutend
> integer :: j,k,ix,jy,m,indzh,indexh,minpart,ipart,mmass
> integer :: numactiveparticles
>
> real :: windl(2),rhol(2)
> real :: windhl(2),rhohl(2)
> real :: windx,rhox
> real :: deltaz,boundarea,fluxofmass
>
> integer :: ixm,ixp,jym,jyp,indzm,mm
> real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2),yh1(2)
>
> integer :: idummy = -11
>
>
> ! If domain-filling is global, no boundary conditions are needed
> !***************************************************************
>
> if (gdomainfill) return
>
> accmasst=0.
> numactiveparticles=0
>
> ! Terminate trajectories that have left the domain, if domain-filling
> ! trajectory calculation domain is not global
> !********************************************************************
>
> do i=1,numpart
> if (itra1(i).eq.itime) then
> if ((ytra1(i).gt.real(ny_sn(2))).or. &
> (ytra1(i).lt.real(ny_sn(1)))) itra1(i)=-999999999
> if (((.not.xglobal).or.(nx_we(2).ne.(nx-2))).and. &
> ((xtra1(i).lt.real(nx_we(1))).or. &
> (xtra1(i).gt.real(nx_we(2))))) itra1(i)=-999999999
> endif
> if (itra1(i).ne.-999999999) numactiveparticles= &
> numactiveparticles+1
> end do
>
>
> ! Determine auxiliary variables for time interpolation
> !*****************************************************
>
> dt1=real(itime-memtime(1))
> dt2=real(memtime(2)-itime)
> dtt=1./(dt1+dt2)
>
> ! Initialize auxiliary variable used to search for vacant storage space
> !**********************************************************************
>
> minpart=1
>
> !***************************************
> ! Western and eastern boundary condition
> !***************************************
>
> ! Loop from south to north
> !*************************
>
> do jy=ny_sn(1),ny_sn(2)
>
> ! Loop over western (index 1) and eastern (index 2) boundary
> !***********************************************************
>
> do k=1,2
>
> ! Loop over all release locations in a column
> !********************************************
>
> do j=1,numcolumn_we(k,jy)
>
> ! Determine, for each release location, the area of the corresponding boundary
> !*****************************************************************************
>
> if (j.eq.1) then
> deltaz=(zcolumn_we(k,jy,2)+zcolumn_we(k,jy,1))/2.
> else if (j.eq.numcolumn_we(k,jy)) then
> ! deltaz=height(nz)-(zcolumn_we(k,jy,j-1)+
> ! + zcolumn_we(k,jy,j))/2.
> ! In order to avoid taking a very high column for very many particles,
> ! use the deltaz from one particle below instead
> deltaz=(zcolumn_we(k,jy,j)-zcolumn_we(k,jy,j-2))/2.
> else
> deltaz=(zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))/2.
> endif
> if ((jy.eq.ny_sn(1)).or.(jy.eq.ny_sn(2))) then
> boundarea=deltaz*111198.5/2.*dy
> else
> boundarea=deltaz*111198.5*dy
> endif
>
>
> ! Interpolate the wind velocity and density to the release location
> !******************************************************************
>
> ! Determine the model level below the release position
> !*****************************************************
>
> do i=2,nz
> if (height(i).gt.zcolumn_we(k,jy,j)) then
> indz=i-1
> indzp=i
> goto 6
> endif
> end do
> 6 continue
>
> ! Vertical distance to the level below and above current position
> !****************************************************************
>
> dz1=zcolumn_we(k,jy,j)-height(indz)
> dz2=height(indzp)-zcolumn_we(k,jy,j)
> dz=1./(dz1+dz2)
>
> ! Vertical and temporal interpolation
> !************************************
>
> do m=1,2
> indexh=memind(m)
> do in=1,2
> indzh=indz+in-1
> windl(in)=uu(nx_we(k),jy,indzh,indexh)
> rhol(in)=rho(nx_we(k),jy,indzh,indexh)
> end do
>
> windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
> rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
> end do
>
> windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
> rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
>
> ! Calculate mass flux
> !********************
>
> fluxofmass=windx*rhox*boundarea*real(lsynctime)
>
>
> ! If the mass flux is directed into the domain, add it to previous mass fluxes;
> ! if it is out of the domain, set accumulated mass flux to zero
> !******************************************************************************
>
> if (k.eq.1) then
> if (fluxofmass.ge.0.) then
> acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+fluxofmass
> else
> acc_mass_we(k,jy,j)=0.
> endif
> else
> if (fluxofmass.le.0.) then
> acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)+abs(fluxofmass)
> else
> acc_mass_we(k,jy,j)=0.
> endif
> endif
> accmasst=accmasst+acc_mass_we(k,jy,j)
>
> ! If the accumulated mass exceeds half the mass that each particle shall carry,
> ! one (or more) particle(s) is (are) released and the accumulated mass is
> ! reduced by the mass of this (these) particle(s)
> !******************************************************************************
>
> if (acc_mass_we(k,jy,j).ge.xmassperparticle/2.) then
> mmass=int((acc_mass_we(k,jy,j)+xmassperparticle/2.)/ &
> xmassperparticle)
> acc_mass_we(k,jy,j)=acc_mass_we(k,jy,j)- &
> real(mmass)*xmassperparticle
> else
> mmass=0
> endif
>
> do m=1,mmass
> do ipart=minpart,maxpart
>
> ! If a vacant storage space is found, attribute everything to this array element
> !*****************************************************************************
>
> if (itra1(ipart).ne.itime) then
>
> ! Assign particle positions
> !**************************
>
> xtra1(ipart)=real(nx_we(k))
> if (jy.eq.ny_sn(1)) then
> ytra1(ipart)=real(jy)+0.5*ran1(idummy)
> else if (jy.eq.ny_sn(2)) then
> ytra1(ipart)=real(jy)-0.5*ran1(idummy)
> else
> ytra1(ipart)=real(jy)+(ran1(idummy)-.5)
> endif
> if (j.eq.1) then
> ztra1(ipart)=zcolumn_we(k,jy,1)+(zcolumn_we(k,jy,2)- &
> zcolumn_we(k,jy,1))/4.
> else if (j.eq.numcolumn_we(k,jy)) then
> ztra1(ipart)=(2.*zcolumn_we(k,jy,j)+ &
> zcolumn_we(k,jy,j-1)+height(nz))/4.
> else
> ztra1(ipart)=zcolumn_we(k,jy,j-1)+ran1(idummy)* &
> (zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))
> endif
>
> ! Interpolate PV to the particle position
> !****************************************
> ixm=int(xtra1(ipart))
> jym=int(ytra1(ipart))
> ixp=ixm+1
> jyp=jym+1
> ddx=xtra1(ipart)-real(ixm)
> ddy=ytra1(ipart)-real(jym)
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
> do i=2,nz
> if (height(i).gt.ztra1(ipart)) then
> indzm=i-1
> indzp=i
> goto 26
> endif
> end do
> 26 continue
> dz1=ztra1(ipart)-height(indzm)
> dz2=height(indzp)-ztra1(ipart)
> dz=1./(dz1+dz2)
> do mm=1,2
> indexh=memind(mm)
> do in=1,2
> indzh=indzm+in-1
> y1(in)=p1*pv(ixm,jym,indzh,indexh) &
> +p2*pv(ixp,jym,indzh,indexh) &
> +p3*pv(ixm,jyp,indzh,indexh) &
> +p4*pv(ixp,jyp,indzh,indexh)
> end do
> yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
> end do
> pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
> ylat=ylat0+ytra1(ipart)*dy
> if (ylat.lt.0.) pvpart=-1.*pvpart
>
>
> ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
> !*****************************************************************************
>
> if (((ztra1(ipart).gt.3000.).and. &
> (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
> nclass(ipart)=min(int(ran1(idummy)* &
> real(nclassunc))+1,nclassunc)
> numactiveparticles=numactiveparticles+1
> numparticlecount=numparticlecount+1
> npoint(ipart)=numparticlecount
> idt(ipart)=mintime
> itra1(ipart)=itime
> itramem(ipart)=itra1(ipart)
> itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
> xmass1(ipart,1)=xmassperparticle
> if (mdomainfill.eq.2) xmass1(ipart,1)= &
> xmass1(ipart,1)*pvpart*48./29.*ozonescale/10.**9
> else
> goto 71
> endif
>
>
> ! Increase numpart, if necessary
> !*******************************
>
> numpart=max(numpart,ipart)
> goto 73 ! Storage space has been found, stop searching
> endif
> end do
> if (ipart.gt.maxpart) &
> stop 'boundcond_domainfill.f: too many particles required'
> 73 minpart=ipart+1
> 71 continue
> end do
>
>
> end do
> end do
> end do
>
>
> !*****************************************
> ! Southern and northern boundary condition
> !*****************************************
>
> ! Loop from west to east
> !***********************
>
> do ix=nx_we(1),nx_we(2)
>
> ! Loop over southern (index 1) and northern (index 2) boundary
> !*************************************************************
>
> do k=1,2
> ylat=ylat0+real(ny_sn(k))*dy
> cosfact=cos(ylat*pi180)
>
> ! Loop over all release locations in a column
> !********************************************
>
> do j=1,numcolumn_sn(k,ix)
>
> ! Determine, for each release location, the area of the corresponding boundary
> !*****************************************************************************
>
> if (j.eq.1) then
> deltaz=(zcolumn_sn(k,ix,2)+zcolumn_sn(k,ix,1))/2.
> else if (j.eq.numcolumn_sn(k,ix)) then
> ! deltaz=height(nz)-(zcolumn_sn(k,ix,j-1)+
> ! + zcolumn_sn(k,ix,j))/2.
> ! In order to avoid taking a very high column for very many particles,
> ! use the deltaz from one particle below instead
> deltaz=(zcolumn_sn(k,ix,j)-zcolumn_sn(k,ix,j-2))/2.
> else
> deltaz=(zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))/2.
> endif
> if ((ix.eq.nx_we(1)).or.(ix.eq.nx_we(2))) then
> boundarea=deltaz*111198.5/2.*cosfact*dx
> else
> boundarea=deltaz*111198.5*cosfact*dx
> endif
>
>
> ! Interpolate the wind velocity and density to the release location
> !******************************************************************
>
> ! Determine the model level below the release position
> !*****************************************************
>
> do i=2,nz
> if (height(i).gt.zcolumn_sn(k,ix,j)) then
> indz=i-1
> indzp=i
> goto 16
> endif
> end do
> 16 continue
>
> ! Vertical distance to the level below and above current position
> !****************************************************************
>
> dz1=zcolumn_sn(k,ix,j)-height(indz)
> dz2=height(indzp)-zcolumn_sn(k,ix,j)
> dz=1./(dz1+dz2)
>
> ! Vertical and temporal interpolation
> !************************************
>
> do m=1,2
> indexh=memind(m)
> do in=1,2
> indzh=indz+in-1
> windl(in)=vv(ix,ny_sn(k),indzh,indexh)
> rhol(in)=rho(ix,ny_sn(k),indzh,indexh)
> end do
>
> windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz
> rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz
> end do
>
> windx=(windhl(1)*dt2+windhl(2)*dt1)*dtt
> rhox=(rhohl(1)*dt2+rhohl(2)*dt1)*dtt
>
> ! Calculate mass flux
> !********************
>
> fluxofmass=windx*rhox*boundarea*real(lsynctime)
>
> ! If the mass flux is directed into the domain, add it to previous mass fluxes;
> ! if it is out of the domain, set accumulated mass flux to zero
> !******************************************************************************
>
> if (k.eq.1) then
> if (fluxofmass.ge.0.) then
> acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+fluxofmass
> else
> acc_mass_sn(k,ix,j)=0.
> endif
> else
> if (fluxofmass.le.0.) then
> acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)+abs(fluxofmass)
> else
> acc_mass_sn(k,ix,j)=0.
> endif
> endif
> accmasst=accmasst+acc_mass_sn(k,ix,j)
>
> ! If the accumulated mass exceeds half the mass that each particle shall carry,
> ! one (or more) particle(s) is (are) released and the accumulated mass is
> ! reduced by the mass of this (these) particle(s)
> !******************************************************************************
>
> if (acc_mass_sn(k,ix,j).ge.xmassperparticle/2.) then
> mmass=int((acc_mass_sn(k,ix,j)+xmassperparticle/2.)/ &
> xmassperparticle)
> acc_mass_sn(k,ix,j)=acc_mass_sn(k,ix,j)- &
> real(mmass)*xmassperparticle
> else
> mmass=0
> endif
>
> do m=1,mmass
> do ipart=minpart,maxpart
>
> ! If a vacant storage space is found, attribute everything to this array element
> !*****************************************************************************
>
> if (itra1(ipart).ne.itime) then
>
> ! Assign particle positions
> !**************************
>
> ytra1(ipart)=real(ny_sn(k))
> if (ix.eq.nx_we(1)) then
> xtra1(ipart)=real(ix)+0.5*ran1(idummy)
> else if (ix.eq.nx_we(2)) then
> xtra1(ipart)=real(ix)-0.5*ran1(idummy)
> else
> xtra1(ipart)=real(ix)+(ran1(idummy)-.5)
> endif
> if (j.eq.1) then
> ztra1(ipart)=zcolumn_sn(k,ix,1)+(zcolumn_sn(k,ix,2)- &
> zcolumn_sn(k,ix,1))/4.
> else if (j.eq.numcolumn_sn(k,ix)) then
> ztra1(ipart)=(2.*zcolumn_sn(k,ix,j)+ &
> zcolumn_sn(k,ix,j-1)+height(nz))/4.
> else
> ztra1(ipart)=zcolumn_sn(k,ix,j-1)+ran1(idummy)* &
> (zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))
> endif
>
>
> ! Interpolate PV to the particle position
> !****************************************
> ixm=int(xtra1(ipart))
> jym=int(ytra1(ipart))
> ixp=ixm+1
> jyp=jym+1
> ddx=xtra1(ipart)-real(ixm)
> ddy=ytra1(ipart)-real(jym)
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
> do i=2,nz
> if (height(i).gt.ztra1(ipart)) then
> indzm=i-1
> indzp=i
> goto 126
> endif
> end do
> 126 continue
> dz1=ztra1(ipart)-height(indzm)
> dz2=height(indzp)-ztra1(ipart)
> dz=1./(dz1+dz2)
> do mm=1,2
> indexh=memind(mm)
> do in=1,2
> indzh=indzm+in-1
> y1(in)=p1*pv(ixm,jym,indzh,indexh) &
> +p2*pv(ixp,jym,indzh,indexh) &
> +p3*pv(ixm,jyp,indzh,indexh) &
> +p4*pv(ixp,jyp,indzh,indexh)
> end do
> yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz
> end do
> pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt
> if (ylat.lt.0.) pvpart=-1.*pvpart
>
>
> ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
> !*****************************************************************************
>
> if (((ztra1(ipart).gt.3000.).and. &
> (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
> nclass(ipart)=min(int(ran1(idummy)* &
> real(nclassunc))+1,nclassunc)
> numactiveparticles=numactiveparticles+1
> numparticlecount=numparticlecount+1
> npoint(ipart)=numparticlecount
> idt(ipart)=mintime
> itra1(ipart)=itime
> itramem(ipart)=itra1(ipart)
> itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
> xmass1(ipart,1)=xmassperparticle
> if (mdomainfill.eq.2) xmass1(ipart,1)= &
> xmass1(ipart,1)*pvpart*48./29.*ozonescale/10.**9
> else
> goto 171
> endif
>
>
> ! Increase numpart, if necessary
> !*******************************
> numpart=max(numpart,ipart)
> goto 173 ! Storage space has been found, stop searching
> endif
> end do
> if (ipart.gt.maxpart) &
> stop 'boundcond_domainfill.f: too many particles required'
> 173 minpart=ipart+1
> 171 continue
> end do
>
>
> end do
> end do
> end do
>
>
> xm=0.
> do i=1,numpart
> if (itra1(i).eq.itime) xm=xm+xmass1(i,1)
> end do
>
> !write(*,*) itime,numactiveparticles,numparticlecount,numpart,
> ! +xm,accmasst,xm+accmasst
>
>
> ! If particles shall be dumped, then accumulated masses at the domain boundaries
> ! must be dumped, too, to be used for later runs
> !*****************************************************************************
>
> if ((ipout.gt.0).and.(itime.eq.loutend)) then
> open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
> form='unformatted')
> write(unitboundcond) numcolumn_we,numcolumn_sn, &
> zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
> close(unitboundcond)
> endif
>
> end subroutine boundcond_domainfill
calcfluxes.f90
----------------------------------------------
1,187c1,187
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine calcfluxes(nage,jpart,xold,yold,zold)
< ! i i i i i
< !*****************************************************************************
< ! *
< ! Calculation of the gross fluxes across horizontal, eastward and *
< ! northward facing surfaces. The routine calculates the mass flux *
< ! due to the motion of only one particle. The fluxes of subsequent calls *
< ! to this subroutine are accumulated until the next output is due. *
< ! Upon output, flux fields are re-set to zero in subroutine fluxoutput.f.*
< ! *
< ! Author: A. Stohl *
< ! *
< ! 04 April 2000 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! nage Age class of the particle considered *
< ! jpart Index of the particle considered *
< ! xold,yold,zold "Memorized" old positions of the particle *
< ! *
< !*****************************************************************************
<
< use flux_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: jpart,nage,ixave,jyave,kz,kzave,kp
< integer :: k,k1,k2,ix,ix1,ix2,ixs,jy,jy1,jy2
< real :: xold,yold,zold,xmean,ymean
<
<
< ! Determine average positions
< !****************************
<
< if ((ioutputforeachrelease.eq.1).and.(mdomainfill.eq.0)) then
< kp=npoint(jpart)
< else
< kp=1
< endif
<
< xmean=(xold+xtra1(jpart))/2.
< ymean=(yold+ytra1(jpart))/2.
<
< ixave=int((xmean*dx+xoutshift)/dxout)
< jyave=int((ymean*dy+youtshift)/dyout)
< do kz=1,numzgrid ! determine height of cell
< if (outheight(kz).gt.ztra1(jpart)) goto 16
< end do
< 16 kzave=kz
<
<
< ! Determine vertical fluxes
< !**************************
<
< if ((ixave.ge.0).and.(jyave.ge.0).and.(ixave.le.numxgrid-1).and. &
< (jyave.le.numygrid-1)) then
< do kz=1,numzgrid ! determine height of cell
< if (outheighthalf(kz).gt.zold) goto 11
< end do
< 11 k1=min(numzgrid,kz)
< do kz=1,numzgrid ! determine height of cell
< if (outheighthalf(kz).gt.ztra1(jpart)) goto 21
< end do
< 21 k2=min(numzgrid,kz)
<
< do k=1,nspec
< do kz=k1,k2-1
< flux(5,ixave,jyave,kz,k,kp,nage)= &
< flux(5,ixave,jyave,kz,k,kp,nage)+ &
< xmass1(jpart,k)
< end do
< do kz=k2,k1-1
< flux(6,ixave,jyave,kz,k,kp,nage)= &
< flux(6,ixave,jyave,kz,k,kp,nage)+ &
< xmass1(jpart,k)
< end do
< end do
< endif
<
<
< ! Determine west-east fluxes (fluxw) and east-west fluxes (fluxe)
< !****************************************************************
<
< if ((kzave.le.numzgrid).and.(jyave.ge.0).and. &
< (jyave.le.numygrid-1)) then
<
< ! 1) Particle does not cross domain boundary
<
< if (abs(xold-xtra1(jpart)).lt.real(nx)/2.) then
< ix1=int((xold*dx+xoutshift)/dxout+0.5)
< ix2=int((xtra1(jpart)*dx+xoutshift)/dxout+0.5)
< do k=1,nspec
< do ix=ix1,ix2-1
< if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
< flux(1,ix,jyave,kzave,k,kp,nage)= &
< flux(1,ix,jyave,kzave,k,kp,nage) &
< +xmass1(jpart,k)
< endif
< end do
< do ix=ix2,ix1-1
< if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
< flux(2,ix,jyave,kzave,k,kp,nage)= &
< flux(2,ix,jyave,kzave,k,kp,nage) &
< +xmass1(jpart,k)
< endif
< end do
< end do
<
< ! 2) Particle crosses domain boundary: use cyclic boundary condition
< ! and attribute flux to easternmost grid row only (approximation valid
< ! for relatively slow motions compared to output grid cell size)
<
< else
< ixs=int(((real(nxmin1)-1.e5)*dx+xoutshift)/dxout)
< if ((ixs.ge.0).and.(ixs.le.numxgrid-1)) then
< if (xold.gt.xtra1(jpart)) then ! west-east flux
< do k=1,nspec
< flux(1,ixs,jyave,kzave,k,kp,nage)= &
< flux(1,ixs,jyave,kzave,k,kp,nage) &
< +xmass1(jpart,k)
< end do
< else ! east-west flux
< do k=1,nspec
< flux(2,ixs,jyave,kzave,k,kp,nage)= &
< flux(2,ixs,jyave,kzave,k,kp,nage) &
< +xmass1(jpart,k)
< end do
< endif
< endif
< endif
< endif
<
<
< ! Determine south-north fluxes (fluxs) and north-south fluxes (fluxn)
< !********************************************************************
<
< if ((kzave.le.numzgrid).and.(ixave.ge.0).and. &
< (ixave.le.numxgrid-1)) then
< jy1=int((yold*dy+youtshift)/dyout+0.5)
< jy2=int((ytra1(jpart)*dy+youtshift)/dyout+0.5)
<
< do k=1,nspec
< do jy=jy1,jy2-1
< if ((jy.ge.0).and.(jy.le.numygrid-1)) then
< flux(3,ixave,jy,kzave,k,kp,nage)= &
< flux(3,ixave,jy,kzave,k,kp,nage) &
< +xmass1(jpart,k)
< endif
< end do
< do jy=jy2,jy1-1
< if ((jy.ge.0).and.(jy.le.numygrid-1)) then
< flux(4,ixave,jy,kzave,k,kp,nage)= &
< flux(4,ixave,jy,kzave,k,kp,nage) &
< +xmass1(jpart,k)
< endif
< end do
< end do
< endif
<
< end subroutine calcfluxes
<
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine calcfluxes(nage,jpart,xold,yold,zold)
> ! i i i i i
> !*****************************************************************************
> ! *
> ! Calculation of the gross fluxes across horizontal, eastward and *
> ! northward facing surfaces. The routine calculates the mass flux *
> ! due to the motion of only one particle. The fluxes of subsequent calls *
> ! to this subroutine are accumulated until the next output is due. *
> ! Upon output, flux fields are re-set to zero in subroutine fluxoutput.f.*
> ! *
> ! Author: A. Stohl *
> ! *
> ! 04 April 2000 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! nage Age class of the particle considered *
> ! jpart Index of the particle considered *
> ! xold,yold,zold "Memorized" old positions of the particle *
> ! *
> !*****************************************************************************
>
> use flux_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: jpart,nage,ixave,jyave,kz,kzave,kp
> integer :: k,k1,k2,ix,ix1,ix2,ixs,jy,jy1,jy2
> real :: xold,yold,zold,xmean,ymean
>
>
> ! Determine average positions
> !****************************
>
> if ((ioutputforeachrelease.eq.1).and.(mdomainfill.eq.0)) then
> kp=npoint(jpart)
> else
> kp=1
> endif
>
> xmean=(xold+xtra1(jpart))/2.
> ymean=(yold+ytra1(jpart))/2.
>
> ixave=int((xmean*dx+xoutshift)/dxout)
> jyave=int((ymean*dy+youtshift)/dyout)
> do kz=1,numzgrid ! determine height of cell
> if (outheight(kz).gt.ztra1(jpart)) goto 16
> end do
> 16 kzave=kz
>
>
> ! Determine vertical fluxes
> !**************************
>
> if ((ixave.ge.0).and.(jyave.ge.0).and.(ixave.le.numxgrid-1).and. &
> (jyave.le.numygrid-1)) then
> do kz=1,numzgrid ! determine height of cell
> if (outheighthalf(kz).gt.zold) goto 11
> end do
> 11 k1=min(numzgrid,kz)
> do kz=1,numzgrid ! determine height of cell
> if (outheighthalf(kz).gt.ztra1(jpart)) goto 21
> end do
> 21 k2=min(numzgrid,kz)
>
> do k=1,nspec
> do kz=k1,k2-1
> flux(5,ixave,jyave,kz,k,kp,nage)= &
> flux(5,ixave,jyave,kz,k,kp,nage)+ &
> xmass1(jpart,k)
> end do
> do kz=k2,k1-1
> flux(6,ixave,jyave,kz,k,kp,nage)= &
> flux(6,ixave,jyave,kz,k,kp,nage)+ &
> xmass1(jpart,k)
> end do
> end do
> endif
>
>
> ! Determine west-east fluxes (fluxw) and east-west fluxes (fluxe)
> !****************************************************************
>
> if ((kzave.le.numzgrid).and.(jyave.ge.0).and. &
> (jyave.le.numygrid-1)) then
>
> ! 1) Particle does not cross domain boundary
>
> if (abs(xold-xtra1(jpart)).lt.real(nx)/2.) then
> ix1=int((xold*dx+xoutshift)/dxout+0.5)
> ix2=int((xtra1(jpart)*dx+xoutshift)/dxout+0.5)
> do k=1,nspec
> do ix=ix1,ix2-1
> if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
> flux(1,ix,jyave,kzave,k,kp,nage)= &
> flux(1,ix,jyave,kzave,k,kp,nage) &
> +xmass1(jpart,k)
> endif
> end do
> do ix=ix2,ix1-1
> if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
> flux(2,ix,jyave,kzave,k,kp,nage)= &
> flux(2,ix,jyave,kzave,k,kp,nage) &
> +xmass1(jpart,k)
> endif
> end do
> end do
>
> ! 2) Particle crosses domain boundary: use cyclic boundary condition
> ! and attribute flux to easternmost grid row only (approximation valid
> ! for relatively slow motions compared to output grid cell size)
>
> else
> ixs=int(((real(nxmin1)-1.e5)*dx+xoutshift)/dxout)
> if ((ixs.ge.0).and.(ixs.le.numxgrid-1)) then
> if (xold.gt.xtra1(jpart)) then ! west-east flux
> do k=1,nspec
> flux(1,ixs,jyave,kzave,k,kp,nage)= &
> flux(1,ixs,jyave,kzave,k,kp,nage) &
> +xmass1(jpart,k)
> end do
> else ! east-west flux
> do k=1,nspec
> flux(2,ixs,jyave,kzave,k,kp,nage)= &
> flux(2,ixs,jyave,kzave,k,kp,nage) &
> +xmass1(jpart,k)
> end do
> endif
> endif
> endif
> endif
>
>
> ! Determine south-north fluxes (fluxs) and north-south fluxes (fluxn)
> !********************************************************************
>
> if ((kzave.le.numzgrid).and.(ixave.ge.0).and. &
> (ixave.le.numxgrid-1)) then
> jy1=int((yold*dy+youtshift)/dyout+0.5)
> jy2=int((ytra1(jpart)*dy+youtshift)/dyout+0.5)
>
> do k=1,nspec
> do jy=jy1,jy2-1
> if ((jy.ge.0).and.(jy.le.numygrid-1)) then
> flux(3,ixave,jy,kzave,k,kp,nage)= &
> flux(3,ixave,jy,kzave,k,kp,nage) &
> +xmass1(jpart,k)
> endif
> end do
> do jy=jy2,jy1-1
> if ((jy.ge.0).and.(jy.le.numygrid-1)) then
> flux(4,ixave,jy,kzave,k,kp,nage)= &
> flux(4,ixave,jy,kzave,k,kp,nage) &
> +xmass1(jpart,k)
> endif
> end do
> end do
> endif
>
> end subroutine calcfluxes
>
calcmatrix.f90
----------------------------------------------
1,142c1,142
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine calcmatrix(lconv,delt,cbmf)
< ! o i o
< !*****************************************************************************
< ! *
< ! This subroutine calculates the matrix describing convective *
< ! redistribution of mass in a grid column, using the subroutine *
< ! convect43c.f provided by Kerry Emanuel. *
< ! *
< ! Petra Seibert, Bernd C. Krueger, 2000-2001 *
< ! *
< ! changed by C. Forster, November 2003 - February 2004 *
< ! array fmassfrac(nconvlevmax,nconvlevmax) represents *
< ! the convective redistribution matrix for the particles *
< ! *
< ! lconv indicates whether there is convection in this cell, or not *
< ! delt time step for convection [s] *
< ! cbmf cloud base mass flux *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use conv_mod
<
< implicit none
<
< real :: rlevmass,summe
<
< integer :: iflag, k, kk, kuvz
<
< !1-d variables for convection
< !variables for redistribution matrix
< real :: cbmfold, precip, qprime
< real :: tprime, wd, f_qvsat
< real :: delt,cbmf
< logical :: lconv
<
< lconv = .false.
<
<
< ! calculate pressure at eta levels for use in convect
< ! and assign temp & spec. hum. to 1D workspace
< ! -------------------------------------------------------
<
< ! pconv(1) is the pressure at the first level above ground
< ! phconv(k) is the pressure between levels k-1 and k
< ! dpr(k) is the pressure difference "around" tconv(k)
< ! phconv(kmax) must also be defined 1/2 level above pconv(kmax)
< ! Therefore, we define k = kuvz-1 and let kuvz start from 2
< ! top layer cannot be used for convection because p at top of this layer is
< ! not given
<
<
< phconv(1) = psconv
< ! Emanuel subroutine needs pressure in hPa, therefore convert all pressures
< do kuvz = 2,nuvz
< k = kuvz-1
< pconv(k) = (akz(kuvz) + bkz(kuvz)*psconv)
< phconv(kuvz) = (akm(kuvz) + bkm(kuvz)*psconv)
< dpr(k) = phconv(k) - phconv(kuvz)
< qsconv(k) = f_qvsat( pconv(k), tconv(k) )
<
< ! initialize mass fractions
< do kk=1,nconvlev
< fmassfrac(k,kk)=0.
< enddo
< enddo
<
<
< !note that Emanuel says it is important
< !a. to set this =0. every grid point
< !b. to keep this value in the calling programme in the iteration
<
< ! CALL CONVECTION
< !******************
<
< cbmfold = cbmf
< ! Convert pressures to hPa, as required by Emanuel scheme
< !********************************************************
< !!$ do k=1,nconvlev !old
< do k=1,nconvlev+1 !bugfix
< pconv_hpa(k)=pconv(k)/100.
< phconv_hpa(k)=phconv(k)/100.
< end do
< phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100.
< call convect(nconvlevmax, nconvlev, delt, iflag, &
< precip, wd, tprime, qprime, cbmf)
<
< ! do not update fmassfrac and cloudbase massflux
< ! if no convection takes place or
< ! if a CFL criterion is violated in convect43c.f
< if (iflag .ne. 1 .and. iflag .ne. 4) then
< cbmf=cbmfold
< goto 200
< endif
<
< ! do not update fmassfrac and cloudbase massflux
< ! if the old and the new cloud base mass
< ! fluxes are zero
< if (cbmf.le.0..and.cbmfold.le.0.) then
< cbmf=cbmfold
< goto 200
< endif
<
< ! Update fmassfrac
< ! account for mass displaced from level k to level k
<
< lconv = .true.
< do k=1,nconvtop
< rlevmass = dpr(k)/ga
< summe = 0.
< do kk=1,nconvtop
< fmassfrac(k,kk) = delt*fmass(k,kk)
< summe = summe + fmassfrac(k,kk)
< end do
< fmassfrac(k,k)=fmassfrac(k,k) + rlevmass - summe
< end do
<
< 200 continue
<
< end subroutine calcmatrix
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine calcmatrix(lconv,delt,cbmf)
> ! o i o
> !*****************************************************************************
> ! *
> ! This subroutine calculates the matrix describing convective *
> ! redistribution of mass in a grid column, using the subroutine *
> ! convect43c.f provided by Kerry Emanuel. *
> ! *
> ! Petra Seibert, Bernd C. Krueger, 2000-2001 *
> ! *
> ! changed by C. Forster, November 2003 - February 2004 *
> ! array fmassfrac(nconvlevmax,nconvlevmax) represents *
> ! the convective redistribution matrix for the particles *
> ! *
> ! lconv indicates whether there is convection in this cell, or not *
> ! delt time step for convection [s] *
> ! cbmf cloud base mass flux *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use conv_mod
>
> implicit none
>
> real :: rlevmass,summe
>
> integer :: iflag, k, kk, kuvz
>
> !1-d variables for convection
> !variables for redistribution matrix
> real :: cbmfold, precip, qprime
> real :: tprime, wd, f_qvsat
> real :: delt,cbmf
> logical :: lconv
>
> lconv = .false.
>
>
> ! calculate pressure at eta levels for use in convect
> ! and assign temp & spec. hum. to 1D workspace
> ! -------------------------------------------------------
>
> ! pconv(1) is the pressure at the first level above ground
> ! phconv(k) is the pressure between levels k-1 and k
> ! dpr(k) is the pressure difference "around" tconv(k)
> ! phconv(kmax) must also be defined 1/2 level above pconv(kmax)
> ! Therefore, we define k = kuvz-1 and let kuvz start from 2
> ! top layer cannot be used for convection because p at top of this layer is
> ! not given
>
>
> phconv(1) = psconv
> ! Emanuel subroutine needs pressure in hPa, therefore convert all pressures
> do kuvz = 2,nuvz
> k = kuvz-1
> pconv(k) = (akz(kuvz) + bkz(kuvz)*psconv)
> phconv(kuvz) = (akm(kuvz) + bkm(kuvz)*psconv)
> dpr(k) = phconv(k) - phconv(kuvz)
> qsconv(k) = f_qvsat( pconv(k), tconv(k) )
>
> ! initialize mass fractions
> do kk=1,nconvlev
> fmassfrac(k,kk)=0.
> enddo
> enddo
>
>
> !note that Emanuel says it is important
> !a. to set this =0. every grid point
> !b. to keep this value in the calling programme in the iteration
>
> ! CALL CONVECTION
> !******************
>
> cbmfold = cbmf
> ! Convert pressures to hPa, as required by Emanuel scheme
> !********************************************************
> !!$ do k=1,nconvlev !old
> do k=1,nconvlev+1 !bugfix
> pconv_hpa(k)=pconv(k)/100.
> phconv_hpa(k)=phconv(k)/100.
> end do
> phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100.
> call convect(nconvlevmax, nconvlev, delt, iflag, &
> precip, wd, tprime, qprime, cbmf)
>
> ! do not update fmassfrac and cloudbase massflux
> ! if no convection takes place or
> ! if a CFL criterion is violated in convect43c.f
> if (iflag .ne. 1 .and. iflag .ne. 4) then
> cbmf=cbmfold
> goto 200
> endif
>
> ! do not update fmassfrac and cloudbase massflux
> ! if the old and the new cloud base mass
> ! fluxes are zero
> if (cbmf.le.0..and.cbmfold.le.0.) then
> cbmf=cbmfold
> goto 200
> endif
>
> ! Update fmassfrac
> ! account for mass displaced from level k to level k
>
> lconv = .true.
> do k=1,nconvtop
> rlevmass = dpr(k)/ga
> summe = 0.
> do kk=1,nconvtop
> fmassfrac(k,kk) = delt*fmass(k,kk)
> summe = summe + fmassfrac(k,kk)
> end do
> fmassfrac(k,k)=fmassfrac(k,k) + rlevmass - summe
> end do
>
> 200 continue
>
> end subroutine calcmatrix
calcmatrix_gfs.f90
----------------------------------------------
1,139c1,139
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine calcmatrix(lconv,delt,cbmf)
< ! o i o
< !*****************************************************************************
< ! *
< ! This subroutine calculates the matrix describing convective *
< ! redistribution of mass in a grid column, using the subroutine *
< ! convect43c.f provided by Kerry Emanuel. *
< ! *
< ! Petra Seibert, Bernd C. Krueger, 2000-2001 *
< ! *
< ! changed by C. Forster, November 2003 - February 2004 *
< ! array fmassfrac(nconvlevmax,nconvlevmax) represents *
< ! the convective redistribution matrix for the particles *
< ! *
< ! Changes by C. Forster, November 2005, NCEP GFS version *
< ! *
< ! lconv indicates whether there is convection in this cell, or not *
< ! delt time step for convection [s] *
< ! cbmf cloud base mass flux *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use conv_mod
<
< implicit none
<
< real :: rlevmass,summe
<
< integer :: iflag, k, kk, kuvz
<
< !1-d variables for convection
< !variables for redistribution matrix
< real :: cbmfold, precip, qprime
< real :: tprime, wd, f_qvsat
< real :: delt,cbmf
< logical :: lconv
<
< lconv = .false.
<
<
< ! calculate pressure at eta levels for use in convect
< ! and assign temp & spec. hum. to 1D workspace
< ! -------------------------------------------------------
<
< ! pconv(1) is the pressure at the first level above ground
< ! phconv(k) is the pressure between levels k-1 and k
< ! dpr(k) is the pressure difference "around" tconv(k)
< ! phconv(kmax) must also be defined 1/2 level above pconv(kmax)
< ! Therefore, we define k = kuvz-1 and let kuvz start from 2
< ! top layer cannot be used for convection because p at top of this layer is
< ! not given
<
< phconv(1) = psconv
< do kuvz = 2,nuvz
< k = kuvz-1
< phconv(kuvz) = 0.5*(pconv(kuvz)+pconv(k))
< dpr(k) = phconv(k) - phconv(kuvz)
< qsconv(k) = f_qvsat( pconv(k), tconv(k) )
< ! initialize mass fractions
< do kk=1,nconvlev
< fmassfrac(k,kk)=0.
< enddo
< end do
<
< !note that Emanuel says it is important
< !a. to set this =0. every grid point
< !b. to keep this value in the calling programme in the iteration
<
< ! CALL CONVECTION
< !******************
<
< cbmfold = cbmf
< ! Convert pressures to hPa, as required by Emanuel scheme
< !********************************************************
< !!$ do k=1,nconvlev !old
< do k=1,nconvlev+1 !bugfix
< pconv_hpa(k)=pconv(k)/100.
< phconv_hpa(k)=phconv(k)/100.
< end do
< phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100.
< call convect(nconvlevmax, nconvlev, delt, iflag, &
< precip, wd, tprime, qprime, cbmf)
<
< ! do not update fmassfrac and cloudbase massflux
< ! if no convection takes place or
< ! if a CFL criterion is violated in convect43c.f
< if (iflag .ne. 1 .and. iflag .ne. 4) then
< cbmf=cbmfold
< goto 200
< endif
<
< ! do not update fmassfrac and cloudbase massflux
< ! if the old and the new cloud base mass
< ! fluxes are zero
< if (cbmf.le.0..and.cbmfold.le.0.) then
< cbmf=cbmfold
< goto 200
< endif
<
< ! Update fmassfrac
< ! account for mass displaced from level k to level k
<
< lconv = .true.
< do k=1,nconvtop
< rlevmass = dpr(k)/ga
< summe = 0.
< do kk=1,nconvtop
< fmassfrac(k,kk) = delt*fmass(k,kk)
< summe = summe + fmassfrac(k,kk)
< end do
< fmassfrac(k,k)=fmassfrac(k,k) + rlevmass - summe
< end do
<
< 200 continue
<
< end subroutine calcmatrix
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine calcmatrix(lconv,delt,cbmf)
> ! o i o
> !*****************************************************************************
> ! *
> ! This subroutine calculates the matrix describing convective *
> ! redistribution of mass in a grid column, using the subroutine *
> ! convect43c.f provided by Kerry Emanuel. *
> ! *
> ! Petra Seibert, Bernd C. Krueger, 2000-2001 *
> ! *
> ! changed by C. Forster, November 2003 - February 2004 *
> ! array fmassfrac(nconvlevmax,nconvlevmax) represents *
> ! the convective redistribution matrix for the particles *
> ! *
> ! Changes by C. Forster, November 2005, NCEP GFS version *
> ! *
> ! lconv indicates whether there is convection in this cell, or not *
> ! delt time step for convection [s] *
> ! cbmf cloud base mass flux *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use conv_mod
>
> implicit none
>
> real :: rlevmass,summe
>
> integer :: iflag, k, kk, kuvz
>
> !1-d variables for convection
> !variables for redistribution matrix
> real :: cbmfold, precip, qprime
> real :: tprime, wd, f_qvsat
> real :: delt,cbmf
> logical :: lconv
>
> lconv = .false.
>
>
> ! calculate pressure at eta levels for use in convect
> ! and assign temp & spec. hum. to 1D workspace
> ! -------------------------------------------------------
>
> ! pconv(1) is the pressure at the first level above ground
> ! phconv(k) is the pressure between levels k-1 and k
> ! dpr(k) is the pressure difference "around" tconv(k)
> ! phconv(kmax) must also be defined 1/2 level above pconv(kmax)
> ! Therefore, we define k = kuvz-1 and let kuvz start from 2
> ! top layer cannot be used for convection because p at top of this layer is
> ! not given
>
> phconv(1) = psconv
> do kuvz = 2,nuvz
> k = kuvz-1
> phconv(kuvz) = 0.5*(pconv(kuvz)+pconv(k))
> dpr(k) = phconv(k) - phconv(kuvz)
> qsconv(k) = f_qvsat( pconv(k), tconv(k) )
> ! initialize mass fractions
> do kk=1,nconvlev
> fmassfrac(k,kk)=0.
> enddo
> end do
>
> !note that Emanuel says it is important
> !a. to set this =0. every grid point
> !b. to keep this value in the calling programme in the iteration
>
> ! CALL CONVECTION
> !******************
>
> cbmfold = cbmf
> ! Convert pressures to hPa, as required by Emanuel scheme
> !********************************************************
> !!$ do k=1,nconvlev !old
> do k=1,nconvlev+1 !bugfix
> pconv_hpa(k)=pconv(k)/100.
> phconv_hpa(k)=phconv(k)/100.
> end do
> phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100.
> call convect(nconvlevmax, nconvlev, delt, iflag, &
> precip, wd, tprime, qprime, cbmf)
>
> ! do not update fmassfrac and cloudbase massflux
> ! if no convection takes place or
> ! if a CFL criterion is violated in convect43c.f
> if (iflag .ne. 1 .and. iflag .ne. 4) then
> cbmf=cbmfold
> goto 200
> endif
>
> ! do not update fmassfrac and cloudbase massflux
> ! if the old and the new cloud base mass
> ! fluxes are zero
> if (cbmf.le.0..and.cbmfold.le.0.) then
> cbmf=cbmfold
> goto 200
> endif
>
> ! Update fmassfrac
> ! account for mass displaced from level k to level k
>
> lconv = .true.
> do k=1,nconvtop
> rlevmass = dpr(k)/ga
> summe = 0.
> do kk=1,nconvtop
> fmassfrac(k,kk) = delt*fmass(k,kk)
> summe = summe + fmassfrac(k,kk)
> end do
> fmassfrac(k,k)=fmassfrac(k,k) + rlevmass - summe
> end do
>
> 200 continue
>
> end subroutine calcmatrix
calcpar.f90
----------------------------------------------
1,238c1,240
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine calcpar(n,uuh,vvh,pvh)
< ! i i i o
< !*****************************************************************************
< ! *
< ! Computation of several boundary layer parameters needed for the *
< ! dispersion calculation and calculation of dry deposition velocities. *
< ! All parameters are calculated over the entire grid. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 21 May 1995 *
< ! *
< ! ------------------------------------------------------------------ *
< ! Petra Seibert, Feb 2000: *
< ! convection scheme: *
< ! new variables in call to richardson *
< ! *
< !*****************************************************************************
< ! Changes, Bernd C. Krueger, Feb. 2001:
< ! Variables tth and qvh (on eta coordinates) in common block
< !*****************************************************************************
< ! *
< ! Variables: *
< ! n temporal index for meteorological fields (1 to 3) *
< ! *
< ! Constants: *
< ! *
< ! *
< ! Functions: *
< ! scalev computation of ustar *
< ! obukhov computatio of Obukhov length *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: n,ix,jy,i,kz,lz,kzmin
< real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
< real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
< real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax)
< real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real,parameter :: const=r_air/ga
<
< !write(*,*) 'in calcpar writting snowheight'
< !***********************************
< ! for test: write out snow depths
<
< ! open(4,file='slandusetest',form='formatted')
< ! do 5 ix=0,nxmin1
< !5 write (4,*) (sd(ix,jy,1,n),jy=0,nymin1)
< ! close(4)
<
<
< ! Loop over entire grid
< !**********************
<
< do jy=0,nymin1
<
< ! Set minimum height for tropopause
< !**********************************
<
< ylat=ylat0+real(jy)*dy
< if ((ylat.ge.-20.).and.(ylat.le.20.)) then
< altmin = 5000.
< else
< if ((ylat.gt.20.).and.(ylat.lt.40.)) then
< altmin=2500.+(40.-ylat)*125.
< else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
< altmin=2500.+(40.+ylat)*125.
< else
< altmin=2500.
< endif
< endif
<
< do ix=0,nxmin1
<
< ! 1) Calculation of friction velocity
< !************************************
<
< ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), &
< td2(ix,jy,1,n),surfstr(ix,jy,1,n))
< if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8
<
< ! 2) Calculation of inverse Obukhov length scale
< !***********************************************
<
< ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
< tth(ix,jy,2,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n),akm,bkm)
< if (ol.ne.0.) then
< oli(ix,jy,1,n)=1./ol
< else
< oli(ix,jy,1,n)=99999.
< endif
<
<
< ! 3) Calculation of convective velocity scale and mixing height
< !**************************************************************
<
< do i=1,nuvz
< ulev(i)=uuh(ix,jy,i)
< vlev(i)=vvh(ix,jy,i)
< ttlev(i)=tth(ix,jy,i,n)
< qvlev(i)=qvh(ix,jy,i,n)
< end do
<
< call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
< ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
< td2(ix,jy,1,n),hmix(ix,jy,1,n),wstar(ix,jy,1,n),hmixplus)
<
< if(lsubgrid.eq.1) then
< subsceff=min(excessoro(ix,jy),hmixplus)
< else
< subsceff=0.0
< endif
< !
< ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
< !
< hmix(ix,jy,1,n)=hmix(ix,jy,1,n)+subsceff
< hmix(ix,jy,1,n)=max(hmixmin,hmix(ix,jy,1,n)) ! set minimum PBL height
< hmix(ix,jy,1,n)=min(hmixmax,hmix(ix,jy,1,n)) ! set maximum PBL height
<
< ! 4) Calculation of dry deposition velocities
< !********************************************
<
< if (DRYDEP) then
< ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on
< ! windspeed
< z0(7)=0.016*ustar(ix,jy,1,n)*ustar(ix,jy,1,n)/ga
<
< ! Calculate relative humidity at surface
< !***************************************
< rh=ew(td2(ix,jy,1,n))/ew(tt2(ix,jy,1,n))
<
< call getvdep(n,ix,jy,ustar(ix,jy,1,n), &
< tt2(ix,jy,1,n),ps(ix,jy,1,n),1./oli(ix,jy,1,n), &
< ssr(ix,jy,1,n),rh,lsprec(ix,jy,1,n)+convprec(ix,jy,1,n), &
< sd(ix,jy,1,n),vd)
<
< do i=1,nspec
< vdep(ix,jy,i,n)=vd(i)
< end do
<
< endif
<
< !******************************************************
< ! Calculate height of thermal tropopause (Hoinka, 1997)
< !******************************************************
<
< ! 1) Calculate altitudes of ECMWF model levels
< !*********************************************
<
< tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
< ps(ix,jy,1,n))
< pold=ps(ix,jy,1,n)
< zold=0.
< do kz=2,nuvz
< pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) ! pressure on model layers
< tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
<
< if (abs(tv-tvold).gt.0.2) then
< zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
< else
< zlev(kz)=zold+const*log(pold/pint)*tv
< endif
< tvold=tv
< pold=pint
< zold=zlev(kz)
< end do
<
< ! 2) Define a minimum level kzmin, from which upward the tropopause is
< ! searched for. This is to avoid inversions in the lower troposphere
< ! to be identified as the tropopause
< !************************************************************************
<
< do kz=1,nuvz
< if (zlev(kz).ge.altmin) then
< kzmin=kz
< goto 45
< endif
< end do
< 45 continue
<
< ! 3) Search for first stable layer above minimum height that fulfills the
< ! thermal tropopause criterion
< !************************************************************************
<
< do kz=kzmin,nuvz
< do lz=kz+1,nuvz
< if ((zlev(lz)-zlev(kz)).gt.2000.) then
< if (((tth(ix,jy,kz,n)-tth(ix,jy,lz,n))/ &
< (zlev(lz)-zlev(kz))).lt.0.002) then
< tropopause(ix,jy,1,n)=zlev(kz)
< goto 51
< endif
< goto 50
< endif
< end do
< 50 continue
< end do
< 51 continue
<
<
< end do
< end do
<
< ! Calculation of potential vorticity on 3-d grid
< !***********************************************
<
< call calcpv(n,uuh,vvh,pvh)
<
<
< end subroutine calcpar
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine calcpar(n,uuh,vvh,pvh)
> ! i i i o
> !*****************************************************************************
> ! *
> ! Computation of several boundary layer parameters needed for the *
> ! dispersion calculation and calculation of dry deposition velocities. *
> ! All parameters are calculated over the entire grid. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 21 May 1995 *
> ! *
> ! ------------------------------------------------------------------ *
> ! Petra Seibert, Feb 2000: *
> ! convection scheme: *
> ! new variables in call to richardson *
> ! *
> !*****************************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001:
> ! Variables tth and qvh (on eta coordinates) in common block
> !*****************************************************************************
> ! *
> ! Variables: *
> ! n temporal index for meteorological fields (1 to 3) *
> ! *
> ! Constants: *
> ! *
> ! *
> ! Functions: *
> ! scalev computation of ustar *
> ! obukhov computatio of Obukhov length *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: n,ix,jy,i,kz,lz,kzmin
> real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
> real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
> real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax)
> real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real,parameter :: const=r_air/ga
>
> !write(*,*) 'in calcpar writting snowheight'
> !***********************************
> ! for test: write out snow depths
>
> ! open(4,file='slandusetest',form='formatted')
> ! do 5 ix=0,nxmin1
> !5 write (4,*) (sd(ix,jy,1,n),jy=0,nymin1)
> ! close(4)
>
>
> ! Loop over entire grid
> !**********************
>
> do jy=0,nymin1
>
> ! Set minimum height for tropopause
> !**********************************
>
> ylat=ylat0+real(jy)*dy
> if ((ylat.ge.-20.).and.(ylat.le.20.)) then
> altmin = 5000.
> else
> if ((ylat.gt.20.).and.(ylat.lt.40.)) then
> altmin=2500.+(40.-ylat)*125.
> else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
> altmin=2500.+(40.+ylat)*125.
> else
> altmin=2500.
> endif
> endif
>
> do ix=0,nxmin1
>
> ! 1) Calculation of friction velocity
> !************************************
>
> ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), &
> td2(ix,jy,1,n),surfstr(ix,jy,1,n))
> if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8
>
> ! 2) Calculation of inverse Obukhov length scale
> !***********************************************
>
> ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
> tth(ix,jy,2,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n),akm,bkm)
> if (ol.ne.0.) then
> oli(ix,jy,1,n)=1./ol
> else
> oli(ix,jy,1,n)=99999.
> endif
>
>
> ! 3) Calculation of convective velocity scale and mixing height
> !**************************************************************
>
> do i=1,nuvz
> ulev(i)=uuh(ix,jy,i)
> vlev(i)=vvh(ix,jy,i)
> ttlev(i)=tth(ix,jy,i,n)
> qvlev(i)=qvh(ix,jy,i,n)
> end do
>
> call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
> ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
> td2(ix,jy,1,n),hmix(ix,jy,1,n),wstar(ix,jy,1,n),hmixplus)
>
> if(lsubgrid.eq.1) then
> subsceff=min(excessoro(ix,jy),hmixplus)
> else
> subsceff=0.0
> endif
> !
> ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
> !
> hmix(ix,jy,1,n)=hmix(ix,jy,1,n)+subsceff
> hmix(ix,jy,1,n)=max(hmixmin,hmix(ix,jy,1,n)) ! set minimum PBL height
> hmix(ix,jy,1,n)=min(hmixmax,hmix(ix,jy,1,n)) ! set maximum PBL height
>
> ! 4) Calculation of dry deposition velocities
> !********************************************
>
> if (DRYDEP) then
> ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on
> ! windspeed
> z0(7)=0.016*ustar(ix,jy,1,n)*ustar(ix,jy,1,n)/ga
>
> ! Calculate relative humidity at surface
> !***************************************
> rh=ew(td2(ix,jy,1,n))/ew(tt2(ix,jy,1,n))
>
> call getvdep(n,ix,jy,ustar(ix,jy,1,n), &
> tt2(ix,jy,1,n),ps(ix,jy,1,n),1./oli(ix,jy,1,n), &
> ssr(ix,jy,1,n),rh,lsprec(ix,jy,1,n)+convprec(ix,jy,1,n), &
> sd(ix,jy,1,n),vd)
>
> do i=1,nspec
> vdep(ix,jy,i,n)=vd(i)
> end do
>
> endif
>
> !******************************************************
> ! Calculate height of thermal tropopause (Hoinka, 1997)
> !******************************************************
>
> ! 1) Calculate altitudes of ECMWF model levels
> !*********************************************
>
> tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
> ps(ix,jy,1,n))
> pold=ps(ix,jy,1,n)
> zold=0.
> do kz=2,nuvz
> pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) ! pressure on model layers
> tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
>
> if (abs(tv-tvold).gt.0.2) then
> zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
> else
> zlev(kz)=zold+const*log(pold/pint)*tv
> endif
> tvold=tv
> pold=pint
> zold=zlev(kz)
> end do
>
> ! 2) Define a minimum level kzmin, from which upward the tropopause is
> ! searched for. This is to avoid inversions in the lower troposphere
> ! to be identified as the tropopause
> !************************************************************************
>
> do kz=1,nuvz
> if (zlev(kz).ge.altmin) then
> kzmin=kz
> goto 45
> endif
> end do
> 45 continue
>
> ! 3) Search for first stable layer above minimum height that fulfills the
> ! thermal tropopause criterion
> !************************************************************************
>
> do kz=kzmin,nuvz
> do lz=kz+1,nuvz
> if ((zlev(lz)-zlev(kz)).gt.2000.) then
> if (((tth(ix,jy,kz,n)-tth(ix,jy,lz,n))/ &
> (zlev(lz)-zlev(kz))).lt.0.002) then
> tropopause(ix,jy,1,n)=zlev(kz)
> goto 51
> endif
> goto 50
> endif
> end do
> 50 continue
> end do
> 51 continue
>
>
> end do
> end do
>
>
>
> ! Calculation of potential vorticity on 3-d grid
> !***********************************************
>
> call calcpv(n,uuh,vvh,pvh)
>
>
> end subroutine calcpar
calcpar_gfs.f90
----------------------------------------------
1,243c1,243
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine calcpar(n,uuh,vvh,pvh)
< ! i i i o
< !*****************************************************************************
< ! *
< ! Computation of several boundary layer parameters needed for the *
< ! dispersion calculation and calculation of dry deposition velocities. *
< ! All parameters are calculated over the entire grid. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 21 May 1995 *
< ! *
< ! ------------------------------------------------------------------ *
< ! Petra Seibert, Feb 2000: *
< ! convection scheme: *
< ! new variables in call to richardson *
< ! *
< !*****************************************************************************
< ! Changes, Bernd C. Krueger, Feb. 2001:
< ! Variables tth and qvh (on eta coordinates) in common block
< !*****************************************************************************
< ! *
< ! CHANGE 17/11/2005 Caroline Forster NCEP GFS version *
< ! *
< ! Variables: *
< ! n temporal index for meteorological fields (1 to 3) *
< ! *
< ! Constants: *
< ! *
< ! *
< ! Functions: *
< ! scalev computation of ustar *
< ! obukhov computatio of Obukhov length *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: n,ix,jy,i,kz,lz,kzmin,llev
< real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
< real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
< real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax),hmixdummy
< real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real,parameter :: const=r_air/ga
<
<
< ! Loop over entire grid
< !**********************
<
< do jy=0,nymin1
<
< ! Set minimum height for tropopause
< !**********************************
<
< ylat=ylat0+real(jy)*dy
< if ((ylat.ge.-20.).and.(ylat.le.20.)) then
< altmin = 5000.
< else
< if ((ylat.gt.20.).and.(ylat.lt.40.)) then
< altmin=2500.+(40.-ylat)*125.
< else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
< altmin=2500.+(40.+ylat)*125.
< else
< altmin=2500.
< endif
< endif
<
< do ix=0,nxmin1
<
< ! 1) Calculation of friction velocity
< !************************************
<
< ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), &
< td2(ix,jy,1,n),surfstr(ix,jy,1,n))
< if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8
<
< ! 2) Calculation of inverse Obukhov length scale
< !***********************************************
<
< ! NCEP version: find first level above ground
< llev = 0
< do i=1,nuvz
< if (ps(ix,jy,1,n).lt.akz(i)) llev=i
< end do
< llev = llev+1
< if (llev.gt.nuvz) llev = nuvz-1
< ! NCEP version
<
< ! calculate inverse Obukhov length scale with tth(llev)
< ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
< tth(ix,jy,llev,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n),akz(llev))
< if (ol.ne.0.) then
< oli(ix,jy,1,n)=1./ol
< else
< oli(ix,jy,1,n)=99999.
< endif
<
<
< ! 3) Calculation of convective velocity scale and mixing height
< !**************************************************************
<
< do i=1,nuvz
< ulev(i)=uuh(ix,jy,i)
< vlev(i)=vvh(ix,jy,i)
< ttlev(i)=tth(ix,jy,i,n)
< qvlev(i)=qvh(ix,jy,i,n)
< end do
<
< ! NCEP version hmix has been read in in readwind.f, is therefore not calculated here
< call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
< ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
< td2(ix,jy,1,n),hmixdummy,wstar(ix,jy,1,n),hmixplus)
<
< if(lsubgrid.eq.1) then
< subsceff=min(excessoro(ix,jy),hmixplus)
< else
< subsceff=0
< endif
< !
< ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
< !
< hmix(ix,jy,1,n)=hmix(ix,jy,1,n)+subsceff
< hmix(ix,jy,1,n)=max(hmixmin,hmix(ix,jy,1,n)) ! set minimum PBL height
< hmix(ix,jy,1,n)=min(hmixmax,hmix(ix,jy,1,n)) ! set maximum PBL height
<
< ! 4) Calculation of dry deposition velocities
< !********************************************
<
< if (DRYDEP) then
< ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on
< ! windspeed
< z0(7)=0.016*ustar(ix,jy,1,n)*ustar(ix,jy,1,n)/ga
<
< ! Calculate relative humidity at surface
< !***************************************
< rh=ew(td2(ix,jy,1,n))/ew(tt2(ix,jy,1,n))
<
< call getvdep(n,ix,jy,ustar(ix,jy,1,n), &
< tt2(ix,jy,1,n),ps(ix,jy,1,n),1./oli(ix,jy,1,n), &
< ssr(ix,jy,1,n),rh,lsprec(ix,jy,1,n)+convprec(ix,jy,1,n), &
< sd(ix,jy,1,n),vd)
<
< do i=1,nspec
< vdep(ix,jy,i,n)=vd(i)
< end do
<
< endif
<
< !******************************************************
< ! Calculate height of thermal tropopause (Hoinka, 1997)
< !******************************************************
<
< ! 1) Calculate altitudes of NCEP model levels
< !*********************************************
<
< tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
< ps(ix,jy,1,n))
< pold=ps(ix,jy,1,n)
< zold=0.
< do kz=llev,nuvz
< pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) ! pressure on model layers
< tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
<
< if (abs(tv-tvold).gt.0.2) then
< zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
< else
< zlev(kz)=zold+const*log(pold/pint)*tv
< endif
< tvold=tv
< pold=pint
< zold=zlev(kz)
< end do
<
< ! 2) Define a minimum level kzmin, from which upward the tropopause is
< ! searched for. This is to avoid inversions in the lower troposphere
< ! to be identified as the tropopause
< !************************************************************************
<
< do kz=llev,nuvz
< if (zlev(kz).ge.altmin) then
< kzmin=kz
< goto 45
< endif
< end do
< 45 continue
<
< ! 3) Search for first stable layer above minimum height that fulfills the
< ! thermal tropopause criterion
< !************************************************************************
<
< do kz=kzmin,nuvz
< do lz=kz+1,nuvz
< if ((zlev(lz)-zlev(kz)).gt.2000.) then
< if (((tth(ix,jy,kz,n)-tth(ix,jy,lz,n))/ &
< (zlev(lz)-zlev(kz))).lt.0.002) then
< tropopause(ix,jy,1,n)=zlev(kz)
< goto 51
< endif
< goto 50
< endif
< end do
< 50 continue
< end do
< 51 continue
<
<
< end do
< end do
<
<
< ! Calculation of potential vorticity on 3-d grid
< !***********************************************
<
< call calcpv(n,uuh,vvh,pvh)
<
<
< end subroutine calcpar
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine calcpar(n,uuh,vvh,pvh)
> ! i i i o
> !*****************************************************************************
> ! *
> ! Computation of several boundary layer parameters needed for the *
> ! dispersion calculation and calculation of dry deposition velocities. *
> ! All parameters are calculated over the entire grid. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 21 May 1995 *
> ! *
> ! ------------------------------------------------------------------ *
> ! Petra Seibert, Feb 2000: *
> ! convection scheme: *
> ! new variables in call to richardson *
> ! *
> !*****************************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001:
> ! Variables tth and qvh (on eta coordinates) in common block
> !*****************************************************************************
> ! *
> ! CHANGE 17/11/2005 Caroline Forster NCEP GFS version *
> ! *
> ! Variables: *
> ! n temporal index for meteorological fields (1 to 3) *
> ! *
> ! Constants: *
> ! *
> ! *
> ! Functions: *
> ! scalev computation of ustar *
> ! obukhov computatio of Obukhov length *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: n,ix,jy,i,kz,lz,kzmin,llev
> real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
> real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
> real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax),hmixdummy
> real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real,parameter :: const=r_air/ga
>
>
> ! Loop over entire grid
> !**********************
>
> do jy=0,nymin1
>
> ! Set minimum height for tropopause
> !**********************************
>
> ylat=ylat0+real(jy)*dy
> if ((ylat.ge.-20.).and.(ylat.le.20.)) then
> altmin = 5000.
> else
> if ((ylat.gt.20.).and.(ylat.lt.40.)) then
> altmin=2500.+(40.-ylat)*125.
> else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
> altmin=2500.+(40.+ylat)*125.
> else
> altmin=2500.
> endif
> endif
>
> do ix=0,nxmin1
>
> ! 1) Calculation of friction velocity
> !************************************
>
> ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), &
> td2(ix,jy,1,n),surfstr(ix,jy,1,n))
> if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8
>
> ! 2) Calculation of inverse Obukhov length scale
> !***********************************************
>
> ! NCEP version: find first level above ground
> llev = 0
> do i=1,nuvz
> if (ps(ix,jy,1,n).lt.akz(i)) llev=i
> end do
> llev = llev+1
> if (llev.gt.nuvz) llev = nuvz-1
> ! NCEP version
>
> ! calculate inverse Obukhov length scale with tth(llev)
> ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), &
> tth(ix,jy,llev,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n),akz(llev))
> if (ol.ne.0.) then
> oli(ix,jy,1,n)=1./ol
> else
> oli(ix,jy,1,n)=99999.
> endif
>
>
> ! 3) Calculation of convective velocity scale and mixing height
> !**************************************************************
>
> do i=1,nuvz
> ulev(i)=uuh(ix,jy,i)
> vlev(i)=vvh(ix,jy,i)
> ttlev(i)=tth(ix,jy,i,n)
> qvlev(i)=qvh(ix,jy,i,n)
> end do
>
> ! NCEP version hmix has been read in in readwind.f, is therefore not calculated here
> call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, &
> ulev,vlev,nuvz,akz,bkz,sshf(ix,jy,1,n),tt2(ix,jy,1,n), &
> td2(ix,jy,1,n),hmixdummy,wstar(ix,jy,1,n),hmixplus)
>
> if(lsubgrid.eq.1) then
> subsceff=min(excessoro(ix,jy),hmixplus)
> else
> subsceff=0
> endif
> !
> ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
> !
> hmix(ix,jy,1,n)=hmix(ix,jy,1,n)+subsceff
> hmix(ix,jy,1,n)=max(hmixmin,hmix(ix,jy,1,n)) ! set minimum PBL height
> hmix(ix,jy,1,n)=min(hmixmax,hmix(ix,jy,1,n)) ! set maximum PBL height
>
> ! 4) Calculation of dry deposition velocities
> !********************************************
>
> if (DRYDEP) then
> ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on
> ! windspeed
> z0(7)=0.016*ustar(ix,jy,1,n)*ustar(ix,jy,1,n)/ga
>
> ! Calculate relative humidity at surface
> !***************************************
> rh=ew(td2(ix,jy,1,n))/ew(tt2(ix,jy,1,n))
>
> call getvdep(n,ix,jy,ustar(ix,jy,1,n), &
> tt2(ix,jy,1,n),ps(ix,jy,1,n),1./oli(ix,jy,1,n), &
> ssr(ix,jy,1,n),rh,lsprec(ix,jy,1,n)+convprec(ix,jy,1,n), &
> sd(ix,jy,1,n),vd)
>
> do i=1,nspec
> vdep(ix,jy,i,n)=vd(i)
> end do
>
> endif
>
> !******************************************************
> ! Calculate height of thermal tropopause (Hoinka, 1997)
> !******************************************************
>
> ! 1) Calculate altitudes of NCEP model levels
> !*********************************************
>
> tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
> ps(ix,jy,1,n))
> pold=ps(ix,jy,1,n)
> zold=0.
> do kz=llev,nuvz
> pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) ! pressure on model layers
> tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
>
> if (abs(tv-tvold).gt.0.2) then
> zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
> else
> zlev(kz)=zold+const*log(pold/pint)*tv
> endif
> tvold=tv
> pold=pint
> zold=zlev(kz)
> end do
>
> ! 2) Define a minimum level kzmin, from which upward the tropopause is
> ! searched for. This is to avoid inversions in the lower troposphere
> ! to be identified as the tropopause
> !************************************************************************
>
> do kz=llev,nuvz
> if (zlev(kz).ge.altmin) then
> kzmin=kz
> goto 45
> endif
> end do
> 45 continue
>
> ! 3) Search for first stable layer above minimum height that fulfills the
> ! thermal tropopause criterion
> !************************************************************************
>
> do kz=kzmin,nuvz
> do lz=kz+1,nuvz
> if ((zlev(lz)-zlev(kz)).gt.2000.) then
> if (((tth(ix,jy,kz,n)-tth(ix,jy,lz,n))/ &
> (zlev(lz)-zlev(kz))).lt.0.002) then
> tropopause(ix,jy,1,n)=zlev(kz)
> goto 51
> endif
> goto 50
> endif
> end do
> 50 continue
> end do
> 51 continue
>
>
> end do
> end do
>
>
> ! Calculation of potential vorticity on 3-d grid
> !***********************************************
>
> call calcpv(n,uuh,vvh,pvh)
>
>
> end subroutine calcpar
calcpar_nests.f90
----------------------------------------------
1,236c1,240
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine calcpar_nests(n,uuhn,vvhn,pvhn)
< ! i i i o
< !*****************************************************************************
< ! *
< ! Computation of several boundary layer parameters needed for the *
< ! dispersion calculation and calculation of dry deposition velocities. *
< ! All parameters are calculated over the entire grid. *
< ! This routine is similar to calcpar, but is used for the nested grids. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 8 February 1999 *
< ! *
< ! ------------------------------------------------------------------ *
< ! Petra Seibert, Feb 2000: *
< ! convection scheme: *
< ! new variables in call to richardson *
< ! *
< !*****************************************************************************
< ! Changes, Bernd C. Krueger, Feb. 2001:
< ! Variables tth and qvh (on eta coordinates) in common block
< !*****************************************************************************
< ! *
< ! Variables: *
< ! n temporal index for meteorological fields (1 to 3) *
< ! *
< ! Constants: *
< ! *
< ! *
< ! Functions: *
< ! scalev computation of ustar *
< ! obukhov computatio of Obukhov length *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: n,ix,jy,i,l,kz,lz,kzmin
< real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
< real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
< real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax)
< real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real,parameter :: const=r_air/ga
<
<
< ! Loop over all nests
< !********************
<
< do l=1,numbnests
<
< ! Loop over entire grid
< !**********************
<
< do jy=0,nyn(l)-1
<
< ! Set minimum height for tropopause
< !**********************************
<
< ylat=ylat0n(l)+real(jy)*dyn(l)
< if ((ylat.ge.-20.).and.(ylat.le.20.)) then
< altmin = 5000.
< else
< if ((ylat.gt.20.).and.(ylat.lt.40.)) then
< altmin=2500.+(40.-ylat)*125.
< else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
< altmin=2500.+(40.+ylat)*125.
< else
< altmin=2500.
< endif
< endif
<
< do ix=0,nxn(l)-1
<
< ! 1) Calculation of friction velocity
< !************************************
<
< ustarn(ix,jy,1,n,l)=scalev(psn(ix,jy,1,n,l),tt2n(ix,jy,1,n,l), &
< td2n(ix,jy,1,n,l),surfstrn(ix,jy,1,n,l))
<
< ! 2) Calculation of inverse Obukhov length scale
< !***********************************************
<
< ol=obukhov(psn(ix,jy,1,n,l),tt2n(ix,jy,1,n,l), &
< td2n(ix,jy,1,n,l),tthn(ix,jy,2,n,l),ustarn(ix,jy,1,n,l), &
< sshfn(ix,jy,1,n,l),akm,bkm)
< if (ol.ne.0.) then
< olin(ix,jy,1,n,l)=1./ol
< else
< olin(ix,jy,1,n,l)=99999.
< endif
<
<
< ! 3) Calculation of convective velocity scale and mixing height
< !**************************************************************
<
< do i=1,nuvz
< ulev(i)=uuhn(ix,jy,i,l)
< vlev(i)=vvhn(ix,jy,i,l)
< ttlev(i)=tthn(ix,jy,i,n,l)
< qvlev(i)=qvhn(ix,jy,i,n,l)
< end do
<
< call richardson(psn(ix,jy,1,n,l),ustarn(ix,jy,1,n,l),ttlev, &
< qvlev,ulev,vlev,nuvz,akz,bkz,sshfn(ix,jy,1,n,l), &
< tt2n(ix,jy,1,n,l),td2n(ix,jy,1,n,l),hmixn(ix,jy,1,n,l), &
< wstarn(ix,jy,1,n,l),hmixplus)
<
< if(lsubgrid.eq.1) then
< subsceff=min(excessoron(ix,jy,l),hmixplus)
< else
< subsceff=0
< endif
< !
< ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
< !
< hmixn(ix,jy,1,n,l)=hmixn(ix,jy,1,n,l)+subsceff
< hmixn(ix,jy,1,n,l)=max(hmixmin,hmixn(ix,jy,1,n,l)) ! minim PBL height
< hmixn(ix,jy,1,n,l)=min(hmixmax,hmixn(ix,jy,1,n,l)) ! maxim PBL height
<
<
< ! 4) Calculation of dry deposition velocities
< !********************************************
<
< if (DRYDEP) then
< z0(4)=0.016*ustarn(ix,jy,1,n,l)*ustarn(ix,jy,1,n,l)/ga
< z0(9)=0.016*ustarn(ix,jy,1,n,l)*ustarn(ix,jy,1,n,l)/ga
<
< ! Calculate relative humidity at surface
< !***************************************
< rh=ew(td2n(ix,jy,1,n,l))/ew(tt2n(ix,jy,1,n,l))
<
< call getvdep_nests(n,ix,jy,ustarn(ix,jy,1,n,l), &
< tt2n(ix,jy,1,n,l),psn(ix,jy,1,n,l),1./olin(ix,jy,1,n,l), &
< ssrn(ix,jy,1,n,l),rh,lsprecn(ix,jy,1,n,l)+ &
< convprecn(ix,jy,1,n,l),sdn(ix,jy,1,n,l),vd,l)
<
< do i=1,nspec
< vdepn(ix,jy,i,n,l)=vd(i)
< end do
<
< endif
<
< !******************************************************
< ! Calculate height of thermal tropopause (Hoinka, 1997)
< !******************************************************
<
< ! 1) Calculate altitudes of ECMWF model levels
< !*********************************************
<
< tvold=tt2n(ix,jy,1,n,l)*(1.+0.378*ew(td2n(ix,jy,1,n,l))/ &
< psn(ix,jy,1,n,l))
< pold=psn(ix,jy,1,n,l)
< zold=0.
< do kz=2,nuvz
< pint=akz(kz)+bkz(kz)*psn(ix,jy,1,n,l) ! pressure on model layers
< tv=tthn(ix,jy,kz,n,l)*(1.+0.608*qvhn(ix,jy,kz,n,l))
<
< if (abs(tv-tvold).gt.0.2) then
< zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
< else
< zlev(kz)=zold+const*log(pold/pint)*tv
< endif
< tvold=tv
< pold=pint
< zold=zlev(kz)
< end do
<
< ! 2) Define a minimum level kzmin, from which upward the tropopause is
< ! searched for. This is to avoid inversions in the lower troposphere
< ! to be identified as the tropopause
< !************************************************************************
<
< do kz=1,nuvz
< if (zlev(kz).ge.altmin) then
< kzmin=kz
< goto 45
< endif
< end do
< 45 continue
<
< ! 3) Search for first stable layer above minimum height that fulfills the
< ! thermal tropopause criterion
< !************************************************************************
<
< do kz=kzmin,nuvz
< do lz=kz+1,nuvz
< if ((zlev(lz)-zlev(kz)).gt.2000.) then
< if (((tthn(ix,jy,kz,n,l)-tthn(ix,jy,lz,n,l))/ &
< (zlev(lz)-zlev(kz))).lt.0.002) then
< tropopausen(ix,jy,1,n,l)=zlev(kz)
< goto 51
< endif
< goto 50
< endif
< end do
< 50 continue
< end do
< 51 continue
<
<
< end do
< end do
<
<
< call calcpv_nests(l,n,uuhn,vvhn,pvhn)
<
< end do
<
<
< end subroutine calcpar_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine calcpar_nests(n,uuhn,vvhn,pvhn)
> ! i i i o
> !*****************************************************************************
> ! *
> ! Computation of several boundary layer parameters needed for the *
> ! dispersion calculation and calculation of dry deposition velocities. *
> ! All parameters are calculated over the entire grid. *
> ! This routine is similar to calcpar, but is used for the nested grids. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 8 February 1999 *
> ! *
> ! ------------------------------------------------------------------ *
> ! Petra Seibert, Feb 2000: *
> ! convection scheme: *
> ! new variables in call to richardson *
> ! *
> !*****************************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001:
> ! Variables tth and qvh (on eta coordinates) in common block
> !*****************************************************************************
> ! *
> ! Variables: *
> ! n temporal index for meteorological fields (1 to 3) *
> ! *
> ! Constants: *
> ! *
> ! *
> ! Functions: *
> ! scalev computation of ustar *
> ! obukhov computatio of Obukhov length *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: n,ix,jy,i,l,kz,lz,kzmin
> real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus
> real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat
> real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax)
> real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real,parameter :: const=r_air/ga
>
>
> ! Loop over all nests
> !********************
>
> do l=1,numbnests
>
> ! Loop over entire grid
> !**********************
>
> do jy=0,nyn(l)-1
>
> ! Set minimum height for tropopause
> !**********************************
>
> ylat=ylat0n(l)+real(jy)*dyn(l)
> if ((ylat.ge.-20.).and.(ylat.le.20.)) then
> altmin = 5000.
> else
> if ((ylat.gt.20.).and.(ylat.lt.40.)) then
> altmin=2500.+(40.-ylat)*125.
> else if ((ylat.gt.-40.).and.(ylat.lt.-20.)) then
> altmin=2500.+(40.+ylat)*125.
> else
> altmin=2500.
> endif
> endif
>
> do ix=0,nxn(l)-1
>
> ! 1) Calculation of friction velocity
> !************************************
>
> ustarn(ix,jy,1,n,l)=scalev(psn(ix,jy,1,n,l),tt2n(ix,jy,1,n,l), &
> td2n(ix,jy,1,n,l),surfstrn(ix,jy,1,n,l))
>
> ! 2) Calculation of inverse Obukhov length scale
> !***********************************************
>
> ol=obukhov(psn(ix,jy,1,n,l),tt2n(ix,jy,1,n,l), &
> td2n(ix,jy,1,n,l),tthn(ix,jy,2,n,l),ustarn(ix,jy,1,n,l), &
> sshfn(ix,jy,1,n,l),akm,bkm)
> if (ol.ne.0.) then
> olin(ix,jy,1,n,l)=1./ol
> else
> olin(ix,jy,1,n,l)=99999.
> endif
>
>
> ! 3) Calculation of convective velocity scale and mixing height
> !**************************************************************
>
> do i=1,nuvz
> ulev(i)=uuhn(ix,jy,i,l)
> vlev(i)=vvhn(ix,jy,i,l)
> ttlev(i)=tthn(ix,jy,i,n,l)
> qvlev(i)=qvhn(ix,jy,i,n,l)
> end do
>
> call richardson(psn(ix,jy,1,n,l),ustarn(ix,jy,1,n,l),ttlev, &
> qvlev,ulev,vlev,nuvz,akz,bkz,sshfn(ix,jy,1,n,l), &
> tt2n(ix,jy,1,n,l),td2n(ix,jy,1,n,l),hmixn(ix,jy,1,n,l), &
> wstarn(ix,jy,1,n,l),hmixplus)
>
> if(lsubgrid.eq.1) then
> subsceff=min(excessoron(ix,jy,l),hmixplus)
> else
> subsceff=0
> endif
> !
> ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY
> !
> hmixn(ix,jy,1,n,l)=hmixn(ix,jy,1,n,l)+subsceff
> hmixn(ix,jy,1,n,l)=max(hmixmin,hmixn(ix,jy,1,n,l)) ! minim PBL height
> hmixn(ix,jy,1,n,l)=min(hmixmax,hmixn(ix,jy,1,n,l)) ! maxim PBL height
>
>
> ! 4) Calculation of dry deposition velocities
> !********************************************
>
> if (DRYDEP) then
> z0(4)=0.016*ustarn(ix,jy,1,n,l)*ustarn(ix,jy,1,n,l)/ga
> z0(9)=0.016*ustarn(ix,jy,1,n,l)*ustarn(ix,jy,1,n,l)/ga
>
> ! Calculate relative humidity at surface
> !***************************************
> rh=ew(td2n(ix,jy,1,n,l))/ew(tt2n(ix,jy,1,n,l))
>
> call getvdep_nests(n,ix,jy,ustarn(ix,jy,1,n,l), &
> tt2n(ix,jy,1,n,l),psn(ix,jy,1,n,l),1./olin(ix,jy,1,n,l), &
> ssrn(ix,jy,1,n,l),rh,lsprecn(ix,jy,1,n,l)+ &
> convprecn(ix,jy,1,n,l),sdn(ix,jy,1,n,l),vd,l)
>
> do i=1,nspec
> vdepn(ix,jy,i,n,l)=vd(i)
> end do
>
> endif
>
> !******************************************************
> ! Calculate height of thermal tropopause (Hoinka, 1997)
> !******************************************************
>
> ! 1) Calculate altitudes of ECMWF model levels
> !*********************************************
>
> tvold=tt2n(ix,jy,1,n,l)*(1.+0.378*ew(td2n(ix,jy,1,n,l))/ &
> psn(ix,jy,1,n,l))
> pold=psn(ix,jy,1,n,l)
> zold=0.
> do kz=2,nuvz
> pint=akz(kz)+bkz(kz)*psn(ix,jy,1,n,l) ! pressure on model layers
> tv=tthn(ix,jy,kz,n,l)*(1.+0.608*qvhn(ix,jy,kz,n,l))
>
> if (abs(tv-tvold).gt.0.2) then
> zlev(kz)=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
> else
> zlev(kz)=zold+const*log(pold/pint)*tv
> endif
> tvold=tv
> pold=pint
> zold=zlev(kz)
> end do
>
> ! 2) Define a minimum level kzmin, from which upward the tropopause is
> ! searched for. This is to avoid inversions in the lower troposphere
> ! to be identified as the tropopause
> !************************************************************************
>
> do kz=1,nuvz
> if (zlev(kz).ge.altmin) then
> kzmin=kz
> goto 45
> endif
> end do
> 45 continue
>
> ! 3) Search for first stable layer above minimum height that fulfills the
> ! thermal tropopause criterion
> !************************************************************************
>
> do kz=kzmin,nuvz
> do lz=kz+1,nuvz
> if ((zlev(lz)-zlev(kz)).gt.2000.) then
> if (((tthn(ix,jy,kz,n,l)-tthn(ix,jy,lz,n,l))/ &
> (zlev(lz)-zlev(kz))).lt.0.002) then
> tropopausen(ix,jy,1,n,l)=zlev(kz)
> goto 51
> endif
> goto 50
> endif
> end do
> 50 continue
> end do
> 51 continue
>
>
> end do
> end do
>
> ! call dump_field("sshf_dump", sshfn(0:nxn(l)-1, 0:nyn(l)-1, 1, n, l), nxn(l), nyn(l), 1)
> ! call dump_field("ustar_dump", ustarn(0:nxn(l)-1, 0:nyn(l)-1, 1, n, l), nxn(l), nyn(l), 1)
> ! call dump_field("wstar_dump", wstarn(0:nxn(l)-1, 0:nyn(l)-1, 1, n, l), nxn(l), nyn(l), 1)
> ! stop
>
> call calcpv_nests(l,n,uuhn,vvhn,pvhn)
>
> end do
>
>
> end subroutine calcpar_nests
calcpv.f90
----------------------------------------------
1,337c1,337
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine calcpv(n,uuh,vvh,pvh)
< ! i i i o
< !*****************************************************************************
< ! *
< ! Calculation of potential vorticity on 3-d grid. *
< ! *
< ! Author: P. James *
< ! 3 February 2000 *
< ! *
< ! Adaptation to FLEXPART, A. Stohl, 1 May 2000 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! n temporal index for meteorological fields (1 to 2) *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
< integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
< integer :: nlck
< real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
< real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt,ppmk
< real :: pvavr,ppml(nuvzmax)
< real :: thup,thdn
< real,parameter :: eps=1.e-5, p0=101325
< real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
<
< ! Set number of levels to check for adjacent theta
< nlck=nuvz/3
< !
< ! Loop over entire grid
< !**********************
< do jy=0,nymin1
< if (sglobal.and.jy.eq.0) goto 10
< if (nglobal.and.jy.eq.nymin1) goto 10
< phi = (ylat0 + jy * dy) * pi / 180.
< f = 0.00014585 * sin(phi)
< tanphi = tan(phi)
< cosphi = cos(phi)
< ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
< jyvp=jy+1
< jyvm=jy-1
< if (jy.eq.0) jyvm=0
< if (jy.eq.nymin1) jyvp=nymin1
< ! Define absolute gap length
< jumpy=2
< if (jy.eq.0.or.jy.eq.nymin1) jumpy=1
< if (sglobal.and.jy.eq.1) then
< jyvm=1
< jumpy=1
< end if
< if (nglobal.and.jy.eq.ny-2) then
< jyvp=ny-2
< jumpy=1
< end if
< juy=jumpy
< !
< do ix=0,nxmin1
< ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
< ixvp=ix+1
< ixvm=ix-1
< jumpx=2
< if (xglobal) then
< ivrp=ixvp
< ivrm=ixvm
< if (ixvm.lt.0) ivrm=ixvm+nxmin1
< if (ixvp.ge.nx) ivrp=ixvp-nx+1
< else
< if (ix.eq.0) ixvm=0
< if (ix.eq.nxmin1) ixvp=nxmin1
< ivrp=ixvp
< ivrm=ixvm
< ! Define absolute gap length
< if (ix.eq.0.or.ix.eq.nxmin1) jumpx=1
< end if
< jux=jumpx
< ! Precalculate pressure values for efficiency
< do kl=1,nuvz
< ppml(kl)=akz(kl)+bkz(kl)*ps(ix,jy,1,n)
< end do
< !
< ! Loop over the vertical
< !***********************
<
< do kl=1,nuvz
< ppmk=akz(kl)+bkz(kl)*ps(ix,jy,1,n)
< theta=tth(ix,jy,kl,n)*(100000./ppmk)**kappa
< klvrp=kl+1
< klvrm=kl-1
< klpt=kl
< ! If top or bottom level, dthetadp is evaluated between the current
< ! level and the level inside, otherwise between level+1 and level-1
< !
< if (klvrp.gt.nuvz) klvrp=nuvz
< if (klvrm.lt.1) klvrm=1
< ppmk=akz(klvrp)+bkz(klvrp)*ps(ix,jy,1,n)
< thetap=tth(ix,jy,klvrp,n)*(100000./ppmk)**kappa
< ppmk=akz(klvrm)+bkz(klvrm)*ps(ix,jy,1,n)
< thetam=tth(ix,jy,klvrm,n)*(100000./ppmk)**kappa
< dthetadp=(thetap-thetam)/(ppml(klvrp)-ppml(klvrm))
<
< ! Compute vertical position at pot. temperature surface on subgrid
< ! and the wind at that position
< !*****************************************************************
< ! a) in x direction
< ii=0
< do i=ixvm,ixvp,jumpx
< ivr=i
< if (xglobal) then
< if (i.lt.0) ivr=ivr+nxmin1
< if (i.ge.nx) ivr=ivr-nx+1
< end if
< ii=ii+1
< ! Search adjacent levels for current theta value
< ! Spiral out from current level for efficiency
< kup=klpt-1
< kdn=klpt
< kch=0
< 40 continue
< ! Upward branch
< kup=kup+1
< if (kch.ge.nlck) goto 21 ! No more levels to check,
< ! ! and no values found
< if (kup.ge.nuvz) goto 41
< kch=kch+1
< k=kup
< ppmk=akz(k)+bkz(k)*ps(ivr,jy,1,n)
< thdn=tth(ivr,jy,k,n)*(100000./ppmk)**kappa
< ppmk=akz(k+1)+bkz(k+1)*ps(ivr,jy,1,n)
< thup=tth(ivr,jy,k+1,n)*(100000./ppmk)**kappa
<
<
< if (((thdn.ge.theta).and.(thup.le.theta)).or. &
< ((thdn.le.theta).and.(thup.ge.theta))) then
< dt1=abs(theta-thdn)
< dt2=abs(theta-thup)
< dt=dt1+dt2
< if (dt.lt.eps) then ! Avoid division by zero error
< dt1=0.5 ! G.W., 10.4.1996
< dt2=0.5
< dt=1.0
< endif
< vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
< goto 20
< endif
< 41 continue
< ! Downward branch
< kdn=kdn-1
< if (kdn.lt.1) goto 40
< kch=kch+1
< k=kdn
< ppmk=akz(k)+bkz(k)*ps(ivr,jy,1,n)
< thdn=tth(ivr,jy,k,n)*(100000./ppmk)**kappa
< ppmk=akz(k+1)+bkz(k+1)*ps(ivr,jy,1,n)
< thup=tth(ivr,jy,k+1,n)*(100000./ppmk)**kappa
<
< if (((thdn.ge.theta).and.(thup.le.theta)).or. &
< ((thdn.le.theta).and.(thup.ge.theta))) then
< dt1=abs(theta-thdn)
< dt2=abs(theta-thup)
< dt=dt1+dt2
< if (dt.lt.eps) then ! Avoid division by zero error
< dt1=0.5 ! G.W., 10.4.1996
< dt2=0.5
< dt=1.0
< endif
< vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
< goto 20
< endif
< goto 40
< ! This section used when no values were found
< 21 continue
< ! Must use vv at current level and long. jux becomes smaller by 1
< vx(ii)=vvh(ix,jy,kl)
< jux=jux-1
< ! Otherwise OK
< 20 continue
< end do
< if (jux.gt.0) then
< dvdx=(vx(2)-vx(1))/real(jux)/(dx*pi/180.)
< else
< dvdx=vvh(ivrp,jy,kl)-vvh(ivrm,jy,kl)
< dvdx=dvdx/real(jumpx)/(dx*pi/180.)
< ! Only happens if no equivalent theta value
< ! can be found on either side, hence must use values
< ! from either side, same pressure level.
< end if
<
< ! b) in y direction
<
< jj=0
< do j=jyvm,jyvp,jumpy
< jj=jj+1
< ! Search adjacent levels for current theta value
< ! Spiral out from current level for efficiency
< kup=klpt-1
< kdn=klpt
< kch=0
< 70 continue
< ! Upward branch
< kup=kup+1
< if (kch.ge.nlck) goto 51 ! No more levels to check,
< ! ! and no values found
< if (kup.ge.nuvz) goto 71
< kch=kch+1
< k=kup
< ppmk=akz(k)+bkz(k)*ps(ix,j,1,n)
< thdn=tth(ix,j,k,n)*(100000./ppmk)**kappa
< ppmk=akz(k+1)+bkz(k+1)*ps(ix,j,1,n)
< thup=tth(ix,j,k+1,n)*(100000./ppmk)**kappa
< if (((thdn.ge.theta).and.(thup.le.theta)).or. &
< ((thdn.le.theta).and.(thup.ge.theta))) then
< dt1=abs(theta-thdn)
< dt2=abs(theta-thup)
< dt=dt1+dt2
< if (dt.lt.eps) then ! Avoid division by zero error
< dt1=0.5 ! G.W., 10.4.1996
< dt2=0.5
< dt=1.0
< endif
< uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
< goto 50
< endif
< 71 continue
< ! Downward branch
< kdn=kdn-1
< if (kdn.lt.1) goto 70
< kch=kch+1
< k=kdn
< ppmk=akz(k)+bkz(k)*ps(ix,j,1,n)
< thdn=tth(ix,j,k,n)*(100000./ppmk)**kappa
< ppmk=akz(k+1)+bkz(k+1)*ps(ix,j,1,n)
< thup=tth(ix,j,k+1,n)*(100000./ppmk)**kappa
< if (((thdn.ge.theta).and.(thup.le.theta)).or. &
< ((thdn.le.theta).and.(thup.ge.theta))) then
< dt1=abs(theta-thdn)
< dt2=abs(theta-thup)
< dt=dt1+dt2
< if (dt.lt.eps) then ! Avoid division by zero error
< dt1=0.5 ! G.W., 10.4.1996
< dt2=0.5
< dt=1.0
< endif
< uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
< goto 50
< endif
< goto 70
< ! This section used when no values were found
< 51 continue
< ! Must use uu at current level and lat. juy becomes smaller by 1
< uy(jj)=uuh(ix,jy,kl)
< juy=juy-1
< ! Otherwise OK
< 50 continue
< end do
< if (juy.gt.0) then
< dudy=(uy(2)-uy(1))/real(juy)/(dy*pi/180.)
< else
< dudy=uuh(ix,jyvp,kl)-uuh(ix,jyvm,kl)
< dudy=dudy/real(jumpy)/(dy*pi/180.)
< end if
< !
< pvh(ix,jy,kl)=dthetadp*(f+(dvdx/cosphi-dudy &
< +uuh(ix,jy,kl)*tanphi)/r_earth)*(-1.e6)*9.81
<
<
< !
< ! Resest jux and juy
< jux=jumpx
< juy=jumpy
< end do
< end do
< 10 continue
< end do
< !
< ! Fill in missing PV values on poles, if present
< ! Use mean PV of surrounding latitude ring
< !
< if (sglobal) then
< do kl=1,nuvz
< pvavr=0.
< do ix=0,nxmin1
< pvavr=pvavr+pvh(ix,1,kl)
< end do
< pvavr=pvavr/real(nx)
< jy=0
< do ix=0,nxmin1
< pvh(ix,jy,kl)=pvavr
< end do
< end do
< end if
< if (nglobal) then
< do kl=1,nuvz
< pvavr=0.
< do ix=0,nxmin1
< pvavr=pvavr+pvh(ix,ny-2,kl)
< end do
< pvavr=pvavr/real(nx)
< jy=nymin1
< do ix=0,nxmin1
< pvh(ix,jy,kl)=pvavr
< end do
< end do
< end if
<
< end subroutine calcpv
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine calcpv(n,uuh,vvh,pvh)
> ! i i i o
> !*****************************************************************************
> ! *
> ! Calculation of potential vorticity on 3-d grid. *
> ! *
> ! Author: P. James *
> ! 3 February 2000 *
> ! *
> ! Adaptation to FLEXPART, A. Stohl, 1 May 2000 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! n temporal index for meteorological fields (1 to 2) *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
> integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
> integer :: nlck
> real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
> real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt,ppmk
> real :: pvavr,ppml(nuvzmax)
> real :: thup,thdn
> real,parameter :: eps=1.e-5, p0=101325
> real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
>
> ! Set number of levels to check for adjacent theta
> nlck=nuvz/3
> !
> ! Loop over entire grid
> !**********************
> do jy=0,nymin1
> if (sglobal.and.jy.eq.0) goto 10
> if (nglobal.and.jy.eq.nymin1) goto 10
> phi = (ylat0 + jy * dy) * pi / 180.
> f = 0.00014585 * sin(phi)
> tanphi = tan(phi)
> cosphi = cos(phi)
> ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
> jyvp=jy+1
> jyvm=jy-1
> if (jy.eq.0) jyvm=0
> if (jy.eq.nymin1) jyvp=nymin1
> ! Define absolute gap length
> jumpy=2
> if (jy.eq.0.or.jy.eq.nymin1) jumpy=1
> if (sglobal.and.jy.eq.1) then
> jyvm=1
> jumpy=1
> end if
> if (nglobal.and.jy.eq.ny-2) then
> jyvp=ny-2
> jumpy=1
> end if
> juy=jumpy
> !
> do ix=0,nxmin1
> ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
> ixvp=ix+1
> ixvm=ix-1
> jumpx=2
> if (xglobal) then
> ivrp=ixvp
> ivrm=ixvm
> if (ixvm.lt.0) ivrm=ixvm+nxmin1
> if (ixvp.ge.nx) ivrp=ixvp-nx+1
> else
> if (ix.eq.0) ixvm=0
> if (ix.eq.nxmin1) ixvp=nxmin1
> ivrp=ixvp
> ivrm=ixvm
> ! Define absolute gap length
> if (ix.eq.0.or.ix.eq.nxmin1) jumpx=1
> end if
> jux=jumpx
> ! Precalculate pressure values for efficiency
> do kl=1,nuvz
> ppml(kl)=akz(kl)+bkz(kl)*ps(ix,jy,1,n)
> end do
> !
> ! Loop over the vertical
> !***********************
>
> do kl=1,nuvz
> ppmk=akz(kl)+bkz(kl)*ps(ix,jy,1,n)
> theta=tth(ix,jy,kl,n)*(100000./ppmk)**kappa
> klvrp=kl+1
> klvrm=kl-1
> klpt=kl
> ! If top or bottom level, dthetadp is evaluated between the current
> ! level and the level inside, otherwise between level+1 and level-1
> !
> if (klvrp.gt.nuvz) klvrp=nuvz
> if (klvrm.lt.1) klvrm=1
> ppmk=akz(klvrp)+bkz(klvrp)*ps(ix,jy,1,n)
> thetap=tth(ix,jy,klvrp,n)*(100000./ppmk)**kappa
> ppmk=akz(klvrm)+bkz(klvrm)*ps(ix,jy,1,n)
> thetam=tth(ix,jy,klvrm,n)*(100000./ppmk)**kappa
> dthetadp=(thetap-thetam)/(ppml(klvrp)-ppml(klvrm))
>
> ! Compute vertical position at pot. temperature surface on subgrid
> ! and the wind at that position
> !*****************************************************************
> ! a) in x direction
> ii=0
> do i=ixvm,ixvp,jumpx
> ivr=i
> if (xglobal) then
> if (i.lt.0) ivr=ivr+nxmin1
> if (i.ge.nx) ivr=ivr-nx+1
> end if
> ii=ii+1
> ! Search adjacent levels for current theta value
> ! Spiral out from current level for efficiency
> kup=klpt-1
> kdn=klpt
> kch=0
> 40 continue
> ! Upward branch
> kup=kup+1
> if (kch.ge.nlck) goto 21 ! No more levels to check,
> ! ! and no values found
> if (kup.ge.nuvz) goto 41
> kch=kch+1
> k=kup
> ppmk=akz(k)+bkz(k)*ps(ivr,jy,1,n)
> thdn=tth(ivr,jy,k,n)*(100000./ppmk)**kappa
> ppmk=akz(k+1)+bkz(k+1)*ps(ivr,jy,1,n)
> thup=tth(ivr,jy,k+1,n)*(100000./ppmk)**kappa
>
>
> if (((thdn.ge.theta).and.(thup.le.theta)).or. &
> ((thdn.le.theta).and.(thup.ge.theta))) then
> dt1=abs(theta-thdn)
> dt2=abs(theta-thup)
> dt=dt1+dt2
> if (dt.lt.eps) then ! Avoid division by zero error
> dt1=0.5 ! G.W., 10.4.1996
> dt2=0.5
> dt=1.0
> endif
> vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
> goto 20
> endif
> 41 continue
> ! Downward branch
> kdn=kdn-1
> if (kdn.lt.1) goto 40
> kch=kch+1
> k=kdn
> ppmk=akz(k)+bkz(k)*ps(ivr,jy,1,n)
> thdn=tth(ivr,jy,k,n)*(100000./ppmk)**kappa
> ppmk=akz(k+1)+bkz(k+1)*ps(ivr,jy,1,n)
> thup=tth(ivr,jy,k+1,n)*(100000./ppmk)**kappa
>
> if (((thdn.ge.theta).and.(thup.le.theta)).or. &
> ((thdn.le.theta).and.(thup.ge.theta))) then
> dt1=abs(theta-thdn)
> dt2=abs(theta-thup)
> dt=dt1+dt2
> if (dt.lt.eps) then ! Avoid division by zero error
> dt1=0.5 ! G.W., 10.4.1996
> dt2=0.5
> dt=1.0
> endif
> vx(ii)=(vvh(ivr,jy,k)*dt2+vvh(ivr,jy,k+1)*dt1)/dt
> goto 20
> endif
> goto 40
> ! This section used when no values were found
> 21 continue
> ! Must use vv at current level and long. jux becomes smaller by 1
> vx(ii)=vvh(ix,jy,kl)
> jux=jux-1
> ! Otherwise OK
> 20 continue
> end do
> if (jux.gt.0) then
> dvdx=(vx(2)-vx(1))/real(jux)/(dx*pi/180.)
> else
> dvdx=vvh(ivrp,jy,kl)-vvh(ivrm,jy,kl)
> dvdx=dvdx/real(jumpx)/(dx*pi/180.)
> ! Only happens if no equivalent theta value
> ! can be found on either side, hence must use values
> ! from either side, same pressure level.
> end if
>
> ! b) in y direction
>
> jj=0
> do j=jyvm,jyvp,jumpy
> jj=jj+1
> ! Search adjacent levels for current theta value
> ! Spiral out from current level for efficiency
> kup=klpt-1
> kdn=klpt
> kch=0
> 70 continue
> ! Upward branch
> kup=kup+1
> if (kch.ge.nlck) goto 51 ! No more levels to check,
> ! ! and no values found
> if (kup.ge.nuvz) goto 71
> kch=kch+1
> k=kup
> ppmk=akz(k)+bkz(k)*ps(ix,j,1,n)
> thdn=tth(ix,j,k,n)*(100000./ppmk)**kappa
> ppmk=akz(k+1)+bkz(k+1)*ps(ix,j,1,n)
> thup=tth(ix,j,k+1,n)*(100000./ppmk)**kappa
> if (((thdn.ge.theta).and.(thup.le.theta)).or. &
> ((thdn.le.theta).and.(thup.ge.theta))) then
> dt1=abs(theta-thdn)
> dt2=abs(theta-thup)
> dt=dt1+dt2
> if (dt.lt.eps) then ! Avoid division by zero error
> dt1=0.5 ! G.W., 10.4.1996
> dt2=0.5
> dt=1.0
> endif
> uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
> goto 50
> endif
> 71 continue
> ! Downward branch
> kdn=kdn-1
> if (kdn.lt.1) goto 70
> kch=kch+1
> k=kdn
> ppmk=akz(k)+bkz(k)*ps(ix,j,1,n)
> thdn=tth(ix,j,k,n)*(100000./ppmk)**kappa
> ppmk=akz(k+1)+bkz(k+1)*ps(ix,j,1,n)
> thup=tth(ix,j,k+1,n)*(100000./ppmk)**kappa
> if (((thdn.ge.theta).and.(thup.le.theta)).or. &
> ((thdn.le.theta).and.(thup.ge.theta))) then
> dt1=abs(theta-thdn)
> dt2=abs(theta-thup)
> dt=dt1+dt2
> if (dt.lt.eps) then ! Avoid division by zero error
> dt1=0.5 ! G.W., 10.4.1996
> dt2=0.5
> dt=1.0
> endif
> uy(jj)=(uuh(ix,j,k)*dt2+uuh(ix,j,k+1)*dt1)/dt
> goto 50
> endif
> goto 70
> ! This section used when no values were found
> 51 continue
> ! Must use uu at current level and lat. juy becomes smaller by 1
> uy(jj)=uuh(ix,jy,kl)
> juy=juy-1
> ! Otherwise OK
> 50 continue
> end do
> if (juy.gt.0) then
> dudy=(uy(2)-uy(1))/real(juy)/(dy*pi/180.)
> else
> dudy=uuh(ix,jyvp,kl)-uuh(ix,jyvm,kl)
> dudy=dudy/real(jumpy)/(dy*pi/180.)
> end if
> !
> pvh(ix,jy,kl)=dthetadp*(f+(dvdx/cosphi-dudy &
> +uuh(ix,jy,kl)*tanphi)/r_earth)*(-1.e6)*9.81
>
>
> !
> ! Resest jux and juy
> jux=jumpx
> juy=jumpy
> end do
> end do
> 10 continue
> end do
> !
> ! Fill in missing PV values on poles, if present
> ! Use mean PV of surrounding latitude ring
> !
> if (sglobal) then
> do kl=1,nuvz
> pvavr=0.
> do ix=0,nxmin1
> pvavr=pvavr+pvh(ix,1,kl)
> end do
> pvavr=pvavr/real(nx)
> jy=0
> do ix=0,nxmin1
> pvh(ix,jy,kl)=pvavr
> end do
> end do
> end if
> if (nglobal) then
> do kl=1,nuvz
> pvavr=0.
> do ix=0,nxmin1
> pvavr=pvavr+pvh(ix,ny-2,kl)
> end do
> pvavr=pvavr/real(nx)
> jy=nymin1
> do ix=0,nxmin1
> pvh(ix,jy,kl)=pvavr
> end do
> end do
> end if
>
> end subroutine calcpv
calcpv_nests.f90
----------------------------------------------
1,281c1,281
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine calcpv_nests(l,n,uuhn,vvhn,pvhn)
< ! i i i i o
< !*****************************************************************************
< ! *
< ! Calculation of potential vorticity on 3-d nested grid *
< ! *
< ! Author: P. James *
< ! 22 February 2000 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! n temporal index for meteorological fields (1 to 2) *
< ! l index of current nest *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
< integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
< integer :: nlck,l
< real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
< real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt,ppmk
< real :: ppml(nuvzmax)
< real :: thup,thdn
< real,parameter :: eps=1.e-5,p0=101325
< real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
<
< ! Set number of levels to check for adjacent theta
< nlck=nuvz/3
< !
< ! Loop over entire grid
< !**********************
< do jy=0,nyn(l)-1
< phi = (ylat0n(l) + jy * dyn(l)) * pi / 180.
< f = 0.00014585 * sin(phi)
< tanphi = tan(phi)
< cosphi = cos(phi)
< ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
< jyvp=jy+1
< jyvm=jy-1
< if (jy.eq.0) jyvm=0
< if (jy.eq.nyn(l)-1) jyvp=nyn(l)-1
< ! Define absolute gap length
< jumpy=2
< if (jy.eq.0.or.jy.eq.nyn(l)-1) jumpy=1
< juy=jumpy
< !
< do ix=0,nxn(l)-1
< ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
< ixvp=ix+1
< ixvm=ix-1
< jumpx=2
< if (ix.eq.0) ixvm=0
< if (ix.eq.nxn(l)-1) ixvp=nxn(l)-1
< ivrp=ixvp
< ivrm=ixvm
< ! Define absolute gap length
< if (ix.eq.0.or.ix.eq.nxn(l)-1) jumpx=1
< jux=jumpx
< ! Precalculate pressure values for efficiency
< do kl=1,nuvz
< ppml(kl)=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l)
< end do
< !
< ! Loop over the vertical
< !***********************
<
< do kl=1,nuvz
< ppmk=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l)
< theta=tthn(ix,jy,kl,n,l)*(100000./ppmk)**kappa
< klvrp=kl+1
< klvrm=kl-1
< klpt=kl
< ! If top or bottom level, dthetadp is evaluated between the current
< ! level and the level inside, otherwise between level+1 and level-1
< !
< if (klvrp.gt.nuvz) klvrp=nuvz
< if (klvrm.lt.1) klvrm=1
< ppmk=akz(klvrp)+bkz(klvrp)*psn(ix,jy,1,n,l)
< thetap=tthn(ix,jy,klvrp,n,l)*(100000./ppmk)**kappa
< ppmk=akz(klvrm)+bkz(klvrm)*psn(ix,jy,1,n,l)
< thetam=tthn(ix,jy,klvrm,n,l)*(100000./ppmk)**kappa
< dthetadp=(thetap-thetam)/(ppml(klvrp)-ppml(klvrm))
<
< ! Compute vertical position at pot. temperature surface on subgrid
< ! and the wind at that position
< !*****************************************************************
< ! a) in x direction
< ii=0
< do i=ixvm,ixvp,jumpx
< ivr=i
< ii=ii+1
< ! Search adjacent levels for current theta value
< ! Spiral out from current level for efficiency
< kup=klpt-1
< kdn=klpt
< kch=0
< 40 continue
< ! Upward branch
< kup=kup+1
< if (kch.ge.nlck) goto 21 ! No more levels to check,
< ! ! and no values found
< if (kup.ge.nuvz) goto 41
< kch=kch+1
< k=kup
< ppmk=akz(k)+bkz(k)*psn(ivr,jy,1,n,l)
< thdn=tthn(ivr,jy,k,n,l)*(100000./ppmk)**kappa
< ppmk=akz(k+1)+bkz(k+1)*psn(ivr,jy,1,n,l)
< thup=tthn(ivr,jy,k+1,n,l)*(100000./ppmk)**kappa
<
< if (((thdn.ge.theta).and.(thup.le.theta)).or. &
< ((thdn.le.theta).and.(thup.ge.theta))) then
< dt1=abs(theta-thdn)
< dt2=abs(theta-thup)
< dt=dt1+dt2
< if (dt.lt.eps) then ! Avoid division by zero error
< dt1=0.5 ! G.W., 10.4.1996
< dt2=0.5
< dt=1.0
< endif
< vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
< goto 20
< endif
< 41 continue
< ! Downward branch
< kdn=kdn-1
< if (kdn.lt.1) goto 40
< kch=kch+1
< k=kdn
< ppmk=akz(k)+bkz(k)*psn(ivr,jy,1,n,l)
< thdn=tthn(ivr,jy,k,n,l)*(100000./ppmk)**kappa
< ppmk=akz(k+1)+bkz(k+1)*psn(ivr,jy,1,n,l)
< thup=tthn(ivr,jy,k+1,n,l)*(100000./ppmk)**kappa
< if (((thdn.ge.theta).and.(thup.le.theta)).or. &
< ((thdn.le.theta).and.(thup.ge.theta))) then
< dt1=abs(theta-thdn)
< dt2=abs(theta-thup)
< dt=dt1+dt2
< if (dt.lt.eps) then ! Avoid division by zero error
< dt1=0.5 ! G.W., 10.4.1996
< dt2=0.5
< dt=1.0
< endif
< vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
< goto 20
< endif
< goto 40
< ! This section used when no values were found
< 21 continue
< ! Must use vv at current level and long. jux becomes smaller by 1
< vx(ii)=vvhn(ix,jy,kl,l)
< jux=jux-1
< ! Otherwise OK
< 20 continue
< end do
< if (jux.gt.0) then
< dvdx=(vx(2)-vx(1))/real(jux)/(dxn(l)*pi/180.)
< else
< dvdx=vvhn(ivrp,jy,kl,l)-vvhn(ivrm,jy,kl,l)
< dvdx=dvdx/real(jumpx)/(dxn(l)*pi/180.)
< ! Only happens if no equivalent theta value
< ! can be found on either side, hence must use values
< ! from either side, same pressure level.
< end if
<
< ! b) in y direction
<
< jj=0
< do j=jyvm,jyvp,jumpy
< jj=jj+1
< ! Search adjacent levels for current theta value
< ! Spiral out from current level for efficiency
< kup=klpt-1
< kdn=klpt
< kch=0
< 70 continue
< ! Upward branch
< kup=kup+1
< if (kch.ge.nlck) goto 51 ! No more levels to check,
< ! ! and no values found
< if (kup.ge.nuvz) goto 71
< kch=kch+1
< k=kup
< ppmk=akz(k)+bkz(k)*psn(ix,j,1,n,l)
< thdn=tthn(ix,j,k,n,l)*(100000./ppmk)**kappa
< ppmk=akz(k+1)+bkz(k+1)*psn(ix,j,1,n,l)
< thup=tthn(ix,j,k+1,n,l)*(100000./ppmk)**kappa
< if (((thdn.ge.theta).and.(thup.le.theta)).or. &
< ((thdn.le.theta).and.(thup.ge.theta))) then
< dt1=abs(theta-thdn)
< dt2=abs(theta-thup)
< dt=dt1+dt2
< if (dt.lt.eps) then ! Avoid division by zero error
< dt1=0.5 ! G.W., 10.4.1996
< dt2=0.5
< dt=1.0
< endif
< uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
< goto 50
< endif
< 71 continue
< ! Downward branch
< kdn=kdn-1
< if (kdn.lt.1) goto 70
< kch=kch+1
< k=kdn
< ppmk=akz(k)+bkz(k)*psn(ix,j,1,n,l)
< thdn=tthn(ix,j,k,n,l)*(100000./ppmk)**kappa
< ppmk=akz(k+1)+bkz(k+1)*psn(ix,j,1,n,l)
< thup=tthn(ix,j,k+1,n,l)*(100000./ppmk)**kappa
< if (((thdn.ge.theta).and.(thup.le.theta)).or. &
< ((thdn.le.theta).and.(thup.ge.theta))) then
< dt1=abs(theta-thdn)
< dt2=abs(theta-thup)
< dt=dt1+dt2
< if (dt.lt.eps) then ! Avoid division by zero error
< dt1=0.5 ! G.W., 10.4.1996
< dt2=0.5
< dt=1.0
< endif
< uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
< goto 50
< endif
< goto 70
< ! This section used when no values were found
< 51 continue
< ! Must use uu at current level and lat. juy becomes smaller by 1
< uy(jj)=uuhn(ix,jy,kl,l)
< juy=juy-1
< ! Otherwise OK
< 50 continue
< end do
< if (juy.gt.0) then
< dudy=(uy(2)-uy(1))/real(juy)/(dyn(l)*pi/180.)
< else
< dudy=uuhn(ix,jyvp,kl,l)-uuhn(ix,jyvm,kl,l)
< dudy=dudy/real(jumpy)/(dyn(l)*pi/180.)
< end if
< !
< pvhn(ix,jy,kl,l)=dthetadp*(f+(dvdx/cosphi-dudy &
< +uuhn(ix,jy,kl,l)*tanphi)/r_earth)*(-1.e6)*9.81
<
< !
< ! Resest jux and juy
< jux=jumpx
< juy=jumpy
< end do
< end do
< end do
< !
< end subroutine calcpv_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine calcpv_nests(l,n,uuhn,vvhn,pvhn)
> ! i i i i o
> !*****************************************************************************
> ! *
> ! Calculation of potential vorticity on 3-d nested grid *
> ! *
> ! Author: P. James *
> ! 22 February 2000 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! n temporal index for meteorological fields (1 to 2) *
> ! l index of current nest *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: n,ix,jy,i,j,k,kl,ii,jj,klvrp,klvrm,klpt,kup,kdn,kch
> integer :: jyvp,jyvm,ixvp,ixvm,jumpx,jumpy,jux,juy,ivrm,ivrp,ivr
> integer :: nlck,l
> real :: vx(2),uy(2),phi,tanphi,cosphi,dvdx,dudy,f
> real :: theta,thetap,thetam,dthetadp,dt1,dt2,dt,ppmk
> real :: ppml(nuvzmax)
> real :: thup,thdn
> real,parameter :: eps=1.e-5,p0=101325
> real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
>
> ! Set number of levels to check for adjacent theta
> nlck=nuvz/3
> !
> ! Loop over entire grid
> !**********************
> do jy=0,nyn(l)-1
> phi = (ylat0n(l) + jy * dyn(l)) * pi / 180.
> f = 0.00014585 * sin(phi)
> tanphi = tan(phi)
> cosphi = cos(phi)
> ! Provide a virtual jy+1 and jy-1 in case we are on domain edge (Lat)
> jyvp=jy+1
> jyvm=jy-1
> if (jy.eq.0) jyvm=0
> if (jy.eq.nyn(l)-1) jyvp=nyn(l)-1
> ! Define absolute gap length
> jumpy=2
> if (jy.eq.0.or.jy.eq.nyn(l)-1) jumpy=1
> juy=jumpy
> !
> do ix=0,nxn(l)-1
> ! Provide a virtual ix+1 and ix-1 in case we are on domain edge (Long)
> ixvp=ix+1
> ixvm=ix-1
> jumpx=2
> if (ix.eq.0) ixvm=0
> if (ix.eq.nxn(l)-1) ixvp=nxn(l)-1
> ivrp=ixvp
> ivrm=ixvm
> ! Define absolute gap length
> if (ix.eq.0.or.ix.eq.nxn(l)-1) jumpx=1
> jux=jumpx
> ! Precalculate pressure values for efficiency
> do kl=1,nuvz
> ppml(kl)=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l)
> end do
> !
> ! Loop over the vertical
> !***********************
>
> do kl=1,nuvz
> ppmk=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l)
> theta=tthn(ix,jy,kl,n,l)*(100000./ppmk)**kappa
> klvrp=kl+1
> klvrm=kl-1
> klpt=kl
> ! If top or bottom level, dthetadp is evaluated between the current
> ! level and the level inside, otherwise between level+1 and level-1
> !
> if (klvrp.gt.nuvz) klvrp=nuvz
> if (klvrm.lt.1) klvrm=1
> ppmk=akz(klvrp)+bkz(klvrp)*psn(ix,jy,1,n,l)
> thetap=tthn(ix,jy,klvrp,n,l)*(100000./ppmk)**kappa
> ppmk=akz(klvrm)+bkz(klvrm)*psn(ix,jy,1,n,l)
> thetam=tthn(ix,jy,klvrm,n,l)*(100000./ppmk)**kappa
> dthetadp=(thetap-thetam)/(ppml(klvrp)-ppml(klvrm))
>
> ! Compute vertical position at pot. temperature surface on subgrid
> ! and the wind at that position
> !*****************************************************************
> ! a) in x direction
> ii=0
> do i=ixvm,ixvp,jumpx
> ivr=i
> ii=ii+1
> ! Search adjacent levels for current theta value
> ! Spiral out from current level for efficiency
> kup=klpt-1
> kdn=klpt
> kch=0
> 40 continue
> ! Upward branch
> kup=kup+1
> if (kch.ge.nlck) goto 21 ! No more levels to check,
> ! ! and no values found
> if (kup.ge.nuvz) goto 41
> kch=kch+1
> k=kup
> ppmk=akz(k)+bkz(k)*psn(ivr,jy,1,n,l)
> thdn=tthn(ivr,jy,k,n,l)*(100000./ppmk)**kappa
> ppmk=akz(k+1)+bkz(k+1)*psn(ivr,jy,1,n,l)
> thup=tthn(ivr,jy,k+1,n,l)*(100000./ppmk)**kappa
>
> if (((thdn.ge.theta).and.(thup.le.theta)).or. &
> ((thdn.le.theta).and.(thup.ge.theta))) then
> dt1=abs(theta-thdn)
> dt2=abs(theta-thup)
> dt=dt1+dt2
> if (dt.lt.eps) then ! Avoid division by zero error
> dt1=0.5 ! G.W., 10.4.1996
> dt2=0.5
> dt=1.0
> endif
> vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
> goto 20
> endif
> 41 continue
> ! Downward branch
> kdn=kdn-1
> if (kdn.lt.1) goto 40
> kch=kch+1
> k=kdn
> ppmk=akz(k)+bkz(k)*psn(ivr,jy,1,n,l)
> thdn=tthn(ivr,jy,k,n,l)*(100000./ppmk)**kappa
> ppmk=akz(k+1)+bkz(k+1)*psn(ivr,jy,1,n,l)
> thup=tthn(ivr,jy,k+1,n,l)*(100000./ppmk)**kappa
> if (((thdn.ge.theta).and.(thup.le.theta)).or. &
> ((thdn.le.theta).and.(thup.ge.theta))) then
> dt1=abs(theta-thdn)
> dt2=abs(theta-thup)
> dt=dt1+dt2
> if (dt.lt.eps) then ! Avoid division by zero error
> dt1=0.5 ! G.W., 10.4.1996
> dt2=0.5
> dt=1.0
> endif
> vx(ii)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt
> goto 20
> endif
> goto 40
> ! This section used when no values were found
> 21 continue
> ! Must use vv at current level and long. jux becomes smaller by 1
> vx(ii)=vvhn(ix,jy,kl,l)
> jux=jux-1
> ! Otherwise OK
> 20 continue
> end do
> if (jux.gt.0) then
> dvdx=(vx(2)-vx(1))/real(jux)/(dxn(l)*pi/180.)
> else
> dvdx=vvhn(ivrp,jy,kl,l)-vvhn(ivrm,jy,kl,l)
> dvdx=dvdx/real(jumpx)/(dxn(l)*pi/180.)
> ! Only happens if no equivalent theta value
> ! can be found on either side, hence must use values
> ! from either side, same pressure level.
> end if
>
> ! b) in y direction
>
> jj=0
> do j=jyvm,jyvp,jumpy
> jj=jj+1
> ! Search adjacent levels for current theta value
> ! Spiral out from current level for efficiency
> kup=klpt-1
> kdn=klpt
> kch=0
> 70 continue
> ! Upward branch
> kup=kup+1
> if (kch.ge.nlck) goto 51 ! No more levels to check,
> ! ! and no values found
> if (kup.ge.nuvz) goto 71
> kch=kch+1
> k=kup
> ppmk=akz(k)+bkz(k)*psn(ix,j,1,n,l)
> thdn=tthn(ix,j,k,n,l)*(100000./ppmk)**kappa
> ppmk=akz(k+1)+bkz(k+1)*psn(ix,j,1,n,l)
> thup=tthn(ix,j,k+1,n,l)*(100000./ppmk)**kappa
> if (((thdn.ge.theta).and.(thup.le.theta)).or. &
> ((thdn.le.theta).and.(thup.ge.theta))) then
> dt1=abs(theta-thdn)
> dt2=abs(theta-thup)
> dt=dt1+dt2
> if (dt.lt.eps) then ! Avoid division by zero error
> dt1=0.5 ! G.W., 10.4.1996
> dt2=0.5
> dt=1.0
> endif
> uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
> goto 50
> endif
> 71 continue
> ! Downward branch
> kdn=kdn-1
> if (kdn.lt.1) goto 70
> kch=kch+1
> k=kdn
> ppmk=akz(k)+bkz(k)*psn(ix,j,1,n,l)
> thdn=tthn(ix,j,k,n,l)*(100000./ppmk)**kappa
> ppmk=akz(k+1)+bkz(k+1)*psn(ix,j,1,n,l)
> thup=tthn(ix,j,k+1,n,l)*(100000./ppmk)**kappa
> if (((thdn.ge.theta).and.(thup.le.theta)).or. &
> ((thdn.le.theta).and.(thup.ge.theta))) then
> dt1=abs(theta-thdn)
> dt2=abs(theta-thup)
> dt=dt1+dt2
> if (dt.lt.eps) then ! Avoid division by zero error
> dt1=0.5 ! G.W., 10.4.1996
> dt2=0.5
> dt=1.0
> endif
> uy(jj)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt
> goto 50
> endif
> goto 70
> ! This section used when no values were found
> 51 continue
> ! Must use uu at current level and lat. juy becomes smaller by 1
> uy(jj)=uuhn(ix,jy,kl,l)
> juy=juy-1
> ! Otherwise OK
> 50 continue
> end do
> if (juy.gt.0) then
> dudy=(uy(2)-uy(1))/real(juy)/(dyn(l)*pi/180.)
> else
> dudy=uuhn(ix,jyvp,kl,l)-uuhn(ix,jyvm,kl,l)
> dudy=dudy/real(jumpy)/(dyn(l)*pi/180.)
> end if
> !
> pvhn(ix,jy,kl,l)=dthetadp*(f+(dvdx/cosphi-dudy &
> +uuhn(ix,jy,kl,l)*tanphi)/r_earth)*(-1.e6)*9.81
>
> !
> ! Resest jux and juy
> jux=jumpx
> juy=jumpy
> end do
> end do
> end do
> !
> end subroutine calcpv_nests
caldate.f90
----------------------------------------------
1,91c1,91
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine caldate(juldate,yyyymmdd,hhmiss)
< ! i o o
< !*****************************************************************************
< ! *
< ! Calculates the Gregorian date from the Julian date *
< ! *
< ! AUTHOR: Andreas Stohl (21 January 1994), adapted from Numerical Recipes*
< ! *
< ! Variables: *
< ! dd Day *
< ! hh Hour *
< ! hhmiss Hour, Minute, Second *
< ! ja,jb,jc,jd,je help variables *
< ! jalpha help variable *
< ! juldate Julian Date *
< ! julday help variable *
< ! mi Minute *
< ! mm Month *
< ! ss Seconds *
< ! yyyy Year *
< ! yyyymmdd Year, Month, Day *
< ! *
< ! Constants: *
< ! igreg help constant *
< ! *
< !*****************************************************************************
<
< use par_mod, only: dp
<
< implicit none
<
< integer :: yyyymmdd,yyyy,mm,dd,hhmiss,hh,mi,ss
< integer :: julday,ja,jb,jc,jd,je,jalpha
< real(kind=dp) :: juldate
< integer,parameter :: igreg=2299161
<
< julday=int(juldate)
< if(julday.ge.igreg)then
< jalpha=int(((julday-1867216)-0.25)/36524.25)
< ja=julday+1+jalpha-int(0.25*jalpha)
< else
< ja=julday
< endif
< jb=ja+1524
< jc=int(6680.+((jb-2439870)-122.1)/365.25)
< jd=365*jc+int(0.25*jc)
< je=int((jb-jd)/30.6001)
< dd=jb-jd-int(30.6001*je)
< mm=je-1
< if (mm.gt.12) mm=mm-12
< yyyy=jc-4715
< if (mm.gt.2) yyyy=yyyy-1
< if (yyyy.le.0) yyyy=yyyy-1
<
< yyyymmdd=10000*yyyy+100*mm+dd
< hh=int(24._dp*(juldate-real(julday,kind=dp)))
< mi=int(1440._dp*(juldate-real(julday,kind=dp))-60._dp*real(hh,kind=dp))
< ss=nint(86400._dp*(juldate-real(julday,kind=dp))-3600._dp*real(hh,kind=dp)- &
< 60._dp*real(mi,kind=dp))
< if (ss.eq.60) then ! 60 seconds = 1 minute
< ss=0
< mi=mi+1
< endif
< if (mi.eq.60) then
< mi=0
< hh=hh+1
< endif
< hhmiss=10000*hh+100*mi+ss
<
< end subroutine caldate
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine caldate(juldate,yyyymmdd,hhmiss)
> ! i o o
> !*****************************************************************************
> ! *
> ! Calculates the Gregorian date from the Julian date *
> ! *
> ! AUTHOR: Andreas Stohl (21 January 1994), adapted from Numerical Recipes*
> ! *
> ! Variables: *
> ! dd Day *
> ! hh Hour *
> ! hhmiss Hour, Minute, Second *
> ! ja,jb,jc,jd,je help variables *
> ! jalpha help variable *
> ! juldate Julian Date *
> ! julday help variable *
> ! mi Minute *
> ! mm Month *
> ! ss Seconds *
> ! yyyy Year *
> ! yyyymmdd Year, Month, Day *
> ! *
> ! Constants: *
> ! igreg help constant *
> ! *
> !*****************************************************************************
>
> use par_mod, only: dp
>
> implicit none
>
> integer :: yyyymmdd,yyyy,mm,dd,hhmiss,hh,mi,ss
> integer :: julday,ja,jb,jc,jd,je,jalpha
> real(kind=dp) :: juldate
> integer,parameter :: igreg=2299161
>
> julday=int(juldate)
> if(julday.ge.igreg)then
> jalpha=int(((julday-1867216)-0.25)/36524.25)
> ja=julday+1+jalpha-int(0.25*jalpha)
> else
> ja=julday
> endif
> jb=ja+1524
> jc=int(6680.+((jb-2439870)-122.1)/365.25)
> jd=365*jc+int(0.25*jc)
> je=int((jb-jd)/30.6001)
> dd=jb-jd-int(30.6001*je)
> mm=je-1
> if (mm.gt.12) mm=mm-12
> yyyy=jc-4715
> if (mm.gt.2) yyyy=yyyy-1
> if (yyyy.le.0) yyyy=yyyy-1
>
> yyyymmdd=10000*yyyy+100*mm+dd
> hh=int(24._dp*(juldate-real(julday,kind=dp)))
> mi=int(1440._dp*(juldate-real(julday,kind=dp))-60._dp*real(hh,kind=dp))
> ss=nint(86400._dp*(juldate-real(julday,kind=dp))-3600._dp*real(hh,kind=dp)- &
> 60._dp*real(mi,kind=dp))
> if (ss.eq.60) then ! 60 seconds = 1 minute
> ss=0
> mi=mi+1
> endif
> if (mi.eq.60) then
> mi=0
> hh=hh+1
> endif
> hhmiss=10000*hh+100*mi+ss
>
> end subroutine caldate
centerofmass.f90
----------------------------------------------
1,89c1,89
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine centerofmass(xl,yl,n,xcenter,ycenter)
< ! i i i o o
< !*****************************************************************************
< ! *
< ! This routine calculates the center of mass of n points on the Earth. *
< ! Input are the longitudes (xl) and latitudes (yl) of the individual *
< ! points, output is the longitude and latitude of the centre of mass. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 24 January 2002 *
< ! *
< !*****************************************************************************
<
< use par_mod
<
< implicit none
<
< integer :: n,l
< real :: xl(n),yl(n),xll,yll,xav,yav,zav,x,y,z,xcenter,ycenter
<
<
< xav=0.
< yav=0.
< zav=0.
<
< do l=1,n
<
< ! Convert longitude and latitude from degrees to radians
< !*******************************************************
<
< xll=xl(l)*pi180
< yll=yl(l)*pi180
<
< ! Calculate 3D coordinates from longitude and latitude
< !*****************************************************
<
< x = cos(yll)*sin(xll)
< y = -1.*cos(yll)*cos(xll)
< z = sin(yll)
<
<
< ! Find the mean location in Cartesian coordinates
< !************************************************
<
< xav=xav+x
< yav=yav+y
< zav=zav+z
< end do
<
< xav=xav/real(n)
< yav=yav/real(n)
< zav=zav/real(n)
<
<
< ! Project the point back onto Earth's surface
< !********************************************
<
< xcenter=atan2(xav,-1.*yav)
< ycenter=atan2(zav,sqrt(xav*xav+yav*yav))
<
< ! Convert back to degrees
< !************************
<
< xcenter=xcenter/pi180
< ycenter=ycenter/pi180
<
< end subroutine centerofmass
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine centerofmass(xl,yl,n,xcenter,ycenter)
> ! i i i o o
> !*****************************************************************************
> ! *
> ! This routine calculates the center of mass of n points on the Earth. *
> ! Input are the longitudes (xl) and latitudes (yl) of the individual *
> ! points, output is the longitude and latitude of the centre of mass. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 24 January 2002 *
> ! *
> !*****************************************************************************
>
> use par_mod
>
> implicit none
>
> integer :: n,l
> real :: xl(n),yl(n),xll,yll,xav,yav,zav,x,y,z,xcenter,ycenter
>
>
> xav=0.
> yav=0.
> zav=0.
>
> do l=1,n
>
> ! Convert longitude and latitude from degrees to radians
> !*******************************************************
>
> xll=xl(l)*pi180
> yll=yl(l)*pi180
>
> ! Calculate 3D coordinates from longitude and latitude
> !*****************************************************
>
> x = cos(yll)*sin(xll)
> y = -1.*cos(yll)*cos(xll)
> z = sin(yll)
>
>
> ! Find the mean location in Cartesian coordinates
> !************************************************
>
> xav=xav+x
> yav=yav+y
> zav=zav+z
> end do
>
> xav=xav/real(n)
> yav=yav/real(n)
> zav=zav/real(n)
>
>
> ! Project the point back onto Earth's surface
> !********************************************
>
> xcenter=atan2(xav,-1.*yav)
> ycenter=atan2(zav,sqrt(xav*xav+yav*yav))
>
> ! Convert back to degrees
> !************************
>
> xcenter=xcenter/pi180
> ycenter=ycenter/pi180
>
> end subroutine centerofmass
clustering.f90
----------------------------------------------
1,210c1,210
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
< rmsclust,zrms)
< ! i i i i o o o o o
< ! o o
< !*****************************************************************************
< ! *
< ! This routine clusters the particle position into ncluster custers. *
< ! Input are the longitudes (xl) and latitudes (yl) of the individual *
< ! points, output are the cluster mean positions (xclust,yclust). *
< ! Vertical positions are not directly used for the clustering. *
< ! *
< ! For clustering, the procedure described in Dorling et al. (1992) is used.*
< ! *
< ! Dorling, S.R., Davies, T.D. and Pierce, C.E. (1992): *
< ! Cluster analysis: a technique for estimating the synoptic meteorological *
< ! controls on air and precipitation chemistry - method and applications. *
< ! Atmospheric Environment 26A, 2575-2581. *
< ! *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 1 February 2002 *
< ! *
< ! Variables: *
< ! fclust fraction of particles belonging to each cluster *
< ! ncluster number of clusters to be used *
< ! rms total horizontal rms distance after clustering *
< ! rmsclust horizontal rms distance for each individual cluster *
< ! zrms total vertical rms distance after clustering *
< ! xclust,yclust, Cluster centroid positions *
< ! zclust *
< ! xl,yl,zl particle positions *
< ! *
< !*****************************************************************************
<
< use par_mod
<
< implicit none
<
< integer :: n,i,j,l,nclust(maxpart),numb(ncluster),ncl
< real :: xl(n),yl(n),zl(n),xclust(ncluster),yclust(ncluster),x,y,z
< real :: zclust(ncluster),distance2,distances,distancemin,rms,rmsold
< real :: xav(ncluster),yav(ncluster),zav(ncluster),fclust(ncluster)
< real :: rmsclust(ncluster)
< real :: zdist,zrms
<
<
<
< if (n.lt.ncluster) return
< rmsold=-5.
<
< ! Convert longitude and latitude from degrees to radians
< !*******************************************************
<
< do i=1,n
< nclust(i)=i
< xl(i)=xl(i)*pi180
< yl(i)=yl(i)*pi180
< end do
<
<
< ! Generate a seed for each cluster
< !*********************************
<
< do j=1,ncluster
< zclust(j)=0.
< xclust(j)=xl(j*n/ncluster)
< yclust(j)=yl(j*n/ncluster)
< end do
<
<
< ! Iterative loop to compute the cluster means
< !********************************************
<
< do l=1,100
<
< ! Assign each particle to a cluster: criterion minimum distance to the
< ! cluster mean position
< !*********************************************************************
<
<
< do i=1,n
< distancemin=10.**10.
< do j=1,ncluster
< distances=distance2(yl(i),xl(i),yclust(j),xclust(j))
< if (distances.lt.distancemin) then
< distancemin=distances
< ncl=j
< endif
< end do
< nclust(i)=ncl
< end do
<
<
< ! Recalculate the cluster centroid position: convert to 3D Cartesian coordinates,
< ! calculate mean position, and re-project this point onto the Earth's surface
< !*****************************************************************************
<
< do j=1,ncluster
< xav(j)=0.
< yav(j)=0.
< zav(j)=0.
< rmsclust(j)=0.
< numb(j)=0
< end do
< rms=0.
<
< do i=1,n
< numb(nclust(i))=numb(nclust(i))+1
< distances=distance2(yl(i),xl(i), &
< yclust(nclust(i)),xclust(nclust(i)))
<
< ! rms is the total rms of all particles
< ! rmsclust is the rms for a particular cluster
< !*********************************************
<
< rms=rms+distances*distances
< rmsclust(nclust(i))=rmsclust(nclust(i))+distances*distances
<
< ! Calculate Cartesian 3D coordinates from longitude and latitude
< !***************************************************************
<
< x = cos(yl(i))*sin(xl(i))
< y = -1.*cos(yl(i))*cos(xl(i))
< z = sin(yl(i))
< xav(nclust(i))=xav(nclust(i))+x
< yav(nclust(i))=yav(nclust(i))+y
< zav(nclust(i))=zav(nclust(i))+z
< end do
<
< rms=sqrt(rms/real(n))
<
<
< ! Find the mean location in Cartesian coordinates
< !************************************************
<
< do j=1,ncluster
< if (numb(j).gt.0) then
< rmsclust(j)=sqrt(rmsclust(j)/real(numb(j)))
< xav(j)=xav(j)/real(numb(j))
< yav(j)=yav(j)/real(numb(j))
< zav(j)=zav(j)/real(numb(j))
<
< ! Project the point back onto Earth's surface
< !********************************************
<
< xclust(j)=atan2(xav(j),-1.*yav(j))
< yclust(j)=atan2(zav(j),sqrt(xav(j)*xav(j)+yav(j)*yav(j)))
< endif
< end do
<
<
< ! Leave the loop if the RMS distance decreases only slightly between 2 iterations
< !*****************************************************************************
<
< if ((l.gt.1).and.(abs(rms-rmsold)/rmsold.lt.0.005)) goto 99
< rmsold=rms
<
< end do
<
< 99 continue
<
< ! Convert longitude and latitude from radians to degrees
< !*******************************************************
<
< do i=1,n
< xl(i)=xl(i)/pi180
< yl(i)=yl(i)/pi180
< zclust(nclust(i))=zclust(nclust(i))+zl(i)
< end do
<
< do j=1,ncluster
< xclust(j)=xclust(j)/pi180
< yclust(j)=yclust(j)/pi180
< if (numb(j).gt.0) zclust(j)=zclust(j)/real(numb(j))
< fclust(j)=100.*real(numb(j))/real(n)
< end do
<
< ! Determine total vertical RMS deviation
< !***************************************
<
< zrms=0.
< do i=1,n
< zdist=zl(i)-zclust(nclust(i))
< zrms=zrms+zdist*zdist
< end do
< if (zrms.gt.0.) zrms=sqrt(zrms/real(n))
<
< end subroutine clustering
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
> rmsclust,zrms)
> ! i i i i o o o o o
> ! o o
> !*****************************************************************************
> ! *
> ! This routine clusters the particle position into ncluster custers. *
> ! Input are the longitudes (xl) and latitudes (yl) of the individual *
> ! points, output are the cluster mean positions (xclust,yclust). *
> ! Vertical positions are not directly used for the clustering. *
> ! *
> ! For clustering, the procedure described in Dorling et al. (1992) is used.*
> ! *
> ! Dorling, S.R., Davies, T.D. and Pierce, C.E. (1992): *
> ! Cluster analysis: a technique for estimating the synoptic meteorological *
> ! controls on air and precipitation chemistry - method and applications. *
> ! Atmospheric Environment 26A, 2575-2581. *
> ! *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 1 February 2002 *
> ! *
> ! Variables: *
> ! fclust fraction of particles belonging to each cluster *
> ! ncluster number of clusters to be used *
> ! rms total horizontal rms distance after clustering *
> ! rmsclust horizontal rms distance for each individual cluster *
> ! zrms total vertical rms distance after clustering *
> ! xclust,yclust, Cluster centroid positions *
> ! zclust *
> ! xl,yl,zl particle positions *
> ! *
> !*****************************************************************************
>
> use par_mod
>
> implicit none
>
> integer :: n,i,j,l,nclust(maxpart),numb(ncluster),ncl
> real :: xl(n),yl(n),zl(n),xclust(ncluster),yclust(ncluster),x,y,z
> real :: zclust(ncluster),distance2,distances,distancemin,rms,rmsold
> real :: xav(ncluster),yav(ncluster),zav(ncluster),fclust(ncluster)
> real :: rmsclust(ncluster)
> real :: zdist,zrms
>
>
>
> if (n.lt.ncluster) return
> rmsold=-5.
>
> ! Convert longitude and latitude from degrees to radians
> !*******************************************************
>
> do i=1,n
> nclust(i)=i
> xl(i)=xl(i)*pi180
> yl(i)=yl(i)*pi180
> end do
>
>
> ! Generate a seed for each cluster
> !*********************************
>
> do j=1,ncluster
> zclust(j)=0.
> xclust(j)=xl(j*n/ncluster)
> yclust(j)=yl(j*n/ncluster)
> end do
>
>
> ! Iterative loop to compute the cluster means
> !********************************************
>
> do l=1,100
>
> ! Assign each particle to a cluster: criterion minimum distance to the
> ! cluster mean position
> !*********************************************************************
>
>
> do i=1,n
> distancemin=10.**10.
> do j=1,ncluster
> distances=distance2(yl(i),xl(i),yclust(j),xclust(j))
> if (distances.lt.distancemin) then
> distancemin=distances
> ncl=j
> endif
> end do
> nclust(i)=ncl
> end do
>
>
> ! Recalculate the cluster centroid position: convert to 3D Cartesian coordinates,
> ! calculate mean position, and re-project this point onto the Earth's surface
> !*****************************************************************************
>
> do j=1,ncluster
> xav(j)=0.
> yav(j)=0.
> zav(j)=0.
> rmsclust(j)=0.
> numb(j)=0
> end do
> rms=0.
>
> do i=1,n
> numb(nclust(i))=numb(nclust(i))+1
> distances=distance2(yl(i),xl(i), &
> yclust(nclust(i)),xclust(nclust(i)))
>
> ! rms is the total rms of all particles
> ! rmsclust is the rms for a particular cluster
> !*********************************************
>
> rms=rms+distances*distances
> rmsclust(nclust(i))=rmsclust(nclust(i))+distances*distances
>
> ! Calculate Cartesian 3D coordinates from longitude and latitude
> !***************************************************************
>
> x = cos(yl(i))*sin(xl(i))
> y = -1.*cos(yl(i))*cos(xl(i))
> z = sin(yl(i))
> xav(nclust(i))=xav(nclust(i))+x
> yav(nclust(i))=yav(nclust(i))+y
> zav(nclust(i))=zav(nclust(i))+z
> end do
>
> rms=sqrt(rms/real(n))
>
>
> ! Find the mean location in Cartesian coordinates
> !************************************************
>
> do j=1,ncluster
> if (numb(j).gt.0) then
> rmsclust(j)=sqrt(rmsclust(j)/real(numb(j)))
> xav(j)=xav(j)/real(numb(j))
> yav(j)=yav(j)/real(numb(j))
> zav(j)=zav(j)/real(numb(j))
>
> ! Project the point back onto Earth's surface
> !********************************************
>
> xclust(j)=atan2(xav(j),-1.*yav(j))
> yclust(j)=atan2(zav(j),sqrt(xav(j)*xav(j)+yav(j)*yav(j)))
> endif
> end do
>
>
> ! Leave the loop if the RMS distance decreases only slightly between 2 iterations
> !*****************************************************************************
>
> if ((l.gt.1).and.(abs(rms-rmsold)/rmsold.lt.0.005)) goto 99
> rmsold=rms
>
> end do
>
> 99 continue
>
> ! Convert longitude and latitude from radians to degrees
> !*******************************************************
>
> do i=1,n
> xl(i)=xl(i)/pi180
> yl(i)=yl(i)/pi180
> zclust(nclust(i))=zclust(nclust(i))+zl(i)
> end do
>
> do j=1,ncluster
> xclust(j)=xclust(j)/pi180
> yclust(j)=yclust(j)/pi180
> if (numb(j).gt.0) zclust(j)=zclust(j)/real(numb(j))
> fclust(j)=100.*real(numb(j))/real(n)
> end do
>
> ! Determine total vertical RMS deviation
> !***************************************
>
> zrms=0.
> do i=1,n
> zdist=zl(i)-zclust(nclust(i))
> zrms=zrms+zdist*zdist
> end do
> if (zrms.gt.0.) zrms=sqrt(zrms/real(n))
>
> end subroutine clustering
cmapf_mod.f90
----------------------------------------------
1,834c1,834
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< ! Changes to the routines by A. Stohl
< ! xi,xi0,eta,eta0 are double precision variables to avoid problems
< ! at poles
<
< module cmapf_mod
<
< use par_mod, only: dp
<
< implicit none
< private
<
< public :: cc2gll, cll2xy, cgszll, cxy2ll, stlmbr, stcm2p
<
< real,parameter :: rearth=6371.2, almst1=.9999999
<
< real,parameter :: pi=3.14159265358979
< real,parameter :: radpdg=pi/180., dgprad=180./pi
<
< contains
<
< subroutine cc2gll (strcmp, xlat,xlong, ue,vn, ug,vg)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real :: strcmp(9), xlat, xlong, ue, vn, ug, vg
<
< real(kind=dp) :: xpolg,ypolg,along,slong,clong,rot
<
< along = cspanf( xlong - strcmp(2), -180., 180.)
< if (xlat.gt.89.985) then
< !* North polar meteorological orientation: "north" along prime meridian
< rot = - strcmp(1) * along + xlong - 180.
< elseif (xlat.lt.-89.985) then
< !* South polar meteorological orientation: "north" along prime meridian
< rot = - strcmp(1) * along - xlong
< else
< rot = - strcmp(1) * along
< endif
< slong = sin( radpdg * rot )
< clong = cos( radpdg * rot )
< xpolg = slong * strcmp(5) + clong * strcmp(6)
< ypolg = clong * strcmp(5) - slong * strcmp(6)
< ug = ypolg * ue + xpolg * vn
< vg = ypolg * vn - xpolg * ue
< return
< end subroutine cc2gll
<
< subroutine ccrvll (strcmp, xlat,xlong, gx,gy)
< !* Written on 9/20/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real(kind=dp) :: xpolg,ypolg,temp,along,slong,clong,ctemp, curv
< real :: strcmp(9), xlat, xlong, gx, gy
<
< along = cspanf( xlong - strcmp(2), -180., 180.)
< slong = sin( radpdg * strcmp(1) * along)
< clong = cos( radpdg * strcmp(1) * along)
< xpolg = - slong * strcmp(5) + clong * strcmp(6)
< ypolg = clong * strcmp(5) + slong * strcmp(6)
< temp = sin(radpdg * xlat)
< ctemp = cos(radpdg * xlat)
< curv = (strcmp(1) - temp) / ctemp / rearth
< gx = curv * xpolg
< gy = curv * ypolg
< return
< end subroutine ccrvll
<
< subroutine ccrvxy (strcmp, x,y, gx,gy)
< !* Written on 9/20/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real :: strcmp(9), x, y, gx, gy
< real(kind=dp) :: xpolg,ypolg,temp,ymerc,efact,curv
<
< temp = strcmp(1) * strcmp(7) /rearth
< xpolg = strcmp(6) + temp * (strcmp(3) - x)
< ypolg = strcmp(5) + temp * (strcmp(4) - y)
< temp = sqrt ( xpolg ** 2 + ypolg ** 2 )
< if (temp.gt.0.) then
< ymerc = - log( temp) /strcmp(1)
< efact = exp(ymerc)
< curv = ( (strcmp(1) - 1.d0) * efact + &
< (strcmp(1) + 1.d0) / efact ) &
< * .5d0 / rearth
< gx = xpolg * curv / temp
< gy = ypolg * curv / temp
< else
< if (abs(strcmp(1)) .eq. 1.) then
< gx = 0.
< gy = 0.
< else
< gx = 1./rearth
< gy = 1./rearth
< endif
< endif
< return
< end subroutine ccrvxy
<
< subroutine cg2cll (strcmp, xlat,xlong, ug,vg, ue,vn)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real(kind=dp) :: xpolg,ypolg,along,slong,clong,rot
< real :: strcmp(9), xlat, xlong, ug, vg, ue, vn
<
< along = cspanf( xlong - strcmp(2), -180., 180.)
< if (xlat.gt.89.985) then
< !* North polar meteorological orientation: "north" along prime meridian
< rot = - strcmp(1) * along + xlong - 180.
< elseif (xlat.lt.-89.985) then
< !* South polar meteorological orientation: "north" along prime meridian
< rot = - strcmp(1) * along - xlong
< else
< rot = - strcmp(1) * along
< endif
< slong = sin( radpdg * rot )
< clong = cos( radpdg * rot )
< xpolg = slong * strcmp(5) + clong * strcmp(6)
< ypolg = clong * strcmp(5) - slong * strcmp(6)
< ue = ypolg * ug - xpolg * vg
< vn = ypolg * vg + xpolg * ug
< return
< end subroutine cg2cll
<
< subroutine cg2cxy (strcmp, x,y, ug,vg, ue,vn)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real :: strcmp(9) , x, y, ug, vg, ue, vn
<
< real :: clong, radial, rot, slong, xlat, xlong
< real(kind=dp) :: xpolg,ypolg,temp,xi0,eta0,xi,eta
<
< xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
< eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
< xi = xi0 * strcmp(5) - eta0 * strcmp(6)
< eta = eta0 * strcmp(5) + xi0 * strcmp(6)
< radial = 2. * eta - strcmp(1) * (xi*xi + eta*eta)
< if (radial.gt.strcmp(8)) then
< !* Case north of 89 degrees. Meteorological wind direction definition
< !* changes.
< call cnxyll(strcmp, xi,eta, xlat,xlong)
< !* North polar meteorological orientation: "north" along prime meridian
< rot = strcmp(1) * (xlong - strcmp(2)) - xlong - 180.
< slong = - sin( radpdg * rot )
< clong = cos( radpdg * rot )
< xpolg = slong * strcmp(5) + clong * strcmp(6)
< ypolg = clong * strcmp(5) - slong * strcmp(6)
< else if (radial.lt.strcmp(9)) then
< !* Case south of -89 degrees. Meteorological wind direction definition
< !* changes.
< call cnxyll(strcmp, xi,eta, xlat,xlong)
< !* South polar meteorological orientation: "north" along prime meridian
< rot = strcmp(1) * (xlong - strcmp(2)) + xlong
< slong = - sin( radpdg * rot )
< clong = cos( radpdg * rot )
< xpolg = slong * strcmp(5) + clong * strcmp(6)
< ypolg = clong * strcmp(5) - slong * strcmp(6)
< else
< !* Normal case. Meteorological direction of wind related to true north.
< xpolg = strcmp(6) - strcmp(1) * xi0
< ypolg = strcmp(5) - strcmp(1) * eta0
< temp = sqrt ( xpolg ** 2 + ypolg ** 2 )
< xpolg = xpolg / temp
< ypolg = ypolg / temp
< end if
< ue = ( ypolg * ug - xpolg * vg )
< vn = ( ypolg * vg + xpolg * ug )
< return
< end subroutine cg2cxy
<
< real function cgszll (strcmp, xlat,xlong)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real :: strcmp(9), xlat, xlong
<
< real(kind=dp) :: slat,ymerc,efact
<
< if (xlat .gt. 89.985) then
< !* Close to north pole
< if (strcmp(1) .gt. 0.9999) then
< !* and to gamma == 1.
< cgszll = 2. * strcmp(7)
< return
< endif
< efact = cos(radpdg * xlat)
< if (efact .le. 0.) then
< cgszll = 0.
< return
< else
< ymerc = - log( efact /(1. + sin(radpdg * xlat)))
< endif
< else if (xlat .lt. -89.985) then
< !* Close to south pole
< if (strcmp(1) .lt. -0.9999) then
< !* and to gamma == -1.0
< cgszll = 2. * strcmp(7)
< return
< endif
< efact = cos(radpdg * xlat)
< if (efact .le. 0.) then
< cgszll = 0.
< return
< else
< ymerc = log( efact /(1. - sin(radpdg * xlat)))
< endif
< else
< slat = sin(radpdg * xlat)
< ymerc = log((1. + slat) / (1. - slat))/2.
< !efact = exp(ymerc)
< !cgszll = 2. * strcmp(7) * exp (strcmp(1) * ymerc)
< !c / (efact + 1./efact)
< endif
< cgszll = strcmp(7) * cos(radpdg * xlat) * exp(strcmp(1) *ymerc)
< return
< end function cgszll
<
< real function cgszxy (strcmp, x,y)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real :: strcmp(9) , x, y
< real(kind=dp) :: ymerc,efact, radial, temp
< real(kind=dp) :: xi0,eta0,xi,eta
<
<
< xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
< eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
< xi = xi0 * strcmp(5) - eta0 * strcmp(6)
< eta = eta0 * strcmp(5) + xi0 * strcmp(6)
< radial = 2. * eta - strcmp(1) * (xi*xi + eta*eta)
< efact = strcmp(1) * radial
< if (efact .gt. almst1) then
< if (strcmp(1).gt.almst1) then
< cgszxy = 2. * strcmp(7)
< else
< cgszxy = 0.
< endif
< return
< endif
< if (abs(efact) .lt. 1.e-2) then
< temp = (efact / (2. - efact) )**2
< ymerc = radial / (2. - efact) * (1. + temp * &
< (1./3. + temp * &
< (1./5. + temp * &
< (1./7. ))))
< else
< ymerc = - log( 1. - efact ) /2. /strcmp(1)
< endif
< if (ymerc .gt. 6.) then
< if (strcmp(1) .gt. almst1) then
< cgszxy = 2. * strcmp(7)
< else
< cgszxy = 0.
< endif
< else if (ymerc .lt. -6.) then
< if (strcmp(1) .lt. -almst1) then
< cgszxy = 2. * strcmp(7)
< else
< cgszxy = 0.
< endif
< else
< efact = exp(ymerc)
< cgszxy = 2. * strcmp(7) * exp (strcmp(1) * ymerc) &
< / (efact + 1./efact)
< endif
< return
< end function cgszxy
<
< subroutine cll2xy (strcmp, xlat,xlong, x,y)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< implicit none
<
< real :: strcmp(9) , xlat, xlong, x, y, xi, eta
<
< call cnllxy(strcmp, xlat,xlong, xi,eta)
< x = strcmp(3) + rearth/strcmp(7) * &
< (xi * strcmp(5) + eta * strcmp(6) )
< y = strcmp(4) + rearth/strcmp(7) * &
< (eta * strcmp(5) - xi * strcmp(6) )
< return
< end subroutine cll2xy
<
< subroutine cnllxy (strcmp, xlat,xlong, xi,eta)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
< ! main transformation routine from latitude-longitude to
< ! canonical (equator-centered, radian unit) coordinates
<
< use par_mod, only: dp
<
< implicit none
<
< real :: strcmp(9), xlat, xlong, xi, eta, &
< gdlong, sndgam, csdgam, rhog1
< real(kind=dp) :: gamma
< real(kind=dp) :: dlong,dlat,slat,mercy,gmercy
<
< gamma = strcmp(1)
< dlat = xlat
< dlong = cspanf(xlong - strcmp(2), -180., 180.)
< dlong = dlong * radpdg
< gdlong = gamma * dlong
< if (abs(gdlong) .lt. .01) then
< ! Code for gamma small or zero. This avoids round-off error or divide-
< ! by zero in the case of mercator or near-mercator projections.
< gdlong = gdlong * gdlong
< sndgam = dlong * (1. - 1./6. * gdlong * &
< (1. - 1./20. * gdlong * &
< (1. - 1./42. * gdlong )))
< csdgam = dlong * dlong * .5 * &
< (1. - 1./12. * gdlong * &
< (1. - 1./30. * gdlong * &
< (1. - 1./56. * gdlong )))
< else
< ! Code for moderate values of gamma
< sndgam = sin (gdlong) /gamma
< csdgam = (1. - cos(gdlong) )/gamma /gamma
< endif
< slat = sin(radpdg * dlat)
< if ((slat .ge. almst1) .or. (slat .le. -almst1)) then
< eta = 1./strcmp(1)
< xi = 0.
< return
< endif
< mercy = .5 * log( (1. + slat) / (1. - slat) )
< gmercy = gamma * mercy
< if (abs(gmercy) .lt. .001) then
< ! Code for gamma small or zero. This avoids round-off error or divide-
< ! by zero in the case of mercator or near-mercator projections.
< rhog1 = mercy * (1. - .5 * gmercy * &
< (1. - 1./3. * gmercy * &
< (1. - 1./4. * gmercy ) ) )
< else
< ! Code for moderate values of gamma
< rhog1 = (1. - exp(-gmercy)) / gamma
< endif
< eta = rhog1 + (1. - gamma * rhog1) * gamma * csdgam
< xi = (1. - gamma * rhog1 ) * sndgam
< end subroutine cnllxy
<
< subroutine cnxyll (strcmp, xi,eta, xlat,xlong)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
< ! main transformation routine from canonical (equator-centered,
< ! radian unit) coordinates
<
< use par_mod, only: dp
<
< implicit none
<
< real :: strcmp(9), xlat, xlong, odist
< real(kind=dp) :: gamma,temp,arg1,arg2,ymerc,along,gxi,cgeta
< real(kind=dp) :: xi,eta
<
< gamma = strcmp(1)
< ! Calculate equivalent mercator coordinate
< odist = xi*xi + eta*eta
< arg2 = 2. * eta - gamma * (xi*xi + eta*eta)
< arg1 = gamma * arg2
< ! Change by A. Stohl to avoid problems close to the poles
< ! if (arg1 .ge. almst1) then
< ! distance to north (or south) pole is zero (or imaginary ;) )
< ! xlat = sign(90.,strcmp(1))
< ! xlong = strcmp(2)
< ! return
< ! endif
< if (abs(arg1) .lt. .01) then
< ! Code for gamma small or zero. This avoids round-off error or divide-
< ! by zero in the case of mercator or near-mercator projections.
< temp = (arg1 / (2. - arg1) )**2
< ymerc = arg2 / (2. - arg1) * (1. + temp * &
< (1./3. + temp * &
< (1./5. + temp * &
< (1./7. ))))
< else
< ! Code for moderate values of gamma
< ymerc = - log ( 1. - arg1 ) /2. / gamma
< endif
< ! Convert ymerc to latitude
< temp = exp( - abs(ymerc) )
< xlat = sign(atan2((1. - temp) * (1. + temp), 2. * temp), ymerc)
< ! Find longitudes
< gxi = gamma*xi
< cgeta = 1. - gamma * eta
< if ( abs(gxi) .lt. .01*cgeta ) then
< ! Code for gamma small or zero. This avoids round-off error or divide-
< ! by zero in the case of mercator or near-mercator projections.
< temp = ( gxi /cgeta )**2
< along = xi / cgeta * (1. - temp * &
< (1./3. - temp * &
< (1./5. - temp * &
< (1./7. ))))
< else
< ! Code for moderate values of gamma
< along = atan2( gxi, cgeta) / gamma
< endif
< xlong = sngl(strcmp(2) + dgprad * along)
< xlat = xlat * dgprad
< return
< end subroutine cnxyll
<
< subroutine cpolll (strcmp, xlat,xlong, enx,eny,enz)
< !* Written on 11/23/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real(kind=dp) :: xpolg,ypolg,along,slong,clong,rot
< real :: strcmp(9), xlat, xlong, enx, eny, enz, clat
<
< along = cspanf( xlong - strcmp(2), -180., 180.)
< rot = - strcmp(1) * along
< slong = sin( radpdg * rot )
< clong = cos( radpdg * rot )
< xpolg = slong * strcmp(5) + clong * strcmp(6)
< ypolg = clong * strcmp(5) - slong * strcmp(6)
< clat = cos(radpdg * xlat)
< enx = clat * xpolg
< eny = clat * ypolg
< enz = sin(radpdg * xlat)
< return
< end subroutine cpolll
<
< subroutine cpolxy (strcmp, x,y, enx,eny,enz)
< !* Written on 11/26/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real :: strcmp(9) , x, y, enx, eny, enz
< real(kind=dp) :: xpol,ypol,temp,xi0,eta0,xi,eta,radial
< real(kind=dp) :: temp2,ymerc,arg,oarg,clat
<
< xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
< eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
< xi = xi0 * strcmp(5) - eta0 * strcmp(6)
< eta = eta0 * strcmp(5) + xi0 * strcmp(6)
< radial = 2. * eta - strcmp(1) * (xi*xi + eta*eta)
< temp = strcmp(1) * radial
< if (temp .ge. 1.) then
< enx = 0.
< eny = 0.
< enz = sign(1.,strcmp(1))
< return
< endif
< if (abs(temp).lt.1.e-2) then
< temp2 = (temp / (2. - temp))**2
< ymerc = radial / (2. - temp) * (1. + temp2 * &
< (1./3. + temp2 * &
< (1./5. + temp2 * &
< (1./7.))))
< else
< ymerc = -.5 * log(1. - temp) / strcmp(1)
< endif
< arg = exp( ymerc )
< oarg = 1./arg
< clat = 2./(arg + oarg)
< enz = (arg - oarg) * clat /2.
< temp = clat / sqrt(1. - temp)
< xpol = - xi * strcmp(1) * temp
< ypol = (1. - eta * strcmp(1) ) * temp
< enx = xpol * strcmp(5) + ypol * strcmp(6)
< eny = ypol * strcmp(5) - xpol * strcmp(6)
< return
< end subroutine cpolxy
<
< real function cspanf (value, begin, end)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
< !* real function cspanf returns a value in the interval (begin,end]
< !* which is equivalent to value, mod (end - begin). It is used to
< !* reduce periodic variables to a standard range. It adjusts for the
< !* behavior of the mod function which provides positive results for
< !* positive input, and negative results for negative input
< !* input:
< !* value - real number to be reduced to the span
< !* begin - first value of the span
< !* end - last value of the span
< !* returns:
< !* the reduced value
< !* examples:
< !* along = cspanf(xlong, -180., +180.)
< !* dir = cspanf(angle, 0., 360.)
<
< implicit none
<
< real :: first,last, value, begin, end, val
<
< first = min(begin,end)
< last = max(begin,end)
< val = mod( value - first , last - first)
< if ( val .le. 0.) then
< cspanf = val + last
< else
< cspanf = val + first
< endif
< return
< end function cspanf
<
< subroutine cxy2ll (strcmp, x,y, xlat,xlong)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< use par_mod, only: dp
<
< implicit none
<
< real(kind=dp) :: xi0,eta0,xi,eta
< real :: strcmp(9), x, y, xlat, xlong
<
< xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
< eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
< xi = xi0 * strcmp(5) - eta0 * strcmp(6)
< eta = eta0 * strcmp(5) + xi0 * strcmp(6)
< call cnxyll(strcmp, xi,eta, xlat,xlong)
< xlong = cspanf(xlong, -180., 180.)
< return
< end subroutine cxy2ll
<
< real function eqvlat (xlat1,xlat2)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< implicit none
<
< real :: xlat1, xlat2, x, ssind, sinl1, sinl2, al1, al2, tau
<
< ssind(x) = sin (radpdg*x)
< sinl1 = ssind (xlat1)
< sinl2 = ssind (xlat2)
< if (abs(sinl1 - sinl2) .gt. .001) then
< al1 = log((1. - sinl1)/(1. - sinl2))
< al2 = log((1. + sinl1)/(1. + sinl2))
< else
< ! Case lat1 near or equal to lat2
< tau = - (sinl1 - sinl2)/(2. - sinl1 - sinl2)
< tau = tau*tau
< al1 = 2. / (2. - sinl1 - sinl2) * (1. + tau * &
< (1./3. + tau * &
< (1./5. + tau * &
< (1./7.))))
< tau = (sinl1 - sinl2)/(2. + sinl1 + sinl2)
< tau = tau*tau
< al2 = -2. / (2. + sinl1 + sinl2) * (1. + tau * &
< (1./3. + tau * &
< (1./5. + tau * &
< (1./7.))))
< endif
< eqvlat = asin((al1 + al2) / (al1 - al2))/radpdg
< return
< end function eqvlat
<
< subroutine stcm1p(strcmp, x1,y1, xlat1,xlong1, &
< xlatg,xlongg, gridsz, orient)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< implicit none
<
< integer :: k
< real :: strcmp(9), x1, y1, xlat1, xlong1, turn, orient, &
< xlatg, xlongg, gridsz, x1a, y1a
<
< do k=3,4
< strcmp (k) = 0.
< enddo
< turn = radpdg * (orient - strcmp(1) * &
< cspanf(xlongg - strcmp(2), -180., 180.) )
< strcmp (5) = cos (turn)
< strcmp (6) = - sin (turn)
< strcmp (7) = 1.
< strcmp (7) = gridsz * strcmp(7) &
< / cgszll(strcmp, xlatg, strcmp(2))
< call cll2xy (strcmp, xlat1,xlong1, x1a,y1a)
< strcmp(3) = strcmp(3) + x1 - x1a
< strcmp(4) = strcmp(4) + y1 - y1a
< return
< end subroutine stcm1p
<
< subroutine stcm2p(strcmp, x1,y1, xlat1,xlong1, &
< x2,y2, xlat2,xlong2)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< implicit none
<
< real :: strcmp(9), x1, y1, xlat1, xlong1, &
< x2, y2, xlat2, xlong2
<
< integer :: k
< real :: x1a, y1a, x2a, y2a, den, dena
<
< do k=3,6
< strcmp (k) = 0.
< enddo
< strcmp (5) = 1.
< strcmp (7) = 1.
< call cll2xy (strcmp, xlat1,xlong1, x1a,y1a)
< call cll2xy (strcmp, xlat2,xlong2, x2a,y2a)
< den = sqrt( (x1 - x2)**2 + (y1 - y2)**2 )
< dena = sqrt( (x1a - x2a)**2 + (y1a - y2a)**2 )
< strcmp(5) = ((x1a - x2a)*(x1 - x2) + (y1a - y2a) * (y1 - y2)) &
< /den /dena
< strcmp(6) = ((y1a - y2a)*(x1 - x2) - (x1a - x2a) * (y1 - y2)) &
< /den /dena
< strcmp (7) = strcmp(7) * dena / den
< call cll2xy (strcmp, xlat1,xlong1, x1a,y1a)
< strcmp(3) = strcmp(3) + x1 - x1a
< strcmp(4) = strcmp(4) + y1 - y1a
< return
< end subroutine stcm2p
<
< !* General conformal map routines for meteorological modelers
< !* written on 3/31/94 by
<
< !* Dr. Albion Taylor
< !* NOAA / OAR / ARL phone: (301) 713-0295 x 132
< !* rm. 3151, 1315 east-west highway fax: (301) 713-0119
< !* silver spring, md 20910 e-mail: adtaylor@arlrisc.ssmc.noaa.gov
<
< !* subroutine stlmbr (strcmp, tnglat, clong)
< !* This routine initializes the map structure array strcmp to
< !* the form of a specific map projection
< !* inputs:
< !* tnglat - the latitude at which the projection will be tangent
< !* to the earth. +90. For north polar stereographic,
< !* -90. for south polar stereographic, 0. For mercator,
< !* and other values for lambert conformal.
< !* -90 <= tnglat <= 90.
< !* clong - a longitude in the region under consideration. Longitudes
< !* between clong-180. and clong+180. Will be mapped in one
< !* connected region
< !* outputs:
< !* strcmp - a 9-value map structure array for use with subsequent
< !* calls to the coordinate transform routines.
< !*
< !* real function eqvlat (xlat1,xlat2)
< !* This function is provided to assist in finding the tangent latitude
< !* equivalent to the 2-reference latitude specification in the legend
< !* of most lambert conformal maps. If the map specifies "scale
< !* 1:xxxxx true at 40n and 60n", then eqvlat(40.,60.) will return the
< !* equivalent tangent latitude.
< !* inputs:
< !* xlat1,xlat2: the two latitudes specified in the map legend
< !* returns:
< !* the equivalent tangent latitude
< !* example: call stlmbr(strcmp, eqvlat(40.,60.), 90.)
<
< !* subroutine stcm2p (strcmp, x1,y1, xlat1,xlong1,
< !* x2,y2, xlat2,xlong2)
< !* subroutine stcm1p (strcmp, x1,y1, xlat1,xlong1,
< !* xlatg,xlongg, gridsz, orient)
< !* These routines complete the specification of the map structure
< !* array by conforming the map coordinates to the specifications
< !* of a particular grid. Either stcm1p or stcm2p must be called,
< !* but not both
< !* inputs:
< !* strcmp - a 9-value map structure array, set to a particular map
< !* form by a previous call to stlmbr
< !* for stcm2p:
< !* x1,y1, x2,y2 - the map coordinates of two points on the grid
< !* xlat1,xlong1, xlat2,xlong2 - the geographic coordinates of the
< !* same two points
< !* for stcm1p:
< !* x1,y1 - the map coordinates of one point on the grid
< !* xlat1,xlong1 - the geographic coordinates of the same point
< !* xlatg,xlongg - latitude and longitude of reference point for
< !* gridsz and orientation specification.
< !* gridsz - the desired grid size in kilometers, at xlatg,xlongg
< !* orient - the angle, with respect to north, of a y-grid line, at
< !* the point xlatg,xlongg
< !* outputs:
< !* strcmp - a 9-value map structure array, fully set for use by
< !* other subroutines in this system
<
< !* subroutine cll2xy (strcmp, xlat,xlong, x,y)
< !* subroutine cxy2ll (strcmp, x,y, xlat,xlong)
< !* these routines convert between map coordinates x,y
< !* and geographic coordinates xlat,xlong
< !* inputs:
< !* strcmp(9) - 9-value map structure array
< !* for cll2xy: xlat,xlong - geographic coordinates
< !* for cxy2ll: x,y - map coordinates
< !* outputs:
< !* for cll2xy: x,y - map coordinates
< !* for cxy2ll: xlat,xlong - geographic coordinates
<
< !* subroutine cc2gxy (strcmp, x,y, ue,vn, ug,vg)
< !* subroutine cg2cxy (strcmp, x,y, ug,vg, ue,vn)
< !* subroutine cc2gll (strcmp, xlat,xlong, ue,vn, ug,vg)
< !* subroutine cg2cll (strcmp, xlat,xlong, ug,vg, ue,vn)
< !* These subroutines convert vector wind components from
< !* geographic, or compass, coordinates, to map or
< !* grid coordinates. The site of the wind to be
< !* converted may be given either in geographic or
< !* map coordinates. Wind components are all in kilometers
< !* per hour, whether geographic or map coordinates.
< !* inputs:
< !* strcmp(9) - 9-value map structure array
< !* for cc2gxy and cg2cxy: x,y - map coordinates of site
< !* for cc2gll and cg2cll: xlat,xlong - geographic coordinates of site
< !* for cc2gxy and cc2gll: ue,vn - east and north wind components
< !* for cg2cxy and cg2cll: ug,vg - x- and y- direction wind components
< !* outputs:
< !* for cc2gxy and cc2gll: ug,vg - x- and y- direction wind components
< !* for cg2cxy and cg2cll: ue,vn - east and north wind components
<
< !* subroutine ccrvxy (strcmp, x, y, gx,gy)
< !* subroutine ccrvll (strcmp, xlat,xlong, gx,gy)
< !* These subroutines return the curvature vector (gx,gy), as referenced
< !* to map coordinates, induced by the map transformation. When
< !* non-linear terms in wind speed are important, a "geodesic" force
< !* should be included in the vector form [ (u,u) g - (u,g) u ] where the
< !* inner product (u,g) is defined as ux*gx + uy*gy.
< !* inputs:
< !* strcmp(9) - 9-value map structure array
< !* for ccrvxy: x,y - map coordinates of site
< !* for ccrvll: xlat,xlong - geographic coordinates of site
< !* outputs:
< !* gx,gy - vector coefficients of curvature, in units radians
< !* per kilometer
<
< !* real function cgszll (strcmp, xlat,xlong)
< !* real function cgszxy (strcmp, x,y)
< !* These functions return the size, in kilometers, of each unit of
< !* motion in map coordinates (grid size). The grid size at any
< !* location depends on that location; the position may be given in
< !* either map or geographic coordinates.
< !* inputs:
< !* strcmp(9) - 9-value map structure array
< !* for cgszxy: x,y - map coordinates of site
< !* for cgszll: xlat,xlong - geographic coordinates of site
< !* returns:
< !* gridsize in kilometers at given site.
<
< !* subroutine cpolxy (strcmp, x,y, enx,eny,enz)
< !* subroutine cpolll (strcmp, xlat,xlong, enx,eny,enz)
< !* These subroutines provide 3-d vector components of a unit vector
< !* in the direction of the north polar axis. When multiplied
< !* by twice the rotation rate of the earth (2 * pi/24 hr), the
< !* vertical component yields the coriolis factor.
< !* inputs:
< !* strcmp(9) - 9-value map structure array
< !* for cpolxy: x,y - map coordinates of site
< !* for cpolll: xlat,xlong - geographic coordinates of site
< !* returns:
< !* enx,eny,enz the direction cosines of a unit vector in the
< !* direction of the rotation axis of the earth
<
< !* subroutine cnllxy (strcmp, xlat,xlong, xi,eta)
< !* subroutine cnxyll (strcmp, xi,eta, xlat,xlong)
< !* These subroutines perform the underlying transformations from
< !* geographic coordinates to and from canonical (equator centered)
< !* coordinates. They are called by cxy2ll and cll2xy, but are not
< !* intended to be called directly
<
< !* real function cspanf (value, begin, end)
< !* This function assists other routines in providing a longitude in
< !* the proper range. It adds to value whatever multiple of
< !* (end - begin) is needed to return a number begin < cspanf <= end
<
< subroutine stlmbr(strcmp, tnglat, xlong)
< !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
<
< implicit none
<
< real :: strcmp(9), tnglat, xlong
<
< real :: eta, xi
<
< strcmp(1) = sin(radpdg * tnglat)
< !* gamma = sine of the tangent latitude
< strcmp(2) = cspanf( xlong, -180., +180.)
< !* lambda_0 = reference longitude
< strcmp(3) = 0.
< !* x_0 = x- grid coordinate of origin (xi,eta) = (0.,0.)
< strcmp(4) = 0.
< !* y_0 = y-grid coordinate of origin (xi,eta) = (0.,0.)
< strcmp(5) = 1.
< !* Cosine of rotation angle from xi,eta to x,y
< strcmp(6) = 0.
< !* Sine of rotation angle from xi,eta to x,y
< strcmp(7) = rearth
< !* Gridsize in kilometers at the equator
< call cnllxy(strcmp, 89.,xlong, xi,eta)
< strcmp(8) = 2. * eta - strcmp(1) * eta * eta
< !* Radial coordinate for 1 degree from north pole
< call cnllxy(strcmp, -89.,xlong, xi,eta)
< strcmp(9) = 2. * eta - strcmp(1) * eta * eta
< !* Radial coordinate for 1 degree from south pole
< return
< end subroutine stlmbr
<
< end module cmapf_mod
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> ! Changes to the routines by A. Stohl
> ! xi,xi0,eta,eta0 are double precision variables to avoid problems
> ! at poles
>
> module cmapf_mod
>
> use par_mod, only: dp
>
> implicit none
> private
>
> public :: cc2gll, cll2xy, cgszll, cxy2ll, stlmbr, stcm2p
>
> real,parameter :: rearth=6371.2, almst1=.9999999
>
> real,parameter :: pi=3.14159265358979
> real,parameter :: radpdg=pi/180., dgprad=180./pi
>
> contains
>
> subroutine cc2gll (strcmp, xlat,xlong, ue,vn, ug,vg)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real :: strcmp(9), xlat, xlong, ue, vn, ug, vg
>
> real(kind=dp) :: xpolg,ypolg,along,slong,clong,rot
>
> along = cspanf( xlong - strcmp(2), -180., 180.)
> if (xlat.gt.89.985) then
> !* North polar meteorological orientation: "north" along prime meridian
> rot = - strcmp(1) * along + xlong - 180.
> elseif (xlat.lt.-89.985) then
> !* South polar meteorological orientation: "north" along prime meridian
> rot = - strcmp(1) * along - xlong
> else
> rot = - strcmp(1) * along
> endif
> slong = sin( radpdg * rot )
> clong = cos( radpdg * rot )
> xpolg = slong * strcmp(5) + clong * strcmp(6)
> ypolg = clong * strcmp(5) - slong * strcmp(6)
> ug = ypolg * ue + xpolg * vn
> vg = ypolg * vn - xpolg * ue
> return
> end subroutine cc2gll
>
> subroutine ccrvll (strcmp, xlat,xlong, gx,gy)
> !* Written on 9/20/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real(kind=dp) :: xpolg,ypolg,temp,along,slong,clong,ctemp, curv
> real :: strcmp(9), xlat, xlong, gx, gy
>
> along = cspanf( xlong - strcmp(2), -180., 180.)
> slong = sin( radpdg * strcmp(1) * along)
> clong = cos( radpdg * strcmp(1) * along)
> xpolg = - slong * strcmp(5) + clong * strcmp(6)
> ypolg = clong * strcmp(5) + slong * strcmp(6)
> temp = sin(radpdg * xlat)
> ctemp = cos(radpdg * xlat)
> curv = (strcmp(1) - temp) / ctemp / rearth
> gx = curv * xpolg
> gy = curv * ypolg
> return
> end subroutine ccrvll
>
> subroutine ccrvxy (strcmp, x,y, gx,gy)
> !* Written on 9/20/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real :: strcmp(9), x, y, gx, gy
> real(kind=dp) :: xpolg,ypolg,temp,ymerc,efact,curv
>
> temp = strcmp(1) * strcmp(7) /rearth
> xpolg = strcmp(6) + temp * (strcmp(3) - x)
> ypolg = strcmp(5) + temp * (strcmp(4) - y)
> temp = sqrt ( xpolg ** 2 + ypolg ** 2 )
> if (temp.gt.0.) then
> ymerc = - log( temp) /strcmp(1)
> efact = exp(ymerc)
> curv = ( (strcmp(1) - 1.d0) * efact + &
> (strcmp(1) + 1.d0) / efact ) &
> * .5d0 / rearth
> gx = xpolg * curv / temp
> gy = ypolg * curv / temp
> else
> if (abs(strcmp(1)) .eq. 1.) then
> gx = 0.
> gy = 0.
> else
> gx = 1./rearth
> gy = 1./rearth
> endif
> endif
> return
> end subroutine ccrvxy
>
> subroutine cg2cll (strcmp, xlat,xlong, ug,vg, ue,vn)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real(kind=dp) :: xpolg,ypolg,along,slong,clong,rot
> real :: strcmp(9), xlat, xlong, ug, vg, ue, vn
>
> along = cspanf( xlong - strcmp(2), -180., 180.)
> if (xlat.gt.89.985) then
> !* North polar meteorological orientation: "north" along prime meridian
> rot = - strcmp(1) * along + xlong - 180.
> elseif (xlat.lt.-89.985) then
> !* South polar meteorological orientation: "north" along prime meridian
> rot = - strcmp(1) * along - xlong
> else
> rot = - strcmp(1) * along
> endif
> slong = sin( radpdg * rot )
> clong = cos( radpdg * rot )
> xpolg = slong * strcmp(5) + clong * strcmp(6)
> ypolg = clong * strcmp(5) - slong * strcmp(6)
> ue = ypolg * ug - xpolg * vg
> vn = ypolg * vg + xpolg * ug
> return
> end subroutine cg2cll
>
> subroutine cg2cxy (strcmp, x,y, ug,vg, ue,vn)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real :: strcmp(9) , x, y, ug, vg, ue, vn
>
> real :: clong, radial, rot, slong, xlat, xlong
> real(kind=dp) :: xpolg,ypolg,temp,xi0,eta0,xi,eta
>
> xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
> eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
> xi = xi0 * strcmp(5) - eta0 * strcmp(6)
> eta = eta0 * strcmp(5) + xi0 * strcmp(6)
> radial = 2. * eta - strcmp(1) * (xi*xi + eta*eta)
> if (radial.gt.strcmp(8)) then
> !* Case north of 89 degrees. Meteorological wind direction definition
> !* changes.
> call cnxyll(strcmp, xi,eta, xlat,xlong)
> !* North polar meteorological orientation: "north" along prime meridian
> rot = strcmp(1) * (xlong - strcmp(2)) - xlong - 180.
> slong = - sin( radpdg * rot )
> clong = cos( radpdg * rot )
> xpolg = slong * strcmp(5) + clong * strcmp(6)
> ypolg = clong * strcmp(5) - slong * strcmp(6)
> else if (radial.lt.strcmp(9)) then
> !* Case south of -89 degrees. Meteorological wind direction definition
> !* changes.
> call cnxyll(strcmp, xi,eta, xlat,xlong)
> !* South polar meteorological orientation: "north" along prime meridian
> rot = strcmp(1) * (xlong - strcmp(2)) + xlong
> slong = - sin( radpdg * rot )
> clong = cos( radpdg * rot )
> xpolg = slong * strcmp(5) + clong * strcmp(6)
> ypolg = clong * strcmp(5) - slong * strcmp(6)
> else
> !* Normal case. Meteorological direction of wind related to true north.
> xpolg = strcmp(6) - strcmp(1) * xi0
> ypolg = strcmp(5) - strcmp(1) * eta0
> temp = sqrt ( xpolg ** 2 + ypolg ** 2 )
> xpolg = xpolg / temp
> ypolg = ypolg / temp
> end if
> ue = ( ypolg * ug - xpolg * vg )
> vn = ( ypolg * vg + xpolg * ug )
> return
> end subroutine cg2cxy
>
> real function cgszll (strcmp, xlat,xlong)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real :: strcmp(9), xlat, xlong
>
> real(kind=dp) :: slat,ymerc,efact
>
> if (xlat .gt. 89.985) then
> !* Close to north pole
> if (strcmp(1) .gt. 0.9999) then
> !* and to gamma == 1.
> cgszll = 2. * strcmp(7)
> return
> endif
> efact = cos(radpdg * xlat)
> if (efact .le. 0.) then
> cgszll = 0.
> return
> else
> ymerc = - log( efact /(1. + sin(radpdg * xlat)))
> endif
> else if (xlat .lt. -89.985) then
> !* Close to south pole
> if (strcmp(1) .lt. -0.9999) then
> !* and to gamma == -1.0
> cgszll = 2. * strcmp(7)
> return
> endif
> efact = cos(radpdg * xlat)
> if (efact .le. 0.) then
> cgszll = 0.
> return
> else
> ymerc = log( efact /(1. - sin(radpdg * xlat)))
> endif
> else
> slat = sin(radpdg * xlat)
> ymerc = log((1. + slat) / (1. - slat))/2.
> !efact = exp(ymerc)
> !cgszll = 2. * strcmp(7) * exp (strcmp(1) * ymerc)
> !c / (efact + 1./efact)
> endif
> cgszll = strcmp(7) * cos(radpdg * xlat) * exp(strcmp(1) *ymerc)
> return
> end function cgszll
>
> real function cgszxy (strcmp, x,y)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real :: strcmp(9) , x, y
> real(kind=dp) :: ymerc,efact, radial, temp
> real(kind=dp) :: xi0,eta0,xi,eta
>
>
> xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
> eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
> xi = xi0 * strcmp(5) - eta0 * strcmp(6)
> eta = eta0 * strcmp(5) + xi0 * strcmp(6)
> radial = 2. * eta - strcmp(1) * (xi*xi + eta*eta)
> efact = strcmp(1) * radial
> if (efact .gt. almst1) then
> if (strcmp(1).gt.almst1) then
> cgszxy = 2. * strcmp(7)
> else
> cgszxy = 0.
> endif
> return
> endif
> if (abs(efact) .lt. 1.e-2) then
> temp = (efact / (2. - efact) )**2
> ymerc = radial / (2. - efact) * (1. + temp * &
> (1./3. + temp * &
> (1./5. + temp * &
> (1./7. ))))
> else
> ymerc = - log( 1. - efact ) /2. /strcmp(1)
> endif
> if (ymerc .gt. 6.) then
> if (strcmp(1) .gt. almst1) then
> cgszxy = 2. * strcmp(7)
> else
> cgszxy = 0.
> endif
> else if (ymerc .lt. -6.) then
> if (strcmp(1) .lt. -almst1) then
> cgszxy = 2. * strcmp(7)
> else
> cgszxy = 0.
> endif
> else
> efact = exp(ymerc)
> cgszxy = 2. * strcmp(7) * exp (strcmp(1) * ymerc) &
> / (efact + 1./efact)
> endif
> return
> end function cgszxy
>
> subroutine cll2xy (strcmp, xlat,xlong, x,y)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> implicit none
>
> real :: strcmp(9) , xlat, xlong, x, y, xi, eta
>
> call cnllxy(strcmp, xlat,xlong, xi,eta)
> x = strcmp(3) + rearth/strcmp(7) * &
> (xi * strcmp(5) + eta * strcmp(6) )
> y = strcmp(4) + rearth/strcmp(7) * &
> (eta * strcmp(5) - xi * strcmp(6) )
> return
> end subroutine cll2xy
>
> subroutine cnllxy (strcmp, xlat,xlong, xi,eta)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
> ! main transformation routine from latitude-longitude to
> ! canonical (equator-centered, radian unit) coordinates
>
> use par_mod, only: dp
>
> implicit none
>
> real :: strcmp(9), xlat, xlong, xi, eta, &
> gdlong, sndgam, csdgam, rhog1
> real(kind=dp) :: gamma
> real(kind=dp) :: dlong,dlat,slat,mercy,gmercy
>
> gamma = strcmp(1)
> dlat = xlat
> dlong = cspanf(xlong - strcmp(2), -180., 180.)
> dlong = dlong * radpdg
> gdlong = gamma * dlong
> if (abs(gdlong) .lt. .01) then
> ! Code for gamma small or zero. This avoids round-off error or divide-
> ! by zero in the case of mercator or near-mercator projections.
> gdlong = gdlong * gdlong
> sndgam = dlong * (1. - 1./6. * gdlong * &
> (1. - 1./20. * gdlong * &
> (1. - 1./42. * gdlong )))
> csdgam = dlong * dlong * .5 * &
> (1. - 1./12. * gdlong * &
> (1. - 1./30. * gdlong * &
> (1. - 1./56. * gdlong )))
> else
> ! Code for moderate values of gamma
> sndgam = sin (gdlong) /gamma
> csdgam = (1. - cos(gdlong) )/gamma /gamma
> endif
> slat = sin(radpdg * dlat)
> if ((slat .ge. almst1) .or. (slat .le. -almst1)) then
> eta = 1./strcmp(1)
> xi = 0.
> return
> endif
> mercy = .5 * log( (1. + slat) / (1. - slat) )
> gmercy = gamma * mercy
> if (abs(gmercy) .lt. .001) then
> ! Code for gamma small or zero. This avoids round-off error or divide-
> ! by zero in the case of mercator or near-mercator projections.
> rhog1 = mercy * (1. - .5 * gmercy * &
> (1. - 1./3. * gmercy * &
> (1. - 1./4. * gmercy ) ) )
> else
> ! Code for moderate values of gamma
> rhog1 = (1. - exp(-gmercy)) / gamma
> endif
> eta = rhog1 + (1. - gamma * rhog1) * gamma * csdgam
> xi = (1. - gamma * rhog1 ) * sndgam
> end subroutine cnllxy
>
> subroutine cnxyll (strcmp, xi,eta, xlat,xlong)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
> ! main transformation routine from canonical (equator-centered,
> ! radian unit) coordinates
>
> use par_mod, only: dp
>
> implicit none
>
> real :: strcmp(9), xlat, xlong, odist
> real(kind=dp) :: gamma,temp,arg1,arg2,ymerc,along,gxi,cgeta
> real(kind=dp) :: xi,eta
>
> gamma = strcmp(1)
> ! Calculate equivalent mercator coordinate
> odist = xi*xi + eta*eta
> arg2 = 2. * eta - gamma * (xi*xi + eta*eta)
> arg1 = gamma * arg2
> ! Change by A. Stohl to avoid problems close to the poles
> ! if (arg1 .ge. almst1) then
> ! distance to north (or south) pole is zero (or imaginary ;) )
> ! xlat = sign(90.,strcmp(1))
> ! xlong = strcmp(2)
> ! return
> ! endif
> if (abs(arg1) .lt. .01) then
> ! Code for gamma small or zero. This avoids round-off error or divide-
> ! by zero in the case of mercator or near-mercator projections.
> temp = (arg1 / (2. - arg1) )**2
> ymerc = arg2 / (2. - arg1) * (1. + temp * &
> (1./3. + temp * &
> (1./5. + temp * &
> (1./7. ))))
> else
> ! Code for moderate values of gamma
> ymerc = - log ( 1. - arg1 ) /2. / gamma
> endif
> ! Convert ymerc to latitude
> temp = exp( - abs(ymerc) )
> xlat = sign(atan2((1. - temp) * (1. + temp), 2. * temp), ymerc)
> ! Find longitudes
> gxi = gamma*xi
> cgeta = 1. - gamma * eta
> if ( abs(gxi) .lt. .01*cgeta ) then
> ! Code for gamma small or zero. This avoids round-off error or divide-
> ! by zero in the case of mercator or near-mercator projections.
> temp = ( gxi /cgeta )**2
> along = xi / cgeta * (1. - temp * &
> (1./3. - temp * &
> (1./5. - temp * &
> (1./7. ))))
> else
> ! Code for moderate values of gamma
> along = atan2( gxi, cgeta) / gamma
> endif
> xlong = sngl(strcmp(2) + dgprad * along)
> xlat = xlat * dgprad
> return
> end subroutine cnxyll
>
> subroutine cpolll (strcmp, xlat,xlong, enx,eny,enz)
> !* Written on 11/23/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real(kind=dp) :: xpolg,ypolg,along,slong,clong,rot
> real :: strcmp(9), xlat, xlong, enx, eny, enz, clat
>
> along = cspanf( xlong - strcmp(2), -180., 180.)
> rot = - strcmp(1) * along
> slong = sin( radpdg * rot )
> clong = cos( radpdg * rot )
> xpolg = slong * strcmp(5) + clong * strcmp(6)
> ypolg = clong * strcmp(5) - slong * strcmp(6)
> clat = cos(radpdg * xlat)
> enx = clat * xpolg
> eny = clat * ypolg
> enz = sin(radpdg * xlat)
> return
> end subroutine cpolll
>
> subroutine cpolxy (strcmp, x,y, enx,eny,enz)
> !* Written on 11/26/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real :: strcmp(9) , x, y, enx, eny, enz
> real(kind=dp) :: xpol,ypol,temp,xi0,eta0,xi,eta,radial
> real(kind=dp) :: temp2,ymerc,arg,oarg,clat
>
> xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
> eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
> xi = xi0 * strcmp(5) - eta0 * strcmp(6)
> eta = eta0 * strcmp(5) + xi0 * strcmp(6)
> radial = 2. * eta - strcmp(1) * (xi*xi + eta*eta)
> temp = strcmp(1) * radial
> if (temp .ge. 1.) then
> enx = 0.
> eny = 0.
> enz = sign(1.,strcmp(1))
> return
> endif
> if (abs(temp).lt.1.e-2) then
> temp2 = (temp / (2. - temp))**2
> ymerc = radial / (2. - temp) * (1. + temp2 * &
> (1./3. + temp2 * &
> (1./5. + temp2 * &
> (1./7.))))
> else
> ymerc = -.5 * log(1. - temp) / strcmp(1)
> endif
> arg = exp( ymerc )
> oarg = 1./arg
> clat = 2./(arg + oarg)
> enz = (arg - oarg) * clat /2.
> temp = clat / sqrt(1. - temp)
> xpol = - xi * strcmp(1) * temp
> ypol = (1. - eta * strcmp(1) ) * temp
> enx = xpol * strcmp(5) + ypol * strcmp(6)
> eny = ypol * strcmp(5) - xpol * strcmp(6)
> return
> end subroutine cpolxy
>
> real function cspanf (value, begin, end)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
> !* real function cspanf returns a value in the interval (begin,end]
> !* which is equivalent to value, mod (end - begin). It is used to
> !* reduce periodic variables to a standard range. It adjusts for the
> !* behavior of the mod function which provides positive results for
> !* positive input, and negative results for negative input
> !* input:
> !* value - real number to be reduced to the span
> !* begin - first value of the span
> !* end - last value of the span
> !* returns:
> !* the reduced value
> !* examples:
> !* along = cspanf(xlong, -180., +180.)
> !* dir = cspanf(angle, 0., 360.)
>
> implicit none
>
> real :: first,last, value, begin, end, val
>
> first = min(begin,end)
> last = max(begin,end)
> val = mod( value - first , last - first)
> if ( val .le. 0.) then
> cspanf = val + last
> else
> cspanf = val + first
> endif
> return
> end function cspanf
>
> subroutine cxy2ll (strcmp, x,y, xlat,xlong)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> use par_mod, only: dp
>
> implicit none
>
> real(kind=dp) :: xi0,eta0,xi,eta
> real :: strcmp(9), x, y, xlat, xlong
>
> xi0 = ( x - strcmp(3) ) * strcmp(7) / rearth
> eta0 = ( y - strcmp(4) ) * strcmp(7) /rearth
> xi = xi0 * strcmp(5) - eta0 * strcmp(6)
> eta = eta0 * strcmp(5) + xi0 * strcmp(6)
> call cnxyll(strcmp, xi,eta, xlat,xlong)
> xlong = cspanf(xlong, -180., 180.)
> return
> end subroutine cxy2ll
>
> real function eqvlat (xlat1,xlat2)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> implicit none
>
> real :: xlat1, xlat2, x, ssind, sinl1, sinl2, al1, al2, tau
>
> ssind(x) = sin (radpdg*x)
> sinl1 = ssind (xlat1)
> sinl2 = ssind (xlat2)
> if (abs(sinl1 - sinl2) .gt. .001) then
> al1 = log((1. - sinl1)/(1. - sinl2))
> al2 = log((1. + sinl1)/(1. + sinl2))
> else
> ! Case lat1 near or equal to lat2
> tau = - (sinl1 - sinl2)/(2. - sinl1 - sinl2)
> tau = tau*tau
> al1 = 2. / (2. - sinl1 - sinl2) * (1. + tau * &
> (1./3. + tau * &
> (1./5. + tau * &
> (1./7.))))
> tau = (sinl1 - sinl2)/(2. + sinl1 + sinl2)
> tau = tau*tau
> al2 = -2. / (2. + sinl1 + sinl2) * (1. + tau * &
> (1./3. + tau * &
> (1./5. + tau * &
> (1./7.))))
> endif
> eqvlat = asin((al1 + al2) / (al1 - al2))/radpdg
> return
> end function eqvlat
>
> subroutine stcm1p(strcmp, x1,y1, xlat1,xlong1, &
> xlatg,xlongg, gridsz, orient)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> implicit none
>
> integer :: k
> real :: strcmp(9), x1, y1, xlat1, xlong1, turn, orient, &
> xlatg, xlongg, gridsz, x1a, y1a
>
> do k=3,4
> strcmp (k) = 0.
> enddo
> turn = radpdg * (orient - strcmp(1) * &
> cspanf(xlongg - strcmp(2), -180., 180.) )
> strcmp (5) = cos (turn)
> strcmp (6) = - sin (turn)
> strcmp (7) = 1.
> strcmp (7) = gridsz * strcmp(7) &
> / cgszll(strcmp, xlatg, strcmp(2))
> call cll2xy (strcmp, xlat1,xlong1, x1a,y1a)
> strcmp(3) = strcmp(3) + x1 - x1a
> strcmp(4) = strcmp(4) + y1 - y1a
> return
> end subroutine stcm1p
>
> subroutine stcm2p(strcmp, x1,y1, xlat1,xlong1, &
> x2,y2, xlat2,xlong2)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> implicit none
>
> real :: strcmp(9), x1, y1, xlat1, xlong1, &
> x2, y2, xlat2, xlong2
>
> integer :: k
> real :: x1a, y1a, x2a, y2a, den, dena
>
> do k=3,6
> strcmp (k) = 0.
> enddo
> strcmp (5) = 1.
> strcmp (7) = 1.
> call cll2xy (strcmp, xlat1,xlong1, x1a,y1a)
> call cll2xy (strcmp, xlat2,xlong2, x2a,y2a)
> den = sqrt( (x1 - x2)**2 + (y1 - y2)**2 )
> dena = sqrt( (x1a - x2a)**2 + (y1a - y2a)**2 )
> strcmp(5) = ((x1a - x2a)*(x1 - x2) + (y1a - y2a) * (y1 - y2)) &
> /den /dena
> strcmp(6) = ((y1a - y2a)*(x1 - x2) - (x1a - x2a) * (y1 - y2)) &
> /den /dena
> strcmp (7) = strcmp(7) * dena / den
> call cll2xy (strcmp, xlat1,xlong1, x1a,y1a)
> strcmp(3) = strcmp(3) + x1 - x1a
> strcmp(4) = strcmp(4) + y1 - y1a
> return
> end subroutine stcm2p
>
> !* General conformal map routines for meteorological modelers
> !* written on 3/31/94 by
>
> !* Dr. Albion Taylor
> !* NOAA / OAR / ARL phone: (301) 713-0295 x 132
> !* rm. 3151, 1315 east-west highway fax: (301) 713-0119
> !* silver spring, md 20910 e-mail: adtaylor@arlrisc.ssmc.noaa.gov
>
> !* subroutine stlmbr (strcmp, tnglat, clong)
> !* This routine initializes the map structure array strcmp to
> !* the form of a specific map projection
> !* inputs:
> !* tnglat - the latitude at which the projection will be tangent
> !* to the earth. +90. For north polar stereographic,
> !* -90. for south polar stereographic, 0. For mercator,
> !* and other values for lambert conformal.
> !* -90 <= tnglat <= 90.
> !* clong - a longitude in the region under consideration. Longitudes
> !* between clong-180. and clong+180. Will be mapped in one
> !* connected region
> !* outputs:
> !* strcmp - a 9-value map structure array for use with subsequent
> !* calls to the coordinate transform routines.
> !*
> !* real function eqvlat (xlat1,xlat2)
> !* This function is provided to assist in finding the tangent latitude
> !* equivalent to the 2-reference latitude specification in the legend
> !* of most lambert conformal maps. If the map specifies "scale
> !* 1:xxxxx true at 40n and 60n", then eqvlat(40.,60.) will return the
> !* equivalent tangent latitude.
> !* inputs:
> !* xlat1,xlat2: the two latitudes specified in the map legend
> !* returns:
> !* the equivalent tangent latitude
> !* example: call stlmbr(strcmp, eqvlat(40.,60.), 90.)
>
> !* subroutine stcm2p (strcmp, x1,y1, xlat1,xlong1,
> !* x2,y2, xlat2,xlong2)
> !* subroutine stcm1p (strcmp, x1,y1, xlat1,xlong1,
> !* xlatg,xlongg, gridsz, orient)
> !* These routines complete the specification of the map structure
> !* array by conforming the map coordinates to the specifications
> !* of a particular grid. Either stcm1p or stcm2p must be called,
> !* but not both
> !* inputs:
> !* strcmp - a 9-value map structure array, set to a particular map
> !* form by a previous call to stlmbr
> !* for stcm2p:
> !* x1,y1, x2,y2 - the map coordinates of two points on the grid
> !* xlat1,xlong1, xlat2,xlong2 - the geographic coordinates of the
> !* same two points
> !* for stcm1p:
> !* x1,y1 - the map coordinates of one point on the grid
> !* xlat1,xlong1 - the geographic coordinates of the same point
> !* xlatg,xlongg - latitude and longitude of reference point for
> !* gridsz and orientation specification.
> !* gridsz - the desired grid size in kilometers, at xlatg,xlongg
> !* orient - the angle, with respect to north, of a y-grid line, at
> !* the point xlatg,xlongg
> !* outputs:
> !* strcmp - a 9-value map structure array, fully set for use by
> !* other subroutines in this system
>
> !* subroutine cll2xy (strcmp, xlat,xlong, x,y)
> !* subroutine cxy2ll (strcmp, x,y, xlat,xlong)
> !* these routines convert between map coordinates x,y
> !* and geographic coordinates xlat,xlong
> !* inputs:
> !* strcmp(9) - 9-value map structure array
> !* for cll2xy: xlat,xlong - geographic coordinates
> !* for cxy2ll: x,y - map coordinates
> !* outputs:
> !* for cll2xy: x,y - map coordinates
> !* for cxy2ll: xlat,xlong - geographic coordinates
>
> !* subroutine cc2gxy (strcmp, x,y, ue,vn, ug,vg)
> !* subroutine cg2cxy (strcmp, x,y, ug,vg, ue,vn)
> !* subroutine cc2gll (strcmp, xlat,xlong, ue,vn, ug,vg)
> !* subroutine cg2cll (strcmp, xlat,xlong, ug,vg, ue,vn)
> !* These subroutines convert vector wind components from
> !* geographic, or compass, coordinates, to map or
> !* grid coordinates. The site of the wind to be
> !* converted may be given either in geographic or
> !* map coordinates. Wind components are all in kilometers
> !* per hour, whether geographic or map coordinates.
> !* inputs:
> !* strcmp(9) - 9-value map structure array
> !* for cc2gxy and cg2cxy: x,y - map coordinates of site
> !* for cc2gll and cg2cll: xlat,xlong - geographic coordinates of site
> !* for cc2gxy and cc2gll: ue,vn - east and north wind components
> !* for cg2cxy and cg2cll: ug,vg - x- and y- direction wind components
> !* outputs:
> !* for cc2gxy and cc2gll: ug,vg - x- and y- direction wind components
> !* for cg2cxy and cg2cll: ue,vn - east and north wind components
>
> !* subroutine ccrvxy (strcmp, x, y, gx,gy)
> !* subroutine ccrvll (strcmp, xlat,xlong, gx,gy)
> !* These subroutines return the curvature vector (gx,gy), as referenced
> !* to map coordinates, induced by the map transformation. When
> !* non-linear terms in wind speed are important, a "geodesic" force
> !* should be included in the vector form [ (u,u) g - (u,g) u ] where the
> !* inner product (u,g) is defined as ux*gx + uy*gy.
> !* inputs:
> !* strcmp(9) - 9-value map structure array
> !* for ccrvxy: x,y - map coordinates of site
> !* for ccrvll: xlat,xlong - geographic coordinates of site
> !* outputs:
> !* gx,gy - vector coefficients of curvature, in units radians
> !* per kilometer
>
> !* real function cgszll (strcmp, xlat,xlong)
> !* real function cgszxy (strcmp, x,y)
> !* These functions return the size, in kilometers, of each unit of
> !* motion in map coordinates (grid size). The grid size at any
> !* location depends on that location; the position may be given in
> !* either map or geographic coordinates.
> !* inputs:
> !* strcmp(9) - 9-value map structure array
> !* for cgszxy: x,y - map coordinates of site
> !* for cgszll: xlat,xlong - geographic coordinates of site
> !* returns:
> !* gridsize in kilometers at given site.
>
> !* subroutine cpolxy (strcmp, x,y, enx,eny,enz)
> !* subroutine cpolll (strcmp, xlat,xlong, enx,eny,enz)
> !* These subroutines provide 3-d vector components of a unit vector
> !* in the direction of the north polar axis. When multiplied
> !* by twice the rotation rate of the earth (2 * pi/24 hr), the
> !* vertical component yields the coriolis factor.
> !* inputs:
> !* strcmp(9) - 9-value map structure array
> !* for cpolxy: x,y - map coordinates of site
> !* for cpolll: xlat,xlong - geographic coordinates of site
> !* returns:
> !* enx,eny,enz the direction cosines of a unit vector in the
> !* direction of the rotation axis of the earth
>
> !* subroutine cnllxy (strcmp, xlat,xlong, xi,eta)
> !* subroutine cnxyll (strcmp, xi,eta, xlat,xlong)
> !* These subroutines perform the underlying transformations from
> !* geographic coordinates to and from canonical (equator centered)
> !* coordinates. They are called by cxy2ll and cll2xy, but are not
> !* intended to be called directly
>
> !* real function cspanf (value, begin, end)
> !* This function assists other routines in providing a longitude in
> !* the proper range. It adds to value whatever multiple of
> !* (end - begin) is needed to return a number begin < cspanf <= end
>
> subroutine stlmbr(strcmp, tnglat, xlong)
> !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL
>
> implicit none
>
> real :: strcmp(9), tnglat, xlong
>
> real :: eta, xi
>
> strcmp(1) = sin(radpdg * tnglat)
> !* gamma = sine of the tangent latitude
> strcmp(2) = cspanf( xlong, -180., +180.)
> !* lambda_0 = reference longitude
> strcmp(3) = 0.
> !* x_0 = x- grid coordinate of origin (xi,eta) = (0.,0.)
> strcmp(4) = 0.
> !* y_0 = y-grid coordinate of origin (xi,eta) = (0.,0.)
> strcmp(5) = 1.
> !* Cosine of rotation angle from xi,eta to x,y
> strcmp(6) = 0.
> !* Sine of rotation angle from xi,eta to x,y
> strcmp(7) = rearth
> !* Gridsize in kilometers at the equator
> call cnllxy(strcmp, 89.,xlong, xi,eta)
> strcmp(8) = 2. * eta - strcmp(1) * eta * eta
> !* Radial coordinate for 1 degree from north pole
> call cnllxy(strcmp, -89.,xlong, xi,eta)
> strcmp(9) = 2. * eta - strcmp(1) * eta * eta
> !* Radial coordinate for 1 degree from south pole
> return
> end subroutine stlmbr
>
> end module cmapf_mod
com_mod.f90
----------------------------------------------
1,674c1,674
< !*******************************************************************************
< ! Include file for particle diffusion model FLEXPART *
< ! This file contains a global common block used by FLEXPART *
< ! *
< ! Author: A. Stohl *
< ! *
< ! June 1996 *
< ! *
< ! Last update: 9 August 2000 *
< ! *
< !*******************************************************************************
<
< module com_mod
<
< use par_mod, only: dp, numpath, maxnests, maxageclass, maxspec, ni, &
< numclass, nymax, nxmax, maxcolumn, maxwf, nzmax, nxmaxn, nymaxn, &
< maxreceptor, maxpart, maxrand, nwzmax, nuvzmax
<
< implicit none
<
< !****************************************************************
< ! Variables defining where FLEXPART input/output files are stored
< !****************************************************************
<
< character :: path(numpath+2*maxnests)*120
< integer :: length(numpath+2*maxnests)
<
< ! path path names needed for trajectory model
< ! length length of path names needed for trajectory model
<
<
< !********************************************************
< ! Variables defining the general model run specifications
< !********************************************************
<
< integer :: ibdate,ibtime,iedate,ietime
< real(kind=dp) :: bdate,edate
<
<
< ! ibdate beginning date (YYYYMMDD)
< ! ibtime beginning time (HHMISS)
< ! iedate ending date (YYYYMMDD)
< ! ietime ending time (HHMISS)
< ! bdate beginning date of simulation (julian date)
< ! edate ending date of simulation (julian date)
<
<
< integer :: ldirect,ideltas
<
< ! ldirect 1 for forward, -1 for backward simulation
< ! ideltas length of trajectory loop from beginning to
< ! ending date (s)
<
< integer :: loutstep,loutaver,loutsample,method,lsynctime
< real :: outstep
<
< ! loutstep [s] gridded concentration output every loutstep seconds
< ! loutaver [s] concentration output is an average over [s] seconds
< ! loutsample [s] sampling interval of gridded concentration output
< ! lsynctime [s] synchronisation time of all particles
< ! method indicator which dispersion method is to be used
< ! outstep = real(abs(loutstep))
<
< real :: ctl,fine
< integer :: ifine,iout,ipout,ipin,iflux,mdomainfill
< integer :: mquasilag,nested_output,ind_source,ind_receptor
< integer :: ind_rel,ind_samp,ioutputforeachrelease,linit_cond
< logical :: turbswitch
<
< ! ctl factor, by which time step must be smaller than Lagrangian time scale
< ! ifine reduction factor for time step used for vertical wind
< ! Langevin equation for the vertical wind component
< ! ioutputforeachrelease Should each release be a seperate output field?
< ! iflux flux calculation options: 1 calculation of fluxes, 2 no fluxes
< ! iout output options: 1 conc. output (ng/m3), 2 mixing ratio (pptv), 3 both
< ! ipout particle dump options: 0 no, 1 every output interval, 2 only at end
< ! ipin read in particle positions from dumped file from a previous run
< ! fine real(ifine)
< ! mdomainfill 0: normal run
< ! 1: particles are initialized according to atmospheric mass distribution
< ! ind_source switches between different units for concentrations at the source
< ! NOTE that in backward simulations the release of computational particles
< ! takes place at the "receptor" and the sampling of particles at the "source".
< ! 1= mass units
< ! 2= mass mixing ratio units
< ! ind_receptor switches between different units for FLEXPART concentration at the receptor
< ! 1= mass units
< ! 2= mass mixing ratio units
< ! linit_cond switch on the output of sensitivity to initial conditions for backward runs
< ! 0=no, 1=mass unit, 2=mass mixing ratio unit
< ! mquasilag 0: normal run
< ! 1: Particle position output is produced in a condensed format and particles are numbered
< ! nested_output: 0 no, 1 yes
< ! turbswitch determines how the Markov chain is formulated
<
< ! ind_rel and ind_samp are used within the code to change between mass and mass-mix (see readcommand.f)
<
<
< integer :: mintime,itsplit
<
< ! mintime minimum time step to be used by FLEXPART
< ! itsplit time constant for splitting particles
<
< integer :: lsubgrid,lconvection,lagespectra
<
< ! lsubgrid 1 if subgrid topography parameterization switched on, 2 if not
< ! lconvection 1 if convection parameterization switched on, 0 if not
< ! lagespectra 1 if age spectra calculation switched on, 2 if not
<
<
< integer :: nageclass,lage(maxageclass)
<
< ! nageclass number of ageclasses for the age spectra calculation
< ! lage [s] ageclasses for the age spectra calculation
<
<
< logical :: gdomainfill
<
< ! gdomainfill .T., if domain-filling is global, .F. if not
<
<
<
< !*********************************************************************
< ! Variables defining the release locations, released species and their
< ! properties, etc.
< !*********************************************************************
<
< !change Sabine Eckhardt, only save the first 1000 identifier for releasepoints
< character :: compoint(1001)*45
< integer :: numpoint
< !sec, now dynamically allocated:
< ! ireleasestart(maxpoint),ireleaseend(maxpoint)
< ! real xpoint1(maxpoint),ypoint1(maxpoint)
< !real xpoint2(maxpoint),ypoint2(maxpoint)
< !real zpoint1(maxpoint),zpoint2(maxpoint)
< !integer*2 kindz(maxpoint)
< integer :: specnum(maxspec)
< !real xmass(maxpoint,maxspec)
< real :: decay(maxspec)
< real :: weta(maxspec),wetb(maxspec)
< real :: reldiff(maxspec),henry(maxspec),f0(maxspec)
< real :: density(maxspec),dquer(maxspec),dsigma(maxspec)
< real :: vsetaver(maxspec),cunningham(maxspec),weightmolar(maxspec)
< real :: vset(maxspec,ni),schmi(maxspec,ni),fract(maxspec,ni)
< real :: ri(5,numclass),rac(5,numclass),rcl(maxspec,5,numclass)
< real :: rgs(maxspec,5,numclass),rlu(maxspec,5,numclass)
< real :: rm(maxspec),dryvel(maxspec),kao(maxspec),ohreact(maxspec)
< ! se it is possible to associate a species with a second one to make transfer from gas to aerosol
< integer :: spec_ass(maxspec)
<
< real :: area_hour(maxspec,24),point_hour(maxspec,24)
< real :: area_dow(maxspec,7),point_dow(maxspec,7)
<
< !integer npart(maxpoint)
< integer :: nspec,maxpointspec_act
< character(len=10) :: species(maxspec)
<
<
< ! compoint comment, also "name" of each starting point
< ! numpoint actual number of trajectory starting/ending points
< ! ireleasestart,ireleaseend [s] starting and ending time of each release
< ! xmass total mass emitted
< ! xpoint1,ypoint1 lower left coordinates of release area
< ! xpoint2,ypoint2 upper right coordinates of release area
< ! zpoint1,zpoint2 min./max. z-coordinates of release points
< ! kindz 1: zpoint is in m agl, 2: zpoint is in m asl
< ! npart number of particles per release point
< ! nspec number of different species allowed for one release
< ! maxpointspec_act number of releaspoints for which a different output shall be created
< ! species name of species
< ! decay decay constant of radionuclide
<
< ! WET DEPOSITION
< ! weta, wetb parameters for determining wet scavenging coefficients
<
< ! GAS DEPOSITION
< ! reldiff diffusivitiy of species relative to diff. of H2O
< ! henry [M/atm] Henry constant
< ! f0 reactivity relative to that of O3
< ! ri [s/m] stomatal resistance
< ! rcl [s/m] lower canopy resistance
< ! rgs [s/m] ground resistance
< ! rlu [s/m] leaf cuticular resistance
< ! rm [s/m] mesophyll resistance
< ! dryvel [m/s] constant dry deposition velocity
<
< ! PARTICLE DEPOSITION
< ! density [kg/m3] density of particles
< ! dquer [m] mean diameter of particles
< ! dsigma dsigma=10 or dsigma=0.1 means that 68% of the
< ! mass are between 0.1*dquer and 10*dquer
<
< ! fract mass fraction of each diameter interval
< ! vset [m/s] gravitational settling velocity in ni intervals
< ! cunningham Cunningham slip correction (strictly valid only near surface)
< ! vsetaver [m/s] average gravitational settling velocity
< ! schmi Schmidt number**2/3 of each diameter interval
< ! weightmolar [g/mol] molecular weight
<
< ! TIME VARIATION OF EMISSION
< ! area_hour, point_hour daily variation of emission strengths for area and point sources
< ! area_dow, point_dow day-of-week variation of emission strengths for area and point sources
<
<
<
< !**********************************************************
< ! Variables used for domain-filling trajectory calculations
< !**********************************************************
<
< integer :: nx_we(2),ny_sn(2)
< integer :: numcolumn
< integer :: numcolumn_we(2,0:nymax-1),numcolumn_sn(2,0:nxmax-1)
< real :: zcolumn_we(2,0:nymax-1,maxcolumn)
< real :: zcolumn_sn(2,0:nxmax-1,maxcolumn)
< real :: xmassperparticle
< real :: acc_mass_we(2,0:nymax-1,maxcolumn)
< real :: acc_mass_sn(2,0:nxmax-1,maxcolumn)
<
< ! nx_we(2) x indices of western and eastern boundary of domain-filling
< ! ny_sn(2) y indices of southern and northern boundary of domain-filling
< ! numcolumn_we number of particles to be released within one column
< ! at the western and eastern boundary surfaces
< ! numcolumn_sn same as numcolumn_we, but for southern and northern domain boundary
< ! numcolumn maximum number of particles to be released within a single
< ! column
< ! zcolumn_we altitudes where particles are to be released
< ! at the western and eastern boundary surfaces
< ! zcolumn_sn same as zcolumn_we, but for southern and northern domain boundary
< ! xmassperparticle air mass per particle in the domain-filling traj. option
< ! acc_mass_we mass that has accumulated at the western and eastern boundary;
< ! if it exceeds xmassperparticle, a particle is released and
< ! acc_mass_we is reduced accordingly
< ! acc_mass_sn same as acc_mass_we, but for southern and northern domain boundary
<
<
<
< !******************************************************************************
< ! Variables associated with the ECMWF meteorological input data ("wind fields")
< !******************************************************************************
<
< integer :: numbwf,wftime(maxwf),lwindinterv
< character(len=255) :: wfname(maxwf),wfspec(maxwf)
<
< ! lwindinterv [s] Interval between wind fields currently in memory
< ! numbwf actual number of wind fields
< ! wftime(maxwf) [s] times relative to beginning time of wind fields
< ! wfname(maxwf) file names of wind fields
< ! wfspec(maxwf) specifications of wind field file, e.g. if on hard
< ! disc or on tape
<
< integer :: memtime(2),memind(2)
<
< ! memtime [s] validation times of wind fields in memory
< ! memind pointer to wind field, in order to avoid shuffling
< ! of wind fields
<
<
<
< !****************************************************************************
< ! Variables defining actual size and geographical location of the wind fields
< !****************************************************************************
<
< integer :: nx,ny,nxmin1,nymin1,nxfield,nuvz,nwz,nz,nmixz,nlev_ec
< real :: dx,dy,xlon0,ylat0,dxconst,dyconst,height(nzmax)
<
< ! nx,ny,nz actual dimensions of wind fields in x,y and z
< ! direction, respectively
< ! nxmin1,nymin1 nx-1, ny-1, respectively
< ! nuvz,nwz vertical dimension of original ECMWF data
< ! nxfield same as nx for limited area fields,
< ! but for global fields nx=nxfield+1
< ! nmixz number of levels up to maximum PBL height (3500 m)
<
< ! nuvz is used for u,v components
< ! nwz is used for w components (staggered grid)
< ! nz is used for the levels in transformed coordinates (terrain-following Cartesian
< ! coordinates)
<
< ! nlev_ec number of levels ECMWF model
< ! dx grid distance in x direction
< ! dy grid distance in y direction
< ! dxconst,dyconst auxiliary variables for utransform,vtransform
< ! height heights of all levels
< ! xlon0 geographical longitude and
< ! ylat0 geographical latitude of lower left grid point
<
<
<
< !*************************************************
< ! Variables used for vertical model discretization
< !*************************************************
<
< real :: akm(nwzmax),bkm(nwzmax)
< real :: akz(nuvzmax),bkz(nuvzmax)
< real :: aknew(nzmax),bknew(nzmax)
<
< ! akm,bkm: coeffizients which regulate vertical discretization of ecmwf model
< ! (at the border of model layers)
< ! akz,bkz: model discretization coeffizients at the centre of the layers
< ! aknew,bknew model discretization coeffizients at the interpolated levels
<
<
<
< ! Fixed fields, unchangeable with time
< !*************************************
<
< real :: oro(0:nxmax-1,0:nymax-1)
< real :: excessoro(0:nxmax-1,0:nymax-1)
< real :: lsm(0:nxmax-1,0:nymax-1)
< real :: xlanduse(0:nxmax-1,0:nymax-1,numclass)
<
< ! oro [m] orography of the ECMWF model
< ! excessoro excess orography mother domain
< ! lsm land sea mask of the ECMWF model
< ! xlanduse [0-1] area fractions in percent
<
< ! 3d fields
< !**********
<
< real :: uu(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: vv(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: uupol(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: vvpol(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: ww(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: tt(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: qv(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: pv(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: rho(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: drhodz(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: tth(0:nxmax-1,0:nymax-1,nuvzmax,2)
< real :: qvh(0:nxmax-1,0:nymax-1,nuvzmax,2)
< real :: pplev(0:nxmax-1,0:nymax-1,nuvzmax,2)
< integer(kind=1) :: clouds(0:nxmax-1,0:nymax-1,nzmax,2)
< integer :: cloudsh(0:nxmax-1,0:nymax-1,2)
<
< ! uu,vv,ww [m/2] wind components in x,y and z direction
< ! uupol,vvpol [m/s] wind components in polar stereographic projection
< ! tt [K] temperature data
< ! qv specific humidity data
< ! pv (pvu) potential vorticity
< ! rho [kg/m3] air density
< ! drhodz [kg/m2] vertical air density gradient
< ! tth,qvh tth,qvh on original eta levels
< ! clouds: no cloud, no precipitation 0
< ! cloud, no precipitation 1
< ! rainout conv/lsp dominated 2/3
< ! washout conv/lsp dominated 4/5
< ! pplev for the GFS version
<
< ! 2d fields
< !**********
<
< real :: ps(0:nxmax-1,0:nymax-1,1,2)
< real :: sd(0:nxmax-1,0:nymax-1,1,2)
< real :: msl(0:nxmax-1,0:nymax-1,1,2)
< real :: tcc(0:nxmax-1,0:nymax-1,1,2)
< real :: u10(0:nxmax-1,0:nymax-1,1,2)
< real :: v10(0:nxmax-1,0:nymax-1,1,2)
< real :: tt2(0:nxmax-1,0:nymax-1,1,2)
< real :: td2(0:nxmax-1,0:nymax-1,1,2)
< real :: lsprec(0:nxmax-1,0:nymax-1,1,2)
< real :: convprec(0:nxmax-1,0:nymax-1,1,2)
< real :: sshf(0:nxmax-1,0:nymax-1,1,2)
< real :: ssr(0:nxmax-1,0:nymax-1,1,2)
< real :: surfstr(0:nxmax-1,0:nymax-1,1,2)
< real :: ustar(0:nxmax-1,0:nymax-1,1,2)
< real :: wstar(0:nxmax-1,0:nymax-1,1,2)
< real :: hmix(0:nxmax-1,0:nymax-1,1,2)
< real :: tropopause(0:nxmax-1,0:nymax-1,1,2)
< real :: oli(0:nxmax-1,0:nymax-1,1,2)
< real :: diffk(0:nxmax-1,0:nymax-1,1,2)
<
< ! ps surface pressure
< ! sd snow depth
< ! msl mean sea level pressure
< ! tcc total cloud cover
< ! u10 10 meter u
< ! v10 10 meter v
< ! tt2 2 meter temperature
< ! td2 2 meter dew point
< ! lsprec [mm/h] large scale total precipitation
< ! convprec [mm/h] convective precipitation
< ! sshf surface sensible heat flux
< ! ssr surface solar radiation
< ! surfstr surface stress
< ! ustar [m/s] friction velocity
< ! wstar [m/s] convective velocity scale
< ! hmix [m] mixing height
< ! tropopause [m] altitude of thermal tropopause
< ! oli [m] inverse Obukhov length (1/L)
< ! diffk [m2/s] diffusion coefficient at reference height
<
<
< real :: vdep(0:nxmax-1,0:nymax-1,maxspec,2)
<
< ! vdep [m/s] deposition velocities
<
<
< !********************************************************************
< ! Variables associated with the ECMWF input data (nested wind fields)
< !********************************************************************
<
< ! NOTE: all nested variables have the same name as the variables used
< ! for the mother domain, except with a 'n' appended at the end
< !********************************************************************
<
< integer :: numbnests
<
< ! numbnests number of nested grids
<
< character(len=255) :: wfnamen(maxnests,maxwf)
< character(len=18) :: wfspecn(maxnests,maxwf)
<
< ! wfnamen nested wind field names
< ! wfspecn specifications of wind field file, e.g. if on hard
< ! disc or on tape
<
<
< !*********************************************************************
< ! Variables characterizing size and location of the nested wind fields
< !*********************************************************************
<
< integer :: nxn(maxnests),nyn(maxnests)
< real :: dxn(maxnests),dyn(maxnests),xlon0n(maxnests),ylat0n(maxnests)
<
< ! nxn,nyn actual dimensions of nested wind fields in x and y direction
< ! dxn,dyn grid distances in x,y direction for the nested grids
< ! xlon0n geographical longitude of lower left grid point of nested wind fields
< ! ylat0n geographical latitude of lower left grid point of nested wind fields
<
<
< ! Nested fields, unchangeable with time
< !**************************************
<
< real :: oron(0:nxmaxn-1,0:nymaxn-1,maxnests)
< real :: excessoron(0:nxmaxn-1,0:nymaxn-1,maxnests)
< real :: lsmn(0:nxmaxn-1,0:nymaxn-1,maxnests)
< real :: xlandusen(0:nxmaxn-1,0:nymaxn-1,numclass,maxnests)
<
<
< ! 3d nested fields
< !*****************
<
< real :: uun(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: vvn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: wwn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: ttn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: qvn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: pvn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< integer(kind=1) :: cloudsn(0:nxmaxn-1,0:nymaxn-1,0:nzmax,2,maxnests)
< integer :: cloudsnh(0:nxmaxn-1,0:nymaxn-1,2,maxnests)
< real :: rhon(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: drhodzn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: tthn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests)
< real :: qvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests)
<
< ! 2d nested fields
< !*****************
<
< real :: psn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: sdn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: msln(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: tccn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: u10n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: v10n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: tt2n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: td2n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: lsprecn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: convprecn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: sshfn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: ssrn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: surfstrn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: ustarn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: wstarn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: hmixn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: tropopausen(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: olin(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: diffkn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
< real :: vdepn(0:nxmaxn-1,0:nymaxn-1,maxspec,2,maxnests)
<
<
< !*************************************************
< ! Certain auxiliary variables needed for the nests
< !*************************************************
<
< real :: xresoln(0:maxnests),yresoln(0:maxnests)
<
< ! xresoln, yresoln Factors by which the resolutions in the nests
< ! are enhanced compared to mother grid
<
< real :: xln(maxnests),yln(maxnests),xrn(maxnests),yrn(maxnests)
<
< ! xln,yln,xrn,yrn Corner points of nested grids in grid coordinates
< ! of mother grid
<
<
< !******************************************************
< ! Variables defining the polar stereographic projection
< !******************************************************
<
< logical :: xglobal,sglobal,nglobal
< real :: switchnorthg,switchsouthg
<
< !xglobal T for global fields, F for limited area fields
< !sglobal T if domain extends towards south pole
< !nglobal T if domain extends towards north pole
< !switchnorthg,switchsouthg same as parameters switchnorth,
< ! switchsouth, but in grid units
<
< real :: southpolemap(9),northpolemap(9)
<
< !southpolemap,northpolemap define stereographic projections
< ! at the two poles
<
<
< !******************
< ! Landuse inventory
< ! Sabine Eckhardt Dec 06: change to new landuse inventary - 11 classes, 1200 x 600 global
< !******************
<
< integer(kind=1) :: landinvent(1200,600,6)
< real :: z0(numclass)
<
< ! landinvent landuse inventory (numclass=11 classes)
< ! z0 roughness length for the landuse classes
<
<
<
< !**************************************************************************
< ! Variables characterizing the output grid and containing the model results
< !**************************************************************************
<
< integer :: numxgrid,numygrid,numzgrid
< real :: dxout,dyout,outlon0,outlat0,xoutshift,youtshift
< integer :: numxgridn,numygridn
< real :: dxoutn,dyoutn,outlon0n,outlat0n,xoutshiftn,youtshiftn
< !real outheight(maxzgrid),outheighthalf(maxzgrid)
< logical :: DEP,DRYDEP,DRYDEPSPEC(maxspec),WETDEP,OHREA,ASSSPEC
<
< ! numxgrid,numygrid number of grid points in x,y-direction
< ! numxgridn,numygridn number of grid points in x,y-direction for nested output grid
< ! numzgrid number of vertical levels of output grid
< ! dxout,dyout grid distance of output grid
< ! dxoutn,dyoutn grid distance of nested output grid
< ! outlon0,outlat0 lower left corner of output grid
< ! outlon0n,outlat0n lower left corner of nested output grid
< ! xoutshift,youtshift xlon0-outlon0, ylat0-outlat0
< ! xoutshiftn,youtshiftn xlon0-outlon0n, ylat0-outlat0n
< ! outheight [m] upper levels of the output grid
< ! outheighthalf [m] half (middle) levels of the output grid cells
< ! DEP .true., if either dry or wet depos. is switched on
< ! DRYDEP .true., if dry deposition is switched on
< ! DRYDEPSPEC .true., if dry deposition is switched on for that species
< ! WETDEP .true., if wet deposition is switched on
< ! OHREA .true., if OH reaction is switched on
< ! ASSSPEC .true., if there are two species asscoiated
< ! (i.e. transfer of mass between these two occurs
<
<
<
< ! if output for each releasepoint shall be created maxpointspec=number of releasepoints
< ! else maxpointspec is 1 -> moved to unc_mod
< ! the OUTGRID is moved to the module outg_mod
< !******************************************************************************
<
< !real gridunc(0:maxxgrid-1,0:maxygrid-1,maxzgrid,maxspec,
< ! + maxpointspec_act,nclassunc,maxageclass)
< !real griduncn(0:maxxgridn-1,0:maxygridn-1,maxzgrid,maxspec,
< ! + maxpointspec_act,nclassunc,maxageclass)
< !real wetgridunc(0:maxxgrid-1,0:maxygrid-1,maxspec,
< ! + maxpointspec_act,nclassunc,maxageclass)
< !real wetgriduncn(0:maxxgridn-1,0:maxygridn-1,maxspec,
< ! +ct maxpointspec,nclassunc,maxageclass)
< !real drygridunc(0:maxxgrid-1,0:maxygrid-1,maxspec,maxpointspec,
< ! + nclassunc,maxageclass)
< !real drygriduncn(0:maxxgridn-1,0:maxygridn-1,maxspec,
< ! + maxpointspec,nclassunc,maxageclass)
<
< !real oroout(0:maxxgrid-1,0:maxygrid-1)
< !real orooutn(0:maxxgridn-1,0:maxygridn-1)
< ! real area(0:maxxgrid-1,0:maxygrid-1)
< !real arean(0:maxxgridn-1,0:maxygridn-1)
< !real volume(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
< !real volumen(0:maxxgridn-1,0:maxygridn-1,maxzgrid)
<
< !real areaeast(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
< !real areanorth(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
<
<
< ! gridunc,griduncn uncertainty of outputted concentrations
< ! wetgridunc,wetgriduncn uncertainty of accumulated wet deposited mass on output grid
< ! drygridunc,drygriduncn uncertainty of accumulated dry deposited mass on output grid
< ! oroout,orooutn [m] height of model topography at output grid
< ! area,arean [m2] area of each grid cell
< ! volume,volumen [m3] volume of each grid cell
< ! ... field names with n at the end indicate a nested output grid
<
<
< !***********************************
< ! Variables defining receptor points
< !***********************************
<
< real :: xreceptor(maxreceptor),yreceptor(maxreceptor)
< real :: receptorarea(maxreceptor)
< real :: creceptor(maxreceptor,maxspec)
< character(len=16) :: receptorname(maxreceptor)
< integer :: numreceptor
<
< ! xreceptor,yreceptor receptor position
< ! creceptor concentrations at receptor points
< ! receptorarea area of 1*1 grid cell at receptor point
<
<
<
< !***************************************
< ! Variables characterizing each particle
< !***************************************
<
< integer :: numpart,itra1(maxpart)
< integer :: npoint(maxpart),nclass(maxpart)
< integer :: idt(maxpart),itramem(maxpart),itrasplit(maxpart)
< integer :: numparticlecount
<
< real(kind=dp) :: xtra1(maxpart),ytra1(maxpart)
< real :: ztra1(maxpart),xmass1(maxpart,maxspec)
<
< ! numpart actual number of particles in memory
< ! itra1 (maxpart) [s] temporal positions of the particles
< ! npoint(maxpart) indicates the release point of each particle
< ! nclass (maxpart) one of nclassunc classes to which the particle is attributed
< ! itramem (maxpart) [s] memorized release times of the particles
< ! itrasplit (maxpart) [s] next time when particle is to be split into two
< ! idt(maxpart) [s] time step to be used for next integration
< ! numparticlecount counts the total number of particles that have been released
< ! xtra1,ytra1,ztra1 spatial positions of the particles
< ! xmass1 [kg] particle masses
<
<
<
< !*******************************************************
< ! Info table on available chemical species/radionuclides
< !*******************************************************
<
< !character*10 specname(maxtable)
< !real decaytime(maxtable),wetscava(maxtable),wetscavb(maxtable)
< !real drydiff(maxtable),dryhenry(maxtable),dryactiv(maxtable)
< !real partrho(maxtable),partmean(maxtable),partsig(maxtable)
< !real dryvelo(maxtable),weightmol(maxtable),ohreact(maxtable)
<
< ! specname Name of chemical species/radionuclide
< ! decaytime Half time of radionuclides
< ! wetscava, wetscavb Parameters for calculating scavenging coefficients
< ! drydiff diffusivitiy of species relative to diff. of H2O
< ! dryhenry [M/atm] Henry constant
< ! dryactiv reactivity relative to that of O3
< ! partrho [kg/m3] density of particles
< ! partmean [m] mean diameter of particles
< ! partsig [m] mean stand. deviation of particle diameter
< ! dryvelo [cm/s] constant dry deposition velocity
< ! weightmol [g/mol] molecular weight
< ! ohreact OH reaction rate
<
<
<
< !********************
< ! Random number field
< !********************
<
< real :: rannumb(maxrand)
<
< ! rannumb field of normally distributed random numbers
<
<
< end module com_mod
---
> !*******************************************************************************
> ! Include file for particle diffusion model FLEXPART *
> ! This file contains a global common block used by FLEXPART *
> ! *
> ! Author: A. Stohl *
> ! *
> ! June 1996 *
> ! *
> ! Last update: 9 August 2000 *
> ! *
> !*******************************************************************************
>
> module com_mod
>
> use par_mod, only: dp, numpath, maxnests, maxageclass, maxspec, ni, &
> numclass, nymax, nxmax, maxcolumn, maxwf, nzmax, nxmaxn, nymaxn, &
> maxreceptor, maxpart, maxrand, nwzmax, nuvzmax
>
> implicit none
>
> !****************************************************************
> ! Variables defining where FLEXPART input/output files are stored
> !****************************************************************
>
> character :: path(numpath+2*maxnests)*120
> integer :: length(numpath+2*maxnests)
>
> ! path path names needed for trajectory model
> ! length length of path names needed for trajectory model
>
>
> !********************************************************
> ! Variables defining the general model run specifications
> !********************************************************
>
> integer :: ibdate,ibtime,iedate,ietime
> real(kind=dp) :: bdate,edate
>
>
> ! ibdate beginning date (YYYYMMDD)
> ! ibtime beginning time (HHMISS)
> ! iedate ending date (YYYYMMDD)
> ! ietime ending time (HHMISS)
> ! bdate beginning date of simulation (julian date)
> ! edate ending date of simulation (julian date)
>
>
> integer :: ldirect,ideltas
>
> ! ldirect 1 for forward, -1 for backward simulation
> ! ideltas length of trajectory loop from beginning to
> ! ending date (s)
>
> integer :: loutstep,loutaver,loutsample,method,lsynctime
> real :: outstep
>
> ! loutstep [s] gridded concentration output every loutstep seconds
> ! loutaver [s] concentration output is an average over [s] seconds
> ! loutsample [s] sampling interval of gridded concentration output
> ! lsynctime [s] synchronisation time of all particles
> ! method indicator which dispersion method is to be used
> ! outstep = real(abs(loutstep))
>
> real :: ctl,fine
> integer :: ifine,iout,ipout,ipin,iflux,mdomainfill
> integer :: mquasilag,nested_output,ind_source,ind_receptor
> integer :: ind_rel,ind_samp,ioutputforeachrelease,linit_cond
> logical :: turbswitch
>
> ! ctl factor, by which time step must be smaller than Lagrangian time scale
> ! ifine reduction factor for time step used for vertical wind
> ! Langevin equation for the vertical wind component
> ! ioutputforeachrelease Should each release be a seperate output field?
> ! iflux flux calculation options: 1 calculation of fluxes, 2 no fluxes
> ! iout output options: 1 conc. output (ng/m3), 2 mixing ratio (pptv), 3 both
> ! ipout particle dump options: 0 no, 1 every output interval, 2 only at end
> ! ipin read in particle positions from dumped file from a previous run
> ! fine real(ifine)
> ! mdomainfill 0: normal run
> ! 1: particles are initialized according to atmospheric mass distribution
> ! ind_source switches between different units for concentrations at the source
> ! NOTE that in backward simulations the release of computational particles
> ! takes place at the "receptor" and the sampling of particles at the "source".
> ! 1= mass units
> ! 2= mass mixing ratio units
> ! ind_receptor switches between different units for FLEXPART concentration at the receptor
> ! 1= mass units
> ! 2= mass mixing ratio units
> ! linit_cond switch on the output of sensitivity to initial conditions for backward runs
> ! 0=no, 1=mass unit, 2=mass mixing ratio unit
> ! mquasilag 0: normal run
> ! 1: Particle position output is produced in a condensed format and particles are numbered
> ! nested_output: 0 no, 1 yes
> ! turbswitch determines how the Markov chain is formulated
>
> ! ind_rel and ind_samp are used within the code to change between mass and mass-mix (see readcommand.f)
>
>
> integer :: mintime,itsplit
>
> ! mintime minimum time step to be used by FLEXPART
> ! itsplit time constant for splitting particles
>
> integer :: lsubgrid,lconvection,lagespectra
>
> ! lsubgrid 1 if subgrid topography parameterization switched on, 2 if not
> ! lconvection 1 if convection parameterization switched on, 0 if not
> ! lagespectra 1 if age spectra calculation switched on, 2 if not
>
>
> integer :: nageclass,lage(maxageclass)
>
> ! nageclass number of ageclasses for the age spectra calculation
> ! lage [s] ageclasses for the age spectra calculation
>
>
> logical :: gdomainfill
>
> ! gdomainfill .T., if domain-filling is global, .F. if not
>
>
>
> !*********************************************************************
> ! Variables defining the release locations, released species and their
> ! properties, etc.
> !*********************************************************************
>
> !change Sabine Eckhardt, only save the first 1000 identifier for releasepoints
> character :: compoint(1001)*45
> integer :: numpoint
> !sec, now dynamically allocated:
> ! ireleasestart(maxpoint),ireleaseend(maxpoint)
> ! real xpoint1(maxpoint),ypoint1(maxpoint)
> !real xpoint2(maxpoint),ypoint2(maxpoint)
> !real zpoint1(maxpoint),zpoint2(maxpoint)
> !integer*2 kindz(maxpoint)
> integer :: specnum(maxspec)
> !real xmass(maxpoint,maxspec)
> real :: decay(maxspec)
> real :: weta(maxspec),wetb(maxspec)
> real :: reldiff(maxspec),henry(maxspec),f0(maxspec)
> real :: density(maxspec),dquer(maxspec),dsigma(maxspec)
> real :: vsetaver(maxspec),cunningham(maxspec),weightmolar(maxspec)
> real :: vset(maxspec,ni),schmi(maxspec,ni),fract(maxspec,ni)
> real :: ri(5,numclass),rac(5,numclass),rcl(maxspec,5,numclass)
> real :: rgs(maxspec,5,numclass),rlu(maxspec,5,numclass)
> real :: rm(maxspec),dryvel(maxspec),kao(maxspec),ohreact(maxspec)
> ! se it is possible to associate a species with a second one to make transfer from gas to aerosol
> integer :: spec_ass(maxspec)
>
> real :: area_hour(maxspec,24),point_hour(maxspec,24)
> real :: area_dow(maxspec,7),point_dow(maxspec,7)
>
> !integer npart(maxpoint)
> integer :: nspec,maxpointspec_act
> character(len=10) :: species(maxspec)
>
>
> ! compoint comment, also "name" of each starting point
> ! numpoint actual number of trajectory starting/ending points
> ! ireleasestart,ireleaseend [s] starting and ending time of each release
> ! xmass total mass emitted
> ! xpoint1,ypoint1 lower left coordinates of release area
> ! xpoint2,ypoint2 upper right coordinates of release area
> ! zpoint1,zpoint2 min./max. z-coordinates of release points
> ! kindz 1: zpoint is in m agl, 2: zpoint is in m asl
> ! npart number of particles per release point
> ! nspec number of different species allowed for one release
> ! maxpointspec_act number of releaspoints for which a different output shall be created
> ! species name of species
> ! decay decay constant of radionuclide
>
> ! WET DEPOSITION
> ! weta, wetb parameters for determining wet scavenging coefficients
>
> ! GAS DEPOSITION
> ! reldiff diffusivitiy of species relative to diff. of H2O
> ! henry [M/atm] Henry constant
> ! f0 reactivity relative to that of O3
> ! ri [s/m] stomatal resistance
> ! rcl [s/m] lower canopy resistance
> ! rgs [s/m] ground resistance
> ! rlu [s/m] leaf cuticular resistance
> ! rm [s/m] mesophyll resistance
> ! dryvel [m/s] constant dry deposition velocity
>
> ! PARTICLE DEPOSITION
> ! density [kg/m3] density of particles
> ! dquer [m] mean diameter of particles
> ! dsigma dsigma=10 or dsigma=0.1 means that 68% of the
> ! mass are between 0.1*dquer and 10*dquer
>
> ! fract mass fraction of each diameter interval
> ! vset [m/s] gravitational settling velocity in ni intervals
> ! cunningham Cunningham slip correction (strictly valid only near surface)
> ! vsetaver [m/s] average gravitational settling velocity
> ! schmi Schmidt number**2/3 of each diameter interval
> ! weightmolar [g/mol] molecular weight
>
> ! TIME VARIATION OF EMISSION
> ! area_hour, point_hour daily variation of emission strengths for area and point sources
> ! area_dow, point_dow day-of-week variation of emission strengths for area and point sources
>
>
>
> !**********************************************************
> ! Variables used for domain-filling trajectory calculations
> !**********************************************************
>
> integer :: nx_we(2),ny_sn(2)
> integer :: numcolumn
> integer :: numcolumn_we(2,0:nymax-1),numcolumn_sn(2,0:nxmax-1)
> real :: zcolumn_we(2,0:nymax-1,maxcolumn)
> real :: zcolumn_sn(2,0:nxmax-1,maxcolumn)
> real :: xmassperparticle
> real :: acc_mass_we(2,0:nymax-1,maxcolumn)
> real :: acc_mass_sn(2,0:nxmax-1,maxcolumn)
>
> ! nx_we(2) x indices of western and eastern boundary of domain-filling
> ! ny_sn(2) y indices of southern and northern boundary of domain-filling
> ! numcolumn_we number of particles to be released within one column
> ! at the western and eastern boundary surfaces
> ! numcolumn_sn same as numcolumn_we, but for southern and northern domain boundary
> ! numcolumn maximum number of particles to be released within a single
> ! column
> ! zcolumn_we altitudes where particles are to be released
> ! at the western and eastern boundary surfaces
> ! zcolumn_sn same as zcolumn_we, but for southern and northern domain boundary
> ! xmassperparticle air mass per particle in the domain-filling traj. option
> ! acc_mass_we mass that has accumulated at the western and eastern boundary;
> ! if it exceeds xmassperparticle, a particle is released and
> ! acc_mass_we is reduced accordingly
> ! acc_mass_sn same as acc_mass_we, but for southern and northern domain boundary
>
>
>
> !******************************************************************************
> ! Variables associated with the ECMWF meteorological input data ("wind fields")
> !******************************************************************************
>
> integer :: numbwf,wftime(maxwf),lwindinterv
> character(len=255) :: wfname(maxwf),wfspec(maxwf)
>
> ! lwindinterv [s] Interval between wind fields currently in memory
> ! numbwf actual number of wind fields
> ! wftime(maxwf) [s] times relative to beginning time of wind fields
> ! wfname(maxwf) file names of wind fields
> ! wfspec(maxwf) specifications of wind field file, e.g. if on hard
> ! disc or on tape
>
> integer :: memtime(2),memind(2)
>
> ! memtime [s] validation times of wind fields in memory
> ! memind pointer to wind field, in order to avoid shuffling
> ! of wind fields
>
>
>
> !****************************************************************************
> ! Variables defining actual size and geographical location of the wind fields
> !****************************************************************************
>
> integer :: nx,ny,nxmin1,nymin1,nxfield,nuvz,nwz,nz,nmixz,nlev_ec
> real :: dx,dy,xlon0,ylat0,dxconst,dyconst,height(nzmax)
>
> ! nx,ny,nz actual dimensions of wind fields in x,y and z
> ! direction, respectively
> ! nxmin1,nymin1 nx-1, ny-1, respectively
> ! nuvz,nwz vertical dimension of original ECMWF data
> ! nxfield same as nx for limited area fields,
> ! but for global fields nx=nxfield+1
> ! nmixz number of levels up to maximum PBL height (3500 m)
>
> ! nuvz is used for u,v components
> ! nwz is used for w components (staggered grid)
> ! nz is used for the levels in transformed coordinates (terrain-following Cartesian
> ! coordinates)
>
> ! nlev_ec number of levels ECMWF model
> ! dx grid distance in x direction
> ! dy grid distance in y direction
> ! dxconst,dyconst auxiliary variables for utransform,vtransform
> ! height heights of all levels
> ! xlon0 geographical longitude and
> ! ylat0 geographical latitude of lower left grid point
>
>
>
> !*************************************************
> ! Variables used for vertical model discretization
> !*************************************************
>
> real :: akm(nwzmax),bkm(nwzmax)
> real :: akz(nuvzmax),bkz(nuvzmax)
> real :: aknew(nzmax),bknew(nzmax)
>
> ! akm,bkm: coeffizients which regulate vertical discretization of ecmwf model
> ! (at the border of model layers)
> ! akz,bkz: model discretization coeffizients at the centre of the layers
> ! aknew,bknew model discretization coeffizients at the interpolated levels
>
>
>
> ! Fixed fields, unchangeable with time
> !*************************************
>
> real :: oro(0:nxmax-1,0:nymax-1)
> real :: excessoro(0:nxmax-1,0:nymax-1)
> real :: lsm(0:nxmax-1,0:nymax-1)
> real :: xlanduse(0:nxmax-1,0:nymax-1,numclass)
>
> ! oro [m] orography of the ECMWF model
> ! excessoro excess orography mother domain
> ! lsm land sea mask of the ECMWF model
> ! xlanduse [0-1] area fractions in percent
>
> ! 3d fields
> !**********
>
> real :: uu(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: vv(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: uupol(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: vvpol(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: ww(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: tt(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: qv(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: pv(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: rho(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: drhodz(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: tth(0:nxmax-1,0:nymax-1,nuvzmax,2)
> real :: qvh(0:nxmax-1,0:nymax-1,nuvzmax,2)
> real :: pplev(0:nxmax-1,0:nymax-1,nuvzmax,2)
> integer(kind=1) :: clouds(0:nxmax-1,0:nymax-1,nzmax,2)
> integer :: cloudsh(0:nxmax-1,0:nymax-1,2)
>
> ! uu,vv,ww [m/2] wind components in x,y and z direction
> ! uupol,vvpol [m/s] wind components in polar stereographic projection
> ! tt [K] temperature data
> ! qv specific humidity data
> ! pv (pvu) potential vorticity
> ! rho [kg/m3] air density
> ! drhodz [kg/m2] vertical air density gradient
> ! tth,qvh tth,qvh on original eta levels
> ! clouds: no cloud, no precipitation 0
> ! cloud, no precipitation 1
> ! rainout conv/lsp dominated 2/3
> ! washout conv/lsp dominated 4/5
> ! pplev for the GFS version
>
> ! 2d fields
> !**********
>
> real :: ps(0:nxmax-1,0:nymax-1,1,2)
> real :: sd(0:nxmax-1,0:nymax-1,1,2)
> real :: msl(0:nxmax-1,0:nymax-1,1,2)
> real :: tcc(0:nxmax-1,0:nymax-1,1,2)
> real :: u10(0:nxmax-1,0:nymax-1,1,2)
> real :: v10(0:nxmax-1,0:nymax-1,1,2)
> real :: tt2(0:nxmax-1,0:nymax-1,1,2)
> real :: td2(0:nxmax-1,0:nymax-1,1,2)
> real :: lsprec(0:nxmax-1,0:nymax-1,1,2)
> real :: convprec(0:nxmax-1,0:nymax-1,1,2)
> real :: sshf(0:nxmax-1,0:nymax-1,1,2)
> real :: ssr(0:nxmax-1,0:nymax-1,1,2)
> real :: surfstr(0:nxmax-1,0:nymax-1,1,2)
> real :: ustar(0:nxmax-1,0:nymax-1,1,2)
> real :: wstar(0:nxmax-1,0:nymax-1,1,2)
> real :: hmix(0:nxmax-1,0:nymax-1,1,2)
> real :: tropopause(0:nxmax-1,0:nymax-1,1,2)
> real :: oli(0:nxmax-1,0:nymax-1,1,2)
> real :: diffk(0:nxmax-1,0:nymax-1,1,2)
>
> ! ps surface pressure
> ! sd snow depth
> ! msl mean sea level pressure
> ! tcc total cloud cover
> ! u10 10 meter u
> ! v10 10 meter v
> ! tt2 2 meter temperature
> ! td2 2 meter dew point
> ! lsprec [mm/h] large scale total precipitation
> ! convprec [mm/h] convective precipitation
> ! sshf surface sensible heat flux
> ! ssr surface solar radiation
> ! surfstr surface stress
> ! ustar [m/s] friction velocity
> ! wstar [m/s] convective velocity scale
> ! hmix [m] mixing height
> ! tropopause [m] altitude of thermal tropopause
> ! oli [m] inverse Obukhov length (1/L)
> ! diffk [m2/s] diffusion coefficient at reference height
>
>
> real :: vdep(0:nxmax-1,0:nymax-1,maxspec,2)
>
> ! vdep [m/s] deposition velocities
>
>
> !********************************************************************
> ! Variables associated with the ECMWF input data (nested wind fields)
> !********************************************************************
>
> ! NOTE: all nested variables have the same name as the variables used
> ! for the mother domain, except with a 'n' appended at the end
> !********************************************************************
>
> integer :: numbnests
>
> ! numbnests number of nested grids
>
> character(len=255) :: wfnamen(maxnests,maxwf)
> character(len=18) :: wfspecn(maxnests,maxwf)
>
> ! wfnamen nested wind field names
> ! wfspecn specifications of wind field file, e.g. if on hard
> ! disc or on tape
>
>
> !*********************************************************************
> ! Variables characterizing size and location of the nested wind fields
> !*********************************************************************
>
> integer :: nxn(maxnests),nyn(maxnests)
> real :: dxn(maxnests),dyn(maxnests),xlon0n(maxnests),ylat0n(maxnests)
>
> ! nxn,nyn actual dimensions of nested wind fields in x and y direction
> ! dxn,dyn grid distances in x,y direction for the nested grids
> ! xlon0n geographical longitude of lower left grid point of nested wind fields
> ! ylat0n geographical latitude of lower left grid point of nested wind fields
>
>
> ! Nested fields, unchangeable with time
> !**************************************
>
> real :: oron(0:nxmaxn-1,0:nymaxn-1,maxnests)
> real :: excessoron(0:nxmaxn-1,0:nymaxn-1,maxnests)
> real :: lsmn(0:nxmaxn-1,0:nymaxn-1,maxnests)
> real :: xlandusen(0:nxmaxn-1,0:nymaxn-1,numclass,maxnests)
>
>
> ! 3d nested fields
> !*****************
>
> real :: uun(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: vvn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: wwn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: ttn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: qvn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: pvn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> integer(kind=1) :: cloudsn(0:nxmaxn-1,0:nymaxn-1,0:nzmax,2,maxnests)
> integer :: cloudsnh(0:nxmaxn-1,0:nymaxn-1,2,maxnests)
> real :: rhon(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: drhodzn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: tthn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests)
> real :: qvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests)
>
> ! 2d nested fields
> !*****************
>
> real :: psn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: sdn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: msln(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: tccn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: u10n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: v10n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: tt2n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: td2n(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: lsprecn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: convprecn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: sshfn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: ssrn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: surfstrn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: ustarn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: wstarn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: hmixn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: tropopausen(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: olin(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: diffkn(0:nxmaxn-1,0:nymaxn-1,1,2,maxnests)
> real :: vdepn(0:nxmaxn-1,0:nymaxn-1,maxspec,2,maxnests)
>
>
> !*************************************************
> ! Certain auxiliary variables needed for the nests
> !*************************************************
>
> real :: xresoln(0:maxnests),yresoln(0:maxnests)
>
> ! xresoln, yresoln Factors by which the resolutions in the nests
> ! are enhanced compared to mother grid
>
> real :: xln(maxnests),yln(maxnests),xrn(maxnests),yrn(maxnests)
>
> ! xln,yln,xrn,yrn Corner points of nested grids in grid coordinates
> ! of mother grid
>
>
> !******************************************************
> ! Variables defining the polar stereographic projection
> !******************************************************
>
> logical :: xglobal,sglobal,nglobal
> real :: switchnorthg,switchsouthg
>
> !xglobal T for global fields, F for limited area fields
> !sglobal T if domain extends towards south pole
> !nglobal T if domain extends towards north pole
> !switchnorthg,switchsouthg same as parameters switchnorth,
> ! switchsouth, but in grid units
>
> real :: southpolemap(9),northpolemap(9)
>
> !southpolemap,northpolemap define stereographic projections
> ! at the two poles
>
>
> !******************
> ! Landuse inventory
> ! Sabine Eckhardt Dec 06: change to new landuse inventary - 11 classes, 1200 x 600 global
> !******************
>
> integer(kind=1) :: landinvent(1200,600,6)
> real :: z0(numclass)
>
> ! landinvent landuse inventory (numclass=11 classes)
> ! z0 roughness length for the landuse classes
>
>
>
> !**************************************************************************
> ! Variables characterizing the output grid and containing the model results
> !**************************************************************************
>
> integer :: numxgrid,numygrid,numzgrid
> real :: dxout,dyout,outlon0,outlat0,xoutshift,youtshift
> integer :: numxgridn,numygridn
> real :: dxoutn,dyoutn,outlon0n,outlat0n,xoutshiftn,youtshiftn
> !real outheight(maxzgrid),outheighthalf(maxzgrid)
> logical :: DEP,DRYDEP,DRYDEPSPEC(maxspec),WETDEP,OHREA,ASSSPEC
>
> ! numxgrid,numygrid number of grid points in x,y-direction
> ! numxgridn,numygridn number of grid points in x,y-direction for nested output grid
> ! numzgrid number of vertical levels of output grid
> ! dxout,dyout grid distance of output grid
> ! dxoutn,dyoutn grid distance of nested output grid
> ! outlon0,outlat0 lower left corner of output grid
> ! outlon0n,outlat0n lower left corner of nested output grid
> ! xoutshift,youtshift xlon0-outlon0, ylat0-outlat0
> ! xoutshiftn,youtshiftn xlon0-outlon0n, ylat0-outlat0n
> ! outheight [m] upper levels of the output grid
> ! outheighthalf [m] half (middle) levels of the output grid cells
> ! DEP .true., if either dry or wet depos. is switched on
> ! DRYDEP .true., if dry deposition is switched on
> ! DRYDEPSPEC .true., if dry deposition is switched on for that species
> ! WETDEP .true., if wet deposition is switched on
> ! OHREA .true., if OH reaction is switched on
> ! ASSSPEC .true., if there are two species asscoiated
> ! (i.e. transfer of mass between these two occurs
>
>
>
> ! if output for each releasepoint shall be created maxpointspec=number of releasepoints
> ! else maxpointspec is 1 -> moved to unc_mod
> ! the OUTGRID is moved to the module outg_mod
> !******************************************************************************
>
> !real gridunc(0:maxxgrid-1,0:maxygrid-1,maxzgrid,maxspec,
> ! + maxpointspec_act,nclassunc,maxageclass)
> !real griduncn(0:maxxgridn-1,0:maxygridn-1,maxzgrid,maxspec,
> ! + maxpointspec_act,nclassunc,maxageclass)
> !real wetgridunc(0:maxxgrid-1,0:maxygrid-1,maxspec,
> ! + maxpointspec_act,nclassunc,maxageclass)
> !real wetgriduncn(0:maxxgridn-1,0:maxygridn-1,maxspec,
> ! +ct maxpointspec,nclassunc,maxageclass)
> !real drygridunc(0:maxxgrid-1,0:maxygrid-1,maxspec,maxpointspec,
> ! + nclassunc,maxageclass)
> !real drygriduncn(0:maxxgridn-1,0:maxygridn-1,maxspec,
> ! + maxpointspec,nclassunc,maxageclass)
>
> !real oroout(0:maxxgrid-1,0:maxygrid-1)
> !real orooutn(0:maxxgridn-1,0:maxygridn-1)
> ! real area(0:maxxgrid-1,0:maxygrid-1)
> !real arean(0:maxxgridn-1,0:maxygridn-1)
> !real volume(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
> !real volumen(0:maxxgridn-1,0:maxygridn-1,maxzgrid)
>
> !real areaeast(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
> !real areanorth(0:maxxgrid-1,0:maxygrid-1,maxzgrid)
>
>
> ! gridunc,griduncn uncertainty of outputted concentrations
> ! wetgridunc,wetgriduncn uncertainty of accumulated wet deposited mass on output grid
> ! drygridunc,drygriduncn uncertainty of accumulated dry deposited mass on output grid
> ! oroout,orooutn [m] height of model topography at output grid
> ! area,arean [m2] area of each grid cell
> ! volume,volumen [m3] volume of each grid cell
> ! ... field names with n at the end indicate a nested output grid
>
>
> !***********************************
> ! Variables defining receptor points
> !***********************************
>
> real :: xreceptor(maxreceptor),yreceptor(maxreceptor)
> real :: receptorarea(maxreceptor)
> real :: creceptor(maxreceptor,maxspec)
> character(len=16) :: receptorname(maxreceptor)
> integer :: numreceptor
>
> ! xreceptor,yreceptor receptor position
> ! creceptor concentrations at receptor points
> ! receptorarea area of 1*1 grid cell at receptor point
>
>
>
> !***************************************
> ! Variables characterizing each particle
> !***************************************
>
> integer :: numpart,itra1(maxpart)
> integer :: npoint(maxpart),nclass(maxpart)
> integer :: idt(maxpart),itramem(maxpart),itrasplit(maxpart)
> integer :: numparticlecount
>
> real(kind=dp) :: xtra1(maxpart),ytra1(maxpart)
> real :: ztra1(maxpart),xmass1(maxpart,maxspec)
>
> ! numpart actual number of particles in memory
> ! itra1 (maxpart) [s] temporal positions of the particles
> ! npoint(maxpart) indicates the release point of each particle
> ! nclass (maxpart) one of nclassunc classes to which the particle is attributed
> ! itramem (maxpart) [s] memorized release times of the particles
> ! itrasplit (maxpart) [s] next time when particle is to be split into two
> ! idt(maxpart) [s] time step to be used for next integration
> ! numparticlecount counts the total number of particles that have been released
> ! xtra1,ytra1,ztra1 spatial positions of the particles
> ! xmass1 [kg] particle masses
>
>
>
> !*******************************************************
> ! Info table on available chemical species/radionuclides
> !*******************************************************
>
> !character*10 specname(maxtable)
> !real decaytime(maxtable),wetscava(maxtable),wetscavb(maxtable)
> !real drydiff(maxtable),dryhenry(maxtable),dryactiv(maxtable)
> !real partrho(maxtable),partmean(maxtable),partsig(maxtable)
> !real dryvelo(maxtable),weightmol(maxtable),ohreact(maxtable)
>
> ! specname Name of chemical species/radionuclide
> ! decaytime Half time of radionuclides
> ! wetscava, wetscavb Parameters for calculating scavenging coefficients
> ! drydiff diffusivitiy of species relative to diff. of H2O
> ! dryhenry [M/atm] Henry constant
> ! dryactiv reactivity relative to that of O3
> ! partrho [kg/m3] density of particles
> ! partmean [m] mean diameter of particles
> ! partsig [m] mean stand. deviation of particle diameter
> ! dryvelo [cm/s] constant dry deposition velocity
> ! weightmol [g/mol] molecular weight
> ! ohreact OH reaction rate
>
>
>
> !********************
> ! Random number field
> !********************
>
> real :: rannumb(maxrand)
>
> ! rannumb field of normally distributed random numbers
>
>
> end module com_mod
conccalc.f90
----------------------------------------------
1,419c1,449
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine conccalc(itime,weight)
< ! i i
< !*****************************************************************************
< ! *
< ! Calculation of the concentrations on a regular grid using volume *
< ! sampling *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 24 May 1996 *
< ! *
< ! April 2000: Update to calculate age spectra *
< ! Bug fix to avoid negative conc. at the domain boundaries, *
< ! as suggested by Petra Seibert *
< ! *
< ! 2 July 2002: re-order if-statements in order to optimize CPU time *
< ! *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! nspeciesdim = nspec for forward runs, 1 for backward runs *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: itime,itage,i,ix,jy,ixp,jyp,kz,ks,n,nage
< integer :: il,ind,indz,indzp,nrelpointer
< real :: rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
< real :: weight,hx,hy,hz,h,xd,yd,zd,xkern,r2,c(maxspec),ddx,ddy
< real :: rhoprof(2),rhoi
< real :: xl,yl,wx,wy,w
< real,parameter :: factor=.596831, hxmax=6.0, hymax=4.0, hzmax=150.
<
<
< ! For forward simulations, make a loop over the number of species;
< ! for backward simulations, make an additional loop over the
< ! releasepoints
< !***************************************************************************
<
<
< do i=1,numpart
< if (itra1(i).ne.itime) goto 20
<
< ! Determine age class of the particle
< itage=abs(itra1(i)-itramem(i))
< do nage=1,nageclass
< if (itage.lt.lage(nage)) goto 33
< end do
< 33 continue
<
<
< ! For special runs, interpolate the air density to the particle position
< !************************************************************************
< !***********************************************************************
< !AF IND_SOURCE switches between different units for concentrations at the source
< !Af NOTE that in backward simulations the release of particles takes place
< !Af at the receptor and the sampling at the source.
< !Af 1="mass"
< !Af 2="mass mixing ratio"
< !Af IND_RECEPTOR switches between different units for concentrations at the receptor
< !Af 1="mass"
< !Af 2="mass mixing ratio"
<
< !Af switches for the conccalcfile:
< !AF IND_SAMP = 0 : xmass * 1
< !Af IND_SAMP = -1 : xmass / rho
<
< !Af ind_samp is defined in readcommand.f
<
< if ( ind_samp .eq. -1 ) then
<
< ix=int(xtra1(i))
< jy=int(ytra1(i))
< ixp=ix+1
< jyp=jy+1
< ddx=xtra1(i)-real(ix)
< ddy=ytra1(i)-real(jy)
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
<
< do il=2,nz
< if (height(il).gt.ztra1(i)) then
< indz=il-1
< indzp=il
< goto 6
< endif
< end do
< 6 continue
<
< dz1=ztra1(i)-height(indz)
< dz2=height(indzp)-ztra1(i)
< dz=1./(dz1+dz2)
<
< ! Take density from 2nd wind field in memory (accurate enough, no time interpolation needed)
< !*****************************************************************************
< do ind=indz,indzp
< rhoprof(ind-indz+1)=p1*rho(ix ,jy ,ind,2) &
< +p2*rho(ixp,jy ,ind,2) &
< +p3*rho(ix ,jyp,ind,2) &
< +p4*rho(ixp,jyp,ind,2)
< end do
< rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
< elseif (ind_samp.eq.0) then
< rhoi = 1.
< endif
<
<
< !****************************************************************************
< ! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
< !****************************************************************************
<
<
< ! For backward simulations, look from which release point the particle comes from
< ! For domain-filling trajectory option, npoint contains a consecutive particle
< ! number, not the release point information. Therefore, nrelpointer is set to 1
< ! for the domain-filling option.
< !*****************************************************************************
<
< if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
< nrelpointer=1
< else
< nrelpointer=npoint(i)
< endif
<
< do kz=1,numzgrid ! determine height of cell
< if (outheight(kz).gt.ztra1(i)) goto 21
< end do
< 21 continue
< if (kz.le.numzgrid) then ! inside output domain
<
<
< !********************************
< ! Do everything for mother domain
< !********************************
<
< xl=(xtra1(i)*dx+xoutshift)/dxout
< yl=(ytra1(i)*dy+youtshift)/dyout
< ix=int(xl)
< if (xl.lt.0.) ix=ix-1
< 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
< ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
< ! For older particles, use the uniform kernel.
< ! If a particle is close to the domain boundary, do not use the kernel either.
< !*****************************************************************************
<
< if ((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
< if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
< (jy.le.numygrid-1)) 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
< end do
< endif
<
< else ! attribution via uniform kernel
<
< ddx=xl-real(ix) ! distance to left cell border
< ddy=yl-real(jy) ! distance to lower cell border
< if (ddx.gt.0.5) then
< ixp=ix+1
< wx=1.5-ddx
< else
< ixp=ix-1
< wx=0.5+ddx
< endif
<
< if (ddy.gt.0.5) then
< jyp=jy+1
< wy=1.5-ddy
< else
< jyp=jy-1
< wy=0.5+ddy
< endif
<
<
< ! Determine mass fractions for four grid points
< !**********************************************
<
< if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
< if ((jy.ge.0).and.(jy.le.numygrid-1)) then
< w=wx*wy
< 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
<
< if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
< w=wx*(1.-wy)
< 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
< end do
< endif
< endif
<
<
< 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)
< 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
<
< if ((jy.ge.0).and.(jy.le.numygrid-1)) then
< w=(1.-wx)*wy
< 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
< end do
< endif
< endif
< endif
<
<
<
< !************************************
< ! Do everything for the nested domain
< !************************************
<
< if (nested_output.eq.1) then
< xl=(xtra1(i)*dx+xoutshiftn)/dxoutn
< yl=(ytra1(i)*dy+youtshiftn)/dyoutn
< ix=int(xl)
< if (xl.lt.0.) ix=ix-1
< jy=int(yl)
< if (yl.lt.0.) jy=jy-1
<
<
< ! For particles aged less than 3 hours, attribute particle mass to grid cell
< ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
< ! For older particles, use the uniform kernel.
< ! If a particle is close to the domain boundary, do not use the kernel either.
< !*****************************************************************************
<
< 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
< if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
< (jy.le.numygridn-1)) 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
< end do
< endif
<
< else ! attribution via uniform kernel
<
< ddx=xl-real(ix) ! distance to left cell border
< ddy=yl-real(jy) ! distance to lower cell border
< if (ddx.gt.0.5) then
< ixp=ix+1
< wx=1.5-ddx
< else
< ixp=ix-1
< wx=0.5+ddx
< endif
<
< if (ddy.gt.0.5) then
< jyp=jy+1
< wy=1.5-ddy
< else
< jyp=jy-1
< wy=0.5+ddy
< endif
<
<
< ! Determine mass fractions for four grid points
< !**********************************************
<
< if ((ix.ge.0).and.(ix.le.numxgridn-1)) then
< if ((jy.ge.0).and.(jy.le.numygridn-1)) then
< w=wx*wy
< 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
<
< if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
< w=wx*(1.-wy)
< 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
< end do
< 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)
< 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
<
< if ((jy.ge.0).and.(jy.le.numygridn-1)) then
< w=(1.-wx)*wy
< 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
< end do
< endif
< endif
< endif
<
< endif
< endif
< 20 continue
< end do
<
< !***********************************************************************
< ! 2. Evaluate concentrations at receptor points, using the kernel method
< !***********************************************************************
<
< do n=1,numreceptor
<
<
< ! Reset concentrations
< !*********************
<
< do ks=1,nspec
< c(ks)=0.
< end do
<
<
< ! Estimate concentration at receptor
< !***********************************
<
< do i=1,numpart
<
< if (itra1(i).ne.itime) goto 40
< itage=abs(itra1(i)-itramem(i))
<
< hz=min(50.+0.3*sqrt(real(itage)),hzmax)
< zd=ztra1(i)/hz
< if (zd.gt.1.) goto 40 ! save computing time, leave loop
<
< hx=min((0.29+2.222e-3*sqrt(real(itage)))*dx+ &
< real(itage)*1.2e-5,hxmax) ! 80 km/day
< xd=(xtra1(i)-xreceptor(n))/hx
< if (xd*xd.gt.1.) goto 40 ! save computing time, leave loop
<
< hy=min((0.18+1.389e-3*sqrt(real(itage)))*dy+ &
< real(itage)*7.5e-6,hymax) ! 80 km/day
< yd=(ytra1(i)-yreceptor(n))/hy
< if (yd*yd.gt.1.) goto 40 ! save computing time, leave loop
< h=hx*hy*hz
<
< r2=xd*xd+yd*yd+zd*zd
< if (r2.lt.1.) then
< xkern=factor*(1.-r2)
< do ks=1,nspec
< c(ks)=c(ks)+xmass1(i,ks)*xkern/h
< end do
< endif
< 40 continue
< end do
<
< do ks=1,nspec
< creceptor(n,ks)=creceptor(n,ks)+2.*weight*c(ks)/receptorarea(n)
< end do
< end do
<
< end subroutine conccalc
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine conccalc(itime,weight)
> ! i i
> !*****************************************************************************
> ! *
> ! Calculation of the concentrations on a regular grid using volume *
> ! sampling *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 24 May 1996 *
> ! *
> ! April 2000: Update to calculate age spectra *
> ! Bug fix to avoid negative conc. at the domain boundaries, *
> ! as suggested by Petra Seibert *
> ! *
> ! 2 July 2002: re-order if-statements in order to optimize CPU time *
> ! *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! nspeciesdim = nspec for forward runs, 1 for backward runs *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use outg_mod
> use par_mod
> use com_mod
> #if (defined _OPENMP)
> use omp_lib
> #endif
>
> implicit none
>
> integer :: itime,itage,i,ix,jy,ixp,jyp,kz,ks,n,nage
> integer :: il,ind,indz,indzp,nrelpointer
> real :: rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
> real :: weight,hx,hy,hz,h,xd,yd,zd,xkern,r2,c(maxspec),ddx,ddy
> real :: rhoprof(2),rhoi
> real :: xl,yl,wx,wy,w
> integer :: griclunc
> #if (defined _OPENMP)
> integer :: thread
> #endif
> real,parameter :: factor=.596831, hxmax=6.0, hymax=4.0, hzmax=150.
>
>
> ! For forward simulations, make a loop over the number of species;
> ! for backward simulations, make an additional loop over the
> ! releasepoints
> !***************************************************************************
>
> !$OMP PARALLEL PRIVATE(griclunc, itage,ix,jy,ixp,jyp,ddx,ddy,rddx,rddy, &
> !$OMP p1,p2,p3,p4,nage,il,indz,indzp,dz1,dz2,dz,rhoprof,rhoi, &
> !$OMP thread,nrelpointer,kz,xl,yl,wx,wy, &
> !$OMP ks,i)
>
> #if (defined _OPENMP)
> thread = OMP_GET_THREAD_NUM()
> #endif
>
> !$OMP DO
>
> particleloop: do i=1,numpart
>
> if (itra1(i).ne.itime) cycle
>
> #if (defined _OPENMP)
> griclunc = thread + 1
> #else
> griclunc = mod(nclass(i)-1, nclassunc) + 1
> #endif
>
>
> ! Determine age class of the particle
> itage=abs(itra1(i)-itramem(i))
> do nage=1,nageclass
> if (itage.lt.lage(nage)) goto 33
> end do
> 33 continue
>
>
> ! For special runs, interpolate the air density to the particle position
> !************************************************************************
> !***********************************************************************
> !AF IND_SOURCE switches between different units for concentrations at the source
> !Af NOTE that in backward simulations the release of particles takes place
> !Af at the receptor and the sampling at the source.
> !Af 1="mass"
> !Af 2="mass mixing ratio"
> !Af IND_RECEPTOR switches between different units for concentrations at the receptor
> !Af 1="mass"
> !Af 2="mass mixing ratio"
>
> !Af switches for the conccalcfile:
> !AF IND_SAMP = 0 : xmass * 1
> !Af IND_SAMP = -1 : xmass / rho
>
> !Af ind_samp is defined in readcommand.f
>
> if ( ind_samp .eq. -1 ) then
>
> ix=int(xtra1(i))
> jy=int(ytra1(i))
> ixp=ix+1
> jyp=jy+1
> ddx=xtra1(i)-real(ix)
> ddy=ytra1(i)-real(jy)
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
>
> do il=2,nz
> if (height(il).gt.ztra1(i)) then
> indz=il-1
> indzp=il
> goto 6
> endif
> end do
> 6 continue
>
> dz1=ztra1(i)-height(indz)
> dz2=height(indzp)-ztra1(i)
> dz=1./(dz1+dz2)
>
> ! Take density from 2nd wind field in memory (accurate enough, no time interpolation needed)
> !*****************************************************************************
> do ind=indz,indzp
> rhoprof(ind-indz+1)=p1*rho(ix ,jy ,ind,2) &
> +p2*rho(ixp,jy ,ind,2) &
> +p3*rho(ix ,jyp,ind,2) &
> +p4*rho(ixp,jyp,ind,2)
> end do
> rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
> elseif (ind_samp.eq.0) then
> rhoi = 1.
> endif
>
>
> !****************************************************************************
> ! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
> !****************************************************************************
>
>
> ! For backward simulations, look from which release point the particle comes from
> ! For domain-filling trajectory option, npoint contains a consecutive particle
> ! number, not the release point information. Therefore, nrelpointer is set to 1
> ! for the domain-filling option.
> !*****************************************************************************
>
> if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
> nrelpointer=1
> else
> nrelpointer=npoint(i)
> endif
>
> do kz=1,numzgrid ! determine height of cell
> if (outheight(kz).gt.ztra1(i)) exit
> end do
>
> if (kz.le.numzgrid) then ! inside output domain
>
>
> !********************************
> ! Do everything for mother domain
> !********************************
>
> xl=(xtra1(i)*dx+xoutshift)/dxout
> yl=(ytra1(i)*dy+youtshift)/dyout
> ix=int(xl)
> if (xl.lt.0.) ix=ix-1
> 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
> ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
> ! For older particles, use the uniform kernel.
> ! If a particle is close to the domain boundary, do not use the kernel either.
> !*****************************************************************************
>
> if ((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
> if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
> (jy.le.numygrid-1)) then
> do ks=1,nspec
> gridunc(ix,jy,kz,ks,nrelpointer,griclunc,nage)= &
> gridunc(ix,jy,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight
> end do
> endif
>
> else ! attribution via uniform kernel
>
> ddx=xl-real(ix) ! distance to left cell border
> ddy=yl-real(jy) ! distance to lower cell border
> if (ddx.gt.0.5) then
> ixp=ix+1
> wx=1.5-ddx
> else
> ixp=ix-1
> wx=0.5+ddx
> endif
>
> if (ddy.gt.0.5) then
> jyp=jy+1
> wy=1.5-ddy
> else
> jyp=jy-1
> wy=0.5+ddy
> endif
>
>
> ! Determine mass fractions for four grid points
> !**********************************************
>
> if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
> if ((jy.ge.0).and.(jy.le.numygrid-1)) then
> w=wx*wy
> do ks=1,nspec
> gridunc(ix,jy,kz,ks,nrelpointer,griclunc,nage)= &
> gridunc(ix,jy,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight*w
> end do
> endif
>
> if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
> w=wx*(1.-wy)
> do ks=1,nspec
> gridunc(ix,jyp,kz,ks,nrelpointer,griclunc,nage)= &
> gridunc(ix,jyp,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight*w
> end do
> endif
> endif
>
>
> 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)
> do ks=1,nspec
> gridunc(ixp,jyp,kz,ks,nrelpointer,griclunc,nage)= &
> gridunc(ixp,jyp,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight*w
> end do
> endif
>
> if ((jy.ge.0).and.(jy.le.numygrid-1)) then
> w=(1.-wx)*wy
> do ks=1,nspec
> gridunc(ixp,jy,kz,ks,nrelpointer,griclunc,nage)= &
> gridunc(ixp,jy,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight*w
> end do
> endif
> endif
> endif
>
>
>
> !************************************
> ! Do everything for the nested domain
> !************************************
>
> if (nested_output.eq.1) then
> xl=(xtra1(i)*dx+xoutshiftn)/dxoutn
> yl=(ytra1(i)*dy+youtshiftn)/dyoutn
> ix=int(xl)
> if (xl.lt.0.) ix=ix-1
> jy=int(yl)
> if (yl.lt.0.) jy=jy-1
>
>
> ! For particles aged less than 3 hours, attribute particle mass to grid cell
> ! it resides in rather than use the kernel, in order to avoid its smoothing effect.
> ! For older particles, use the uniform kernel.
> ! If a particle is close to the domain boundary, do not use the kernel either.
> !*****************************************************************************
>
> 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
> if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
> (jy.le.numygridn-1)) then
> do ks=1,nspec
> griduncn(ix,jy,kz,ks,nrelpointer,griclunc,nage)= &
> griduncn(ix,jy,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight
> end do
> endif
>
> else ! attribution via uniform kernel
>
> ddx=xl-real(ix) ! distance to left cell border
> ddy=yl-real(jy) ! distance to lower cell border
> if (ddx.gt.0.5) then
> ixp=ix+1
> wx=1.5-ddx
> else
> ixp=ix-1
> wx=0.5+ddx
> endif
>
> if (ddy.gt.0.5) then
> jyp=jy+1
> wy=1.5-ddy
> else
> jyp=jy-1
> wy=0.5+ddy
> endif
>
>
> ! Determine mass fractions for four grid points
> !**********************************************
>
> if ((ix.ge.0).and.(ix.le.numxgridn-1)) then
> if ((jy.ge.0).and.(jy.le.numygridn-1)) then
> w=wx*wy
> do ks=1,nspec
> griduncn(ix,jy,kz,ks,nrelpointer,griclunc,nage)= &
> griduncn(ix,jy,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight*w
> end do
> endif
>
> if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then
> w=wx*(1.-wy)
> do ks=1,nspec
> griduncn(ix,jyp,kz,ks,nrelpointer,griclunc,nage)= &
> griduncn(ix,jyp,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight*w
> end do
> 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)
> do ks=1,nspec
> griduncn(ixp,jyp,kz,ks,nrelpointer,griclunc,nage)= &
> griduncn(ixp,jyp,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight*w
> end do
> endif
>
> if ((jy.ge.0).and.(jy.le.numygridn-1)) then
> w=(1.-wx)*wy
> do ks=1,nspec
> griduncn(ixp,jy,kz,ks,nrelpointer,griclunc,nage)= &
> griduncn(ixp,jy,kz,ks,nrelpointer,griclunc,nage)+ &
> xmass1(i,ks)/rhoi*weight*w
> end do
> endif
> endif
> endif
>
> endif
> endif
>
> end do particleloop
>
> !$OMP END DO
>
> !$OMP END PARALLEL
>
>
> !***********************************************************************
> ! 2. Evaluate concentrations at receptor points, using the kernel method
> !***********************************************************************
>
> do n=1,numreceptor
>
>
> ! Reset concentrations
> !*********************
>
> do ks=1,nspec
> c(ks)=0.
> end do
>
>
> ! Estimate concentration at receptor
> !***********************************
>
> do i=1,numpart
>
> if (itra1(i).ne.itime) goto 40
> itage=abs(itra1(i)-itramem(i))
>
> hz=min(50.+0.3*sqrt(real(itage)),hzmax)
> zd=ztra1(i)/hz
> if (zd.gt.1.) goto 40 ! save computing time, leave loop
>
> hx=min((0.29+2.222e-3*sqrt(real(itage)))*dx+ &
> real(itage)*1.2e-5,hxmax) ! 80 km/day
> xd=(xtra1(i)-xreceptor(n))/hx
> if (xd*xd.gt.1.) goto 40 ! save computing time, leave loop
>
> hy=min((0.18+1.389e-3*sqrt(real(itage)))*dy+ &
> real(itage)*7.5e-6,hymax) ! 80 km/day
> yd=(ytra1(i)-yreceptor(n))/hy
> if (yd*yd.gt.1.) goto 40 ! save computing time, leave loop
> h=hx*hy*hz
>
> r2=xd*xd+yd*yd+zd*zd
> if (r2.lt.1.) then
> xkern=factor*(1.-r2)
> do ks=1,nspec
> c(ks)=c(ks)+xmass1(i,ks)*xkern/h
> end do
> endif
> 40 continue
> end do
>
> do ks=1,nspec
> creceptor(n,ks)=creceptor(n,ks)+2.*weight*c(ks)/receptorarea(n)
> end do
> end do
>
> end subroutine conccalc
concoutput.f90
----------------------------------------------
1,609c1,609
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine concoutput(itime,outnum,gridtotalunc,wetgridtotalunc, &
< drygridtotalunc)
< ! i i o o
< ! o
< !*****************************************************************************
< ! *
< ! Output of the concentration grid and the receptor concentrations. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 24 May 1995 *
< ! *
< ! 13 April 1999, Major update: if output size is smaller, dump output *
< ! in sparse matrix format; additional output of *
< ! uncertainty *
< ! *
< ! 05 April 2000, Major update: output of age classes; output for backward*
< ! runs is time spent in grid cell times total mass of *
< ! species. *
< ! *
< ! 17 February 2002, Appropriate dimensions for backward and forward runs *
< ! are now specified in file par_mod *
< ! *
< ! June 2006, write grid in sparse matrix with a single write command *
< ! in order to save disk space *
< ! *
< ! 2008 new sparse matrix format *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! outnum number of samples *
< ! ncells number of cells with non-zero concentrations *
< ! sparse .true. if in sparse matrix format, else .false. *
< ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use point_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< real(kind=dp) :: jul
< integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
< integer :: sp_count_i,sp_count_r
< real :: sp_fact
< real :: outnum,densityoutrecept(maxreceptor),xl,yl
<
< !real densityoutgrid(0:numxgrid-1,0:numygrid-1,numzgrid),
< ! +grid(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,maxpointspec_act,
< ! + maxageclass)
< !real wetgrid(0:numxgrid-1,0:numygrid-1,maxspec,maxpointspec_act,
< ! + maxageclass)
< !real drygrid(0:numxgrid-1,0:numygrid-1,maxspec,
< ! + maxpointspec_act,maxageclass)
< !real gridsigma(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,
< ! + maxpointspec_act,maxageclass),
< ! + drygridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
< ! + maxpointspec_act,maxageclass),
< ! + wetgridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
< ! + maxpointspec_act,maxageclass)
< !real factor(0:numxgrid-1,0:numygrid-1,numzgrid)
< !real sparse_dump_r(numxgrid*numygrid*numzgrid)
< !integer sparse_dump_i(numxgrid*numygrid*numzgrid)
<
< !real sparse_dump_u(numxgrid*numygrid*numzgrid)
< real :: auxgrid(nclassunc),gridtotal,gridsigmatotal,gridtotalunc
< real :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc
< real :: drygridtotal,drygridsigmatotal,drygridtotalunc
< real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
< real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
< real,parameter :: weightair=28.97
< logical :: sp_zer
< character :: adate*8,atime*6
< character(len=3) :: anspec
<
<
< ! Determine current calendar date, needed for the file name
< !**********************************************************
<
< jul=bdate+real(itime,kind=dp)/86400._dp
< call caldate(jul,jjjjmmdd,ihmmss)
< write(adate,'(i8.8)') jjjjmmdd
< write(atime,'(i6.6)') ihmmss
< write(unitdates,'(a)') adate//atime
<
<
< ! For forward simulations, output fields have dimension MAXSPEC,
< ! for backward simulations, output fields have dimension MAXPOINT.
< ! Thus, make loops either about nspec, or about numpoint
< !*****************************************************************
<
<
< if (ldirect.eq.1) then
< do ks=1,nspec
< do kp=1,maxpointspec_act
< tot_mu(ks,kp)=1
< end do
< end do
< else
< do ks=1,nspec
< do kp=1,maxpointspec_act
< tot_mu(ks,kp)=xmass(kp,ks)
< end do
< end do
< endif
<
<
< !*******************************************************************
< ! Compute air density: sufficiently accurate to take it
< ! from coarse grid at some time
< ! Determine center altitude of output layer, and interpolate density
< ! data to that altitude
< !*******************************************************************
<
< do kz=1,numzgrid
< if (kz.eq.1) then
< halfheight=outheight(1)/2.
< else
< halfheight=(outheight(kz)+outheight(kz-1))/2.
< endif
< do kzz=2,nz
< if ((height(kzz-1).lt.halfheight).and. &
< (height(kzz).gt.halfheight)) goto 46
< end do
< 46 kzz=max(min(kzz,nz),2)
< dz1=halfheight-height(kzz-1)
< dz2=height(kzz)-halfheight
< dz=dz1+dz2
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< xl=outlon0+real(ix)*dxout
< yl=outlat0+real(jy)*dyout
< xl=(xl-xlon0)/dx
< yl=(yl-ylat0)/dx
< iix=max(min(nint(xl),nxmin1),0)
< jjy=max(min(nint(yl),nymin1),0)
< densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
< rho(iix,jjy,kzz-1,2)*dz2)/dz
< end do
< end do
< end do
<
< do i=1,numreceptor
< xl=xreceptor(i)
< yl=yreceptor(i)
< iix=max(min(nint(xl),nxmin1),0)
< jjy=max(min(nint(yl),nymin1),0)
< densityoutrecept(i)=rho(iix,jjy,1,2)
< end do
<
<
< ! Output is different for forward and backward simulations
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (ldirect.eq.1) then
< factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum
< else
< factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
< endif
< end do
< end do
< end do
<
< !*********************************************************************
< ! Determine the standard deviation of the mean concentration or mixing
< ! ratio (uncertainty of the output) and the dry and wet deposition
< !*********************************************************************
<
< gridtotal=0.
< gridsigmatotal=0.
< gridtotalunc=0.
< wetgridtotal=0.
< wetgridsigmatotal=0.
< wetgridtotalunc=0.
< drygridtotal=0.
< drygridsigmatotal=0.
< drygridtotalunc=0.
<
< do ks=1,nspec
<
< write(anspec,'(i3.3)') ks
< 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// &
< atime//'_'//anspec,form='unformatted')
< else
< open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// &
< atime//'_'//anspec,form='unformatted')
< 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
<
< do kp=1,maxpointspec_act
< do nage=1,nageclass
<
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
<
< ! WET DEPOSITION
< if ((WETDEP).and.(ldirect.gt.0)) then
< do l=1,nclassunc
< auxgrid(l)=wetgridunc(ix,jy,ks,kp,l,nage)
< end do
< call mean(auxgrid,wetgrid(ix,jy), &
< wetgridsigma(ix,jy),nclassunc)
< ! Multiply by number of classes to get total concentration
< wetgrid(ix,jy)=wetgrid(ix,jy) &
< *nclassunc
< wetgridtotal=wetgridtotal+wetgrid(ix,jy)
< ! Calculate standard deviation of the mean
< wetgridsigma(ix,jy)= &
< wetgridsigma(ix,jy)* &
< sqrt(real(nclassunc))
< wetgridsigmatotal=wetgridsigmatotal+ &
< wetgridsigma(ix,jy)
< endif
<
< ! DRY DEPOSITION
< if ((DRYDEP).and.(ldirect.gt.0)) then
< do l=1,nclassunc
< auxgrid(l)=drygridunc(ix,jy,ks,kp,l,nage)
< end do
< call mean(auxgrid,drygrid(ix,jy), &
< drygridsigma(ix,jy),nclassunc)
< ! Multiply by number of classes to get total concentration
< drygrid(ix,jy)=drygrid(ix,jy)* &
< nclassunc
< drygridtotal=drygridtotal+drygrid(ix,jy)
< ! Calculate standard deviation of the mean
< drygridsigma(ix,jy)= &
< drygridsigma(ix,jy)* &
< sqrt(real(nclassunc))
< 125 drygridsigmatotal=drygridsigmatotal+ &
< drygridsigma(ix,jy)
< endif
<
< ! CONCENTRATION OR MIXING RATIO
< do kz=1,numzgrid
< do l=1,nclassunc
< auxgrid(l)=gridunc(ix,jy,kz,ks,kp,l,nage)
< end do
< call mean(auxgrid,grid(ix,jy,kz), &
< gridsigma(ix,jy,kz),nclassunc)
< ! Multiply by number of classes to get total concentration
< grid(ix,jy,kz)= &
< grid(ix,jy,kz)*nclassunc
< gridtotal=gridtotal+grid(ix,jy,kz)
< ! Calculate standard deviation of the mean
< gridsigma(ix,jy,kz)= &
< gridsigma(ix,jy,kz)* &
< sqrt(real(nclassunc))
< gridsigmatotal=gridsigmatotal+ &
< gridsigma(ix,jy,kz)
< end do
< end do
< end do
<
<
<
<
< !*******************************************************************
< ! Generate output: may be in concentration (ng/m3) or in mixing
< ! ratio (ppt) or both
< ! Output the position and the values alternated multiplied by
< ! 1 or -1, first line is number of values, number of positions
< ! For backward simulations, the unit is seconds, stored in grid_time
< !*******************************************************************
<
< ! Concentration output
< !*********************
< if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
<
< ! Wet deposition
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< if ((ldirect.eq.1).and.(WETDEP)) then
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< !oncentraion greater zero
< if (wetgrid(ix,jy).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)=ix+jy*numxgrid
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact*1.e12*wetgrid(ix,jy)/area(ix,jy)
< ! sparse_dump_u(sp_count_r)=
< !+ 1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< else
< sp_count_i=0
< sp_count_r=0
< endif
< write(unitoutgrid) sp_count_i
< write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgrid) sp_count_r
< write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgrid) sp_count_u
< ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
<
< ! Dry deposition
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< if ((ldirect.eq.1).and.(DRYDEP)) then
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (drygrid(ix,jy).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)=ix+jy*numxgrid
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< 1.e12*drygrid(ix,jy)/area(ix,jy)
< ! sparse_dump_u(sp_count_r)=
< !+ 1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< else
< sp_count_i=0
< sp_count_r=0
< endif
< write(unitoutgrid) sp_count_i
< write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgrid) sp_count_r
< write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(*,*) sp_count_u
< ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
<
<
<
< ! Concentrations
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (grid(ix,jy,kz).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)= &
< ix+jy*numxgrid+kz*numxgrid*numygrid
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< grid(ix,jy,kz)* &
< factor3d(ix,jy,kz)/tot_mu(ks,kp)
< ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
< ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
< ! sparse_dump_u(sp_count_r)=
< !+ ,gridsigma(ix,jy,kz,ks,kp,nage)*
< !+ factor(ix,jy,kz)/tot_mu(ks,kp)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< end do
< write(unitoutgrid) sp_count_i
< write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgrid) sp_count_r
< write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgrid) sp_count_u
< ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
<
<
<
< endif ! concentration output
<
< ! Mixing ratio output
< !********************
<
< if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
<
< ! Wet deposition
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< if ((ldirect.eq.1).and.(WETDEP)) then
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (wetgrid(ix,jy).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)= &
< ix+jy*numxgrid
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< 1.e12*wetgrid(ix,jy)/area(ix,jy)
< ! sparse_dump_u(sp_count_r)=
< ! + ,1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< else
< sp_count_i=0
< sp_count_r=0
< endif
< write(unitoutgridppt) sp_count_i
< write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgridppt) sp_count_r
< write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgridppt) sp_count_u
< ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
<
<
< ! Dry deposition
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< if ((ldirect.eq.1).and.(DRYDEP)) then
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (drygrid(ix,jy).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)= &
< ix+jy*numxgrid
< sp_zer=.false.
< sp_fact=sp_fact*(-1)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< 1.e12*drygrid(ix,jy)/area(ix,jy)
< ! sparse_dump_u(sp_count_r)=
< ! + ,1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< else
< sp_count_i=0
< sp_count_r=0
< endif
< write(unitoutgridppt) sp_count_i
< write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgridppt) sp_count_r
< write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgridppt) sp_count_u
< ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
<
<
< ! Mixing ratios
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (grid(ix,jy,kz).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)= &
< ix+jy*numxgrid+kz*numxgrid*numygrid
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< 1.e12*grid(ix,jy,kz) &
< /volume(ix,jy,kz)/outnum* &
< weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
< ! sparse_dump_u(sp_count_r)=
< !+ ,1.e12*gridsigma(ix,jy,kz,ks,kp,nage)/volume(ix,jy,kz)/
< !+ outnum*weightair/weightmolar(ks)/
< !+ densityoutgrid(ix,jy,kz)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< end do
< write(unitoutgridppt) sp_count_i
< write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgridppt) sp_count_r
< write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgridppt) sp_count_u
< ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
<
< endif ! output for ppt
<
< end do
< end do
<
< close(unitoutgridppt)
< close(unitoutgrid)
<
< end do
<
< if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal
< if (wetgridtotal.gt.0.) wetgridtotalunc=wetgridsigmatotal/ &
< wetgridtotal
< if (drygridtotal.gt.0.) drygridtotalunc=drygridsigmatotal/ &
< drygridtotal
<
< ! Dump of receptor concentrations
<
< if (numreceptor.gt.0 .and. (iout.eq.2 .or. iout.eq.3) ) then
< write(unitoutreceptppt) itime
< do ks=1,nspec
< write(unitoutreceptppt) (1.e12*creceptor(i,ks)/outnum* &
< weightair/weightmolar(ks)/densityoutrecept(i),i=1,numreceptor)
< end do
< endif
<
< ! Dump of receptor concentrations
<
< if (numreceptor.gt.0) then
< write(unitoutrecept) itime
< do ks=1,nspec
< write(unitoutrecept) (1.e12*creceptor(i,ks)/outnum, &
< i=1,numreceptor)
< end do
< endif
<
<
<
< ! Reinitialization of grid
< !*************************
<
< do ks=1,nspec
< do kp=1,maxpointspec_act
< do i=1,numreceptor
< creceptor(i,ks)=0.
< end do
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< do l=1,nclassunc
< do nage=1,nageclass
< do kz=1,numzgrid
< gridunc(ix,jy,kz,ks,kp,l,nage)=0.
< end do
< end do
< end do
< end do
< end do
< end do
< end do
<
<
< end subroutine concoutput
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine concoutput(itime,outnum,gridtotalunc,wetgridtotalunc, &
> drygridtotalunc)
> ! i i o o
> ! o
> !*****************************************************************************
> ! *
> ! Output of the concentration grid and the receptor concentrations. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 24 May 1995 *
> ! *
> ! 13 April 1999, Major update: if output size is smaller, dump output *
> ! in sparse matrix format; additional output of *
> ! uncertainty *
> ! *
> ! 05 April 2000, Major update: output of age classes; output for backward*
> ! runs is time spent in grid cell times total mass of *
> ! species. *
> ! *
> ! 17 February 2002, Appropriate dimensions for backward and forward runs *
> ! are now specified in file par_mod *
> ! *
> ! June 2006, write grid in sparse matrix with a single write command *
> ! in order to save disk space *
> ! *
> ! 2008 new sparse matrix format *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! outnum number of samples *
> ! ncells number of cells with non-zero concentrations *
> ! sparse .true. if in sparse matrix format, else .false. *
> ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use point_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> real(kind=dp) :: jul
> integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
> integer :: sp_count_i,sp_count_r
> real :: sp_fact
> real :: outnum,densityoutrecept(maxreceptor),xl,yl
>
> !real densityoutgrid(0:numxgrid-1,0:numygrid-1,numzgrid),
> ! +grid(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,maxpointspec_act,
> ! + maxageclass)
> !real wetgrid(0:numxgrid-1,0:numygrid-1,maxspec,maxpointspec_act,
> ! + maxageclass)
> !real drygrid(0:numxgrid-1,0:numygrid-1,maxspec,
> ! + maxpointspec_act,maxageclass)
> !real gridsigma(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,
> ! + maxpointspec_act,maxageclass),
> ! + drygridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
> ! + maxpointspec_act,maxageclass),
> ! + wetgridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
> ! + maxpointspec_act,maxageclass)
> !real factor(0:numxgrid-1,0:numygrid-1,numzgrid)
> !real sparse_dump_r(numxgrid*numygrid*numzgrid)
> !integer sparse_dump_i(numxgrid*numygrid*numzgrid)
>
> !real sparse_dump_u(numxgrid*numygrid*numzgrid)
> real :: auxgrid(nclassunc),gridtotal,gridsigmatotal,gridtotalunc
> real :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc
> real :: drygridtotal,drygridsigmatotal,drygridtotalunc
> real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
> real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
> real,parameter :: weightair=28.97
> logical :: sp_zer
> character :: adate*8,atime*6
> character(len=3) :: anspec
>
>
> ! Determine current calendar date, needed for the file name
> !**********************************************************
>
> jul=bdate+real(itime,kind=dp)/86400._dp
> call caldate(jul,jjjjmmdd,ihmmss)
> write(adate,'(i8.8)') jjjjmmdd
> write(atime,'(i6.6)') ihmmss
> write(unitdates,'(a)') adate//atime
>
>
> ! For forward simulations, output fields have dimension MAXSPEC,
> ! for backward simulations, output fields have dimension MAXPOINT.
> ! Thus, make loops either about nspec, or about numpoint
> !*****************************************************************
>
>
> if (ldirect.eq.1) then
> do ks=1,nspec
> do kp=1,maxpointspec_act
> tot_mu(ks,kp)=1
> end do
> end do
> else
> do ks=1,nspec
> do kp=1,maxpointspec_act
> tot_mu(ks,kp)=xmass(kp,ks)
> end do
> end do
> endif
>
>
> !*******************************************************************
> ! Compute air density: sufficiently accurate to take it
> ! from coarse grid at some time
> ! Determine center altitude of output layer, and interpolate density
> ! data to that altitude
> !*******************************************************************
>
> do kz=1,numzgrid
> if (kz.eq.1) then
> halfheight=outheight(1)/2.
> else
> halfheight=(outheight(kz)+outheight(kz-1))/2.
> endif
> do kzz=2,nz
> if ((height(kzz-1).lt.halfheight).and. &
> (height(kzz).gt.halfheight)) goto 46
> end do
> 46 kzz=max(min(kzz,nz),2)
> dz1=halfheight-height(kzz-1)
> dz2=height(kzz)-halfheight
> dz=dz1+dz2
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> xl=outlon0+real(ix)*dxout
> yl=outlat0+real(jy)*dyout
> xl=(xl-xlon0)/dx
> yl=(yl-ylat0)/dy
> iix=max(min(nint(xl),nxmin1),0)
> jjy=max(min(nint(yl),nymin1),0)
> densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
> rho(iix,jjy,kzz-1,2)*dz2)/dz
> end do
> end do
> end do
>
> do i=1,numreceptor
> xl=xreceptor(i)
> yl=yreceptor(i)
> iix=max(min(nint(xl),nxmin1),0)
> jjy=max(min(nint(yl),nymin1),0)
> densityoutrecept(i)=rho(iix,jjy,1,2)
> end do
>
>
> ! Output is different for forward and backward simulations
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (ldirect.eq.1) then
> factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum
> else
> factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
> endif
> end do
> end do
> end do
>
> !*********************************************************************
> ! Determine the standard deviation of the mean concentration or mixing
> ! ratio (uncertainty of the output) and the dry and wet deposition
> !*********************************************************************
>
> gridtotal=0.
> gridsigmatotal=0.
> gridtotalunc=0.
> wetgridtotal=0.
> wetgridsigmatotal=0.
> wetgridtotalunc=0.
> drygridtotal=0.
> drygridsigmatotal=0.
> drygridtotalunc=0.
>
> do ks=1,nspec
>
> write(anspec,'(i3.3)') ks
> 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// &
> atime//'_'//anspec,form='unformatted')
> else
> open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// &
> atime//'_'//anspec,form='unformatted')
> 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
>
> do kp=1,maxpointspec_act
> do nage=1,nageclass
>
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
>
> ! WET DEPOSITION
> if ((WETDEP).and.(ldirect.gt.0)) then
> do l=1,nclassunc
> auxgrid(l)=wetgridunc(ix,jy,ks,kp,l,nage)
> end do
> call mean(auxgrid,wetgrid(ix,jy), &
> wetgridsigma(ix,jy),nclassunc)
> ! Multiply by number of classes to get total concentration
> wetgrid(ix,jy)=wetgrid(ix,jy) &
> *nclassunc
> wetgridtotal=wetgridtotal+wetgrid(ix,jy)
> ! Calculate standard deviation of the mean
> wetgridsigma(ix,jy)= &
> wetgridsigma(ix,jy)* &
> sqrt(real(nclassunc))
> wetgridsigmatotal=wetgridsigmatotal+ &
> wetgridsigma(ix,jy)
> endif
>
> ! DRY DEPOSITION
> if ((DRYDEP).and.(ldirect.gt.0)) then
> do l=1,nclassunc
> auxgrid(l)=drygridunc(ix,jy,ks,kp,l,nage)
> end do
> call mean(auxgrid,drygrid(ix,jy), &
> drygridsigma(ix,jy),nclassunc)
> ! Multiply by number of classes to get total concentration
> drygrid(ix,jy)=drygrid(ix,jy)* &
> nclassunc
> drygridtotal=drygridtotal+drygrid(ix,jy)
> ! Calculate standard deviation of the mean
> drygridsigma(ix,jy)= &
> drygridsigma(ix,jy)* &
> sqrt(real(nclassunc))
> 125 drygridsigmatotal=drygridsigmatotal+ &
> drygridsigma(ix,jy)
> endif
>
> ! CONCENTRATION OR MIXING RATIO
> do kz=1,numzgrid
> do l=1,nclassunc
> auxgrid(l)=gridunc(ix,jy,kz,ks,kp,l,nage)
> end do
> call mean(auxgrid,grid(ix,jy,kz), &
> gridsigma(ix,jy,kz),nclassunc)
> ! Multiply by number of classes to get total concentration
> grid(ix,jy,kz)= &
> grid(ix,jy,kz)*nclassunc
> gridtotal=gridtotal+grid(ix,jy,kz)
> ! Calculate standard deviation of the mean
> gridsigma(ix,jy,kz)= &
> gridsigma(ix,jy,kz)* &
> sqrt(real(nclassunc))
> gridsigmatotal=gridsigmatotal+ &
> gridsigma(ix,jy,kz)
> end do
> end do
> end do
>
>
>
>
> !*******************************************************************
> ! Generate output: may be in concentration (ng/m3) or in mixing
> ! ratio (ppt) or both
> ! Output the position and the values alternated multiplied by
> ! 1 or -1, first line is number of values, number of positions
> ! For backward simulations, the unit is seconds, stored in grid_time
> !*******************************************************************
>
> ! Concentration output
> !*********************
> if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
>
> ! Wet deposition
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> if ((ldirect.eq.1).and.(WETDEP)) then
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> !oncentraion greater zero
> if (wetgrid(ix,jy).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)=ix+jy*numxgrid
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact*1.e12*wetgrid(ix,jy)/area(ix,jy)
> ! sparse_dump_u(sp_count_r)=
> !+ 1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> else
> sp_count_i=0
> sp_count_r=0
> endif
> write(unitoutgrid) sp_count_i
> write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgrid) sp_count_r
> write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgrid) sp_count_u
> ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
>
> ! Dry deposition
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> if ((ldirect.eq.1).and.(DRYDEP)) then
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (drygrid(ix,jy).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)=ix+jy*numxgrid
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> 1.e12*drygrid(ix,jy)/area(ix,jy)
> ! sparse_dump_u(sp_count_r)=
> !+ 1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> else
> sp_count_i=0
> sp_count_r=0
> endif
> write(unitoutgrid) sp_count_i
> write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgrid) sp_count_r
> write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(*,*) sp_count_u
> ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
>
>
>
> ! Concentrations
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (grid(ix,jy,kz).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)= &
> ix+jy*numxgrid+kz*numxgrid*numygrid
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> grid(ix,jy,kz)* &
> factor3d(ix,jy,kz)/tot_mu(ks,kp)
> ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
> ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
> ! sparse_dump_u(sp_count_r)=
> !+ ,gridsigma(ix,jy,kz,ks,kp,nage)*
> !+ factor(ix,jy,kz)/tot_mu(ks,kp)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> end do
> write(unitoutgrid) sp_count_i
> write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgrid) sp_count_r
> write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgrid) sp_count_u
> ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
>
>
>
> endif ! concentration output
>
> ! Mixing ratio output
> !********************
>
> if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
>
> ! Wet deposition
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> if ((ldirect.eq.1).and.(WETDEP)) then
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (wetgrid(ix,jy).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)= &
> ix+jy*numxgrid
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> 1.e12*wetgrid(ix,jy)/area(ix,jy)
> ! sparse_dump_u(sp_count_r)=
> ! + ,1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> else
> sp_count_i=0
> sp_count_r=0
> endif
> write(unitoutgridppt) sp_count_i
> write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgridppt) sp_count_r
> write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgridppt) sp_count_u
> ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
>
>
> ! Dry deposition
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> if ((ldirect.eq.1).and.(DRYDEP)) then
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (drygrid(ix,jy).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)= &
> ix+jy*numxgrid
> sp_zer=.false.
> sp_fact=sp_fact*(-1)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> 1.e12*drygrid(ix,jy)/area(ix,jy)
> ! sparse_dump_u(sp_count_r)=
> ! + ,1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> else
> sp_count_i=0
> sp_count_r=0
> endif
> write(unitoutgridppt) sp_count_i
> write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgridppt) sp_count_r
> write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgridppt) sp_count_u
> ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
>
>
> ! Mixing ratios
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (grid(ix,jy,kz).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)= &
> ix+jy*numxgrid+kz*numxgrid*numygrid
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> 1.e12*grid(ix,jy,kz) &
> /volume(ix,jy,kz)/outnum* &
> weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
> ! sparse_dump_u(sp_count_r)=
> !+ ,1.e12*gridsigma(ix,jy,kz,ks,kp,nage)/volume(ix,jy,kz)/
> !+ outnum*weightair/weightmolar(ks)/
> !+ densityoutgrid(ix,jy,kz)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> end do
> write(unitoutgridppt) sp_count_i
> write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgridppt) sp_count_r
> write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgridppt) sp_count_u
> ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
>
> endif ! output for ppt
>
> end do
> end do
>
> close(unitoutgridppt)
> close(unitoutgrid)
>
> end do
>
> if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal
> if (wetgridtotal.gt.0.) wetgridtotalunc=wetgridsigmatotal/ &
> wetgridtotal
> if (drygridtotal.gt.0.) drygridtotalunc=drygridsigmatotal/ &
> drygridtotal
>
> ! Dump of receptor concentrations
>
> if (numreceptor.gt.0 .and. (iout.eq.2 .or. iout.eq.3) ) then
> write(unitoutreceptppt) itime
> do ks=1,nspec
> write(unitoutreceptppt) (1.e12*creceptor(i,ks)/outnum* &
> weightair/weightmolar(ks)/densityoutrecept(i),i=1,numreceptor)
> end do
> endif
>
> ! Dump of receptor concentrations
>
> if (numreceptor.gt.0) then
> write(unitoutrecept) itime
> do ks=1,nspec
> write(unitoutrecept) (1.e12*creceptor(i,ks)/outnum, &
> i=1,numreceptor)
> end do
> endif
>
>
>
> ! Reinitialization of grid
> !*************************
>
> do ks=1,nspec
> do kp=1,maxpointspec_act
> do i=1,numreceptor
> creceptor(i,ks)=0.
> end do
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> do l=1,nclassunc
> do nage=1,nageclass
> do kz=1,numzgrid
> gridunc(ix,jy,kz,ks,kp,l,nage)=0.
> end do
> end do
> end do
> end do
> end do
> end do
> end do
>
>
> end subroutine concoutput
concoutput_nest.f90
----------------------------------------------
1,561c1,561
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine concoutput_nest(itime,outnum)
< ! i i
< !*****************************************************************************
< ! *
< ! Output of the concentration grid and the receptor concentrations. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 24 May 1995 *
< ! *
< ! 13 April 1999, Major update: if output size is smaller, dump output *
< ! in sparse matrix format; additional output of *
< ! uncertainty *
< ! *
< ! 05 April 2000, Major update: output of age classes; output for backward*
< ! runs is time spent in grid cell times total mass of *
< ! species. *
< ! *
< ! 17 February 2002, Appropriate dimensions for backward and forward runs *
< ! are now specified in file par_mod *
< ! *
< ! June 2006, write grid in sparse matrix with a single write command *
< ! in order to save disk space *
< ! *
< ! 2008 new sparse matrix format *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! outnum number of samples *
< ! ncells number of cells with non-zero concentrations *
< ! sparse .true. if in sparse matrix format, else .false. *
< ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use point_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< real(kind=dp) :: jul
< integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
< integer :: sp_count_i,sp_count_r
< real :: sp_fact
< real :: outnum,densityoutrecept(maxreceptor),xl,yl
<
< !real densityoutgrid(0:numxgrid-1,0:numygrid-1,numzgrid),
< ! +grid(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,maxpointspec_act,
< ! + maxageclass)
< !real wetgrid(0:numxgrid-1,0:numygrid-1,maxspec,maxpointspec_act,
< ! + maxageclass)
< !real drygrid(0:numxgrid-1,0:numygrid-1,maxspec,
< ! + maxpointspec_act,maxageclass)
< !real gridsigma(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,
< ! + maxpointspec_act,maxageclass),
< ! + drygridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
< ! + maxpointspec_act,maxageclass),
< ! + wetgridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
< ! + maxpointspec_act,maxageclass)
< !real factor(0:numxgrid-1,0:numygrid-1,numzgrid)
< !real sparse_dump_r(numxgrid*numygrid*numzgrid)
< !integer sparse_dump_i(numxgrid*numygrid*numzgrid)
<
< !real sparse_dump_u(numxgrid*numygrid*numzgrid)
< real :: auxgrid(nclassunc)
< real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
< real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
< real,parameter :: weightair=28.97
< logical :: sp_zer
< character :: adate*8,atime*6
< character(len=3) :: anspec
<
<
< ! Determine current calendar date, needed for the file name
< !**********************************************************
<
< jul=bdate+real(itime,kind=dp)/86400._dp
< call caldate(jul,jjjjmmdd,ihmmss)
< write(adate,'(i8.8)') jjjjmmdd
< write(atime,'(i6.6)') ihmmss
<
<
< ! For forward simulations, output fields have dimension MAXSPEC,
< ! for backward simulations, output fields have dimension MAXPOINT.
< ! Thus, make loops either about nspec, or about numpoint
< !*****************************************************************
<
<
< if (ldirect.eq.1) then
< do ks=1,nspec
< do kp=1,maxpointspec_act
< tot_mu(ks,kp)=1
< end do
< end do
< else
< do ks=1,nspec
< do kp=1,maxpointspec_act
< tot_mu(ks,kp)=xmass(kp,ks)
< end do
< end do
< endif
<
<
< !*******************************************************************
< ! Compute air density: sufficiently accurate to take it
< ! from coarse grid at some time
< ! Determine center altitude of output layer, and interpolate density
< ! data to that altitude
< !*******************************************************************
<
< do kz=1,numzgrid
< if (kz.eq.1) then
< halfheight=outheight(1)/2.
< else
< halfheight=(outheight(kz)+outheight(kz-1))/2.
< endif
< do kzz=2,nz
< if ((height(kzz-1).lt.halfheight).and. &
< (height(kzz).gt.halfheight)) goto 46
< end do
< 46 kzz=max(min(kzz,nz),2)
< dz1=halfheight-height(kzz-1)
< dz2=height(kzz)-halfheight
< dz=dz1+dz2
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< xl=outlon0n+real(ix)*dxoutn
< yl=outlat0n+real(jy)*dyoutn
< xl=(xl-xlon0)/dx
< yl=(yl-ylat0)/dy
< iix=max(min(nint(xl),nxmin1),0)
< jjy=max(min(nint(yl),nymin1),0)
< densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
< rho(iix,jjy,kzz-1,2)*dz2)/dz
< end do
< end do
< end do
<
< do i=1,numreceptor
< xl=xreceptor(i)
< yl=yreceptor(i)
< iix=max(min(nint(xl),nxmin1),0)
< jjy=max(min(nint(yl),nymin1),0)
< densityoutrecept(i)=rho(iix,jjy,1,2)
< end do
<
<
< ! Output is different for forward and backward simulations
< do kz=1,numzgrid
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< if (ldirect.eq.1) then
< factor3d(ix,jy,kz)=1.e12/volumen(ix,jy,kz)/outnum
< else
< factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
< endif
< end do
< end do
< end do
<
< !*********************************************************************
< ! Determine the standard deviation of the mean concentration or mixing
< ! ratio (uncertainty of the output) and the dry and wet deposition
< !*********************************************************************
<
< do ks=1,nspec
<
< write(anspec,'(i3.3)') ks
< 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_nest_' &
< //adate// &
< atime//'_'//anspec,form='unformatted')
< else
< open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' &
< //adate// &
< atime//'_'//anspec,form='unformatted')
< 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_nest_' &
< //adate// &
< atime//'_'//anspec,form='unformatted')
<
< write(unitoutgridppt) itime
< endif
<
< do kp=1,maxpointspec_act
< do nage=1,nageclass
<
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
<
< ! WET DEPOSITION
< if ((WETDEP).and.(ldirect.gt.0)) then
< do l=1,nclassunc
< auxgrid(l)=wetgriduncn(ix,jy,ks,kp,l,nage)
< end do
< call mean(auxgrid,wetgrid(ix,jy), &
< wetgridsigma(ix,jy),nclassunc)
< ! Multiply by number of classes to get total concentration
< wetgrid(ix,jy)=wetgrid(ix,jy) &
< *nclassunc
< ! Calculate standard deviation of the mean
< wetgridsigma(ix,jy)= &
< wetgridsigma(ix,jy)* &
< sqrt(real(nclassunc))
< endif
<
< ! DRY DEPOSITION
< if ((DRYDEP).and.(ldirect.gt.0)) then
< do l=1,nclassunc
< auxgrid(l)=drygriduncn(ix,jy,ks,kp,l,nage)
< end do
< call mean(auxgrid,drygrid(ix,jy), &
< drygridsigma(ix,jy),nclassunc)
< ! Multiply by number of classes to get total concentration
< drygrid(ix,jy)=drygrid(ix,jy)* &
< nclassunc
< ! Calculate standard deviation of the mean
< drygridsigma(ix,jy)= &
< drygridsigma(ix,jy)* &
< sqrt(real(nclassunc))
< endif
<
< ! CONCENTRATION OR MIXING RATIO
< do kz=1,numzgrid
< do l=1,nclassunc
< auxgrid(l)=griduncn(ix,jy,kz,ks,kp,l,nage)
< end do
< call mean(auxgrid,grid(ix,jy,kz), &
< gridsigma(ix,jy,kz),nclassunc)
< ! Multiply by number of classes to get total concentration
< grid(ix,jy,kz)= &
< grid(ix,jy,kz)*nclassunc
< ! Calculate standard deviation of the mean
< gridsigma(ix,jy,kz)= &
< gridsigma(ix,jy,kz)* &
< sqrt(real(nclassunc))
< end do
< end do
< end do
<
<
< !*******************************************************************
< ! Generate output: may be in concentration (ng/m3) or in mixing
< ! ratio (ppt) or both
< ! Output the position and the values alternated multiplied by
< ! 1 or -1, first line is number of values, number of positions
< ! For backward simulations, the unit is seconds, stored in grid_time
< !*******************************************************************
<
< ! Concentration output
< !*********************
< if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
<
< ! Wet deposition
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< if ((ldirect.eq.1).and.(WETDEP)) then
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< !oncentraion greater zero
< if (wetgrid(ix,jy).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)=ix+jy*numxgridn
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact*1.e12*wetgrid(ix,jy)/arean(ix,jy)
< ! sparse_dump_u(sp_count_r)=
< !+ 1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< else
< sp_count_i=0
< sp_count_r=0
< endif
< write(unitoutgrid) sp_count_i
< write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgrid) sp_count_r
< write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgrid) sp_count_u
< ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
<
< ! Dry deposition
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< if ((ldirect.eq.1).and.(DRYDEP)) then
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< if (drygrid(ix,jy).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)=ix+jy*numxgridn
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< 1.e12*drygrid(ix,jy)/arean(ix,jy)
< ! sparse_dump_u(sp_count_r)=
< !+ 1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< else
< sp_count_i=0
< sp_count_r=0
< endif
< write(unitoutgrid) sp_count_i
< write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgrid) sp_count_r
< write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(*,*) sp_count_u
< ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
<
<
<
< ! Concentrations
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< do kz=1,numzgrid
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< if (grid(ix,jy,kz).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)= &
< ix+jy*numxgridn+kz*numxgridn*numygridn
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< grid(ix,jy,kz)* &
< factor3d(ix,jy,kz)/tot_mu(ks,kp)
< ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
< ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
< ! sparse_dump_u(sp_count_r)=
< !+ ,gridsigma(ix,jy,kz,ks,kp,nage)*
< !+ factor(ix,jy,kz)/tot_mu(ks,kp)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< end do
< write(unitoutgrid) sp_count_i
< write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgrid) sp_count_r
< write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgrid) sp_count_u
< ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
<
<
<
< endif ! concentration output
<
< ! Mixing ratio output
< !********************
<
< if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
<
< ! Wet deposition
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< if ((ldirect.eq.1).and.(WETDEP)) then
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< if (wetgrid(ix,jy).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)= &
< ix+jy*numxgridn
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< 1.e12*wetgrid(ix,jy)/arean(ix,jy)
< ! sparse_dump_u(sp_count_r)=
< ! + ,1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< else
< sp_count_i=0
< sp_count_r=0
< endif
< write(unitoutgridppt) sp_count_i
< write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgridppt) sp_count_r
< write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgridppt) sp_count_u
< ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
<
<
< ! Dry deposition
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< if ((ldirect.eq.1).and.(DRYDEP)) then
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< if (drygrid(ix,jy).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)= &
< ix+jy*numxgridn
< sp_zer=.false.
< sp_fact=sp_fact*(-1)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< 1.e12*drygrid(ix,jy)/arean(ix,jy)
< ! sparse_dump_u(sp_count_r)=
< ! + ,1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< else
< sp_count_i=0
< sp_count_r=0
< endif
< write(unitoutgridppt) sp_count_i
< write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgridppt) sp_count_r
< write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgridppt) sp_count_u
< ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
<
<
< ! Mixing ratios
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< do kz=1,numzgrid
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< if (grid(ix,jy,kz).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)= &
< ix+jy*numxgridn+kz*numxgridn*numygridn
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)= &
< sp_fact* &
< 1.e12*grid(ix,jy,kz) &
< /volumen(ix,jy,kz)/outnum* &
< weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
< ! sparse_dump_u(sp_count_r)=
< !+ ,1.e12*gridsigma(ix,jy,kz,ks,kp,nage)/volume(ix,jy,kz)/
< !+ outnum*weightair/weightmolar(ks)/
< !+ densityoutgrid(ix,jy,kz)
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< end do
< write(unitoutgridppt) sp_count_i
< write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
< write(unitoutgridppt) sp_count_r
< write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
< ! write(unitoutgridppt) sp_count_u
< ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
<
< endif ! output for ppt
<
< end do
< end do
<
< close(unitoutgridppt)
< close(unitoutgrid)
<
< end do
<
<
<
< ! Reinitialization of grid
< !*************************
<
< do ks=1,nspec
< do kp=1,maxpointspec_act
< do i=1,numreceptor
< creceptor(i,ks)=0.
< end do
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< do l=1,nclassunc
< do nage=1,nageclass
< do kz=1,numzgrid
< griduncn(ix,jy,kz,ks,kp,l,nage)=0.
< end do
< end do
< end do
< end do
< end do
< end do
< end do
<
<
< end subroutine concoutput_nest
<
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine concoutput_nest(itime,outnum)
> ! i i
> !*****************************************************************************
> ! *
> ! Output of the concentration grid and the receptor concentrations. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 24 May 1995 *
> ! *
> ! 13 April 1999, Major update: if output size is smaller, dump output *
> ! in sparse matrix format; additional output of *
> ! uncertainty *
> ! *
> ! 05 April 2000, Major update: output of age classes; output for backward*
> ! runs is time spent in grid cell times total mass of *
> ! species. *
> ! *
> ! 17 February 2002, Appropriate dimensions for backward and forward runs *
> ! are now specified in file par_mod *
> ! *
> ! June 2006, write grid in sparse matrix with a single write command *
> ! in order to save disk space *
> ! *
> ! 2008 new sparse matrix format *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! outnum number of samples *
> ! ncells number of cells with non-zero concentrations *
> ! sparse .true. if in sparse matrix format, else .false. *
> ! tot_mu 1 for forward, initial mass mixing ration for backw. runs *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use point_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> real(kind=dp) :: jul
> integer :: itime,i,ix,jy,kz,ks,kp,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss
> integer :: sp_count_i,sp_count_r
> real :: sp_fact
> real :: outnum,densityoutrecept(maxreceptor),xl,yl
>
> !real densityoutgrid(0:numxgrid-1,0:numygrid-1,numzgrid),
> ! +grid(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,maxpointspec_act,
> ! + maxageclass)
> !real wetgrid(0:numxgrid-1,0:numygrid-1,maxspec,maxpointspec_act,
> ! + maxageclass)
> !real drygrid(0:numxgrid-1,0:numygrid-1,maxspec,
> ! + maxpointspec_act,maxageclass)
> !real gridsigma(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec,
> ! + maxpointspec_act,maxageclass),
> ! + drygridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
> ! + maxpointspec_act,maxageclass),
> ! + wetgridsigma(0:numxgrid-1,0:numygrid-1,maxspec,
> ! + maxpointspec_act,maxageclass)
> !real factor(0:numxgrid-1,0:numygrid-1,numzgrid)
> !real sparse_dump_r(numxgrid*numygrid*numzgrid)
> !integer sparse_dump_i(numxgrid*numygrid*numzgrid)
>
> !real sparse_dump_u(numxgrid*numygrid*numzgrid)
> real :: auxgrid(nclassunc)
> real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act)
> real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
> real,parameter :: weightair=28.97
> logical :: sp_zer
> character :: adate*8,atime*6
> character(len=3) :: anspec
>
>
> ! Determine current calendar date, needed for the file name
> !**********************************************************
>
> jul=bdate+real(itime,kind=dp)/86400._dp
> call caldate(jul,jjjjmmdd,ihmmss)
> write(adate,'(i8.8)') jjjjmmdd
> write(atime,'(i6.6)') ihmmss
>
>
> ! For forward simulations, output fields have dimension MAXSPEC,
> ! for backward simulations, output fields have dimension MAXPOINT.
> ! Thus, make loops either about nspec, or about numpoint
> !*****************************************************************
>
>
> if (ldirect.eq.1) then
> do ks=1,nspec
> do kp=1,maxpointspec_act
> tot_mu(ks,kp)=1
> end do
> end do
> else
> do ks=1,nspec
> do kp=1,maxpointspec_act
> tot_mu(ks,kp)=xmass(kp,ks)
> end do
> end do
> endif
>
>
> !*******************************************************************
> ! Compute air density: sufficiently accurate to take it
> ! from coarse grid at some time
> ! Determine center altitude of output layer, and interpolate density
> ! data to that altitude
> !*******************************************************************
>
> do kz=1,numzgrid
> if (kz.eq.1) then
> halfheight=outheight(1)/2.
> else
> halfheight=(outheight(kz)+outheight(kz-1))/2.
> endif
> do kzz=2,nz
> if ((height(kzz-1).lt.halfheight).and. &
> (height(kzz).gt.halfheight)) goto 46
> end do
> 46 kzz=max(min(kzz,nz),2)
> dz1=halfheight-height(kzz-1)
> dz2=height(kzz)-halfheight
> dz=dz1+dz2
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> xl=outlon0n+real(ix)*dxoutn
> yl=outlat0n+real(jy)*dyoutn
> xl=(xl-xlon0)/dx
> yl=(yl-ylat0)/dy
> iix=max(min(nint(xl),nxmin1),0)
> jjy=max(min(nint(yl),nymin1),0)
> densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,2)*dz1+ &
> rho(iix,jjy,kzz-1,2)*dz2)/dz
> end do
> end do
> end do
>
> do i=1,numreceptor
> xl=xreceptor(i)
> yl=yreceptor(i)
> iix=max(min(nint(xl),nxmin1),0)
> jjy=max(min(nint(yl),nymin1),0)
> densityoutrecept(i)=rho(iix,jjy,1,2)
> end do
>
>
> ! Output is different for forward and backward simulations
> do kz=1,numzgrid
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> if (ldirect.eq.1) then
> factor3d(ix,jy,kz)=1.e12/volumen(ix,jy,kz)/outnum
> else
> factor3d(ix,jy,kz)=real(abs(loutaver))/outnum
> endif
> end do
> end do
> end do
>
> !*********************************************************************
> ! Determine the standard deviation of the mean concentration or mixing
> ! ratio (uncertainty of the output) and the dry and wet deposition
> !*********************************************************************
>
> do ks=1,nspec
>
> write(anspec,'(i3.3)') ks
> 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_nest_' &
> //adate// &
> atime//'_'//anspec,form='unformatted')
> else
> open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' &
> //adate// &
> atime//'_'//anspec,form='unformatted')
> 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_nest_' &
> //adate// &
> atime//'_'//anspec,form='unformatted')
>
> write(unitoutgridppt) itime
> endif
>
> do kp=1,maxpointspec_act
> do nage=1,nageclass
>
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
>
> ! WET DEPOSITION
> if ((WETDEP).and.(ldirect.gt.0)) then
> do l=1,nclassunc
> auxgrid(l)=wetgriduncn(ix,jy,ks,kp,l,nage)
> end do
> call mean(auxgrid,wetgrid(ix,jy), &
> wetgridsigma(ix,jy),nclassunc)
> ! Multiply by number of classes to get total concentration
> wetgrid(ix,jy)=wetgrid(ix,jy) &
> *nclassunc
> ! Calculate standard deviation of the mean
> wetgridsigma(ix,jy)= &
> wetgridsigma(ix,jy)* &
> sqrt(real(nclassunc))
> endif
>
> ! DRY DEPOSITION
> if ((DRYDEP).and.(ldirect.gt.0)) then
> do l=1,nclassunc
> auxgrid(l)=drygriduncn(ix,jy,ks,kp,l,nage)
> end do
> call mean(auxgrid,drygrid(ix,jy), &
> drygridsigma(ix,jy),nclassunc)
> ! Multiply by number of classes to get total concentration
> drygrid(ix,jy)=drygrid(ix,jy)* &
> nclassunc
> ! Calculate standard deviation of the mean
> drygridsigma(ix,jy)= &
> drygridsigma(ix,jy)* &
> sqrt(real(nclassunc))
> endif
>
> ! CONCENTRATION OR MIXING RATIO
> do kz=1,numzgrid
> do l=1,nclassunc
> auxgrid(l)=griduncn(ix,jy,kz,ks,kp,l,nage)
> end do
> call mean(auxgrid,grid(ix,jy,kz), &
> gridsigma(ix,jy,kz),nclassunc)
> ! Multiply by number of classes to get total concentration
> grid(ix,jy,kz)= &
> grid(ix,jy,kz)*nclassunc
> ! Calculate standard deviation of the mean
> gridsigma(ix,jy,kz)= &
> gridsigma(ix,jy,kz)* &
> sqrt(real(nclassunc))
> end do
> end do
> end do
>
>
> !*******************************************************************
> ! Generate output: may be in concentration (ng/m3) or in mixing
> ! ratio (ppt) or both
> ! Output the position and the values alternated multiplied by
> ! 1 or -1, first line is number of values, number of positions
> ! For backward simulations, the unit is seconds, stored in grid_time
> !*******************************************************************
>
> ! Concentration output
> !*********************
> if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
>
> ! Wet deposition
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> if ((ldirect.eq.1).and.(WETDEP)) then
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> !oncentraion greater zero
> if (wetgrid(ix,jy).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)=ix+jy*numxgridn
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact*1.e12*wetgrid(ix,jy)/arean(ix,jy)
> ! sparse_dump_u(sp_count_r)=
> !+ 1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> else
> sp_count_i=0
> sp_count_r=0
> endif
> write(unitoutgrid) sp_count_i
> write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgrid) sp_count_r
> write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgrid) sp_count_u
> ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
>
> ! Dry deposition
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> if ((ldirect.eq.1).and.(DRYDEP)) then
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> if (drygrid(ix,jy).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)=ix+jy*numxgridn
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> 1.e12*drygrid(ix,jy)/arean(ix,jy)
> ! sparse_dump_u(sp_count_r)=
> !+ 1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> else
> sp_count_i=0
> sp_count_r=0
> endif
> write(unitoutgrid) sp_count_i
> write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgrid) sp_count_r
> write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(*,*) sp_count_u
> ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
>
>
>
> ! Concentrations
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> do kz=1,numzgrid
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> if (grid(ix,jy,kz).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)= &
> ix+jy*numxgridn+kz*numxgridn*numygridn
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> grid(ix,jy,kz)* &
> factor3d(ix,jy,kz)/tot_mu(ks,kp)
> ! if ((factor(ix,jy,kz)/tot_mu(ks,kp)).eq.0)
> ! + write (*,*) factor(ix,jy,kz),tot_mu(ks,kp),ks,kp
> ! sparse_dump_u(sp_count_r)=
> !+ ,gridsigma(ix,jy,kz,ks,kp,nage)*
> !+ factor(ix,jy,kz)/tot_mu(ks,kp)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> end do
> write(unitoutgrid) sp_count_i
> write(unitoutgrid) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgrid) sp_count_r
> write(unitoutgrid) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgrid) sp_count_u
> ! write(unitoutgrid) (sparse_dump_u(i),i=1,sp_count_r)
>
>
>
> endif ! concentration output
>
> ! Mixing ratio output
> !********************
>
> if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio
>
> ! Wet deposition
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> if ((ldirect.eq.1).and.(WETDEP)) then
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> if (wetgrid(ix,jy).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)= &
> ix+jy*numxgridn
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> 1.e12*wetgrid(ix,jy)/arean(ix,jy)
> ! sparse_dump_u(sp_count_r)=
> ! + ,1.e12*wetgridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> else
> sp_count_i=0
> sp_count_r=0
> endif
> write(unitoutgridppt) sp_count_i
> write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgridppt) sp_count_r
> write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgridppt) sp_count_u
> ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
>
>
> ! Dry deposition
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> if ((ldirect.eq.1).and.(DRYDEP)) then
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> if (drygrid(ix,jy).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)= &
> ix+jy*numxgridn
> sp_zer=.false.
> sp_fact=sp_fact*(-1)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> 1.e12*drygrid(ix,jy)/arean(ix,jy)
> ! sparse_dump_u(sp_count_r)=
> ! + ,1.e12*drygridsigma(ix,jy,ks,kp,nage)/area(ix,jy)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> else
> sp_count_i=0
> sp_count_r=0
> endif
> write(unitoutgridppt) sp_count_i
> write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgridppt) sp_count_r
> write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgridppt) sp_count_u
> ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
>
>
> ! Mixing ratios
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> do kz=1,numzgrid
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> if (grid(ix,jy,kz).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)= &
> ix+jy*numxgridn+kz*numxgridn*numygridn
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)= &
> sp_fact* &
> 1.e12*grid(ix,jy,kz) &
> /volumen(ix,jy,kz)/outnum* &
> weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)
> ! sparse_dump_u(sp_count_r)=
> !+ ,1.e12*gridsigma(ix,jy,kz,ks,kp,nage)/volume(ix,jy,kz)/
> !+ outnum*weightair/weightmolar(ks)/
> !+ densityoutgrid(ix,jy,kz)
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> end do
> write(unitoutgridppt) sp_count_i
> write(unitoutgridppt) (sparse_dump_i(i),i=1,sp_count_i)
> write(unitoutgridppt) sp_count_r
> write(unitoutgridppt) (sparse_dump_r(i),i=1,sp_count_r)
> ! write(unitoutgridppt) sp_count_u
> ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r)
>
> endif ! output for ppt
>
> end do
> end do
>
> close(unitoutgridppt)
> close(unitoutgrid)
>
> end do
>
>
>
> ! Reinitialization of grid
> !*************************
>
> do ks=1,nspec
> do kp=1,maxpointspec_act
> do i=1,numreceptor
> creceptor(i,ks)=0.
> end do
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> do l=1,nclassunc
> do nage=1,nageclass
> do kz=1,numzgrid
> griduncn(ix,jy,kz,ks,kp,l,nage)=0.
> end do
> end do
> end do
> end do
> end do
> end do
> end do
>
>
> end subroutine concoutput_nest
>
convect43c.f90
----------------------------------------------
1,1110c1,1110
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< !**************************************************************************
< !**** SUBROUTINE CONVECT *****
< !**** VERSION 4.3c *****
< !**** 20 May, 2002 *****
< !**** Kerry Emanuel *****
< !**************************************************************************
< !
< SUBROUTINE CONVECT &
< (ND, NL, DELT, IFLAG, &
< PRECIP, WD, TPRIME, QPRIME, CBMF )
< !
< !-cv *************************************************************************
< !-cv C. Forster, November 2003 - May 2004:
< !-cv
< !-cv The subroutine has been downloaded from Kerry Emanuel's homepage,
< !-cv where further infos on the convection scheme can be found
< !-cv http://www-paoc.mit.edu/~emanuel/home.html
< !-cv
< !-cv The following changes have been made to integrate this subroutine
< !-cv into FLEXPART
< !-cv
< !-cv Putting most of the variables in a new common block
< !-cv renaming eps to eps0 because there is some eps already in includepar
< !-cv
< !-cv removing the arrays U,V,TRA and related arrays
< !-cv
< !-cv renaming the original arrays T,Q,QS,P,PH to
< !-cv TCONV,QCONV,QSCONV,PCONV_HPA,PHCONV_HPA
< !-cv
< !-cv Initialization of variables has been put into parameter statements
< !-cv instead of assignment of values at each call, in order to save
< !-cv computation time.
< !***************************************************************************
< !
< !-----------------------------------------------------------------------------
< ! *** On input: ***
< !
< !T: Array of absolute temperature (K) of dimension ND, with first
< ! index corresponding to lowest model level. Note that this array
< ! will be altered by the subroutine if dry convective adjustment
< ! occurs and if IPBL is not equal to 0.
< !
< !Q: Array of specific humidity (gm/gm) of dimension ND, with first
< ! index corresponding to lowest model level. Must be defined
< ! at same grid levels as T. Note that this array will be altered
< ! if dry convective adjustment occurs and if IPBL is not equal to 0.
< !
< !QS: Array of saturation specific humidity of dimension ND, with first
< ! index corresponding to lowest model level. Must be defined
< ! at same grid levels as T. Note that this array will be altered
< ! if dry convective adjustment occurs and if IPBL is not equal to 0.
< !
< !U: Array of zonal wind velocity (m/s) of dimension ND, witth first
< ! index corresponding with the lowest model level. Defined at
< ! same levels as T. Note that this array will be altered if
< ! dry convective adjustment occurs and if IPBL is not equal to 0.
< !
< !V: Same as U but for meridional velocity.
< !
< !TRA: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
< ! where NTRA is the number of different tracers. If no
< ! convective tracer transport is needed, define a dummy
< ! input array of dimension (ND,1). Tracers are defined at
< ! same vertical levels as T. Note that this array will be altered
< ! if dry convective adjustment occurs and if IPBL is not equal to 0.
< !
< !P: Array of pressure (mb) of dimension ND, with first
< ! index corresponding to lowest model level. Must be defined
< ! at same grid levels as T.
< !
< !PH: Array of pressure (mb) of dimension ND+1, with first index
< ! corresponding to lowest level. These pressures are defined at
< ! levels intermediate between those of P, T, Q and QS. The first
< ! value of PH should be greater than (i.e. at a lower level than)
< ! the first value of the array P.
< !
< !ND: The dimension of the arrays T,Q,QS,P,PH,FT and FQ
< !
< !NL: The maximum number of levels to which convection can
< ! penetrate, plus 1.
< ! NL MUST be less than or equal to ND-1.
< !
< !NTRA:The number of different tracers. If no tracer transport
< ! is needed, set this equal to 1. (On most compilers, setting
< ! NTRA to 0 will bypass tracer calculation, saving some CPU.)
< !
< !DELT: The model time step (sec) between calls to CONVECT
< !
< !----------------------------------------------------------------------------
< ! *** On Output: ***
< !
< !IFLAG: An output integer whose value denotes the following:
< !
< ! VALUE INTERPRETATION
< ! ----- --------------
< ! 0 No moist convection; atmosphere is not
< ! unstable, or surface temperature is less
< ! than 250 K or surface specific humidity
< ! is non-positive.
< !
< ! 1 Moist convection occurs.
< !
< ! 2 No moist convection: lifted condensation
< ! level is above the 200 mb level.
< !
< ! 3 No moist convection: cloud base is higher
< ! then the level NL-1.
< !
< ! 4 Moist convection occurs, but a CFL condition
< ! on the subsidence warming is violated. This
< ! does not cause the scheme to terminate.
< !
< !FT: Array of temperature tendency (K/s) of dimension ND, defined at same
< ! grid levels as T, Q, QS and P.
< !
< !FQ: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
< ! defined at same grid levels as T, Q, QS and P.
< !
< !FU: Array of forcing of zonal velocity (m/s^2) of dimension ND,
< ! defined at same grid levels as T.
< !
< !FV: Same as FU, but for forcing of meridional velocity.
< !
< !FTRA: Array of forcing of tracer content, in tracer mixing ratio per
< ! second, defined at same levels as T. Dimensioned (ND,NTRA).
< !
< !PRECIP: Scalar convective precipitation rate (mm/day).
< !
< !WD: A convective downdraft velocity scale. For use in surface
< ! flux parameterizations. See convect.ps file for details.
< !
< !TPRIME: A convective downdraft temperature perturbation scale (K).
< ! For use in surface flux parameterizations. See convect.ps
< ! file for details.
< !
< !QPRIME: A convective downdraft specific humidity
< ! perturbation scale (gm/gm).
< ! For use in surface flux parameterizations. See convect.ps
< ! file for details.
< !
< !CBMF: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
< ! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
< ! ITS NEXT CALL. That is, the value of CBMF must be "remembered"
< ! by the calling program between calls to CONVECT.
< !
< !-----------------------------------------------------------------------------
< !
< ! *** THE PARAMETER NA SHOULD IN GENERAL BE GREATER THAN ***
< ! *** OR EQUAL TO ND + 1 ***
< !
< !
< use par_mod
< use conv_mod
<
< implicit none
< !
< !-cv====>Begin Module CONVECT File convect.f Undeclared variables
< !
< !Argument variables
< !
< integer :: iflag, nd, nl
< !
< real :: cbmf, delt, precip, qprime, tprime, wd
< !
< !Local variables
< !
< integer :: i, icb, ihmin, inb, inb1, j, jtt, k
< integer :: nk
< !
< real :: ad, afac, ahmax, ahmin, alt, altem
< real :: am, amp1, anum, asij, awat, b6, bf2, bsum, by
< real :: byp, c6, cape, capem, cbmfold, chi, coeff
< real :: cpinv, cwat, damps, dbo, dbosum
< real :: defrac, dei, delm, delp, delt0, delti, denom, dhdp
< real :: dpinv, dtma, dtmin, dtpbl, elacrit, ents
< real :: epmax, fac, fqold, frac, ftold
< real :: plcl, qp1, qsm, qstm, qti, rat
< real :: rdcp, revap, rh, scrit, sigt, sjmax
< real :: sjmin, smid, smin, stemp, tca
< real :: tvaplcl, tvpplcl, tvx, tvy, wdtrain
<
< !integer jc,jn
< !real alvnew,a2,ahm,alv,rm,sum,qnew,dphinv,tc,thbar,tnew,x
<
< real :: FUP(NA),FDOWN(NA)
< !
< !-cv====>End Module CONVECT File convect.f
<
< INTEGER :: NENT(NA)
< REAL :: M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA)
< REAL :: SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA)
< REAL :: QP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA)
< REAL :: SIGP(NA),TP(NA),CPN(NA)
< REAL :: LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA),HM(NA)
< !REAL TOLD(NA)
< !
< ! -----------------------------------------------------------------------
< !
< ! *** Specify Switches ***
< !
< ! *** IPBL: Set to zero to bypass dry adiabatic adjustment ***
< ! *** Any other value results in dry adiabatic adjustment ***
< ! *** (Zero value recommended for use in models with ***
< ! *** boundary layer schemes) ***
< !
< ! *** MINORIG: Lowest level from which convection may originate ***
< ! *** (Should be first model level at which T is defined ***
< ! *** for models using bulk PBL schemes; otherwise, it should ***
< ! *** be the first model level at which T is defined above ***
< ! *** the surface layer) ***
< !
< INTEGER,PARAMETER :: IPBL=0
< INTEGER,PARAMETER :: MINORIG=1
< !
< !------------------------------------------------------------------------------
< !
< ! *** SPECIFY PARAMETERS ***
< !
< ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
< ! *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- ***
< ! *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO ***
< ! *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY ***
< ! *** BETWEEN 0 C AND TLCRIT) ***
< ! *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT ***
< ! *** FORMULATION ***
< ! *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT ***
< ! *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
< ! *** OF CLOUD ***
< ! *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN ***
< ! *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW ***
< ! *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION ***
< ! *** OF RAIN ***
< ! *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION ***
< ! *** OF SNOW ***
< ! *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM ***
< ! *** TRANSPORT ***
< ! *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION ***
< ! *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC ***
< ! *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF ***
< ! *** APPROACH TO QUASI-EQUILIBRIUM ***
< ! *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) ***
< ! *** (DAMP MUST BE LESS THAN 1) ***
< !
< REAL,PARAMETER :: ELCRIT=.0011
< REAL,PARAMETER :: TLCRIT=-55.0
< REAL,PARAMETER :: ENTP=1.5
< REAL,PARAMETER :: SIGD=0.05
< REAL,PARAMETER :: SIGS=0.12
< REAL,PARAMETER :: OMTRAIN=50.0
< REAL,PARAMETER :: OMTSNOW=5.5
< REAL,PARAMETER :: COEFFR=1.0
< REAL,PARAMETER :: COEFFS=0.8
< REAL,PARAMETER :: CU=0.7
< REAL,PARAMETER :: BETA=10.0
< REAL,PARAMETER :: DTMAX=0.9
< REAL,PARAMETER :: ALPHA=0.025 !original 0.2
< REAL,PARAMETER :: DAMP=0.1
< !
< ! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS, ***
< ! *** GRAVITY, AND LIQUID WATER DENSITY. ***
< ! *** THESE SHOULD BE CONSISTENT WITH ***
< ! *** THOSE USED IN CALLING PROGRAM ***
< ! *** NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT ***
< !
< REAL,PARAMETER :: CPD=1005.7
< REAL,PARAMETER :: CPV=1870.0
< REAL,PARAMETER :: CL=2500.0
< REAL,PARAMETER :: RV=461.5
< REAL,PARAMETER :: RD=287.04
< REAL,PARAMETER :: LV0=2.501E6
< REAL,PARAMETER :: G=9.81
< REAL,PARAMETER :: ROWL=1000.0
< !
< REAL,PARAMETER :: CPVMCL=CL-CPV
< REAL,PARAMETER :: EPS0=RD/RV
< REAL,PARAMETER :: EPSI=1./EPS0
< REAL,PARAMETER :: GINV=1.0/G
< REAL,PARAMETER :: EPSILON=1.e-20
<
< ! EPSILON IS A SMALL NUMBER USED TO EXCLUDE MASS FLUXES OF ZERO
< !
< DELTI=1.0/DELT
< !
< ! *** INITIALIZE OUTPUT ARRAYS AND PARAMETERS ***
< !
<
< DO I=1,NL+1
< FT(I)=0.0
< FQ(I)=0.0
< FDOWN(I)=0.0
< SUB(I)=0.0
< FUP(I)=0.0
< M(I)=0.0
< MP(I)=0.0
< DO J=1,NL+1
< FMASS(I,J)=0.0
< MENT(I,J)=0.0
< END DO
< END DO
< DO I=1,NL+1
< RDCP=(RD*(1.-QCONV(I))+QCONV(I)*RV)/ &
< (CPD*(1.-QCONV(I))+QCONV(I)*CPV)
< TH(I)=TCONV(I)*(1000.0/PCONV_HPA(I))**RDCP
< END DO
< PRECIP=0.0
< WD=0.0
< TPRIME=0.0
< QPRIME=0.0
< IFLAG=0
< !
< ! IF(IPBL.NE.0)THEN
< !
< !*** PERFORM DRY ADIABATIC ADJUSTMENT ***
< !
< ! JC=0
< ! DO 30 I=NL-1,1,-1
< ! JN=0
< ! SUM=TH(I)*(1.+QCONV(I)*EPSI-QCONV(I))
< ! DO 10 J=I+1,NL
< ! SUM=SUM+TH(J)*(1.+QCONV(J)*EPSI-QCONV(J))
< ! THBAR=SUM/REAL(J+1-I)
< ! IF((TH(J)*(1.+QCONV(J)*EPSI-QCONV(J))).LT.THBAR)JN=J
< ! 10 CONTINUE
< ! IF(I.EQ.1)JN=MAX(JN,2)
< ! IF(JN.EQ.0)GOTO 30
< ! 12 CONTINUE
< ! AHM=0.0
< ! RM=0.0
< ! DO 15 J=I,JN
< ! AHM=AHM+(CPD*(1.-QCONV(J))+QCONV(J)*CPV)*TCONV(J)*
< ! + (PHCONV_HPA(J)-PHCONV_HPA(J+1))
< ! RM=RM+QCONV(J)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
< ! 15 CONTINUE
< ! DPHINV=1./(PHCONV_HPA(I)-PHCONV_HPA(JN+1))
< ! RM=RM*DPHINV
< ! A2=0.0
< ! DO 20 J=I,JN
< ! QCONV(J)=RM
< ! RDCP=(RD*(1.-QCONV(J))+QCONV(J)*RV)/
< ! 1 (CPD*(1.-QCONV(J))+QCONV(J)*CPV)
< ! X=(0.001*PCONV_HPA(J))**RDCP
< ! TOLD(J)=TCONV(J)
< ! TCONV(J)=X
< ! A2=A2+(CPD*(1.-QCONV(J))+QCONV(J)*CPV)*X*
< ! 1 (PHCONV_HPA(J)-PHCONV_HPA(J+1))
< ! 20 CONTINUE
< ! DO 25 J=I,JN
< ! TH(J)=AHM/A2
< ! TCONV(J)=TCONV(J)*TH(J)
< ! TC=TOLD(J)-273.15
< ! ALV=LV0-CPVMCL*TC
< ! QSCONV(J)=QSCONV(J)+QSCONV(J)*(1.+QSCONV(J)*(EPSI-1.))*ALV*
< ! 1 (TCONV(J)- TOLD(J))/(RV*TOLD(J)*TOLD(J))
< ! if (qslev(j) .lt. 0.) then
< ! write(*,*) 'qslev.lt.0 ',j,qslev
< ! endif
< ! 25 CONTINUE
< ! IF((TH(JN+1)*(1.+QCONV(JN+1)*EPSI-QCONV(JN+1))).LT.
< ! 1 (TH(JN)*(1.+QCONV(JN)*EPSI-QCONV(JN))))THEN
< ! JN=JN+1
< ! GOTO 12
< ! END IF
< ! IF(I.EQ.1)JC=JN
< ! 30 CONTINUE
< !
< ! *** Remove any supersaturation that results from adjustment ***
< !
< !IF(JC.GT.1)THEN
< ! DO 38 J=1,JC
< ! IF(QSCONV(J).LT.QCONV(J))THEN
< ! ALV=LV0-CPVMCL*(TCONV(J)-273.15)
< ! TNEW=TCONV(J)+ALV*(QCONV(J)-QSCONV(J))/(CPD*(1.-QCONV(J))+
< ! 1 CL*QCONV(J)+QSCONV(J)*(CPV-CL+ALV*ALV/(RV*TCONV(J)*TCONV(J))))
< ! ALVNEW=LV0-CPVMCL*(TNEW-273.15)
< ! QNEW=(ALV*QCONV(J)-(TNEW-TCONV(J))*(CPD*(1.-QCONV(J))
< ! 1 +CL*QCONV(J)))/ALVNEW
< ! PRECIP=PRECIP+24.*3600.*1.0E5*(PHCONV_HPA(J)-PHCONV_HPA(J+1))*
< ! 1 (QCONV(J)-QNEW)/(G*DELT*ROWL)
< ! TCONV(J)=TNEW
< ! QCONV(J)=QNEW
< ! QSCONV(J)=QNEW
< ! END IF
< ! 38 CONTINUE
< !END IF
< !
< !END IF
< !
< ! *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
< !
< GZ(1)=0.0
< CPN(1)=CPD*(1.-QCONV(1))+QCONV(1)*CPV
< H(1)=TCONV(1)*CPN(1)
< LV(1)=LV0-CPVMCL*(TCONV(1)-273.15)
< HM(1)=LV(1)*QCONV(1)
< TV(1)=TCONV(1)*(1.+QCONV(1)*EPSI-QCONV(1))
< AHMIN=1.0E12
< IHMIN=NL
< DO I=2,NL+1
< TVX=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
< TVY=TCONV(I-1)*(1.+QCONV(I-1)*EPSI-QCONV(I-1))
< GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(PCONV_HPA(I-1)-PCONV_HPA(I))/ &
< PHCONV_HPA(I)
< CPN(I)=CPD*(1.-QCONV(I))+CPV*QCONV(I)
< H(I)=TCONV(I)*CPN(I)+GZ(I)
< LV(I)=LV0-CPVMCL*(TCONV(I)-273.15)
< HM(I)=(CPD*(1.-QCONV(I))+CL*QCONV(I))*(TCONV(I)-TCONV(1))+ &
< LV(I)*QCONV(I)+GZ(I)
< TV(I)=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
< !
< ! *** Find level of minimum moist static energy ***
< !
< IF(I.GE.MINORIG.AND.HM(I).LT.AHMIN.AND.HM(I).LT.HM(I-1))THEN
< AHMIN=HM(I)
< IHMIN=I
< END IF
< END DO
< IHMIN=MIN(IHMIN, NL-1)
< !
< ! *** Find that model level below the level of minimum moist ***
< ! *** static energy that has the maximum value of moist static energy ***
< !
< AHMAX=0.0
< ! *** bug fixed: need to assign an initial value to NK
< ! HSO, 05.08.2009
< NK=MINORIG
< DO I=MINORIG,IHMIN
< IF(HM(I).GT.AHMAX)THEN
< NK=I
< AHMAX=HM(I)
< END IF
< END DO
< !
< ! *** CHECK WHETHER PARCEL LEVEL TEMPERATURE AND SPECIFIC HUMIDITY ***
< ! *** ARE REASONABLE ***
< ! *** Skip convection if HM increases monotonically upward ***
< !
< IF(TCONV(NK).LT.250.0.OR.QCONV(NK).LE.0.0.OR.IHMIN.EQ.(NL-1)) &
< THEN
< IFLAG=0
< CBMF=0.0
< RETURN
< END IF
< !
< ! *** CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT PARCEL ORIGIN LEVEL ***
< ! *** (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) ***
< !
< RH=QCONV(NK)/QSCONV(NK)
< CHI=TCONV(NK)/(1669.0-122.0*RH-TCONV(NK))
< PLCL=PCONV_HPA(NK)*(RH**CHI)
< IF(PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
< IFLAG=2
< CBMF=0.0
< RETURN
< END IF
< !
< ! *** CALCULATE FIRST LEVEL ABOVE LCL (=ICB) ***
< !
< ICB=NL-1
< DO I=NK+1,NL
< IF(PCONV_HPA(I).LT.PLCL)THEN
< ICB=MIN(ICB,I)
< END IF
< END DO
< IF(ICB.GE.(NL-1))THEN
< IFLAG=3
< CBMF=0.0
< RETURN
< END IF
< !
< ! *** FIND TEMPERATURE UP THROUGH ICB AND TEST FOR INSTABILITY ***
< !
< ! *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL ***
< ! *** TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC ***
< ! *** LIQUID WATER CONTENT ***
< !
< CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,1)
< DO I=NK,ICB
< TVP(I)=TVP(I)-TP(I)*QCONV(NK)
< END DO
< !
< ! *** If there was no convection at last time step and parcel ***
< ! *** is stable at ICB then skip rest of calculation ***
< !
< IF(CBMF.EQ.0.0.AND.TVP(ICB).LE.(TV(ICB)-DTMAX))THEN
< IFLAG=0
< RETURN
< END IF
< !
< ! *** IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
< !
< IF(IFLAG.NE.4)IFLAG=1
< !
< ! *** FIND THE REST OF THE LIFTED PARCEL TEMPERATURES ***
< !
< CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,2)
< !
< ! *** SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF ***
< ! *** PRECIPITATION FALLING OUTSIDE OF CLOUD ***
< ! *** THESE MAY BE FUNCTIONS OF TP(I), PCONV_HPA(I) AND CLW(I) ***
< !
< DO I=1,NK
< EP(I)=0.0
< SIGP(I)=SIGS
< END DO
< DO I=NK+1,NL
< TCA=TP(I)-273.15
< IF(TCA.GE.0.0)THEN
< ELACRIT=ELCRIT
< ELSE
< ELACRIT=ELCRIT*(1.0-TCA/TLCRIT)
< END IF
< ELACRIT=MAX(ELACRIT,0.0)
< EPMAX=0.999
< EP(I)=EPMAX*(1.0-ELACRIT/MAX(CLW(I),1.0E-8))
< EP(I)=MAX(EP(I),0.0)
< EP(I)=MIN(EP(I),EPMAX)
< SIGP(I)=SIGS
< END DO
< !
< ! *** CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL ***
< ! *** VIRTUAL TEMPERATURE ***
< !
< DO I=ICB+1,NL
< TVP(I)=TVP(I)-TP(I)*QCONV(NK)
< END DO
< TVP(NL+1)=TVP(NL)-(GZ(NL+1)-GZ(NL))/CPD
< !
< ! *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS ***
< !
< DO I=1,NL+1
< HP(I)=H(I)
< NENT(I)=0
< WATER(I)=0.0
< EVAP(I)=0.0
< WT(I)=OMTSNOW
< LVCP(I)=LV(I)/CPN(I)
< DO J=1,NL+1
< QENT(I,J)=QCONV(J)
< ELIJ(I,J)=0.0
< SIJ(I,J)=0.0
< END DO
< END DO
< QP(1)=QCONV(1)
< DO I=2,NL+1
< QP(I)=QCONV(I-1)
< END DO
< !
< ! *** FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S ***
< ! *** HIGHEST LEVEL OF NEUTRAL BUOYANCY ***
< ! *** AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) ***
< !
< CAPE=0.0
< CAPEM=0.0
< INB=ICB+1
< INB1=INB
< BYP=0.0
< DO I=ICB+1,NL-1
< BY=(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))/PCONV_HPA(I)
< CAPE=CAPE+BY
< IF(BY.GE.0.0)INB1=I+1
< IF(CAPE.GT.0.0)THEN
< INB=I+1
< BYP=(TVP(I+1)-TV(I+1))*(PHCONV_HPA(I+1)-PHCONV_HPA(I+2))/ &
< PCONV_HPA(I+1)
< CAPEM=CAPE
< END IF
< END DO
< INB=MAX(INB,INB1)
< CAPE=CAPEM+BYP
< DEFRAC=CAPEM-CAPE
< DEFRAC=MAX(DEFRAC,0.001)
< FRAC=-CAPE/DEFRAC
< FRAC=MIN(FRAC,1.0)
< FRAC=MAX(FRAC,0.0)
< !
< ! *** CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL ***
< !
< DO I=ICB,INB
< HP(I)=H(NK)+(LV(I)+(CPD-CPV)*TCONV(I))*EP(I)*CLW(I)
< END DO
< !
< ! *** CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), ***
< ! *** AT EACH MODEL LEVEL ***
< !
< DBOSUM=0.0
< !
< ! *** INTERPOLATE DIFFERENCE BETWEEN LIFTED PARCEL AND ***
< ! *** ENVIRONMENTAL TEMPERATURES TO LIFTED CONDENSATION LEVEL ***
< !
< TVPPLCL=TVP(ICB-1)-RD*TVP(ICB-1)*(PCONV_HPA(ICB-1)-PLCL)/ &
< (CPN(ICB-1)*PCONV_HPA(ICB-1))
< TVAPLCL=TV(ICB)+(TVP(ICB)-TVP(ICB+1))*(PLCL-PCONV_HPA(ICB))/ &
< (PCONV_HPA(ICB)-PCONV_HPA(ICB+1))
< DTPBL=0.0
< DO I=NK,ICB-1
< DTPBL=DTPBL+(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))
< END DO
< DTPBL=DTPBL/(PHCONV_HPA(NK)-PHCONV_HPA(ICB))
< DTMIN=TVPPLCL-TVAPLCL+DTMAX+DTPBL
< DTMA=DTMIN
< !
< ! *** ADJUST CLOUD BASE MASS FLUX ***
< !
< CBMFOLD=CBMF
< ! *** C. Forster: adjustment of CBMF is not allowed to depend on FLEXPART timestep
< DELT0=DELT/3.
< DAMPS=DAMP*DELT/DELT0
< CBMF=(1.-DAMPS)*CBMF+0.1*ALPHA*DTMA
< CBMF=MAX(CBMF,0.0)
< !
< ! *** If cloud base mass flux is zero, skip rest of calculation ***
< !
< IF(CBMF.EQ.0.0.AND.CBMFOLD.EQ.0.0)THEN
< RETURN
< END IF
<
< !
< ! *** CALCULATE RATES OF MIXING, M(I) ***
< !
< M(ICB)=0.0
< DO I=ICB+1,INB
< K=MIN(I,INB1)
< DBO=ABS(TV(K)-TVP(K))+ &
< ENTP*0.02*(PHCONV_HPA(K)-PHCONV_HPA(K+1))
< DBOSUM=DBOSUM+DBO
< M(I)=CBMF*DBO
< END DO
< DO I=ICB+1,INB
< M(I)=M(I)/DBOSUM
< END DO
< !
< ! *** CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING ***
< ! *** RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING ***
< ! *** FRACTION (SIJ) ***
< !
< DO I=ICB+1,INB
< QTI=QCONV(NK)-EP(I)*CLW(I)
< DO J=ICB,INB
< BF2=1.+LV(J)*LV(J)*QSCONV(J)/(RV*TCONV(J)*TCONV(J)*CPD)
< ANUM=H(J)-HP(I)+(CPV-CPD)*TCONV(J)*(QTI-QCONV(J))
< DENOM=H(I)-HP(I)+(CPD-CPV)*(QCONV(I)-QTI)*TCONV(J)
< DEI=DENOM
< IF(ABS(DEI).LT.0.01)DEI=0.01
< SIJ(I,J)=ANUM/DEI
< SIJ(I,I)=1.0
< ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
< ALTEM=ALTEM/BF2
< CWAT=CLW(J)*(1.-EP(J))
< STEMP=SIJ(I,J)
< IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR. &
< ALTEM.GT.CWAT).AND.J.GT.I)THEN
< ANUM=ANUM-LV(J)*(QTI-QSCONV(J)-CWAT*BF2)
< DENOM=DENOM+LV(J)*(QCONV(I)-QTI)
< IF(ABS(DENOM).LT.0.01)DENOM=0.01
< SIJ(I,J)=ANUM/DENOM
< ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
< ALTEM=ALTEM-(BF2-1.)*CWAT
< END IF
< IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
< QENT(I,J)=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI
< ELIJ(I,J)=ALTEM
< ELIJ(I,J)=MAX(0.0,ELIJ(I,J))
< MENT(I,J)=M(I)/(1.-SIJ(I,J))
< NENT(I)=NENT(I)+1
< END IF
< SIJ(I,J)=MAX(0.0,SIJ(I,J))
< SIJ(I,J)=MIN(1.0,SIJ(I,J))
< END DO
< !
< ! *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS ***
< ! *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES ***
< !
< IF(NENT(I).EQ.0)THEN
< MENT(I,I)=M(I)
< QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
< ELIJ(I,I)=CLW(I)
< SIJ(I,I)=1.0
< END IF
< END DO
< SIJ(INB,INB)=1.0
< !
< ! *** NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL ***
< ! *** PROBABILITIES OF MIXING ***
< !
< DO I=ICB+1,INB
< IF(NENT(I).NE.0)THEN
< QP1=QCONV(NK)-EP(I)*CLW(I)
< ANUM=H(I)-HP(I)-LV(I)*(QP1-QSCONV(I))
< DENOM=H(I)-HP(I)+LV(I)*(QCONV(I)-QP1)
< IF(ABS(DENOM).LT.0.01)DENOM=0.01
< SCRIT=ANUM/DENOM
< ALT=QP1-QSCONV(I)+SCRIT*(QCONV(I)-QP1)
< IF(ALT.LT.0.0)SCRIT=1.0
< SCRIT=MAX(SCRIT,0.0)
< ASIJ=0.0
< SMIN=1.0
< DO J=ICB,INB
< IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
< IF(J.GT.I)THEN
< SMID=MIN(SIJ(I,J),SCRIT)
< SJMAX=SMID
< SJMIN=SMID
< IF(SMID.LT.SMIN.AND.SIJ(I,J+1).LT.SMID)THEN
< SMIN=SMID
< SJMAX=MIN(SIJ(I,J+1),SIJ(I,J),SCRIT)
< SJMIN=MAX(SIJ(I,J-1),SIJ(I,J))
< SJMIN=MIN(SJMIN,SCRIT)
< END IF
< ELSE
< SJMAX=MAX(SIJ(I,J+1),SCRIT)
< SMID=MAX(SIJ(I,J),SCRIT)
< SJMIN=0.0
< IF(J.GT.1)SJMIN=SIJ(I,J-1)
< SJMIN=MAX(SJMIN,SCRIT)
< END IF
< DELP=ABS(SJMAX-SMID)
< DELM=ABS(SJMIN-SMID)
< ASIJ=ASIJ+(DELP+DELM)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
< MENT(I,J)=MENT(I,J)*(DELP+DELM)* &
< (PHCONV_HPA(J)-PHCONV_HPA(J+1))
< END IF
< END DO
< ASIJ=MAX(1.0E-21,ASIJ)
< ASIJ=1.0/ASIJ
< DO J=ICB,INB
< MENT(I,J)=MENT(I,J)*ASIJ
< END DO
< BSUM=0.0
< DO J=ICB,INB
< BSUM=BSUM+MENT(I,J)
< END DO
< IF(BSUM.LT.1.0E-18)THEN
< NENT(I)=0
< MENT(I,I)=M(I)
< QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
< ELIJ(I,I)=CLW(I)
< SIJ(I,I)=1.0
< END IF
< END IF
< END DO
< !
< ! *** CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING ***
< ! *** DOWNDRAFT CALCULATION ***
< !
< IF(EP(INB).LT.0.0001)GOTO 405
< !
< ! *** INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER ***
< ! *** AND CONDENSED WATER FLUX ***
< !
< JTT=2
< !
< ! *** BEGIN DOWNDRAFT LOOP ***
< !
< DO I=INB,1,-1
< !
< ! *** CALCULATE DETRAINED PRECIPITATION ***
< !
< WDTRAIN=G*EP(I)*M(I)*CLW(I)
< IF(I.GT.1)THEN
< DO J=1,I-1
< AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
< AWAT=MAX(0.0,AWAT)
< WDTRAIN=WDTRAIN+G*AWAT*MENT(J,I)
< END DO
< END IF
< !
< ! *** FIND RAIN WATER AND EVAPORATION USING PROVISIONAL ***
< ! *** ESTIMATES OF QP(I)AND QP(I-1) ***
< !
< !
< ! *** Value of terminal velocity and coefficient of evaporation for snow ***
< !
< COEFF=COEFFS
< WT(I)=OMTSNOW
< !
< ! *** Value of terminal velocity and coefficient of evaporation for rain ***
< !
< IF(TCONV(I).GT.273.0)THEN
< COEFF=COEFFR
< WT(I)=OMTRAIN
< END IF
< QSM=0.5*(QCONV(I)+QP(I+1))
< AFAC=COEFF*PHCONV_HPA(I)*(QSCONV(I)-QSM)/ &
< (1.0E4+2.0E3*PHCONV_HPA(I)*QSCONV(I))
< AFAC=MAX(AFAC,0.0)
< SIGT=SIGP(I)
< SIGT=MAX(0.0,SIGT)
< SIGT=MIN(1.0,SIGT)
< B6=100.*(PHCONV_HPA(I)-PHCONV_HPA(I+1))*SIGT*AFAC/WT(I)
< C6=(WATER(I+1)*WT(I+1)+WDTRAIN/SIGD)/WT(I)
< REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6))
< EVAP(I)=SIGT*AFAC*REVAP
< WATER(I)=REVAP*REVAP
< !
< ! *** CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER ***
< ! *** HYDROSTATIC APPROXIMATION ***
< !
< IF(I.EQ.1)GOTO 360
< DHDP=(H(I)-H(I-1))/(PCONV_HPA(I-1)-PCONV_HPA(I))
< DHDP=MAX(DHDP,10.0)
< MP(I)=100.*GINV*LV(I)*SIGD*EVAP(I)/DHDP
< MP(I)=MAX(MP(I),0.0)
< !
< ! *** ADD SMALL AMOUNT OF INERTIA TO DOWNDRAFT ***
< !
< FAC=20.0/(PHCONV_HPA(I-1)-PHCONV_HPA(I))
< MP(I)=(FAC*MP(I+1)+MP(I))/(1.+FAC)
< !
< ! *** FORCE MP TO DECREASE LINEARLY TO ZERO ***
< ! *** BETWEEN ABOUT 950 MB AND THE SURFACE ***
< !
< IF(PCONV_HPA(I).GT.(0.949*PCONV_HPA(1)))THEN
< JTT=MAX(JTT,I)
< MP(I)=MP(JTT)*(PCONV_HPA(1)-PCONV_HPA(I))/(PCONV_HPA(1)- &
< PCONV_HPA(JTT))
< END IF
< 360 CONTINUE
< !
< ! *** FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT ***
< !
< IF(I.EQ.INB)GOTO 400
< IF(I.EQ.1)THEN
< QSTM=QSCONV(1)
< ELSE
< QSTM=QSCONV(I-1)
< END IF
< IF(MP(I).GT.MP(I+1))THEN
< RAT=MP(I+1)/MP(I)
< QP(I)=QP(I+1)*RAT+QCONV(I)*(1.0-RAT)+100.*GINV* &
< SIGD*(PHCONV_HPA(I)-PHCONV_HPA(I+1))*(EVAP(I)/MP(I))
< ELSE
< IF(MP(I+1).GT.0.0)THEN
< QP(I)=(GZ(I+1)-GZ(I)+QP(I+1)*(LV(I+1)+TCONV(I+1)*(CL-CPD))+ &
< CPD*(TCONV(I+1)-TCONV(I)))/(LV(I)+TCONV(I)*(CL-CPD))
< END IF
< END IF
< QP(I)=MIN(QP(I),QSTM)
< QP(I)=MAX(QP(I),0.0)
< 400 CONTINUE
< END DO
< !
< ! *** CALCULATE SURFACE PRECIPITATION IN MM/DAY ***
< !
< PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G)
< !
< 405 CONTINUE
< !
< ! *** CALCULATE DOWNDRAFT VELOCITY SCALE AND SURFACE TEMPERATURE AND ***
< ! *** WATER VAPOR FLUCTUATIONS ***
< !
< WD=BETA*ABS(MP(ICB))*0.01*RD*TCONV(ICB)/(SIGD*PCONV_HPA(ICB))
< QPRIME=0.5*(QP(1)-QCONV(1))
< TPRIME=LV0*QPRIME/CPD
< !
< ! *** CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE ***
< ! *** AND MIXING RATIO ***
< !
< DPINV=0.01/(PHCONV_HPA(1)-PHCONV_HPA(2))
< AM=0.0
< IF(NK.EQ.1)THEN
< DO K=2,INB
< AM=AM+M(K)
< END DO
< END IF
< ! save saturated upward mass flux for first level
< FUP(1)=AM
< IF((2.*G*DPINV*AM).GE.DELTI)IFLAG=4
< FT(1)=FT(1)+G*DPINV*AM*(TCONV(2)-TCONV(1)+(GZ(2)-GZ(1))/CPN(1))
< FT(1)=FT(1)-LVCP(1)*SIGD*EVAP(1)
< FT(1)=FT(1)+SIGD*WT(2)*(CL-CPD)*WATER(2)*(TCONV(2)- &
< TCONV(1))*DPINV/CPN(1)
< FQ(1)=FQ(1)+G*MP(2)*(QP(2)-QCONV(1))* &
< DPINV+SIGD*EVAP(1)
< FQ(1)=FQ(1)+G*AM*(QCONV(2)-QCONV(1))*DPINV
< DO J=2,INB
< FQ(1)=FQ(1)+G*DPINV*MENT(J,1)*(QENT(J,1)-QCONV(1))
< END DO
< !
< ! *** CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO ***
< ! *** AT LEVELS ABOVE THE LOWEST LEVEL ***
< !
< ! *** FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES ***
< ! *** THROUGH EACH LEVEL ***
< !
< DO I=2,INB
< DPINV=0.01/(PHCONV_HPA(I)-PHCONV_HPA(I+1))
< CPINV=1.0/CPN(I)
< AMP1=0.0
< AD=0.0
< IF(I.GE.NK)THEN
< DO K=I+1,INB+1
< AMP1=AMP1+M(K)
< END DO
< END IF
< DO K=1,I
< DO J=I+1,INB+1
< AMP1=AMP1+MENT(K,J)
< END DO
< END DO
< ! save saturated upward mass flux
< FUP(I)=AMP1
< IF((2.*G*DPINV*AMP1).GE.DELTI)IFLAG=4
< DO K=1,I-1
< DO J=I,INB
< AD=AD+MENT(J,K)
< END DO
< END DO
< ! save saturated downward mass flux
< FDOWN(I)=AD
< FT(I)=FT(I)+G*DPINV*(AMP1*(TCONV(I+1)-TCONV(I)+(GZ(I+1)-GZ(I))* &
< CPINV)-AD*(TCONV(I)-TCONV(I-1)+(GZ(I)-GZ(I-1))*CPINV)) &
< -SIGD*LVCP(I)*EVAP(I)
< FT(I)=FT(I)+G*DPINV*MENT(I,I)*(HP(I)-H(I)+ &
< TCONV(I)*(CPV-CPD)*(QCONV(I)-QENT(I,I)))*CPINV
< FT(I)=FT(I)+SIGD*WT(I+1)*(CL-CPD)*WATER(I+1)* &
< (TCONV(I+1)-TCONV(I))*DPINV*CPINV
< FQ(I)=FQ(I)+G*DPINV*(AMP1*(QCONV(I+1)-QCONV(I))- &
< AD*(QCONV(I)-QCONV(I-1)))
< DO K=1,I-1
< AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
< AWAT=MAX(AWAT,0.0)
< FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-QCONV(I))
< END DO
< DO K=I,INB
< FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-QCONV(I))
< END DO
< FQ(I)=FQ(I)+SIGD*EVAP(I)+G*(MP(I+1)* &
< (QP(I+1)-QCONV(I))-MP(I)*(QP(I)-QCONV(I-1)))*DPINV
< END DO
< !
< ! *** Adjust tendencies at top of convection layer to reflect ***
< ! *** actual position of the level zero CAPE ***
< !
< FQOLD=FQ(INB)
< FQ(INB)=FQ(INB)*(1.-FRAC)
< FQ(INB-1)=FQ(INB-1)+FRAC*FQOLD*((PHCONV_HPA(INB)- &
< PHCONV_HPA(INB+1))/ &
< (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*LV(INB)/LV(INB-1)
< FTOLD=FT(INB)
< FT(INB)=FT(INB)*(1.-FRAC)
< FT(INB-1)=FT(INB-1)+FRAC*FTOLD*((PHCONV_HPA(INB)- &
< PHCONV_HPA(INB+1))/ &
< (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*CPN(INB)/CPN(INB-1)
< !
< ! *** Very slightly adjust tendencies to force exact ***
< ! *** enthalpy, momentum and tracer conservation ***
< !
< ENTS=0.0
< DO I=1,INB
< ENTS=ENTS+(CPN(I)*FT(I)+LV(I)*FQ(I))* &
< (PHCONV_HPA(I)-PHCONV_HPA(I+1))
< END DO
< ENTS=ENTS/(PHCONV_HPA(1)-PHCONV_HPA(INB+1))
< DO I=1,INB
< FT(I)=FT(I)-ENTS/CPN(I)
< END DO
<
< ! ************************************************
< ! **** DETERMINE MASS DISPLACEMENT MATRIX
< ! ***** AND COMPENSATING SUBSIDENCE
< ! ************************************************
<
< ! mass displacement matrix due to saturated up-and downdrafts
< ! inside the cloud and determine compensating subsidence
< ! FUP(I) (saturated updrafts), FDOWN(I) (saturated downdrafts) are assumed to be
< ! balanced by compensating subsidence (SUB(I))
< ! FDOWN(I) and SUB(I) defined positive downwards
<
< ! NCONVTOP IS THE TOP LEVEL AT WHICH CONVECTIVE MASS FLUXES ARE DIAGNOSED
< ! EPSILON IS A SMALL NUMBER
<
< SUB(1)=0.
< NCONVTOP=1
< do i=1,INB+1
< do j=1,INB+1
< if (j.eq.NK) then
< FMASS(j,i)=FMASS(j,i)+M(i)
< endif
< FMASS(j,i)=FMASS(j,i)+MENT(j,i)
< IF (FMASS(J,I).GT.EPSILON) NCONVTOP=MAX(NCONVTOP,I,J)
< end do
< if (i.gt.1) then
< SUB(i)=FUP(i-1)-FDOWN(i)
< endif
< end do
< NCONVTOP=NCONVTOP+1
<
< RETURN
< !
< END SUBROUTINE CONVECT
< !
< ! ---------------------------------------------------------------------------
< !
< SUBROUTINE TLIFT(GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
< !
< !-cv
< use par_mod
< use conv_mod
<
< implicit none
< !-cv
< !====>Begin Module TLIFT File convect.f Undeclared variables
< !
< !Argument variables
< !
< integer :: icb, kk, nd, nk, nl
< !
< !Local variables
< !
< integer :: i, j, nsb, nst
< !
< real :: ah0, ahg, alv, cpinv, cpp, denom
< real :: es, qg, rg, s, tc, tg
< !
< !====>End Module TLIFT File convect.f
<
< REAL :: GZ(ND),TPK(ND),CLW(ND)
< REAL :: TVP(ND)
< !
< ! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS ***
< !
< REAL,PARAMETER :: CPD=1005.7
< REAL,PARAMETER :: CPV=1870.0
< REAL,PARAMETER :: CL=2500.0
< REAL,PARAMETER :: RV=461.5
< REAL,PARAMETER :: RD=287.04
< REAL,PARAMETER :: LV0=2.501E6
< !
< REAL,PARAMETER :: CPVMCL=CL-CPV
< REAL,PARAMETER :: EPS0=RD/RV
< REAL,PARAMETER :: EPSI=1./EPS0
< !
< ! *** CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY ***
< !
< AH0=(CPD*(1.-QCONV(NK))+CL*QCONV(NK))*TCONV(NK)+QCONV(NK)* &
< (LV0-CPVMCL*( &
< TCONV(NK)-273.15))+GZ(NK)
< CPP=CPD*(1.-QCONV(NK))+QCONV(NK)*CPV
< CPINV=1./CPP
< !
< IF(KK.EQ.1)THEN
< !
< ! *** CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE ***
< !
< DO I=1,ICB-1
< CLW(I)=0.0
< END DO
< DO I=NK,ICB-1
< TPK(I)=TCONV(NK)-(GZ(I)-GZ(NK))*CPINV
< TVP(I)=TPK(I)*(1.+QCONV(NK)*EPSI)
< END DO
< END IF
< !
< ! *** FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE ***
< !
< NST=ICB
< NSB=ICB
< IF(KK.EQ.2)THEN
< NST=NL
< NSB=ICB+1
< END IF
< DO I=NSB,NST
< TG=TCONV(I)
< QG=QSCONV(I)
< ALV=LV0-CPVMCL*(TCONV(I)-273.15)
< DO J=1,2
< S=CPD+ALV*ALV*QG/(RV*TCONV(I)*TCONV(I))
< S=1./S
< AHG=CPD*TG+(CL-CPD)*QCONV(NK)*TCONV(I)+ALV*QG+GZ(I)
< TG=TG+S*(AH0-AHG)
< TG=MAX(TG,35.0)
< TC=TG-273.15
< DENOM=243.5+TC
< IF(TC.GE.0.0)THEN
< ES=6.112*EXP(17.67*TC/DENOM)
< ELSE
< ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
< END IF
< QG=EPS0*ES/(PCONV_HPA(I)-ES*(1.-EPS0))
< END DO
< ALV=LV0-CPVMCL*(TCONV(I)-273.15)
< TPK(I)=(AH0-(CL-CPD)*QCONV(NK)*TCONV(I)-GZ(I)-ALV*QG)/CPD
< CLW(I)=QCONV(NK)-QG
< CLW(I)=MAX(0.0,CLW(I))
< RG=QG/(1.-QCONV(NK))
< TVP(I)=TPK(I)*(1.+RG*EPSI)
< END DO
< RETURN
< END SUBROUTINE TLIFT
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> !**************************************************************************
> !**** SUBROUTINE CONVECT *****
> !**** VERSION 4.3c *****
> !**** 20 May, 2002 *****
> !**** Kerry Emanuel *****
> !**************************************************************************
> !
> SUBROUTINE CONVECT &
> (ND, NL, DELT, IFLAG, &
> PRECIP, WD, TPRIME, QPRIME, CBMF )
> !
> !-cv *************************************************************************
> !-cv C. Forster, November 2003 - May 2004:
> !-cv
> !-cv The subroutine has been downloaded from Kerry Emanuel's homepage,
> !-cv where further infos on the convection scheme can be found
> !-cv http://www-paoc.mit.edu/~emanuel/home.html
> !-cv
> !-cv The following changes have been made to integrate this subroutine
> !-cv into FLEXPART
> !-cv
> !-cv Putting most of the variables in a new common block
> !-cv renaming eps to eps0 because there is some eps already in includepar
> !-cv
> !-cv removing the arrays U,V,TRA and related arrays
> !-cv
> !-cv renaming the original arrays T,Q,QS,P,PH to
> !-cv TCONV,QCONV,QSCONV,PCONV_HPA,PHCONV_HPA
> !-cv
> !-cv Initialization of variables has been put into parameter statements
> !-cv instead of assignment of values at each call, in order to save
> !-cv computation time.
> !***************************************************************************
> !
> !-----------------------------------------------------------------------------
> ! *** On input: ***
> !
> !T: Array of absolute temperature (K) of dimension ND, with first
> ! index corresponding to lowest model level. Note that this array
> ! will be altered by the subroutine if dry convective adjustment
> ! occurs and if IPBL is not equal to 0.
> !
> !Q: Array of specific humidity (gm/gm) of dimension ND, with first
> ! index corresponding to lowest model level. Must be defined
> ! at same grid levels as T. Note that this array will be altered
> ! if dry convective adjustment occurs and if IPBL is not equal to 0.
> !
> !QS: Array of saturation specific humidity of dimension ND, with first
> ! index corresponding to lowest model level. Must be defined
> ! at same grid levels as T. Note that this array will be altered
> ! if dry convective adjustment occurs and if IPBL is not equal to 0.
> !
> !U: Array of zonal wind velocity (m/s) of dimension ND, witth first
> ! index corresponding with the lowest model level. Defined at
> ! same levels as T. Note that this array will be altered if
> ! dry convective adjustment occurs and if IPBL is not equal to 0.
> !
> !V: Same as U but for meridional velocity.
> !
> !TRA: Array of passive tracer mixing ratio, of dimensions (ND,NTRA),
> ! where NTRA is the number of different tracers. If no
> ! convective tracer transport is needed, define a dummy
> ! input array of dimension (ND,1). Tracers are defined at
> ! same vertical levels as T. Note that this array will be altered
> ! if dry convective adjustment occurs and if IPBL is not equal to 0.
> !
> !P: Array of pressure (mb) of dimension ND, with first
> ! index corresponding to lowest model level. Must be defined
> ! at same grid levels as T.
> !
> !PH: Array of pressure (mb) of dimension ND+1, with first index
> ! corresponding to lowest level. These pressures are defined at
> ! levels intermediate between those of P, T, Q and QS. The first
> ! value of PH should be greater than (i.e. at a lower level than)
> ! the first value of the array P.
> !
> !ND: The dimension of the arrays T,Q,QS,P,PH,FT and FQ
> !
> !NL: The maximum number of levels to which convection can
> ! penetrate, plus 1.
> ! NL MUST be less than or equal to ND-1.
> !
> !NTRA:The number of different tracers. If no tracer transport
> ! is needed, set this equal to 1. (On most compilers, setting
> ! NTRA to 0 will bypass tracer calculation, saving some CPU.)
> !
> !DELT: The model time step (sec) between calls to CONVECT
> !
> !----------------------------------------------------------------------------
> ! *** On Output: ***
> !
> !IFLAG: An output integer whose value denotes the following:
> !
> ! VALUE INTERPRETATION
> ! ----- --------------
> ! 0 No moist convection; atmosphere is not
> ! unstable, or surface temperature is less
> ! than 250 K or surface specific humidity
> ! is non-positive.
> !
> ! 1 Moist convection occurs.
> !
> ! 2 No moist convection: lifted condensation
> ! level is above the 200 mb level.
> !
> ! 3 No moist convection: cloud base is higher
> ! then the level NL-1.
> !
> ! 4 Moist convection occurs, but a CFL condition
> ! on the subsidence warming is violated. This
> ! does not cause the scheme to terminate.
> !
> !FT: Array of temperature tendency (K/s) of dimension ND, defined at same
> ! grid levels as T, Q, QS and P.
> !
> !FQ: Array of specific humidity tendencies ((gm/gm)/s) of dimension ND,
> ! defined at same grid levels as T, Q, QS and P.
> !
> !FU: Array of forcing of zonal velocity (m/s^2) of dimension ND,
> ! defined at same grid levels as T.
> !
> !FV: Same as FU, but for forcing of meridional velocity.
> !
> !FTRA: Array of forcing of tracer content, in tracer mixing ratio per
> ! second, defined at same levels as T. Dimensioned (ND,NTRA).
> !
> !PRECIP: Scalar convective precipitation rate (mm/day).
> !
> !WD: A convective downdraft velocity scale. For use in surface
> ! flux parameterizations. See convect.ps file for details.
> !
> !TPRIME: A convective downdraft temperature perturbation scale (K).
> ! For use in surface flux parameterizations. See convect.ps
> ! file for details.
> !
> !QPRIME: A convective downdraft specific humidity
> ! perturbation scale (gm/gm).
> ! For use in surface flux parameterizations. See convect.ps
> ! file for details.
> !
> !CBMF: The cloud base mass flux ((kg/m**2)/s). THIS SCALAR VALUE MUST
> ! BE STORED BY THE CALLING PROGRAM AND RETURNED TO CONVECT AT
> ! ITS NEXT CALL. That is, the value of CBMF must be "remembered"
> ! by the calling program between calls to CONVECT.
> !
> !-----------------------------------------------------------------------------
> !
> ! *** THE PARAMETER NA SHOULD IN GENERAL BE GREATER THAN ***
> ! *** OR EQUAL TO ND + 1 ***
> !
> !
> use par_mod
> use conv_mod
>
> implicit none
> !
> !-cv====>Begin Module CONVECT File convect.f Undeclared variables
> !
> !Argument variables
> !
> integer :: iflag, nd, nl
> !
> real :: cbmf, delt, precip, qprime, tprime, wd
> !
> !Local variables
> !
> integer :: i, icb, ihmin, inb, inb1, j, jtt, k
> integer :: nk
> !
> real :: ad, afac, ahmax, ahmin, alt, altem
> real :: am, amp1, anum, asij, awat, b6, bf2, bsum, by
> real :: byp, c6, cape, capem, cbmfold, chi, coeff
> real :: cpinv, cwat, damps, dbo, dbosum
> real :: defrac, dei, delm, delp, delt0, delti, denom, dhdp
> real :: dpinv, dtma, dtmin, dtpbl, elacrit, ents
> real :: epmax, fac, fqold, frac, ftold
> real :: plcl, qp1, qsm, qstm, qti, rat
> real :: rdcp, revap, rh, scrit, sigt, sjmax
> real :: sjmin, smid, smin, stemp, tca
> real :: tvaplcl, tvpplcl, tvx, tvy, wdtrain
>
> !integer jc,jn
> !real alvnew,a2,ahm,alv,rm,sum,qnew,dphinv,tc,thbar,tnew,x
>
> real :: FUP(NA),FDOWN(NA)
> !
> !-cv====>End Module CONVECT File convect.f
>
> INTEGER :: NENT(NA)
> REAL :: M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA)
> REAL :: SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA)
> REAL :: QP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA)
> REAL :: SIGP(NA),TP(NA),CPN(NA)
> REAL :: LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA),HM(NA)
> !REAL TOLD(NA)
> !
> ! -----------------------------------------------------------------------
> !
> ! *** Specify Switches ***
> !
> ! *** IPBL: Set to zero to bypass dry adiabatic adjustment ***
> ! *** Any other value results in dry adiabatic adjustment ***
> ! *** (Zero value recommended for use in models with ***
> ! *** boundary layer schemes) ***
> !
> ! *** MINORIG: Lowest level from which convection may originate ***
> ! *** (Should be first model level at which T is defined ***
> ! *** for models using bulk PBL schemes; otherwise, it should ***
> ! *** be the first model level at which T is defined above ***
> ! *** the surface layer) ***
> !
> INTEGER,PARAMETER :: IPBL=0
> INTEGER,PARAMETER :: MINORIG=1
> !
> !------------------------------------------------------------------------------
> !
> ! *** SPECIFY PARAMETERS ***
> !
> ! *** ELCRIT IS THE AUTOCONVERSION THERSHOLD WATER CONTENT (gm/gm) ***
> ! *** TLCRIT IS CRITICAL TEMPERATURE BELOW WHICH THE AUTO- ***
> ! *** CONVERSION THRESHOLD IS ASSUMED TO BE ZERO ***
> ! *** (THE AUTOCONVERSION THRESHOLD VARIES LINEARLY ***
> ! *** BETWEEN 0 C AND TLCRIT) ***
> ! *** ENTP IS THE COEFFICIENT OF MIXING IN THE ENTRAINMENT ***
> ! *** FORMULATION ***
> ! *** SIGD IS THE FRACTIONAL AREA COVERED BY UNSATURATED DNDRAFT ***
> ! *** SIGS IS THE FRACTION OF PRECIPITATION FALLING OUTSIDE ***
> ! *** OF CLOUD ***
> ! *** OMTRAIN IS THE ASSUMED FALL SPEED (P/s) OF RAIN ***
> ! *** OMTSNOW IS THE ASSUMED FALL SPEED (P/s) OF SNOW ***
> ! *** COEFFR IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION ***
> ! *** OF RAIN ***
> ! *** COEFFS IS A COEFFICIENT GOVERNING THE RATE OF EVAPORATION ***
> ! *** OF SNOW ***
> ! *** CU IS THE COEFFICIENT GOVERNING CONVECTIVE MOMENTUM ***
> ! *** TRANSPORT ***
> ! *** DTMAX IS THE MAXIMUM NEGATIVE TEMPERATURE PERTURBATION ***
> ! *** A LIFTED PARCEL IS ALLOWED TO HAVE BELOW ITS LFC ***
> ! *** ALPHA AND DAMP ARE PARAMETERS THAT CONTROL THE RATE OF ***
> ! *** APPROACH TO QUASI-EQUILIBRIUM ***
> ! *** (THEIR STANDARD VALUES ARE 0.20 AND 0.1, RESPECTIVELY) ***
> ! *** (DAMP MUST BE LESS THAN 1) ***
> !
> REAL,PARAMETER :: ELCRIT=.0011
> REAL,PARAMETER :: TLCRIT=-55.0
> REAL,PARAMETER :: ENTP=1.5
> REAL,PARAMETER :: SIGD=0.05
> REAL,PARAMETER :: SIGS=0.12
> REAL,PARAMETER :: OMTRAIN=50.0
> REAL,PARAMETER :: OMTSNOW=5.5
> REAL,PARAMETER :: COEFFR=1.0
> REAL,PARAMETER :: COEFFS=0.8
> REAL,PARAMETER :: CU=0.7
> REAL,PARAMETER :: BETA=10.0
> REAL,PARAMETER :: DTMAX=0.9
> REAL,PARAMETER :: ALPHA=0.025 !original 0.2
> REAL,PARAMETER :: DAMP=0.1
> !
> ! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS, ***
> ! *** GRAVITY, AND LIQUID WATER DENSITY. ***
> ! *** THESE SHOULD BE CONSISTENT WITH ***
> ! *** THOSE USED IN CALLING PROGRAM ***
> ! *** NOTE: THESE ARE ALSO SPECIFIED IN SUBROUTINE TLIFT ***
> !
> REAL,PARAMETER :: CPD=1005.7
> REAL,PARAMETER :: CPV=1870.0
> REAL,PARAMETER :: CL=2500.0
> REAL,PARAMETER :: RV=461.5
> REAL,PARAMETER :: RD=287.04
> REAL,PARAMETER :: LV0=2.501E6
> REAL,PARAMETER :: G=9.81
> REAL,PARAMETER :: ROWL=1000.0
> !
> REAL,PARAMETER :: CPVMCL=CL-CPV
> REAL,PARAMETER :: EPS0=RD/RV
> REAL,PARAMETER :: EPSI=1./EPS0
> REAL,PARAMETER :: GINV=1.0/G
> REAL,PARAMETER :: EPSILON=1.e-20
>
> ! EPSILON IS A SMALL NUMBER USED TO EXCLUDE MASS FLUXES OF ZERO
> !
> DELTI=1.0/DELT
> !
> ! *** INITIALIZE OUTPUT ARRAYS AND PARAMETERS ***
> !
>
> DO I=1,NL+1
> FT(I)=0.0
> FQ(I)=0.0
> FDOWN(I)=0.0
> SUB(I)=0.0
> FUP(I)=0.0
> M(I)=0.0
> MP(I)=0.0
> DO J=1,NL+1
> FMASS(I,J)=0.0
> MENT(I,J)=0.0
> END DO
> END DO
> DO I=1,NL+1
> RDCP=(RD*(1.-QCONV(I))+QCONV(I)*RV)/ &
> (CPD*(1.-QCONV(I))+QCONV(I)*CPV)
> TH(I)=TCONV(I)*(1000.0/PCONV_HPA(I))**RDCP
> END DO
> PRECIP=0.0
> WD=0.0
> TPRIME=0.0
> QPRIME=0.0
> IFLAG=0
> !
> ! IF(IPBL.NE.0)THEN
> !
> !*** PERFORM DRY ADIABATIC ADJUSTMENT ***
> !
> ! JC=0
> ! DO 30 I=NL-1,1,-1
> ! JN=0
> ! SUM=TH(I)*(1.+QCONV(I)*EPSI-QCONV(I))
> ! DO 10 J=I+1,NL
> ! SUM=SUM+TH(J)*(1.+QCONV(J)*EPSI-QCONV(J))
> ! THBAR=SUM/REAL(J+1-I)
> ! IF((TH(J)*(1.+QCONV(J)*EPSI-QCONV(J))).LT.THBAR)JN=J
> ! 10 CONTINUE
> ! IF(I.EQ.1)JN=MAX(JN,2)
> ! IF(JN.EQ.0)GOTO 30
> ! 12 CONTINUE
> ! AHM=0.0
> ! RM=0.0
> ! DO 15 J=I,JN
> ! AHM=AHM+(CPD*(1.-QCONV(J))+QCONV(J)*CPV)*TCONV(J)*
> ! + (PHCONV_HPA(J)-PHCONV_HPA(J+1))
> ! RM=RM+QCONV(J)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
> ! 15 CONTINUE
> ! DPHINV=1./(PHCONV_HPA(I)-PHCONV_HPA(JN+1))
> ! RM=RM*DPHINV
> ! A2=0.0
> ! DO 20 J=I,JN
> ! QCONV(J)=RM
> ! RDCP=(RD*(1.-QCONV(J))+QCONV(J)*RV)/
> ! 1 (CPD*(1.-QCONV(J))+QCONV(J)*CPV)
> ! X=(0.001*PCONV_HPA(J))**RDCP
> ! TOLD(J)=TCONV(J)
> ! TCONV(J)=X
> ! A2=A2+(CPD*(1.-QCONV(J))+QCONV(J)*CPV)*X*
> ! 1 (PHCONV_HPA(J)-PHCONV_HPA(J+1))
> ! 20 CONTINUE
> ! DO 25 J=I,JN
> ! TH(J)=AHM/A2
> ! TCONV(J)=TCONV(J)*TH(J)
> ! TC=TOLD(J)-273.15
> ! ALV=LV0-CPVMCL*TC
> ! QSCONV(J)=QSCONV(J)+QSCONV(J)*(1.+QSCONV(J)*(EPSI-1.))*ALV*
> ! 1 (TCONV(J)- TOLD(J))/(RV*TOLD(J)*TOLD(J))
> ! if (qslev(j) .lt. 0.) then
> ! write(*,*) 'qslev.lt.0 ',j,qslev
> ! endif
> ! 25 CONTINUE
> ! IF((TH(JN+1)*(1.+QCONV(JN+1)*EPSI-QCONV(JN+1))).LT.
> ! 1 (TH(JN)*(1.+QCONV(JN)*EPSI-QCONV(JN))))THEN
> ! JN=JN+1
> ! GOTO 12
> ! END IF
> ! IF(I.EQ.1)JC=JN
> ! 30 CONTINUE
> !
> ! *** Remove any supersaturation that results from adjustment ***
> !
> !IF(JC.GT.1)THEN
> ! DO 38 J=1,JC
> ! IF(QSCONV(J).LT.QCONV(J))THEN
> ! ALV=LV0-CPVMCL*(TCONV(J)-273.15)
> ! TNEW=TCONV(J)+ALV*(QCONV(J)-QSCONV(J))/(CPD*(1.-QCONV(J))+
> ! 1 CL*QCONV(J)+QSCONV(J)*(CPV-CL+ALV*ALV/(RV*TCONV(J)*TCONV(J))))
> ! ALVNEW=LV0-CPVMCL*(TNEW-273.15)
> ! QNEW=(ALV*QCONV(J)-(TNEW-TCONV(J))*(CPD*(1.-QCONV(J))
> ! 1 +CL*QCONV(J)))/ALVNEW
> ! PRECIP=PRECIP+24.*3600.*1.0E5*(PHCONV_HPA(J)-PHCONV_HPA(J+1))*
> ! 1 (QCONV(J)-QNEW)/(G*DELT*ROWL)
> ! TCONV(J)=TNEW
> ! QCONV(J)=QNEW
> ! QSCONV(J)=QNEW
> ! END IF
> ! 38 CONTINUE
> !END IF
> !
> !END IF
> !
> ! *** CALCULATE ARRAYS OF GEOPOTENTIAL, HEAT CAPACITY AND STATIC ENERGY
> !
> GZ(1)=0.0
> CPN(1)=CPD*(1.-QCONV(1))+QCONV(1)*CPV
> H(1)=TCONV(1)*CPN(1)
> LV(1)=LV0-CPVMCL*(TCONV(1)-273.15)
> HM(1)=LV(1)*QCONV(1)
> TV(1)=TCONV(1)*(1.+QCONV(1)*EPSI-QCONV(1))
> AHMIN=1.0E12
> IHMIN=NL
> DO I=2,NL+1
> TVX=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
> TVY=TCONV(I-1)*(1.+QCONV(I-1)*EPSI-QCONV(I-1))
> GZ(I)=GZ(I-1)+0.5*RD*(TVX+TVY)*(PCONV_HPA(I-1)-PCONV_HPA(I))/ &
> PHCONV_HPA(I)
> CPN(I)=CPD*(1.-QCONV(I))+CPV*QCONV(I)
> H(I)=TCONV(I)*CPN(I)+GZ(I)
> LV(I)=LV0-CPVMCL*(TCONV(I)-273.15)
> HM(I)=(CPD*(1.-QCONV(I))+CL*QCONV(I))*(TCONV(I)-TCONV(1))+ &
> LV(I)*QCONV(I)+GZ(I)
> TV(I)=TCONV(I)*(1.+QCONV(I)*EPSI-QCONV(I))
> !
> ! *** Find level of minimum moist static energy ***
> !
> IF(I.GE.MINORIG.AND.HM(I).LT.AHMIN.AND.HM(I).LT.HM(I-1))THEN
> AHMIN=HM(I)
> IHMIN=I
> END IF
> END DO
> IHMIN=MIN(IHMIN, NL-1)
> !
> ! *** Find that model level below the level of minimum moist ***
> ! *** static energy that has the maximum value of moist static energy ***
> !
> AHMAX=0.0
> ! *** bug fixed: need to assign an initial value to NK
> ! HSO, 05.08.2009
> NK=MINORIG
> DO I=MINORIG,IHMIN
> IF(HM(I).GT.AHMAX)THEN
> NK=I
> AHMAX=HM(I)
> END IF
> END DO
> !
> ! *** CHECK WHETHER PARCEL LEVEL TEMPERATURE AND SPECIFIC HUMIDITY ***
> ! *** ARE REASONABLE ***
> ! *** Skip convection if HM increases monotonically upward ***
> !
> IF(TCONV(NK).LT.250.0.OR.QCONV(NK).LE.0.0.OR.IHMIN.EQ.(NL-1)) &
> THEN
> IFLAG=0
> CBMF=0.0
> RETURN
> END IF
> !
> ! *** CALCULATE LIFTED CONDENSATION LEVEL OF AIR AT PARCEL ORIGIN LEVEL ***
> ! *** (WITHIN 0.2% OF FORMULA OF BOLTON, MON. WEA. REV.,1980) ***
> !
> RH=QCONV(NK)/QSCONV(NK)
> CHI=TCONV(NK)/(1669.0-122.0*RH-TCONV(NK))
> PLCL=PCONV_HPA(NK)*(RH**CHI)
> IF(PLCL.LT.200.0.OR.PLCL.GE.2000.0)THEN
> IFLAG=2
> CBMF=0.0
> RETURN
> END IF
> !
> ! *** CALCULATE FIRST LEVEL ABOVE LCL (=ICB) ***
> !
> ICB=NL-1
> DO I=NK+1,NL
> IF(PCONV_HPA(I).LT.PLCL)THEN
> ICB=MIN(ICB,I)
> END IF
> END DO
> IF(ICB.GE.(NL-1))THEN
> IFLAG=3
> CBMF=0.0
> RETURN
> END IF
> !
> ! *** FIND TEMPERATURE UP THROUGH ICB AND TEST FOR INSTABILITY ***
> !
> ! *** SUBROUTINE TLIFT CALCULATES PART OF THE LIFTED PARCEL VIRTUAL ***
> ! *** TEMPERATURE, THE ACTUAL TEMPERATURE AND THE ADIABATIC ***
> ! *** LIQUID WATER CONTENT ***
> !
> CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,1)
> DO I=NK,ICB
> TVP(I)=TVP(I)-TP(I)*QCONV(NK)
> END DO
> !
> ! *** If there was no convection at last time step and parcel ***
> ! *** is stable at ICB then skip rest of calculation ***
> !
> IF(CBMF.EQ.0.0.AND.TVP(ICB).LE.(TV(ICB)-DTMAX))THEN
> IFLAG=0
> RETURN
> END IF
> !
> ! *** IF THIS POINT IS REACHED, MOIST CONVECTIVE ADJUSTMENT IS NECESSARY ***
> !
> IF(IFLAG.NE.4)IFLAG=1
> !
> ! *** FIND THE REST OF THE LIFTED PARCEL TEMPERATURES ***
> !
> CALL TLIFT(GZ,ICB,NK,TVP,TP,CLW,ND,NL,2)
> !
> ! *** SET THE PRECIPITATION EFFICIENCIES AND THE FRACTION OF ***
> ! *** PRECIPITATION FALLING OUTSIDE OF CLOUD ***
> ! *** THESE MAY BE FUNCTIONS OF TP(I), PCONV_HPA(I) AND CLW(I) ***
> !
> DO I=1,NK
> EP(I)=0.0
> SIGP(I)=SIGS
> END DO
> DO I=NK+1,NL
> TCA=TP(I)-273.15
> IF(TCA.GE.0.0)THEN
> ELACRIT=ELCRIT
> ELSE
> ELACRIT=ELCRIT*(1.0-TCA/TLCRIT)
> END IF
> ELACRIT=MAX(ELACRIT,0.0)
> EPMAX=0.999
> EP(I)=EPMAX*(1.0-ELACRIT/MAX(CLW(I),1.0E-8))
> EP(I)=MAX(EP(I),0.0)
> EP(I)=MIN(EP(I),EPMAX)
> SIGP(I)=SIGS
> END DO
> !
> ! *** CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL ***
> ! *** VIRTUAL TEMPERATURE ***
> !
> DO I=ICB+1,NL
> TVP(I)=TVP(I)-TP(I)*QCONV(NK)
> END DO
> TVP(NL+1)=TVP(NL)-(GZ(NL+1)-GZ(NL))/CPD
> !
> ! *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS ***
> !
> DO I=1,NL+1
> HP(I)=H(I)
> NENT(I)=0
> WATER(I)=0.0
> EVAP(I)=0.0
> WT(I)=OMTSNOW
> LVCP(I)=LV(I)/CPN(I)
> DO J=1,NL+1
> QENT(I,J)=QCONV(J)
> ELIJ(I,J)=0.0
> SIJ(I,J)=0.0
> END DO
> END DO
> QP(1)=QCONV(1)
> DO I=2,NL+1
> QP(I)=QCONV(I-1)
> END DO
> !
> ! *** FIND THE FIRST MODEL LEVEL (INB1) ABOVE THE PARCEL'S ***
> ! *** HIGHEST LEVEL OF NEUTRAL BUOYANCY ***
> ! *** AND THE HIGHEST LEVEL OF POSITIVE CAPE (INB) ***
> !
> CAPE=0.0
> CAPEM=0.0
> INB=ICB+1
> INB1=INB
> BYP=0.0
> DO I=ICB+1,NL-1
> BY=(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))/PCONV_HPA(I)
> CAPE=CAPE+BY
> IF(BY.GE.0.0)INB1=I+1
> IF(CAPE.GT.0.0)THEN
> INB=I+1
> BYP=(TVP(I+1)-TV(I+1))*(PHCONV_HPA(I+1)-PHCONV_HPA(I+2))/ &
> PCONV_HPA(I+1)
> CAPEM=CAPE
> END IF
> END DO
> INB=MAX(INB,INB1)
> CAPE=CAPEM+BYP
> DEFRAC=CAPEM-CAPE
> DEFRAC=MAX(DEFRAC,0.001)
> FRAC=-CAPE/DEFRAC
> FRAC=MIN(FRAC,1.0)
> FRAC=MAX(FRAC,0.0)
> !
> ! *** CALCULATE LIQUID WATER STATIC ENERGY OF LIFTED PARCEL ***
> !
> DO I=ICB,INB
> HP(I)=H(NK)+(LV(I)+(CPD-CPV)*TCONV(I))*EP(I)*CLW(I)
> END DO
> !
> ! *** CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), ***
> ! *** AT EACH MODEL LEVEL ***
> !
> DBOSUM=0.0
> !
> ! *** INTERPOLATE DIFFERENCE BETWEEN LIFTED PARCEL AND ***
> ! *** ENVIRONMENTAL TEMPERATURES TO LIFTED CONDENSATION LEVEL ***
> !
> TVPPLCL=TVP(ICB-1)-RD*TVP(ICB-1)*(PCONV_HPA(ICB-1)-PLCL)/ &
> (CPN(ICB-1)*PCONV_HPA(ICB-1))
> TVAPLCL=TV(ICB)+(TVP(ICB)-TVP(ICB+1))*(PLCL-PCONV_HPA(ICB))/ &
> (PCONV_HPA(ICB)-PCONV_HPA(ICB+1))
> DTPBL=0.0
> DO I=NK,ICB-1
> DTPBL=DTPBL+(TVP(I)-TV(I))*(PHCONV_HPA(I)-PHCONV_HPA(I+1))
> END DO
> DTPBL=DTPBL/(PHCONV_HPA(NK)-PHCONV_HPA(ICB))
> DTMIN=TVPPLCL-TVAPLCL+DTMAX+DTPBL
> DTMA=DTMIN
> !
> ! *** ADJUST CLOUD BASE MASS FLUX ***
> !
> CBMFOLD=CBMF
> ! *** C. Forster: adjustment of CBMF is not allowed to depend on FLEXPART timestep
> DELT0=DELT/3.
> DAMPS=DAMP*DELT/DELT0
> CBMF=(1.-DAMPS)*CBMF+0.1*ALPHA*DTMA
> CBMF=MAX(CBMF,0.0)
> !
> ! *** If cloud base mass flux is zero, skip rest of calculation ***
> !
> IF(CBMF.EQ.0.0.AND.CBMFOLD.EQ.0.0)THEN
> RETURN
> END IF
>
> !
> ! *** CALCULATE RATES OF MIXING, M(I) ***
> !
> M(ICB)=0.0
> DO I=ICB+1,INB
> K=MIN(I,INB1)
> DBO=ABS(TV(K)-TVP(K))+ &
> ENTP*0.02*(PHCONV_HPA(K)-PHCONV_HPA(K+1))
> DBOSUM=DBOSUM+DBO
> M(I)=CBMF*DBO
> END DO
> DO I=ICB+1,INB
> M(I)=M(I)/DBOSUM
> END DO
> !
> ! *** CALCULATE ENTRAINED AIR MASS FLUX (MENT), TOTAL WATER MIXING ***
> ! *** RATIO (QENT), TOTAL CONDENSED WATER (ELIJ), AND MIXING ***
> ! *** FRACTION (SIJ) ***
> !
> DO I=ICB+1,INB
> QTI=QCONV(NK)-EP(I)*CLW(I)
> DO J=ICB,INB
> BF2=1.+LV(J)*LV(J)*QSCONV(J)/(RV*TCONV(J)*TCONV(J)*CPD)
> ANUM=H(J)-HP(I)+(CPV-CPD)*TCONV(J)*(QTI-QCONV(J))
> DENOM=H(I)-HP(I)+(CPD-CPV)*(QCONV(I)-QTI)*TCONV(J)
> DEI=DENOM
> IF(ABS(DEI).LT.0.01)DEI=0.01
> SIJ(I,J)=ANUM/DEI
> SIJ(I,I)=1.0
> ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
> ALTEM=ALTEM/BF2
> CWAT=CLW(J)*(1.-EP(J))
> STEMP=SIJ(I,J)
> IF((STEMP.LT.0.0.OR.STEMP.GT.1.0.OR. &
> ALTEM.GT.CWAT).AND.J.GT.I)THEN
> ANUM=ANUM-LV(J)*(QTI-QSCONV(J)-CWAT*BF2)
> DENOM=DENOM+LV(J)*(QCONV(I)-QTI)
> IF(ABS(DENOM).LT.0.01)DENOM=0.01
> SIJ(I,J)=ANUM/DENOM
> ALTEM=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J)
> ALTEM=ALTEM-(BF2-1.)*CWAT
> END IF
> IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
> QENT(I,J)=SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI
> ELIJ(I,J)=ALTEM
> ELIJ(I,J)=MAX(0.0,ELIJ(I,J))
> MENT(I,J)=M(I)/(1.-SIJ(I,J))
> NENT(I)=NENT(I)+1
> END IF
> SIJ(I,J)=MAX(0.0,SIJ(I,J))
> SIJ(I,J)=MIN(1.0,SIJ(I,J))
> END DO
> !
> ! *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS ***
> ! *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES ***
> !
> IF(NENT(I).EQ.0)THEN
> MENT(I,I)=M(I)
> QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
> ELIJ(I,I)=CLW(I)
> SIJ(I,I)=1.0
> END IF
> END DO
> SIJ(INB,INB)=1.0
> !
> ! *** NORMALIZE ENTRAINED AIR MASS FLUXES TO REPRESENT EQUAL ***
> ! *** PROBABILITIES OF MIXING ***
> !
> DO I=ICB+1,INB
> IF(NENT(I).NE.0)THEN
> QP1=QCONV(NK)-EP(I)*CLW(I)
> ANUM=H(I)-HP(I)-LV(I)*(QP1-QSCONV(I))
> DENOM=H(I)-HP(I)+LV(I)*(QCONV(I)-QP1)
> IF(ABS(DENOM).LT.0.01)DENOM=0.01
> SCRIT=ANUM/DENOM
> ALT=QP1-QSCONV(I)+SCRIT*(QCONV(I)-QP1)
> IF(ALT.LT.0.0)SCRIT=1.0
> SCRIT=MAX(SCRIT,0.0)
> ASIJ=0.0
> SMIN=1.0
> DO J=ICB,INB
> IF(SIJ(I,J).GT.0.0.AND.SIJ(I,J).LT.0.9)THEN
> IF(J.GT.I)THEN
> SMID=MIN(SIJ(I,J),SCRIT)
> SJMAX=SMID
> SJMIN=SMID
> IF(SMID.LT.SMIN.AND.SIJ(I,J+1).LT.SMID)THEN
> SMIN=SMID
> SJMAX=MIN(SIJ(I,J+1),SIJ(I,J),SCRIT)
> SJMIN=MAX(SIJ(I,J-1),SIJ(I,J))
> SJMIN=MIN(SJMIN,SCRIT)
> END IF
> ELSE
> SJMAX=MAX(SIJ(I,J+1),SCRIT)
> SMID=MAX(SIJ(I,J),SCRIT)
> SJMIN=0.0
> IF(J.GT.1)SJMIN=SIJ(I,J-1)
> SJMIN=MAX(SJMIN,SCRIT)
> END IF
> DELP=ABS(SJMAX-SMID)
> DELM=ABS(SJMIN-SMID)
> ASIJ=ASIJ+(DELP+DELM)*(PHCONV_HPA(J)-PHCONV_HPA(J+1))
> MENT(I,J)=MENT(I,J)*(DELP+DELM)* &
> (PHCONV_HPA(J)-PHCONV_HPA(J+1))
> END IF
> END DO
> ASIJ=MAX(1.0E-21,ASIJ)
> ASIJ=1.0/ASIJ
> DO J=ICB,INB
> MENT(I,J)=MENT(I,J)*ASIJ
> END DO
> BSUM=0.0
> DO J=ICB,INB
> BSUM=BSUM+MENT(I,J)
> END DO
> IF(BSUM.LT.1.0E-18)THEN
> NENT(I)=0
> MENT(I,I)=M(I)
> QENT(I,I)=QCONV(NK)-EP(I)*CLW(I)
> ELIJ(I,I)=CLW(I)
> SIJ(I,I)=1.0
> END IF
> END IF
> END DO
> !
> ! *** CHECK WHETHER EP(INB)=0, IF SO, SKIP PRECIPITATING ***
> ! *** DOWNDRAFT CALCULATION ***
> !
> IF(EP(INB).LT.0.0001)GOTO 405
> !
> ! *** INTEGRATE LIQUID WATER EQUATION TO FIND CONDENSED WATER ***
> ! *** AND CONDENSED WATER FLUX ***
> !
> JTT=2
> !
> ! *** BEGIN DOWNDRAFT LOOP ***
> !
> DO I=INB,1,-1
> !
> ! *** CALCULATE DETRAINED PRECIPITATION ***
> !
> WDTRAIN=G*EP(I)*M(I)*CLW(I)
> IF(I.GT.1)THEN
> DO J=1,I-1
> AWAT=ELIJ(J,I)-(1.-EP(I))*CLW(I)
> AWAT=MAX(0.0,AWAT)
> WDTRAIN=WDTRAIN+G*AWAT*MENT(J,I)
> END DO
> END IF
> !
> ! *** FIND RAIN WATER AND EVAPORATION USING PROVISIONAL ***
> ! *** ESTIMATES OF QP(I)AND QP(I-1) ***
> !
> !
> ! *** Value of terminal velocity and coefficient of evaporation for snow ***
> !
> COEFF=COEFFS
> WT(I)=OMTSNOW
> !
> ! *** Value of terminal velocity and coefficient of evaporation for rain ***
> !
> IF(TCONV(I).GT.273.0)THEN
> COEFF=COEFFR
> WT(I)=OMTRAIN
> END IF
> QSM=0.5*(QCONV(I)+QP(I+1))
> AFAC=COEFF*PHCONV_HPA(I)*(QSCONV(I)-QSM)/ &
> (1.0E4+2.0E3*PHCONV_HPA(I)*QSCONV(I))
> AFAC=MAX(AFAC,0.0)
> SIGT=SIGP(I)
> SIGT=MAX(0.0,SIGT)
> SIGT=MIN(1.0,SIGT)
> B6=100.*(PHCONV_HPA(I)-PHCONV_HPA(I+1))*SIGT*AFAC/WT(I)
> C6=(WATER(I+1)*WT(I+1)+WDTRAIN/SIGD)/WT(I)
> REVAP=0.5*(-B6+SQRT(B6*B6+4.*C6))
> EVAP(I)=SIGT*AFAC*REVAP
> WATER(I)=REVAP*REVAP
> !
> ! *** CALCULATE PRECIPITATING DOWNDRAFT MASS FLUX UNDER ***
> ! *** HYDROSTATIC APPROXIMATION ***
> !
> IF(I.EQ.1)GOTO 360
> DHDP=(H(I)-H(I-1))/(PCONV_HPA(I-1)-PCONV_HPA(I))
> DHDP=MAX(DHDP,10.0)
> MP(I)=100.*GINV*LV(I)*SIGD*EVAP(I)/DHDP
> MP(I)=MAX(MP(I),0.0)
> !
> ! *** ADD SMALL AMOUNT OF INERTIA TO DOWNDRAFT ***
> !
> FAC=20.0/(PHCONV_HPA(I-1)-PHCONV_HPA(I))
> MP(I)=(FAC*MP(I+1)+MP(I))/(1.+FAC)
> !
> ! *** FORCE MP TO DECREASE LINEARLY TO ZERO ***
> ! *** BETWEEN ABOUT 950 MB AND THE SURFACE ***
> !
> IF(PCONV_HPA(I).GT.(0.949*PCONV_HPA(1)))THEN
> JTT=MAX(JTT,I)
> MP(I)=MP(JTT)*(PCONV_HPA(1)-PCONV_HPA(I))/(PCONV_HPA(1)- &
> PCONV_HPA(JTT))
> END IF
> 360 CONTINUE
> !
> ! *** FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT ***
> !
> IF(I.EQ.INB)GOTO 400
> IF(I.EQ.1)THEN
> QSTM=QSCONV(1)
> ELSE
> QSTM=QSCONV(I-1)
> END IF
> IF(MP(I).GT.MP(I+1))THEN
> RAT=MP(I+1)/MP(I)
> QP(I)=QP(I+1)*RAT+QCONV(I)*(1.0-RAT)+100.*GINV* &
> SIGD*(PHCONV_HPA(I)-PHCONV_HPA(I+1))*(EVAP(I)/MP(I))
> ELSE
> IF(MP(I+1).GT.0.0)THEN
> QP(I)=(GZ(I+1)-GZ(I)+QP(I+1)*(LV(I+1)+TCONV(I+1)*(CL-CPD))+ &
> CPD*(TCONV(I+1)-TCONV(I)))/(LV(I)+TCONV(I)*(CL-CPD))
> END IF
> END IF
> QP(I)=MIN(QP(I),QSTM)
> QP(I)=MAX(QP(I),0.0)
> 400 CONTINUE
> END DO
> !
> ! *** CALCULATE SURFACE PRECIPITATION IN MM/DAY ***
> !
> PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G)
> !
> 405 CONTINUE
> !
> ! *** CALCULATE DOWNDRAFT VELOCITY SCALE AND SURFACE TEMPERATURE AND ***
> ! *** WATER VAPOR FLUCTUATIONS ***
> !
> WD=BETA*ABS(MP(ICB))*0.01*RD*TCONV(ICB)/(SIGD*PCONV_HPA(ICB))
> QPRIME=0.5*(QP(1)-QCONV(1))
> TPRIME=LV0*QPRIME/CPD
> !
> ! *** CALCULATE TENDENCIES OF LOWEST LEVEL POTENTIAL TEMPERATURE ***
> ! *** AND MIXING RATIO ***
> !
> DPINV=0.01/(PHCONV_HPA(1)-PHCONV_HPA(2))
> AM=0.0
> IF(NK.EQ.1)THEN
> DO K=2,INB
> AM=AM+M(K)
> END DO
> END IF
> ! save saturated upward mass flux for first level
> FUP(1)=AM
> IF((2.*G*DPINV*AM).GE.DELTI)IFLAG=4
> FT(1)=FT(1)+G*DPINV*AM*(TCONV(2)-TCONV(1)+(GZ(2)-GZ(1))/CPN(1))
> FT(1)=FT(1)-LVCP(1)*SIGD*EVAP(1)
> FT(1)=FT(1)+SIGD*WT(2)*(CL-CPD)*WATER(2)*(TCONV(2)- &
> TCONV(1))*DPINV/CPN(1)
> FQ(1)=FQ(1)+G*MP(2)*(QP(2)-QCONV(1))* &
> DPINV+SIGD*EVAP(1)
> FQ(1)=FQ(1)+G*AM*(QCONV(2)-QCONV(1))*DPINV
> DO J=2,INB
> FQ(1)=FQ(1)+G*DPINV*MENT(J,1)*(QENT(J,1)-QCONV(1))
> END DO
> !
> ! *** CALCULATE TENDENCIES OF POTENTIAL TEMPERATURE AND MIXING RATIO ***
> ! *** AT LEVELS ABOVE THE LOWEST LEVEL ***
> !
> ! *** FIRST FIND THE NET SATURATED UPDRAFT AND DOWNDRAFT MASS FLUXES ***
> ! *** THROUGH EACH LEVEL ***
> !
> DO I=2,INB
> DPINV=0.01/(PHCONV_HPA(I)-PHCONV_HPA(I+1))
> CPINV=1.0/CPN(I)
> AMP1=0.0
> AD=0.0
> IF(I.GE.NK)THEN
> DO K=I+1,INB+1
> AMP1=AMP1+M(K)
> END DO
> END IF
> DO K=1,I
> DO J=I+1,INB+1
> AMP1=AMP1+MENT(K,J)
> END DO
> END DO
> ! save saturated upward mass flux
> FUP(I)=AMP1
> IF((2.*G*DPINV*AMP1).GE.DELTI)IFLAG=4
> DO K=1,I-1
> DO J=I,INB
> AD=AD+MENT(J,K)
> END DO
> END DO
> ! save saturated downward mass flux
> FDOWN(I)=AD
> FT(I)=FT(I)+G*DPINV*(AMP1*(TCONV(I+1)-TCONV(I)+(GZ(I+1)-GZ(I))* &
> CPINV)-AD*(TCONV(I)-TCONV(I-1)+(GZ(I)-GZ(I-1))*CPINV)) &
> -SIGD*LVCP(I)*EVAP(I)
> FT(I)=FT(I)+G*DPINV*MENT(I,I)*(HP(I)-H(I)+ &
> TCONV(I)*(CPV-CPD)*(QCONV(I)-QENT(I,I)))*CPINV
> FT(I)=FT(I)+SIGD*WT(I+1)*(CL-CPD)*WATER(I+1)* &
> (TCONV(I+1)-TCONV(I))*DPINV*CPINV
> FQ(I)=FQ(I)+G*DPINV*(AMP1*(QCONV(I+1)-QCONV(I))- &
> AD*(QCONV(I)-QCONV(I-1)))
> DO K=1,I-1
> AWAT=ELIJ(K,I)-(1.-EP(I))*CLW(I)
> AWAT=MAX(AWAT,0.0)
> FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-AWAT-QCONV(I))
> END DO
> DO K=I,INB
> FQ(I)=FQ(I)+G*DPINV*MENT(K,I)*(QENT(K,I)-QCONV(I))
> END DO
> FQ(I)=FQ(I)+SIGD*EVAP(I)+G*(MP(I+1)* &
> (QP(I+1)-QCONV(I))-MP(I)*(QP(I)-QCONV(I-1)))*DPINV
> END DO
> !
> ! *** Adjust tendencies at top of convection layer to reflect ***
> ! *** actual position of the level zero CAPE ***
> !
> FQOLD=FQ(INB)
> FQ(INB)=FQ(INB)*(1.-FRAC)
> FQ(INB-1)=FQ(INB-1)+FRAC*FQOLD*((PHCONV_HPA(INB)- &
> PHCONV_HPA(INB+1))/ &
> (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*LV(INB)/LV(INB-1)
> FTOLD=FT(INB)
> FT(INB)=FT(INB)*(1.-FRAC)
> FT(INB-1)=FT(INB-1)+FRAC*FTOLD*((PHCONV_HPA(INB)- &
> PHCONV_HPA(INB+1))/ &
> (PHCONV_HPA(INB-1)-PHCONV_HPA(INB)))*CPN(INB)/CPN(INB-1)
> !
> ! *** Very slightly adjust tendencies to force exact ***
> ! *** enthalpy, momentum and tracer conservation ***
> !
> ENTS=0.0
> DO I=1,INB
> ENTS=ENTS+(CPN(I)*FT(I)+LV(I)*FQ(I))* &
> (PHCONV_HPA(I)-PHCONV_HPA(I+1))
> END DO
> ENTS=ENTS/(PHCONV_HPA(1)-PHCONV_HPA(INB+1))
> DO I=1,INB
> FT(I)=FT(I)-ENTS/CPN(I)
> END DO
>
> ! ************************************************
> ! **** DETERMINE MASS DISPLACEMENT MATRIX
> ! ***** AND COMPENSATING SUBSIDENCE
> ! ************************************************
>
> ! mass displacement matrix due to saturated up-and downdrafts
> ! inside the cloud and determine compensating subsidence
> ! FUP(I) (saturated updrafts), FDOWN(I) (saturated downdrafts) are assumed to be
> ! balanced by compensating subsidence (SUB(I))
> ! FDOWN(I) and SUB(I) defined positive downwards
>
> ! NCONVTOP IS THE TOP LEVEL AT WHICH CONVECTIVE MASS FLUXES ARE DIAGNOSED
> ! EPSILON IS A SMALL NUMBER
>
> SUB(1)=0.
> NCONVTOP=1
> do i=1,INB+1
> do j=1,INB+1
> if (j.eq.NK) then
> FMASS(j,i)=FMASS(j,i)+M(i)
> endif
> FMASS(j,i)=FMASS(j,i)+MENT(j,i)
> IF (FMASS(J,I).GT.EPSILON) NCONVTOP=MAX(NCONVTOP,I,J)
> end do
> if (i.gt.1) then
> SUB(i)=FUP(i-1)-FDOWN(i)
> endif
> end do
> NCONVTOP=NCONVTOP+1
>
> RETURN
> !
> END SUBROUTINE CONVECT
> !
> ! ---------------------------------------------------------------------------
> !
> SUBROUTINE TLIFT(GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK)
> !
> !-cv
> use par_mod
> use conv_mod
>
> implicit none
> !-cv
> !====>Begin Module TLIFT File convect.f Undeclared variables
> !
> !Argument variables
> !
> integer :: icb, kk, nd, nk, nl
> !
> !Local variables
> !
> integer :: i, j, nsb, nst
> !
> real :: ah0, ahg, alv, cpinv, cpp, denom
> real :: es, qg, rg, s, tc, tg
> !
> !====>End Module TLIFT File convect.f
>
> REAL :: GZ(ND),TPK(ND),CLW(ND)
> REAL :: TVP(ND)
> !
> ! *** ASSIGN VALUES OF THERMODYNAMIC CONSTANTS ***
> !
> REAL,PARAMETER :: CPD=1005.7
> REAL,PARAMETER :: CPV=1870.0
> REAL,PARAMETER :: CL=2500.0
> REAL,PARAMETER :: RV=461.5
> REAL,PARAMETER :: RD=287.04
> REAL,PARAMETER :: LV0=2.501E6
> !
> REAL,PARAMETER :: CPVMCL=CL-CPV
> REAL,PARAMETER :: EPS0=RD/RV
> REAL,PARAMETER :: EPSI=1./EPS0
> !
> ! *** CALCULATE CERTAIN PARCEL QUANTITIES, INCLUDING STATIC ENERGY ***
> !
> AH0=(CPD*(1.-QCONV(NK))+CL*QCONV(NK))*TCONV(NK)+QCONV(NK)* &
> (LV0-CPVMCL*( &
> TCONV(NK)-273.15))+GZ(NK)
> CPP=CPD*(1.-QCONV(NK))+QCONV(NK)*CPV
> CPINV=1./CPP
> !
> IF(KK.EQ.1)THEN
> !
> ! *** CALCULATE LIFTED PARCEL QUANTITIES BELOW CLOUD BASE ***
> !
> DO I=1,ICB-1
> CLW(I)=0.0
> END DO
> DO I=NK,ICB-1
> TPK(I)=TCONV(NK)-(GZ(I)-GZ(NK))*CPINV
> TVP(I)=TPK(I)*(1.+QCONV(NK)*EPSI)
> END DO
> END IF
> !
> ! *** FIND LIFTED PARCEL QUANTITIES ABOVE CLOUD BASE ***
> !
> NST=ICB
> NSB=ICB
> IF(KK.EQ.2)THEN
> NST=NL
> NSB=ICB+1
> END IF
> DO I=NSB,NST
> TG=TCONV(I)
> QG=QSCONV(I)
> ALV=LV0-CPVMCL*(TCONV(I)-273.15)
> DO J=1,2
> S=CPD+ALV*ALV*QG/(RV*TCONV(I)*TCONV(I))
> S=1./S
> AHG=CPD*TG+(CL-CPD)*QCONV(NK)*TCONV(I)+ALV*QG+GZ(I)
> TG=TG+S*(AH0-AHG)
> TG=MAX(TG,35.0)
> TC=TG-273.15
> DENOM=243.5+TC
> IF(TC.GE.0.0)THEN
> ES=6.112*EXP(17.67*TC/DENOM)
> ELSE
> ES=EXP(23.33086-6111.72784/TG+0.15215*LOG(TG))
> END IF
> QG=EPS0*ES/(PCONV_HPA(I)-ES*(1.-EPS0))
> END DO
> ALV=LV0-CPVMCL*(TCONV(I)-273.15)
> TPK(I)=(AH0-(CL-CPD)*QCONV(NK)*TCONV(I)-GZ(I)-ALV*QG)/CPD
> CLW(I)=QCONV(NK)-QG
> CLW(I)=MAX(0.0,CLW(I))
> RG=QG/(1.-QCONV(NK))
> TVP(I)=TPK(I)*(1.+RG*EPSI)
> END DO
> RETURN
> END SUBROUTINE TLIFT
convmix.f90
----------------------------------------------
1,299c1,315
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine convmix(itime)
< ! i
< !**************************************************************
< !handles all the calculations related to convective mixing
< !Petra Seibert, Bernd C. Krueger, Feb 2001
< !nested grids included, Bernd C. Krueger, May 2001
< !
< !Changes by Caroline Forster, April 2004 - February 2005:
< ! convmix called every lsynctime seconds
< !CHANGES by A. Stohl:
< ! various run-time optimizations - February 2005
< !**************************************************************
<
< use flux_mod
< use par_mod
< use com_mod
< use conv_mod
<
< implicit none
<
< integer :: igr,igrold, ipart, itime, ix, j, inest
< integer :: ipconv
< integer :: jy, kpart, ktop, ngrid,kz
< integer :: igrid(maxpart), ipoint(maxpart), igridn(maxpart,maxnests)
< ! itime [s] current time
< ! igrid(maxpart) horizontal grid position of each particle
< ! igridn(maxpart,maxnests) dto. for nested grids
< ! ipoint(maxpart) pointer to access particles according to grid position
<
< logical :: lconv
< real :: x, y, xtn,ytn, ztold, delt
< real :: dt1,dt2,dtt
< integer :: mind1,mind2
< ! dt1,dt2,dtt,mind1,mind2 variables used for time interpolation
< integer :: itage,nage
< real,parameter :: eps=nxmax/3.e5
<
<
< !monitoring variables
< !real sumconv,sumall
<
<
< ! Calculate auxiliary variables for time interpolation
< !*****************************************************
<
< dt1=real(itime-memtime(1))
< dt2=real(memtime(2)-itime)
< dtt=1./(dt1+dt2)
< mind1=memind(1)
< mind2=memind(2)
< delt=real(abs(lsynctime))
<
<
< lconv = .false.
<
< ! if no particles are present return after initialization
< !********************************************************
<
< if (numpart.le.0) return
<
< ! Assign igrid and igridn, which are pseudo grid numbers indicating particles
< ! that are outside the part of the grid under consideration
< ! (e.g. particles near the poles or particles in other nests).
< ! Do this for all nests but use only the innermost nest; for all others
< ! igrid shall be -1
< ! Also, initialize index vector ipoint
< !************************************************************************
<
< do ipart=1,numpart
< igrid(ipart)=-1
< do j=numbnests,1,-1
< igridn(ipart,j)=-1
< end do
< ipoint(ipart)=ipart
< ! do not consider particles that are (yet) not part of simulation
< if (itra1(ipart).ne.itime) goto 20
< x = xtra1(ipart)
< y = ytra1(ipart)
<
< ! Determine which nesting level to be used
< !**********************************************************
<
< ngrid=0
< do j=numbnests,1,-1
< if ( x.gt.xln(j)+eps .and. x.lt.xrn(j)-eps .and. &
< y.gt.yln(j)+eps .and. y.lt.yrn(j)-eps ) then
< ngrid=j
< goto 23
< endif
< end do
< 23 continue
<
< ! Determine nested grid coordinates
< !**********************************
<
< if (ngrid.gt.0) then
< ! nested grids
< xtn=(x-xln(ngrid))*xresoln(ngrid)
< ytn=(y-yln(ngrid))*yresoln(ngrid)
< ix=nint(xtn)
< jy=nint(ytn)
< igridn(ipart,ngrid) = 1 + jy*nxn(ngrid) + ix
< else if(ngrid.eq.0) then
< ! mother grid
< ix=nint(x)
< jy=nint(y)
< igrid(ipart) = 1 + jy*nx + ix
< endif
<
< 20 continue
< end do
<
< !sumall = 0.
< !sumconv = 0.
<
< !*****************************************************************************
< ! 1. Now, do everything for the mother domain and, later, for all of the nested domains
< ! While all particles have to be considered for redistribution, the Emanuel convection
< ! scheme only needs to be called once for every grid column where particles are present.
< ! Therefore, particles are sorted according to their grid position. Whenever a new grid
< ! cell is encountered by looping through the sorted particles, the convection scheme is called.
< !*****************************************************************************
<
< ! sort particles according to horizontal position and calculate index vector IPOINT
<
< call sort2(numpart,igrid,ipoint)
<
< ! Now visit all grid columns where particles are present
< ! by going through the sorted particles
<
< igrold = -1
< do kpart=1,numpart
< igr = igrid(kpart)
< if (igr .eq. -1) goto 50
< ipart = ipoint(kpart)
< ! sumall = sumall + 1
< if (igr .ne. igrold) then
< ! we are in a new grid column
< jy = (igr-1)/nx
< ix = igr - jy*nx - 1
<
< ! Interpolate all meteorological data needed for the convection scheme
< psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt
< tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt
< td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt
< !!$ do kz=1,nconvlev+1 !old
< do kz=1,nuvz-1 !bugfix
< tconv(kz)=(tth(ix,jy,kz+1,mind1)*dt2+ &
< tth(ix,jy,kz+1,mind2)*dt1)*dtt
< qconv(kz)=(qvh(ix,jy,kz+1,mind1)*dt2+ &
< qvh(ix,jy,kz+1,mind2)*dt1)*dtt
< end do
<
< ! Calculate translocation matrix
< call calcmatrix(lconv,delt,cbaseflux(ix,jy))
< igrold = igr
< ktop = 0
< endif
<
< ! treat particle only if column has convection
< if (lconv .eqv. .true.) then
< ! assign new vertical position to particle
<
< ztold=ztra1(ipart)
< call redist(ipart,ktop,ipconv)
< ! if (ipconv.le.0) sumconv = sumconv+1
<
< ! Calculate the gross fluxes across layer interfaces
< !***************************************************
<
< if (iflux.eq.1) then
< itage=abs(itra1(ipart)-itramem(ipart))
< do nage=1,nageclass
< if (itage.lt.lage(nage)) goto 37
< end do
< 37 continue
<
< if (nage.le.nageclass) &
< call calcfluxes(nage,ipart,real(xtra1(ipart)), &
< real(ytra1(ipart)),ztold)
< endif
<
< endif !(lconv .eqv. .true)
< 50 continue
< end do
<
<
< !*****************************************************************************
< ! 2. Nested domains
< !*****************************************************************************
<
< ! sort particles according to horizontal position and calculate index vector IPOINT
<
< do inest=1,numbnests
< do ipart=1,numpart
< ipoint(ipart)=ipart
< igrid(ipart) = igridn(ipart,inest)
< enddo
< call sort2(numpart,igrid,ipoint)
<
< ! Now visit all grid columns where particles are present
< ! by going through the sorted particles
<
< igrold = -1
< do kpart=1,numpart
< igr = igrid(kpart)
< if (igr .eq. -1) goto 60
< ipart = ipoint(kpart)
< ! sumall = sumall + 1
< if (igr .ne. igrold) then
< ! we are in a new grid column
< jy = (igr-1)/nxn(inest)
< ix = igr - jy*nxn(inest) - 1
<
< ! Interpolate all meteorological data needed for the convection scheme
< psconv=(psn(ix,jy,1,mind1,inest)*dt2+ &
< psn(ix,jy,1,mind2,inest)*dt1)*dtt
< tt2conv=(tt2n(ix,jy,1,mind1,inest)*dt2+ &
< tt2n(ix,jy,1,mind2,inest)*dt1)*dtt
< td2conv=(td2n(ix,jy,1,mind1,inest)*dt2+ &
< td2n(ix,jy,1,mind2,inest)*dt1)*dtt
< !!$ do kz=1,nconvlev+1 !old
< do kz=1,nuvz-1 !bugfix
< tconv(kz)=(tthn(ix,jy,kz+1,mind1,inest)*dt2+ &
< tthn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
< qconv(kz)=(qvhn(ix,jy,kz+1,mind1,inest)*dt2+ &
< qvhn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
< end do
<
< ! calculate translocation matrix
< !*******************************
< call calcmatrix(lconv,delt,cbasefluxn(ix,jy,inest))
< igrold = igr
< ktop = 0
< endif
<
< ! treat particle only if column has convection
< if (lconv .eqv. .true.) then
< ! assign new vertical position to particle
< ztold=ztra1(ipart)
< call redist(ipart,ktop,ipconv)
< ! if (ipconv.le.0) sumconv = sumconv+1
<
< ! Calculate the gross fluxes across layer interfaces
< !***************************************************
<
< if (iflux.eq.1) then
< itage=abs(itra1(ipart)-itramem(ipart))
< do nage=1,nageclass
< if (itage.lt.lage(nage)) goto 47
< end do
< 47 continue
<
< if (nage.le.nageclass) &
< call calcfluxes(nage,ipart,real(xtra1(ipart)), &
< real(ytra1(ipart)),ztold)
< endif
<
< endif !(lconv .eqv. .true.)
<
<
< 60 continue
< end do
< end do
< !--------------------------------------------------------------------------
< !write(*,*)'############################################'
< !write(*,*)'TIME=',
< ! & itime
< !write(*,*)'fraction of particles under convection',
< ! & sumconv/(sumall+0.001)
< !write(*,*)'total number of particles',
< ! & sumall
< !write(*,*)'number of particles under convection',
< ! & sumconv
< !write(*,*)'############################################'
<
< return
< end subroutine convmix
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine convmix(itime)
> ! i
> !**************************************************************
> !handles all the calculations related to convective mixing
> !Petra Seibert, Bernd C. Krueger, Feb 2001
> !nested grids included, Bernd C. Krueger, May 2001
> !
> !Changes by Caroline Forster, April 2004 - February 2005:
> ! convmix called every lsynctime seconds
> !CHANGES by A. Stohl:
> ! various run-time optimizations - February 2005
> !**************************************************************
>
> use flux_mod
> use par_mod
> use com_mod
> use conv_mod
>
> implicit none
>
> integer :: igr,igrold, ipart, itime, ix, j, inest
> integer :: ipconv
> integer :: jy, kpart, ktop, ngrid,kz
> integer :: igrid(maxpart), ipoint(maxpart), igridn(maxpart,maxnests)
> ! itime [s] current time
> ! igrid(maxpart) horizontal grid position of each particle
> ! igridn(maxpart,maxnests) dto. for nested grids
> ! ipoint(maxpart) pointer to access particles according to grid position
>
> logical :: lconv
> real :: x, y, xtn,ytn, ztold, delt
> real :: dt1,dt2,dtt
> integer :: mind1,mind2
> ! dt1,dt2,dtt,mind1,mind2 variables used for time interpolation
> integer :: itage,nage
> real,parameter :: eps=nxmax/3.e5
>
> !! for test output of cloud base mass flux
> ! character(len=256) :: fn
> ! real(kind=dp) :: jul
> ! integer :: jjjjmmdd, ihmmss
> !
> ! jul=bdate+real(itime,kind=dp)/86400._dp
> ! call caldate(jul,jjjjmmdd,ihmmss)
>
> !monitoring variables
> !real sumconv,sumall
>
>
> ! Calculate auxiliary variables for time interpolation
> !*****************************************************
>
> dt1=real(itime-memtime(1))
> dt2=real(memtime(2)-itime)
> dtt=1./(dt1+dt2)
> mind1=memind(1)
> mind2=memind(2)
> delt=real(abs(lsynctime))
>
>
> lconv = .false.
>
> ! if no particles are present return after initialization
> !********************************************************
>
> if (numpart.le.0) return
>
> ! Assign igrid and igridn, which are pseudo grid numbers indicating particles
> ! that are outside the part of the grid under consideration
> ! (e.g. particles near the poles or particles in other nests).
> ! Do this for all nests but use only the innermost nest; for all others
> ! igrid shall be -1
> ! Also, initialize index vector ipoint
> !************************************************************************
>
> do ipart=1,numpart
> igrid(ipart)=-1
> do j=numbnests,1,-1
> igridn(ipart,j)=-1
> end do
> ipoint(ipart)=ipart
> ! do not consider particles that are (yet) not part of simulation
> if (itra1(ipart).ne.itime) goto 20
> x = xtra1(ipart)
> y = ytra1(ipart)
>
> ! Determine which nesting level to be used
> !**********************************************************
>
> ngrid=0
> do j=numbnests,1,-1
> if ( x.gt.xln(j)+eps .and. x.lt.xrn(j)-eps .and. &
> y.gt.yln(j)+eps .and. y.lt.yrn(j)-eps ) then
> ngrid=j
> goto 23
> endif
> end do
> 23 continue
>
> ! Determine nested grid coordinates
> !**********************************
>
> if (ngrid.gt.0) then
> ! nested grids
> xtn=(x-xln(ngrid))*xresoln(ngrid)
> ytn=(y-yln(ngrid))*yresoln(ngrid)
> ix=nint(xtn)
> jy=nint(ytn)
> igridn(ipart,ngrid) = 1 + jy*nxn(ngrid) + ix
> else if(ngrid.eq.0) then
> ! mother grid
> ix=nint(x)
> jy=nint(y)
> igrid(ipart) = 1 + jy*nx + ix
> endif
>
> 20 continue
> end do
>
> !sumall = 0.
> !sumconv = 0.
>
> !*****************************************************************************
> ! 1. Now, do everything for the mother domain and, later, for all of the nested domains
> ! While all particles have to be considered for redistribution, the Emanuel convection
> ! scheme only needs to be called once for every grid column where particles are present.
> ! Therefore, particles are sorted according to their grid position. Whenever a new grid
> ! cell is encountered by looping through the sorted particles, the convection scheme is called.
> !*****************************************************************************
>
> ! sort particles according to horizontal position and calculate index vector IPOINT
>
> call sort2(numpart,igrid,ipoint)
>
> ! Now visit all grid columns where particles are present
> ! by going through the sorted particles
>
> igrold = -1
> do kpart=1,numpart
> igr = igrid(kpart)
> if (igr .eq. -1) goto 50
> ipart = ipoint(kpart)
> ! sumall = sumall + 1
> if (igr .ne. igrold) then
> ! we are in a new grid column
> jy = (igr-1)/nx
> ix = igr - jy*nx - 1
>
> ! Interpolate all meteorological data needed for the convection scheme
> psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt
> tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt
> td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt
> !!$ do kz=1,nconvlev+1 !old
> do kz=1,nuvz-1 !bugfix
> tconv(kz)=(tth(ix,jy,kz+1,mind1)*dt2+ &
> tth(ix,jy,kz+1,mind2)*dt1)*dtt
> qconv(kz)=(qvh(ix,jy,kz+1,mind1)*dt2+ &
> qvh(ix,jy,kz+1,mind2)*dt1)*dtt
> end do
>
> ! Calculate translocation matrix
> call calcmatrix(lconv,delt,cbaseflux(ix,jy))
> igrold = igr
> ktop = 0
> endif
>
> ! treat particle only if column has convection
> if (lconv .eqv. .true.) then
> ! assign new vertical position to particle
>
> ztold=ztra1(ipart)
> call redist(ipart,ktop,ipconv)
> ! if (ipconv.le.0) sumconv = sumconv+1
>
> ! Calculate the gross fluxes across layer interfaces
> !***************************************************
>
> if (iflux.eq.1) then
> itage=abs(itra1(ipart)-itramem(ipart))
> do nage=1,nageclass
> if (itage.lt.lage(nage)) goto 37
> end do
> 37 continue
>
> if (nage.le.nageclass) &
> call calcfluxes(nage,ipart,real(xtra1(ipart)), &
> real(ytra1(ipart)),ztold)
> endif
>
> endif !(lconv .eqv. .true)
> 50 continue
> end do
>
>
> !*****************************************************************************
> ! 2. Nested domains
> !*****************************************************************************
>
> ! sort particles according to horizontal position and calculate index vector IPOINT
>
> do inest=1,numbnests
> do ipart=1,numpart
> ipoint(ipart)=ipart
> igrid(ipart) = igridn(ipart,inest)
> enddo
> call sort2(numpart,igrid,ipoint)
>
> ! Now visit all grid columns where particles are present
> ! by going through the sorted particles
>
> igrold = -1
> do kpart=1,numpart
> igr = igrid(kpart)
> if (igr .eq. -1) goto 60
> ipart = ipoint(kpart)
> ! sumall = sumall + 1
> if (igr .ne. igrold) then
> ! we are in a new grid column
> jy = (igr-1)/nxn(inest)
> ix = igr - jy*nxn(inest) - 1
>
> ! Interpolate all meteorological data needed for the convection scheme
> psconv=(psn(ix,jy,1,mind1,inest)*dt2+ &
> psn(ix,jy,1,mind2,inest)*dt1)*dtt
> tt2conv=(tt2n(ix,jy,1,mind1,inest)*dt2+ &
> tt2n(ix,jy,1,mind2,inest)*dt1)*dtt
> td2conv=(td2n(ix,jy,1,mind1,inest)*dt2+ &
> td2n(ix,jy,1,mind2,inest)*dt1)*dtt
> !!$ do kz=1,nconvlev+1 !old
> do kz=1,nuvz-1 !bugfix
> tconv(kz)=(tthn(ix,jy,kz+1,mind1,inest)*dt2+ &
> tthn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
> qconv(kz)=(qvhn(ix,jy,kz+1,mind1,inest)*dt2+ &
> qvhn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
> end do
>
> ! calculate translocation matrix
> !*******************************
> call calcmatrix(lconv,delt,cbasefluxn(ix,jy,inest))
> igrold = igr
> ktop = 0
> endif
>
> ! treat particle only if column has convection
> if (lconv .eqv. .true.) then
> ! assign new vertical position to particle
> ztold=ztra1(ipart)
> call redist(ipart,ktop,ipconv)
> ! if (ipconv.le.0) sumconv = sumconv+1
>
> ! Calculate the gross fluxes across layer interfaces
> !***************************************************
>
> if (iflux.eq.1) then
> itage=abs(itra1(ipart)-itramem(ipart))
> do nage=1,nageclass
> if (itage.lt.lage(nage)) goto 47
> end do
> 47 continue
>
> if (nage.le.nageclass) &
> call calcfluxes(nage,ipart,real(xtra1(ipart)), &
> real(ytra1(ipart)),ztold)
> endif
>
> endif !(lconv .eqv. .true.)
>
>
> 60 continue
> end do
>
> ! output of calcflux field at full hour
> ! if (mod(ihmmss, 10000).eq.0) then
> ! write(*,*) inest, nxn(inest), nyn(inest)
> ! write(fn, '(A,A,I8.8,I6.6)') path(2)(1:length(2)), 'cbaseflux_', jjjjmmdd, ihmmss
> ! call dump_field(fn, cbasefluxn(0:(nxn(inest)-1), 0:(nyn(inest)-1), inest), nxn(inest), &
> ! nyn(inest), 1)
> ! end if
>
> end do ! loop over nests
> !--------------------------------------------------------------------------
> !write(*,*)'############################################'
> !write(*,*)'TIME=',
> ! & itime
> !write(*,*)'fraction of particles under convection',
> ! & sumconv/(sumall+0.001)
> !write(*,*)'total number of particles',
> ! & sumall
> !write(*,*)'number of particles under convection',
> ! & sumconv
> !write(*,*)'############################################'
>
> return
> end subroutine convmix
convmix_gfs.f90
----------------------------------------------
1,303c1,303
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine convmix(itime)
< ! i
< !**************************************************************
< !handles all the calculations related to convective mixing
< !Petra Seibert, Bernd C. Krueger, Feb 2001
< !nested grids included, Bernd C. Krueger, May 2001
< !
< !Changes by Caroline Forster, April 2004 - February 2005:
< ! convmix called every lsynctime seconds
< !CHANGES by A. Stohl:
< ! various run-time optimizations - February 2005
< !CHANGES by C. Forster, November 2005, NCEP GFS version
< ! in the ECMWF version convection is calculated on the
< ! original eta-levels
< ! in the GFS version convection is calculated on the
< ! FLEXPART levels
< !**************************************************************
<
< use par_mod
< use com_mod
< use conv_mod
<
< implicit none
<
< integer :: igr,igrold, ipart, itime, ix, j, inest
< integer :: ipconv
< integer :: jy, kpart, ktop, ngrid,kz
< integer :: igrid(maxpart), ipoint(maxpart), igridn(maxpart,maxnests)
< ! itime [s] current time
< ! igrid(maxpart) horizontal grid position of each particle
< ! igridn(maxpart,maxnests) dto. for nested grids
< ! ipoint(maxpart) pointer to access particles according to grid position
<
< logical :: lconv
< real :: x, y, xtn,ytn, ztold, delt
< real :: dt1,dt2,dtt
< integer :: mind1,mind2
< ! dt1,dt2,dtt,mind1,mind2 variables used for time interpolation
< integer :: itage,nage
<
< !monitoring variables
< !real sumconv,sumall
<
<
< ! Calculate auxiliary variables for time interpolation
< !*****************************************************
<
< dt1=real(itime-memtime(1))
< dt2=real(memtime(2)-itime)
< dtt=1./(dt1+dt2)
< mind1=memind(1)
< mind2=memind(2)
< delt=real(abs(lsynctime))
<
<
< lconv = .false.
<
< ! if no particles are present return after initialization
< !********************************************************
<
< if (numpart.le.0) return
<
< ! Assign igrid and igridn, which are pseudo grid numbers indicating particles
< ! that are outside the part of the grid under consideration
< ! (e.g. particles near the poles or particles in other nests).
< ! Do this for all nests but use only the innermost nest; for all others
< ! igrid shall be -1
< ! Also, initialize index vector ipoint
< !************************************************************************
<
< do ipart=1,numpart
< igrid(ipart)=-1
< do j=numbnests,1,-1
< igridn(ipart,j)=-1
< end do
< ipoint(ipart)=ipart
< ! do not consider particles that are (yet) not part of simulation
< if (itra1(ipart).ne.itime) goto 20
< x = xtra1(ipart)
< y = ytra1(ipart)
<
< ! Determine which nesting level to be used
< !**********************************************************
<
< ngrid=0
< do j=numbnests,1,-1
< if ( x.gt.xln(j) .and. x.lt.xrn(j) .and. &
< y.gt.yln(j) .and. y.lt.yrn(j) ) then
< ngrid=j
< goto 23
< endif
< end do
< 23 continue
<
< ! Determine nested grid coordinates
< !**********************************
<
< if (ngrid.gt.0) then
< ! nested grids
< xtn=(x-xln(ngrid))*xresoln(ngrid)
< ytn=(y-yln(ngrid))*yresoln(ngrid)
< ix=nint(xtn)
< jy=nint(ytn)
< igridn(ipart,ngrid) = 1 + jy*nxn(ngrid) + ix
< else if(ngrid.eq.0) then
< ! mother grid
< ix=nint(x)
< jy=nint(y)
< igrid(ipart) = 1 + jy*nx + ix
< endif
<
< 20 continue
< end do
<
< !sumall = 0.
< !sumconv = 0.
<
< !*****************************************************************************
< ! 1. Now, do everything for the mother domain and, later, for all of the nested domains
< ! While all particles have to be considered for redistribution, the Emanuel convection
< ! scheme only needs to be called once for every grid column where particles are present.
< ! Therefore, particles are sorted according to their grid position. Whenever a new grid
< ! cell is encountered by looping through the sorted particles, the convection scheme is called.
< !*****************************************************************************
<
< ! sort particles according to horizontal position and calculate index vector IPOINT
<
< call sort2(numpart,igrid,ipoint)
<
< ! Now visit all grid columns where particles are present
< ! by going through the sorted particles
<
< igrold = -1
< do kpart=1,numpart
< igr = igrid(kpart)
< if (igr .eq. -1) goto 50
< ipart = ipoint(kpart)
< ! sumall = sumall + 1
< if (igr .ne. igrold) then
< ! we are in a new grid column
< jy = (igr-1)/nx
< ix = igr - jy*nx - 1
<
< ! Interpolate all meteorological data needed for the convection scheme
< psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt
< tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt
< td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt
< !!$ do kz=1,nconvlev+1 !old
< do kz=1,nuvz-1 !bugfix
< pconv(kz)=(pplev(ix,jy,kz,mind1)*dt2+ &
< pplev(ix,jy,kz,mind2)*dt1)*dtt
< tconv(kz)=(tt(ix,jy,kz,mind1)*dt2+ &
< tt(ix,jy,kz,mind2)*dt1)*dtt
< qconv(kz)=(qv(ix,jy,kz,mind1)*dt2+ &
< qv(ix,jy,kz,mind2)*dt1)*dtt
< end do
<
< ! Calculate translocation matrix
< call calcmatrix(lconv,delt,cbaseflux(ix,jy))
< igrold = igr
< ktop = 0
< endif
<
< ! treat particle only if column has convection
< if (lconv .eqv. .true.) then
< ! assign new vertical position to particle
<
< ztold=ztra1(ipart)
< call redist(ipart,ktop,ipconv)
< ! if (ipconv.le.0) sumconv = sumconv+1
<
< ! Calculate the gross fluxes across layer interfaces
< !***************************************************
<
< if (iflux.eq.1) then
< itage=abs(itra1(ipart)-itramem(ipart))
< do nage=1,nageclass
< if (itage.lt.lage(nage)) goto 37
< end do
< 37 continue
<
< if (nage.le.nageclass) &
< call calcfluxes(nage,ipart,real(xtra1(ipart)), &
< real(ytra1(ipart)),ztold)
< endif
<
< endif !(lconv .eqv. .true)
< 50 continue
< end do
<
<
< !*****************************************************************************
< ! 2. Nested domains
< !*****************************************************************************
<
< ! sort particles according to horizontal position and calculate index vector IPOINT
<
< do inest=1,numbnests
< do ipart=1,numpart
< ipoint(ipart)=ipart
< igrid(ipart) = igridn(ipart,inest)
< enddo
< call sort2(numpart,igrid,ipoint)
<
< ! Now visit all grid columns where particles are present
< ! by going through the sorted particles
<
< igrold = -1
< do kpart=1,numpart
< igr = igrid(kpart)
< if (igr .eq. -1) goto 60
< ipart = ipoint(kpart)
< ! sumall = sumall + 1
< if (igr .ne. igrold) then
< ! we are in a new grid column
< jy = (igr-1)/nxn(inest)
< ix = igr - jy*nxn(inest) - 1
<
< ! Interpolate all meteorological data needed for the convection scheme
< psconv=(psn(ix,jy,1,mind1,inest)*dt2+ &
< psn(ix,jy,1,mind2,inest)*dt1)*dtt
< tt2conv=(tt2n(ix,jy,1,mind1,inest)*dt2+ &
< tt2n(ix,jy,1,mind2,inest)*dt1)*dtt
< td2conv=(td2n(ix,jy,1,mind1,inest)*dt2+ &
< td2n(ix,jy,1,mind2,inest)*dt1)*dtt
< !!$ do kz=1,nconvlev+1 !old
< do kz=1,nuvz-1 !bugfix
< tconv(kz)=(tthn(ix,jy,kz+1,mind1,inest)*dt2+ &
< tthn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
< qconv(kz)=(qvhn(ix,jy,kz+1,mind1,inest)*dt2+ &
< qvhn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
< end do
<
< ! calculate translocation matrix
< !*******************************
< call calcmatrix(lconv,delt,cbasefluxn(ix,jy,inest))
< igrold = igr
< ktop = 0
< endif
<
< ! treat particle only if column has convection
< if (lconv .eqv. .true.) then
< ! assign new vertical position to particle
< ztold=ztra1(ipart)
< call redist(ipart,ktop,ipconv)
< ! if (ipconv.le.0) sumconv = sumconv+1
<
< ! Calculate the gross fluxes across layer interfaces
< !***************************************************
<
< if (iflux.eq.1) then
< itage=abs(itra1(ipart)-itramem(ipart))
< do nage=1,nageclass
< if (itage.lt.lage(nage)) goto 47
< end do
< 47 continue
<
< if (nage.le.nageclass) &
< call calcfluxes(nage,ipart,real(xtra1(ipart)), &
< real(ytra1(ipart)),ztold)
< endif
<
< endif !(lconv .eqv. .true.)
<
<
< 60 continue
< end do
< end do
< !--------------------------------------------------------------------------
< !write(*,*)'############################################'
< !write(*,*)'TIME=',
< ! & itime
< !write(*,*)'fraction of particles under convection',
< ! & sumconv/(sumall+0.001)
< !write(*,*)'total number of particles',
< ! & sumall
< !write(*,*)'number of particles under convection',
< ! & sumconv
< !write(*,*)'############################################'
<
< return
< end subroutine convmix
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine convmix(itime)
> ! i
> !**************************************************************
> !handles all the calculations related to convective mixing
> !Petra Seibert, Bernd C. Krueger, Feb 2001
> !nested grids included, Bernd C. Krueger, May 2001
> !
> !Changes by Caroline Forster, April 2004 - February 2005:
> ! convmix called every lsynctime seconds
> !CHANGES by A. Stohl:
> ! various run-time optimizations - February 2005
> !CHANGES by C. Forster, November 2005, NCEP GFS version
> ! in the ECMWF version convection is calculated on the
> ! original eta-levels
> ! in the GFS version convection is calculated on the
> ! FLEXPART levels
> !**************************************************************
>
> use par_mod
> use com_mod
> use conv_mod
>
> implicit none
>
> integer :: igr,igrold, ipart, itime, ix, j, inest
> integer :: ipconv
> integer :: jy, kpart, ktop, ngrid,kz
> integer :: igrid(maxpart), ipoint(maxpart), igridn(maxpart,maxnests)
> ! itime [s] current time
> ! igrid(maxpart) horizontal grid position of each particle
> ! igridn(maxpart,maxnests) dto. for nested grids
> ! ipoint(maxpart) pointer to access particles according to grid position
>
> logical :: lconv
> real :: x, y, xtn,ytn, ztold, delt
> real :: dt1,dt2,dtt
> integer :: mind1,mind2
> ! dt1,dt2,dtt,mind1,mind2 variables used for time interpolation
> integer :: itage,nage
>
> !monitoring variables
> !real sumconv,sumall
>
>
> ! Calculate auxiliary variables for time interpolation
> !*****************************************************
>
> dt1=real(itime-memtime(1))
> dt2=real(memtime(2)-itime)
> dtt=1./(dt1+dt2)
> mind1=memind(1)
> mind2=memind(2)
> delt=real(abs(lsynctime))
>
>
> lconv = .false.
>
> ! if no particles are present return after initialization
> !********************************************************
>
> if (numpart.le.0) return
>
> ! Assign igrid and igridn, which are pseudo grid numbers indicating particles
> ! that are outside the part of the grid under consideration
> ! (e.g. particles near the poles or particles in other nests).
> ! Do this for all nests but use only the innermost nest; for all others
> ! igrid shall be -1
> ! Also, initialize index vector ipoint
> !************************************************************************
>
> do ipart=1,numpart
> igrid(ipart)=-1
> do j=numbnests,1,-1
> igridn(ipart,j)=-1
> end do
> ipoint(ipart)=ipart
> ! do not consider particles that are (yet) not part of simulation
> if (itra1(ipart).ne.itime) goto 20
> x = xtra1(ipart)
> y = ytra1(ipart)
>
> ! Determine which nesting level to be used
> !**********************************************************
>
> ngrid=0
> do j=numbnests,1,-1
> if ( x.gt.xln(j) .and. x.lt.xrn(j) .and. &
> y.gt.yln(j) .and. y.lt.yrn(j) ) then
> ngrid=j
> goto 23
> endif
> end do
> 23 continue
>
> ! Determine nested grid coordinates
> !**********************************
>
> if (ngrid.gt.0) then
> ! nested grids
> xtn=(x-xln(ngrid))*xresoln(ngrid)
> ytn=(y-yln(ngrid))*yresoln(ngrid)
> ix=nint(xtn)
> jy=nint(ytn)
> igridn(ipart,ngrid) = 1 + jy*nxn(ngrid) + ix
> else if(ngrid.eq.0) then
> ! mother grid
> ix=nint(x)
> jy=nint(y)
> igrid(ipart) = 1 + jy*nx + ix
> endif
>
> 20 continue
> end do
>
> !sumall = 0.
> !sumconv = 0.
>
> !*****************************************************************************
> ! 1. Now, do everything for the mother domain and, later, for all of the nested domains
> ! While all particles have to be considered for redistribution, the Emanuel convection
> ! scheme only needs to be called once for every grid column where particles are present.
> ! Therefore, particles are sorted according to their grid position. Whenever a new grid
> ! cell is encountered by looping through the sorted particles, the convection scheme is called.
> !*****************************************************************************
>
> ! sort particles according to horizontal position and calculate index vector IPOINT
>
> call sort2(numpart,igrid,ipoint)
>
> ! Now visit all grid columns where particles are present
> ! by going through the sorted particles
>
> igrold = -1
> do kpart=1,numpart
> igr = igrid(kpart)
> if (igr .eq. -1) goto 50
> ipart = ipoint(kpart)
> ! sumall = sumall + 1
> if (igr .ne. igrold) then
> ! we are in a new grid column
> jy = (igr-1)/nx
> ix = igr - jy*nx - 1
>
> ! Interpolate all meteorological data needed for the convection scheme
> psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt
> tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt
> td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt
> !!$ do kz=1,nconvlev+1 !old
> do kz=1,nuvz-1 !bugfix
> pconv(kz)=(pplev(ix,jy,kz,mind1)*dt2+ &
> pplev(ix,jy,kz,mind2)*dt1)*dtt
> tconv(kz)=(tt(ix,jy,kz,mind1)*dt2+ &
> tt(ix,jy,kz,mind2)*dt1)*dtt
> qconv(kz)=(qv(ix,jy,kz,mind1)*dt2+ &
> qv(ix,jy,kz,mind2)*dt1)*dtt
> end do
>
> ! Calculate translocation matrix
> call calcmatrix(lconv,delt,cbaseflux(ix,jy))
> igrold = igr
> ktop = 0
> endif
>
> ! treat particle only if column has convection
> if (lconv .eqv. .true.) then
> ! assign new vertical position to particle
>
> ztold=ztra1(ipart)
> call redist(ipart,ktop,ipconv)
> ! if (ipconv.le.0) sumconv = sumconv+1
>
> ! Calculate the gross fluxes across layer interfaces
> !***************************************************
>
> if (iflux.eq.1) then
> itage=abs(itra1(ipart)-itramem(ipart))
> do nage=1,nageclass
> if (itage.lt.lage(nage)) goto 37
> end do
> 37 continue
>
> if (nage.le.nageclass) &
> call calcfluxes(nage,ipart,real(xtra1(ipart)), &
> real(ytra1(ipart)),ztold)
> endif
>
> endif !(lconv .eqv. .true)
> 50 continue
> end do
>
>
> !*****************************************************************************
> ! 2. Nested domains
> !*****************************************************************************
>
> ! sort particles according to horizontal position and calculate index vector IPOINT
>
> do inest=1,numbnests
> do ipart=1,numpart
> ipoint(ipart)=ipart
> igrid(ipart) = igridn(ipart,inest)
> enddo
> call sort2(numpart,igrid,ipoint)
>
> ! Now visit all grid columns where particles are present
> ! by going through the sorted particles
>
> igrold = -1
> do kpart=1,numpart
> igr = igrid(kpart)
> if (igr .eq. -1) goto 60
> ipart = ipoint(kpart)
> ! sumall = sumall + 1
> if (igr .ne. igrold) then
> ! we are in a new grid column
> jy = (igr-1)/nxn(inest)
> ix = igr - jy*nxn(inest) - 1
>
> ! Interpolate all meteorological data needed for the convection scheme
> psconv=(psn(ix,jy,1,mind1,inest)*dt2+ &
> psn(ix,jy,1,mind2,inest)*dt1)*dtt
> tt2conv=(tt2n(ix,jy,1,mind1,inest)*dt2+ &
> tt2n(ix,jy,1,mind2,inest)*dt1)*dtt
> td2conv=(td2n(ix,jy,1,mind1,inest)*dt2+ &
> td2n(ix,jy,1,mind2,inest)*dt1)*dtt
> !!$ do kz=1,nconvlev+1 !old
> do kz=1,nuvz-1 !bugfix
> tconv(kz)=(tthn(ix,jy,kz+1,mind1,inest)*dt2+ &
> tthn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
> qconv(kz)=(qvhn(ix,jy,kz+1,mind1,inest)*dt2+ &
> qvhn(ix,jy,kz+1,mind2,inest)*dt1)*dtt
> end do
>
> ! calculate translocation matrix
> !*******************************
> call calcmatrix(lconv,delt,cbasefluxn(ix,jy,inest))
> igrold = igr
> ktop = 0
> endif
>
> ! treat particle only if column has convection
> if (lconv .eqv. .true.) then
> ! assign new vertical position to particle
> ztold=ztra1(ipart)
> call redist(ipart,ktop,ipconv)
> ! if (ipconv.le.0) sumconv = sumconv+1
>
> ! Calculate the gross fluxes across layer interfaces
> !***************************************************
>
> if (iflux.eq.1) then
> itage=abs(itra1(ipart)-itramem(ipart))
> do nage=1,nageclass
> if (itage.lt.lage(nage)) goto 47
> end do
> 47 continue
>
> if (nage.le.nageclass) &
> call calcfluxes(nage,ipart,real(xtra1(ipart)), &
> real(ytra1(ipart)),ztold)
> endif
>
> endif !(lconv .eqv. .true.)
>
>
> 60 continue
> end do
> end do
> !--------------------------------------------------------------------------
> !write(*,*)'############################################'
> !write(*,*)'TIME=',
> ! & itime
> !write(*,*)'fraction of particles under convection',
> ! & sumconv/(sumall+0.001)
> !write(*,*)'total number of particles',
> ! & sumall
> !write(*,*)'number of particles under convection',
> ! & sumconv
> !write(*,*)'############################################'
>
> return
> end subroutine convmix
conv_mod.f90
----------------------------------------------
1,34c1,34
< !*******************************************************************************
< ! Include file for convection
< ! This file contains a global common block used by convect
< ! and other subroutines
< ! Author: P. Ferstl
< !
< ! Feb 2001
< !
< !*******************************************************************************
<
< module conv_mod
<
< use par_mod, only: nconvlevmax, na, nxmax, nymax, nxmaxn, nymaxn, maxnests
<
< implicit none
<
< !integer,parameter :: nconvlevmax = nuvzmax-1, &
< ! na = nconvlevmax+1
< !these parameters are defined in par_mod now!
<
< real :: pconv(nconvlevmax),phconv(na),dpr(nconvlevmax)
< real :: pconv_hpa(nconvlevmax),phconv_hpa(na)
<
< real :: ft(nconvlevmax), fq(nconvlevmax)
< real :: fmass(nconvlevmax,nconvlevmax),sub(nconvlevmax)
< real :: fmassfrac(nconvlevmax,nconvlevmax)
< real :: cbaseflux(0:nxmax-1,0:nymax-1)
< real :: cbasefluxn(0:nxmaxn-1,0:nymaxn-1,maxnests)
< real :: tconv(na),qconv(na),qsconv(na)
< real :: psconv,tt2conv,td2conv
<
< integer :: nconvlev,nconvtop
<
< end module conv_mod
---
> !*******************************************************************************
> ! Include file for convection
> ! This file contains a global common block used by convect
> ! and other subroutines
> ! Author: P. Ferstl
> !
> ! Feb 2001
> !
> !*******************************************************************************
>
> module conv_mod
>
> use par_mod, only: nconvlevmax, na, nxmax, nymax, nxmaxn, nymaxn, maxnests
>
> implicit none
>
> !integer,parameter :: nconvlevmax = nuvzmax-1, &
> ! na = nconvlevmax+1
> !these parameters are defined in par_mod now!
>
> real :: pconv(nconvlevmax),phconv(na),dpr(nconvlevmax)
> real :: pconv_hpa(nconvlevmax),phconv_hpa(na)
>
> real :: ft(nconvlevmax), fq(nconvlevmax)
> real :: fmass(nconvlevmax,nconvlevmax),sub(nconvlevmax)
> real :: fmassfrac(nconvlevmax,nconvlevmax)
> real :: cbaseflux(0:nxmax-1,0:nymax-1)
> real :: cbasefluxn(0:nxmaxn-1,0:nymaxn-1,maxnests)
> real :: tconv(na),qconv(na),qsconv(na)
> real :: psconv,tt2conv,td2conv
>
> integer :: nconvlev,nconvtop
>
> end module conv_mod
coordtrafo.f90
----------------------------------------------
1,114c1,114
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine coordtrafo
<
< !**********************************************************************
< ! *
< ! FLEXPART MODEL SUBROUTINE COORDTRAFO *
< ! *
< !**********************************************************************
< ! *
< ! AUTHOR: G. WOTAWA *
< ! DATE: 1994-02-07 *
< ! LAST UPDATE: 1996-05-18 A. STOHL *
< ! *
< !**********************************************************************
< ! *
< ! DESCRIPTION: This subroutine transforms x and y coordinates of *
< ! particle release points to grid coordinates. *
< ! *
< !**********************************************************************
<
< use point_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: i,j,k
<
< if (numpoint.eq.0) goto 30
<
< ! TRANSFORM X- AND Y- COORDINATES OF STARTING POINTS TO GRID COORDINATES
< !***********************************************************************
<
< do i=1,numpoint
< xpoint1(i)=(xpoint1(i)-xlon0)/dx
< xpoint2(i)=(xpoint2(i)-xlon0)/dx
< ypoint1(i)=(ypoint1(i)-ylat0)/dy
< ypoint2(i)=(ypoint2(i)-ylat0)/dy
< end do
<
< 15 continue
<
<
< ! CHECK IF RELEASE POINTS ARE WITHIN DOMAIN
< !******************************************
<
< do i=1,numpoint
< if (sglobal.and.(ypoint1(i).lt.1.e-6)) ypoint1(i)=1.e-6
< if (nglobal.and.(ypoint2(i).gt.real(nymin1)-1.e-5)) &
< ypoint2(i)=real(nymin1)-1.e-5
< if ((ypoint1(i).lt.1.e-6).or.(ypoint1(i).ge.real(nymin1)-1.e-6) &
< .or.(ypoint2(i).lt.1.e-6).or.(ypoint2(i).ge.real(nymin1)-1.e-6) &
< .or.((.not.xglobal).and.((xpoint1(i).lt.1.e-6).or. &
< (xpoint1(i).ge.real(nxmin1)-1.e-6).or.(xpoint2(i).lt.1.e-6).or. &
< (xpoint2(i).ge.real(nxmin1)-1.e-6)))) then
< write(*,*) ' NOTICE: RELEASE POINT OUT OF DOMAIN DETECTED.'
< write(*,*) ' IT IS REMOVED NOW ... '
< if (i.ge.1000) then
< write(*,*) ' COMMENT: ',compoint(i)
< else
< write(*,*) ' COMMENT: ',compoint(1001)
< endif
< if (i.lt.numpoint) then
< do j=i+1,numpoint
< xpoint1(j-1)=xpoint1(j)
< ypoint1(j-1)=ypoint1(j)
< xpoint2(j-1)=xpoint2(j)
< ypoint2(j-1)=ypoint2(j)
< zpoint1(j-1)=zpoint1(j)
< zpoint2(j-1)=zpoint2(j)
< npart(j-1)=npart(j)
< kindz(j-1)=kindz(j)
< ireleasestart(j-1)=ireleasestart(j)
< ireleaseend(j-1)=ireleaseend(j)
< if (j.le.1000) compoint(j-1)=compoint(j)
< do k=1,nspec
< xmass(j-1,k)=xmass(j,k)
< end do
< end do
< endif
<
< numpoint=numpoint-1
< if (numpoint.gt.0) goto 15
< endif
< end do
<
< 30 if(numpoint.eq.0) then
< write(*,*) ' FLEXPART MODEL SUBROUTINE COORDTRAFO: ERROR ! '
< write(*,*) ' NO PARTICLE RELEASES ARE DEFINED!'
< write(*,*) ' CHECK FILE RELEASES...'
< stop
< endif
<
< end subroutine coordtrafo
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine coordtrafo
>
> !**********************************************************************
> ! *
> ! FLEXPART MODEL SUBROUTINE COORDTRAFO *
> ! *
> !**********************************************************************
> ! *
> ! AUTHOR: G. WOTAWA *
> ! DATE: 1994-02-07 *
> ! LAST UPDATE: 1996-05-18 A. STOHL *
> ! *
> !**********************************************************************
> ! *
> ! DESCRIPTION: This subroutine transforms x and y coordinates of *
> ! particle release points to grid coordinates. *
> ! *
> !**********************************************************************
>
> use point_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: i,j,k
>
> if (numpoint.eq.0) goto 30
>
> ! TRANSFORM X- AND Y- COORDINATES OF STARTING POINTS TO GRID COORDINATES
> !***********************************************************************
>
> do i=1,numpoint
> xpoint1(i)=(xpoint1(i)-xlon0)/dx
> xpoint2(i)=(xpoint2(i)-xlon0)/dx
> ypoint1(i)=(ypoint1(i)-ylat0)/dy
> ypoint2(i)=(ypoint2(i)-ylat0)/dy
> end do
>
> 15 continue
>
>
> ! CHECK IF RELEASE POINTS ARE WITHIN DOMAIN
> !******************************************
>
> do i=1,numpoint
> if (sglobal.and.(ypoint1(i).lt.1.e-6)) ypoint1(i)=1.e-6
> if (nglobal.and.(ypoint2(i).gt.real(nymin1)-1.e-5)) &
> ypoint2(i)=real(nymin1)-1.e-5
> if ((ypoint1(i).lt.1.e-6).or.(ypoint1(i).ge.real(nymin1)-1.e-6) &
> .or.(ypoint2(i).lt.1.e-6).or.(ypoint2(i).ge.real(nymin1)-1.e-6) &
> .or.((.not.xglobal).and.((xpoint1(i).lt.1.e-6).or. &
> (xpoint1(i).ge.real(nxmin1)-1.e-6).or.(xpoint2(i).lt.1.e-6).or. &
> (xpoint2(i).ge.real(nxmin1)-1.e-6)))) then
> write(*,*) ' NOTICE: RELEASE POINT OUT OF DOMAIN DETECTED.'
> write(*,*) ' IT IS REMOVED NOW ... '
> if (i.ge.1000) then
> write(*,*) ' COMMENT: ',compoint(i)
> else
> write(*,*) ' COMMENT: ',compoint(1001)
> endif
> if (i.lt.numpoint) then
> do j=i+1,numpoint
> xpoint1(j-1)=xpoint1(j)
> ypoint1(j-1)=ypoint1(j)
> xpoint2(j-1)=xpoint2(j)
> ypoint2(j-1)=ypoint2(j)
> zpoint1(j-1)=zpoint1(j)
> zpoint2(j-1)=zpoint2(j)
> npart(j-1)=npart(j)
> kindz(j-1)=kindz(j)
> ireleasestart(j-1)=ireleasestart(j)
> ireleaseend(j-1)=ireleaseend(j)
> if (j.le.1000) compoint(j-1)=compoint(j)
> do k=1,nspec
> xmass(j-1,k)=xmass(j,k)
> end do
> end do
> endif
>
> numpoint=numpoint-1
> if (numpoint.gt.0) goto 15
> endif
> end do
>
> 30 if(numpoint.eq.0) then
> write(*,*) ' FLEXPART MODEL SUBROUTINE COORDTRAFO: ERROR ! '
> write(*,*) ' NO PARTICLE RELEASES ARE DEFINED!'
> write(*,*) ' CHECK FILE RELEASES...'
> stop
> endif
>
> end subroutine coordtrafo
distance2.f90
----------------------------------------------
1,76c1,76
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< !-----------------------------------------------------------------------
< function distance2(rlat1,rlon1,rlat2,rlon2)
<
< !$$$ SUBPROGRAM DOCUMENTATION BLOCK
< !
< ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE
< ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10
< !
< ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE
< ! BETWEEN TWO POINTS ON THE EARTH. COORDINATES ARE GIVEN IN RADIANS!
< !
< ! PROGRAM HISTORY LOG:
< ! 96-04-10 IREDELL
< !
< ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2)
< !
< ! INPUT ARGUMENT LIST:
< !rlat1 - REAL LATITUDE OF POINT 1 IN RADIANS
< !rlon1 - REAL LONGITUDE OF POINT 1 IN RADIANS
< !rlat2 - REAL LATITUDE OF POINT 2 IN RADIANS
< !rlon2 - REAL LONGITUDE OF POINT 2 IN RADIANS
< !
< ! OUTPUT ARGUMENT LIST:
< !distance2 - REAL GREAT CIRCLE DISTANCE IN KM
< !
< ! ATTRIBUTES:
< ! LANGUAGE: Fortran 90
< !
< !$$$
<
< use par_mod, only: dp
<
< implicit none
<
< real :: rlat1,rlon1,rlat2,rlon2,distance2
< real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd
< real(kind=dp),parameter :: rerth=6.3712e6_dp
< real(kind=dp),parameter :: pi=3.14159265358979_dp
<
< if ((abs(rlat1-rlat2).lt.0.0003).and. &
< (abs(rlon1-rlon2).lt.0.0003)) then
< distance2=0.0_dp
< else
<
< ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
< clat1=cos(real(rlat1,kind=dp))
< slat1=sin(real(rlat1,kind=dp))
< clat2=cos(real(rlat2,kind=dp))
< slat2=sin(real(rlat2,kind=dp))
< cdlon=cos(real(rlon1-rlon2,kind=dp))
< crd=slat1*slat2+clat1*clat2*cdlon
< distance2=real(rerth*acos(crd)/1000.0_dp)
< endif
< ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
< end function distance2
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> !-----------------------------------------------------------------------
> function distance2(rlat1,rlon1,rlat2,rlon2)
>
> !$$$ SUBPROGRAM DOCUMENTATION BLOCK
> !
> ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE
> ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10
> !
> ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE
> ! BETWEEN TWO POINTS ON THE EARTH. COORDINATES ARE GIVEN IN RADIANS!
> !
> ! PROGRAM HISTORY LOG:
> ! 96-04-10 IREDELL
> !
> ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2)
> !
> ! INPUT ARGUMENT LIST:
> !rlat1 - REAL LATITUDE OF POINT 1 IN RADIANS
> !rlon1 - REAL LONGITUDE OF POINT 1 IN RADIANS
> !rlat2 - REAL LATITUDE OF POINT 2 IN RADIANS
> !rlon2 - REAL LONGITUDE OF POINT 2 IN RADIANS
> !
> ! OUTPUT ARGUMENT LIST:
> !distance2 - REAL GREAT CIRCLE DISTANCE IN KM
> !
> ! ATTRIBUTES:
> ! LANGUAGE: Fortran 90
> !
> !$$$
>
> use par_mod, only: dp
>
> implicit none
>
> real :: rlat1,rlon1,rlat2,rlon2,distance2
> real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd
> real(kind=dp),parameter :: rerth=6.3712e6_dp
> real(kind=dp),parameter :: pi=3.14159265358979_dp
>
> if ((abs(rlat1-rlat2).lt.0.0003).and. &
> (abs(rlon1-rlon2).lt.0.0003)) then
> distance2=0.0_dp
> else
>
> ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
> clat1=cos(real(rlat1,kind=dp))
> slat1=sin(real(rlat1,kind=dp))
> clat2=cos(real(rlat2,kind=dp))
> slat2=sin(real(rlat2,kind=dp))
> cdlon=cos(real(rlon1-rlon2,kind=dp))
> crd=slat1*slat2+clat1*clat2*cdlon
> distance2=real(rerth*acos(crd)/1000.0_dp)
> endif
> ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
> end function distance2
distance.f90
----------------------------------------------
1,74c1,74
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< !-----------------------------------------------------------------------
< function distance(rlat1,rlon1,rlat2,rlon2)
<
< !$$$ SUBPROGRAM DOCUMENTATION BLOCK
< !
< ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE
< ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10
< !
< ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE
< ! BETWEEN TWO POINTS ON THE EARTH.
< !
< ! PROGRAM HISTORY LOG:
< ! 96-04-10 IREDELL
< !
< ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2)
< !
< ! INPUT ARGUMENT LIST:
< !rlat1 - REAL LATITUDE OF POINT 1 IN DEGREES
< !rlon1 - REAL LONGITUDE OF POINT 1 IN DEGREES
< !rlat2 - REAL LATITUDE OF POINT 2 IN DEGREES
< !rlon2 - REAL LONGITUDE OF POINT 2 IN DEGREES
< !
< ! OUTPUT ARGUMENT LIST:
< !distance - REAL GREAT CIRCLE DISTANCE IN KILOMETERS
< !
< ! ATTRIBUTES:
< ! LANGUAGE: Fortran 90
< !
< !$$$
<
< use par_mod, only: dp
<
< implicit none
<
< real :: rlat1,rlon1,rlat2,rlon2,distance
< real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd
< real(kind=dp),parameter :: rerth=6.3712e6_dp
< real(kind=dp),parameter :: pi=3.14159265358979_dp, dpr=180.0_dp/pi
< ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
< if ((abs(rlat1-rlat2).lt.0.03).and. &
< (abs(rlon1-rlon2).lt.0.03)) then
< distance=0.
< else
< clat1=cos(real(rlat1,kind=dp)/dpr)
< slat1=sin(real(rlat1,kind=dp)/dpr)
< clat2=cos(real(rlat2,kind=dp)/dpr)
< slat2=sin(real(rlat2,kind=dp)/dpr)
< cdlon=cos(real((rlon1-rlon2),kind=dp)/dpr)
< crd=slat1*slat2+clat1*clat2*cdlon
< distance=real(rerth*acos(crd)/1000.0_dp)
< endif
< ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
< end function distance
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> !-----------------------------------------------------------------------
> function distance(rlat1,rlon1,rlat2,rlon2)
>
> !$$$ SUBPROGRAM DOCUMENTATION BLOCK
> !
> ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE
> ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10
> !
> ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE
> ! BETWEEN TWO POINTS ON THE EARTH.
> !
> ! PROGRAM HISTORY LOG:
> ! 96-04-10 IREDELL
> !
> ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2)
> !
> ! INPUT ARGUMENT LIST:
> !rlat1 - REAL LATITUDE OF POINT 1 IN DEGREES
> !rlon1 - REAL LONGITUDE OF POINT 1 IN DEGREES
> !rlat2 - REAL LATITUDE OF POINT 2 IN DEGREES
> !rlon2 - REAL LONGITUDE OF POINT 2 IN DEGREES
> !
> ! OUTPUT ARGUMENT LIST:
> !distance - REAL GREAT CIRCLE DISTANCE IN KILOMETERS
> !
> ! ATTRIBUTES:
> ! LANGUAGE: Fortran 90
> !
> !$$$
>
> use par_mod, only: dp
>
> implicit none
>
> real :: rlat1,rlon1,rlat2,rlon2,distance
> real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd
> real(kind=dp),parameter :: rerth=6.3712e6_dp
> real(kind=dp),parameter :: pi=3.14159265358979_dp, dpr=180.0_dp/pi
> ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
> if ((abs(rlat1-rlat2).lt.0.03).and. &
> (abs(rlon1-rlon2).lt.0.03)) then
> distance=0.
> else
> clat1=cos(real(rlat1,kind=dp)/dpr)
> slat1=sin(real(rlat1,kind=dp)/dpr)
> clat2=cos(real(rlat2,kind=dp)/dpr)
> slat2=sin(real(rlat2,kind=dp)/dpr)
> cdlon=cos(real((rlon1-rlon2),kind=dp)/dpr)
> crd=slat1*slat2+clat1*clat2*cdlon
> distance=real(rerth*acos(crd)/1000.0_dp)
> endif
> ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
> end function distance
drydepokernel.f90
----------------------------------------------
1,116c1,116
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine drydepokernel(nunc,deposit,x,y,nage,kp)
< ! i i i i i
< !*****************************************************************************
< ! *
< ! Attribution of the deposition to the grid using a uniform kernel with *
< ! bandwidths dx and dy. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 26 December 1996 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! nunc uncertainty class of the respective particle *
< ! nage age class of the respective particle *
< ! deposit amount (kg) to be deposited *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use par_mod
< use com_mod
<
< implicit none
<
< real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
< integer :: ix,jy,ixp,jyp,ks,nunc,nage,kp
<
<
< xl=(x*dx+xoutshift)/dxout
< yl=(y*dy+youtshift)/dyout
< ix=int(xl)
< jy=int(yl)
< ddx=xl-real(ix) ! distance to left cell border
< ddy=yl-real(jy) ! distance to lower cell border
<
< if (ddx.gt.0.5) then
< ixp=ix+1
< wx=1.5-ddx
< else
< ixp=ix-1
< wx=0.5+ddx
< endif
<
< if (ddy.gt.0.5) then
< jyp=jy+1
< wy=1.5-ddy
< else
< jyp=jy-1
< wy=0.5+ddy
< endif
<
<
< ! Determine mass fractions for four grid points
< !**********************************************
< do ks=1,nspec
<
< if ((abs(deposit(ks)).gt.0).and.DRYDEPSPEC(ks)) then
<
< 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. &
< (jyp.le.numygrid-1)) then
< w=(1.-wx)*(1.-wy)
< drygridunc(ixp,jyp,ks,kp,nunc,nage)= &
< drygridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. &
< (jy.le.numygrid-1)) then
< w=(1.-wx)*wy
< drygridunc(ixp,jy,ks,kp,nunc,nage)= &
< drygridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. &
< (jyp.le.numygrid-1)) then
< w=wx*(1.-wy)
< drygridunc(ix,jyp,ks,kp,nunc,nage)= &
< drygridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< endif
<
< end do
<
< end subroutine drydepokernel
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine drydepokernel(nunc,deposit,x,y,nage,kp)
> ! i i i i i
> !*****************************************************************************
> ! *
> ! Attribution of the deposition to the grid using a uniform kernel with *
> ! bandwidths dx and dy. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 26 December 1996 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! nunc uncertainty class of the respective particle *
> ! nage age class of the respective particle *
> ! deposit amount (kg) to be deposited *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use par_mod
> use com_mod
>
> implicit none
>
> real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
> integer :: ix,jy,ixp,jyp,ks,nunc,nage,kp
>
>
> xl=(x*dx+xoutshift)/dxout
> yl=(y*dy+youtshift)/dyout
> ix=int(xl)
> jy=int(yl)
> ddx=xl-real(ix) ! distance to left cell border
> ddy=yl-real(jy) ! distance to lower cell border
>
> if (ddx.gt.0.5) then
> ixp=ix+1
> wx=1.5-ddx
> else
> ixp=ix-1
> wx=0.5+ddx
> endif
>
> if (ddy.gt.0.5) then
> jyp=jy+1
> wy=1.5-ddy
> else
> jyp=jy-1
> wy=0.5+ddy
> endif
>
>
> ! Determine mass fractions for four grid points
> !**********************************************
> do ks=1,nspec
>
> if ((abs(deposit(ks)).gt.0).and.DRYDEPSPEC(ks)) then
>
> 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. &
> (jyp.le.numygrid-1)) then
> w=(1.-wx)*(1.-wy)
> drygridunc(ixp,jyp,ks,kp,nunc,nage)= &
> drygridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. &
> (jy.le.numygrid-1)) then
> w=(1.-wx)*wy
> drygridunc(ixp,jy,ks,kp,nunc,nage)= &
> drygridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. &
> (jyp.le.numygrid-1)) then
> w=wx*(1.-wy)
> drygridunc(ix,jyp,ks,kp,nunc,nage)= &
> drygridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> endif
>
> end do
>
> end subroutine drydepokernel
drydepokernel_nest.f90
----------------------------------------------
1,118c1,118
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine drydepokernel_nest(nunc,deposit,x,y,nage,kp)
< ! i i i i i
< !*****************************************************************************
< ! *
< ! Attribution of the deposition from an individual particle to the *
< ! nested deposition fields using a uniform kernel with bandwidths *
< ! dxoutn and dyoutn. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 26 December 1996 *
< ! *
< ! 2 September 2004: Adaptation from drydepokernel. *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! nunc uncertainty class of the respective particle *
< ! nage age class of the respective particle *
< ! deposit amount (kg) to be deposited *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use par_mod
< use com_mod
<
< implicit none
<
< real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
< integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage
<
<
<
< xl=(x*dx+xoutshiftn)/dxoutn
< yl=(y*dy+youtshiftn)/dyoutn
< ix=int(xl)
< jy=int(yl)
< ddx=xl-real(ix) ! distance to left cell border
< ddy=yl-real(jy) ! distance to lower cell border
<
< if (ddx.gt.0.5) then
< ixp=ix+1
< wx=1.5-ddx
< else
< ixp=ix-1
< wx=0.5+ddx
< endif
<
< if (ddy.gt.0.5) then
< jyp=jy+1
< wy=1.5-ddy
< else
< jyp=jy-1
< wy=0.5+ddy
< endif
<
<
< ! Determine mass fractions for four grid points
< !**********************************************
< do ks=1,nspec
<
< if (DRYDEPSPEC(ks).and.(abs(deposit(ks)).gt.0)) then
<
< if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
< (jy.le.numygridn-1)) then
< w=wx*wy
< drygriduncn(ix,jy,ks,kp,nunc,nage)= &
< drygriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgridn-1).and. &
< (jyp.le.numygridn-1)) then
< w=(1.-wx)*(1.-wy)
< drygriduncn(ixp,jyp,ks,kp,nunc,nage)= &
< drygriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. &
< (jy.le.numygridn-1)) then
< w=(1.-wx)*wy
< drygriduncn(ixp,jy,ks,kp,nunc,nage)= &
< drygriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. &
< (jyp.le.numygridn-1)) then
< w=wx*(1.-wy)
< drygriduncn(ix,jyp,ks,kp,nunc,nage)= &
< drygriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< endif
<
< end do
< end subroutine drydepokernel_nest
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine drydepokernel_nest(nunc,deposit,x,y,nage,kp)
> ! i i i i i
> !*****************************************************************************
> ! *
> ! Attribution of the deposition from an individual particle to the *
> ! nested deposition fields using a uniform kernel with bandwidths *
> ! dxoutn and dyoutn. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 26 December 1996 *
> ! *
> ! 2 September 2004: Adaptation from drydepokernel. *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! nunc uncertainty class of the respective particle *
> ! nage age class of the respective particle *
> ! deposit amount (kg) to be deposited *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use par_mod
> use com_mod
>
> implicit none
>
> real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
> integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage
>
>
>
> xl=(x*dx+xoutshiftn)/dxoutn
> yl=(y*dy+youtshiftn)/dyoutn
> ix=int(xl)
> jy=int(yl)
> ddx=xl-real(ix) ! distance to left cell border
> ddy=yl-real(jy) ! distance to lower cell border
>
> if (ddx.gt.0.5) then
> ixp=ix+1
> wx=1.5-ddx
> else
> ixp=ix-1
> wx=0.5+ddx
> endif
>
> if (ddy.gt.0.5) then
> jyp=jy+1
> wy=1.5-ddy
> else
> jyp=jy-1
> wy=0.5+ddy
> endif
>
>
> ! Determine mass fractions for four grid points
> !**********************************************
> do ks=1,nspec
>
> if (DRYDEPSPEC(ks).and.(abs(deposit(ks)).gt.0)) then
>
> if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
> (jy.le.numygridn-1)) then
> w=wx*wy
> drygriduncn(ix,jy,ks,kp,nunc,nage)= &
> drygriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgridn-1).and. &
> (jyp.le.numygridn-1)) then
> w=(1.-wx)*(1.-wy)
> drygriduncn(ixp,jyp,ks,kp,nunc,nage)= &
> drygriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. &
> (jy.le.numygridn-1)) then
> w=(1.-wx)*wy
> drygriduncn(ixp,jy,ks,kp,nunc,nage)= &
> drygriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. &
> (jyp.le.numygridn-1)) then
> w=wx*(1.-wy)
> drygriduncn(ix,jyp,ks,kp,nunc,nage)= &
> drygriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> endif
>
> end do
> end subroutine drydepokernel_nest
dynamic_viscosity.f90
----------------------------------------------
1,36c1,36
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< ! Function calculates dynamic viscosity of air (kg/m/s) as function of
< ! temperature (K) using Sutherland's formula
<
< real function viscosity(t)
<
< implicit none
<
< real :: t
< real,parameter :: c=120.,t_0=291.15,eta_0=1.827e-5
<
< viscosity=eta_0*(t_0+c)/(t+c)*(t/t_0)**1.5
<
< return
<
< end function viscosity
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> ! Function calculates dynamic viscosity of air (kg/m/s) as function of
> ! temperature (K) using Sutherland's formula
>
> real function viscosity(t)
>
> implicit none
>
> real :: t
> real,parameter :: c=120.,t_0=291.15,eta_0=1.827e-5
>
> viscosity=eta_0*(t_0+c)/(t+c)*(t/t_0)**1.5
>
> return
>
> end function viscosity
erf.f90
----------------------------------------------
1,226c1,213
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< ! To be used, if the non-standard Fortran function erf does not exist on
< ! your machine
< !
< !aus: Numerical Recipes (FORTRAN) / Chapter 6.
< !
< !6.1 FUNCTION GAMMLN
< !6.2 FUNCTION GAMMP <6.2:GSER/6.2:GCF/6.1:GAMMLN>
< !6.2 FUNCTION GAMMQ <6.2:GSER/6.2:GCF/6.1:GAMMLN>
< !6.2 SUBROUTINE GSER <6.1:GAMMLN>
< !6.2 SUBROUTINE GCF <6.1:GAMMLN>
< !6.2 FUNCTION ERF <6.2:GAMMP/6.2:GSER/6.2:GCF/6.1:GAMMLN>
< !6.2 FUNCTION ERFC <6.2.:GAMMP/6.2:GAMMQ/6.2:GSER/
< ! 6.2:GCF/6.1:GAMMLN>
< !6.2 FUNCTION ERFCC
<
< function gammln(xx)
<
< use par_mod, only: dp
<
< implicit none
<
< integer :: j
< real(kind=dp) :: x,tmp,ser,xx,gammln
< real(KIND=dp) :: cof(6) = (/ &
< 76.18009173_dp, -86.50532033_dp, 24.01409822_dp, &
< -1.231739516_dp, .120858003e-2_dp, -.536382e-5_dp /)
< real(KIND=dp) :: stp = 2.50662827465_dp
< real(KIND=dp) :: half = 0.5_dp, one = 1.0_dp, fpf = 5.5_dp
<
< x=xx-one
< tmp=x+fpf
< tmp=(x+half)*log(tmp)-tmp
< ser=one
< do j=1,6
< x=x+one
< ser=ser+cof(j)/x
< end do
< gammln=tmp+log(stp*ser)
< end function gammln
<
< function gammp(a,x)
<
< use par_mod, only: dp
<
< implicit none
<
< real(KIND=dp) :: a, x, gln, gamser, gammp, gammcf
<
< if(x .lt. 0. .or. a .le. 0.) then
< print*, 'gammp'
< stop
< end if
< if(x.lt.a+1.)then
< call gser(gamser,a,x,gln)
< gammp=gamser
< else
< call gcf(gammcf,a,x,gln)
< gammp=1.-gammcf
< endif
< end function gammp
<
< function gammq(a,x)
<
< use par_mod, only: dp
<
< implicit none
<
< real(KIND=dp) :: a, x, gln, gamser, gammq, gammcf
<
< if(x.lt.0..or.a.le.0.) then
< print*, 'gammq'
< stop
< end if
< if(x.lt.a+1.)then
< call gser(gamser,a,x,gln)
< gammq=1.-gamser
< else
< call gcf(gammcf,a,x,gln)
< gammq=gammcf
< endif
< end function gammq
<
< subroutine gser(gamser,a,x,gln)
<
< use par_mod, only: dp
<
< implicit none
<
< integer :: n
< real(KIND=dp) :: gamser, a, x, gln, ap, summ, del
< real(KIND=dp), external :: gammln
<
< integer,parameter :: itmax=100
< real,parameter :: eps=3.e-7
<
< gln=gammln(a)
< if(x.le.0.)then
< if(x.lt.0.) then
< print*, 'gser'
< stop
< end if
< gamser=0.
< return
< endif
< ap=a
< summ=1./a
< del=summ
< do n=1,itmax
< ap=ap+1.
< del=del*x/ap
< summ=summ+del
< if(abs(del).lt.abs(summ)*eps)go to 1
< end do
< print*, 'gser: a too large, itmax too small'
< stop
< 1 gamser=summ*exp(-x+a*log(x)-gln)
< end subroutine gser
<
< subroutine gcf(gammcf,a,x,gln)
<
< use par_mod, only: dp
<
< implicit none
<
< integer :: n
< real(KIND=4) :: gammcf, x, a, gln, gold, a0, a1, b0, b1, fac, an, anf, ana, g
< real(KIND=dp), external :: gammln
<
< integer,parameter :: itmax=100
< real,parameter :: eps=3.e-7
<
< gln=gammln(a)
< gold=0.
< a0=1.
< a1=x
< b0=0.
< b1=1.
< fac=1.
< do n=1,itmax
< an=real(n)
< ana=an-a
< a0=(a1+a0*ana)*fac
< b0=(b1+b0*ana)*fac
< anf=an*fac
< a1=x*a0+anf*a1
< b1=x*b0+anf*b1
< if(a1.ne.0.)then
< fac=1./a1
< g=b1*fac
< if(abs((g-gold)/g).lt.eps)go to 1
< gold=g
< endif
< end do
< print*, 'gcf: a too large, itmax too small'
< stop
< 1 gammcf=exp(-x+a*alog(x)-gln)*g
< end subroutine gcf
<
< function erf(x)
<
< use par_mod, only: dp
<
< implicit none
<
< real(KIND=dp) :: x, erf
< real(KIND=dp), external :: gammp
<
< if(x.lt.0.)then
< erf=-gammp(.5,x**2)
< else
< erf=gammp(.5,x**2)
< endif
< end function erf
<
< function erfc(x)
<
< use par_mod, only: dp
<
< implicit none
<
< real(KIND=dp) :: x, erfc
< real(KIND=dp), external :: gammp, gammq
<
< if(x.lt.0.)then
< erfc=1.+gammp(.5,x**2)
< else
< erfc=gammq(.5,x**2)
< endif
< end function erfc
<
< function erfcc(x)
<
< use par_mod, only: dp
<
< implicit none
<
< real(KIND=dp) :: x, z, t, erfcc
<
< z=abs(x)
< t=1./(1.+0.5*z)
< erfcc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+ &
< t*(.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+ &
< t*(1.48851587+t*(-.82215223+t*.17087277)))))))))
< if (x.lt.0.) erfcc=2.-erfcc
< end function erfcc
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> ! To be used, if the non-standard Fortran function erf does not exist on
> ! your machine
> !
> !aus: Numerical Recipes (FORTRAN) / Chapter 6.
> !
> !6.1 FUNCTION GAMMLN
> !6.2 FUNCTION GAMMP <6.2:GSER/6.2:GCF/6.1:GAMMLN>
> !6.2 FUNCTION GAMMQ <6.2:GSER/6.2:GCF/6.1:GAMMLN>
> !6.2 SUBROUTINE GSER <6.1:GAMMLN>
> !6.2 SUBROUTINE GCF <6.1:GAMMLN>
> !6.2 FUNCTION ERF <6.2:GAMMP/6.2:GSER/6.2:GCF/6.1:GAMMLN>
> !6.2 FUNCTION ERFC <6.2.:GAMMP/6.2:GAMMQ/6.2:GSER/
> ! 6.2:GCF/6.1:GAMMLN>
> !6.2 FUNCTION ERFCC
>
> function gammln(xx)
>
> use par_mod, only: dp
>
> implicit none
>
> integer :: j
> real(kind=dp) :: x,tmp,ser,xx
> real :: gammln
> real(KIND=dp) :: cof(6) = (/ &
> 76.18009173_dp, -86.50532033_dp, 24.01409822_dp, &
> -1.231739516_dp, .120858003e-2_dp, -.536382e-5_dp /)
> real(KIND=dp) :: stp = 2.50662827465_dp
> real(KIND=dp) :: half = 0.5_dp, one = 1.0_dp, fpf = 5.5_dp
>
> x=xx-one
> tmp=x+fpf
> tmp=(x+half)*log(tmp)-tmp
> ser=one
> do j=1,6
> x=x+one
> ser=ser+cof(j)/x
> end do
> gammln=real(tmp+log(stp*ser))
> end function gammln
>
> function gammp(a,x)
>
> implicit none
>
> real :: a, x, gln, gamser, gammp, gammcf
>
> if(x .lt. 0. .or. a .le. 0.) then
> print*, 'gammp'
> stop
> end if
> if(x.lt.a+1.)then
> call gser(gamser,a,x,gln)
> gammp=gamser
> else
> call gcf(gammcf,a,x,gln)
> gammp=1.-gammcf
> endif
> end function gammp
>
> function gammq(a,x)
>
> implicit none
>
> real :: a, x, gln, gamser, gammq, gammcf
>
> if(x.lt.0..or.a.le.0.) then
> print*, 'gammq'
> stop
> end if
> if(x.lt.a+1.)then
> call gser(gamser,a,x,gln)
> gammq=1.-gamser
> else
> call gcf(gammcf,a,x,gln)
> gammq=gammcf
> endif
> end function gammq
>
> subroutine gser(gamser,a,x,gln)
>
> implicit none
>
> integer :: n
> real :: gamser, a, x, gln, ap, summ, del
> real, external :: gammln
>
> integer,parameter :: itmax=100
> real,parameter :: eps=3.e-7
>
> gln=gammln(a)
> if(x.le.0.)then
> if(x.lt.0.) then
> print*, 'gser'
> stop
> end if
> gamser=0.
> return
> endif
> ap=a
> summ=1./a
> del=summ
> do n=1,itmax
> ap=ap+1.
> del=del*x/ap
> summ=summ+del
> if(abs(del).lt.abs(summ)*eps)go to 1
> end do
> print*, 'gser: a too large, itmax too small'
> stop
> 1 gamser=summ*exp(-x+a*log(x)-gln)
> end subroutine gser
>
> subroutine gcf(gammcf,a,x,gln)
>
> implicit none
>
> integer :: n
> real :: gammcf, a, x, gln, gold, a0, a1, b0, b1, fac, an, anf, ana, g
> real, external :: gammln
>
> integer,parameter :: itmax=100
> real,parameter :: eps=3.e-7
>
> gln=gammln(a)
> gold=0.
> a0=1.
> a1=x
> b0=0.
> b1=1.
> fac=1.
> do n=1,itmax
> an=real(n)
> ana=an-a
> a0=(a1+a0*ana)*fac
> b0=(b1+b0*ana)*fac
> anf=an*fac
> a1=x*a0+anf*a1
> b1=x*b0+anf*b1
> if(a1.ne.0.)then
> fac=1./a1
> g=b1*fac
> if(abs((g-gold)/g).lt.eps)go to 1
> gold=g
> endif
> end do
> print*, 'gcf: a too large, itmax too small'
> stop
> 1 gammcf=exp(-x+a*alog(x)-gln)*g
> end subroutine gcf
>
> function erf(x)
>
> implicit none
>
> real :: x, erf
> real, external :: gammp
>
> if(x.lt.0.)then
> erf=-gammp(.5,x**2)
> else
> erf=gammp(.5,x**2)
> endif
> end function erf
>
> function erfc(x)
>
> implicit none
>
> real :: x, erfc
> real, external :: gammp, gammq
>
> if(x.lt.0.)then
> erfc=1.+gammp(.5,x**2)
> else
> erfc=gammq(.5,x**2)
> endif
> end function erfc
>
> function erfcc(x)
>
> implicit none
>
> real :: x, z, t, erfcc
>
> z=abs(x)
> t=1./(1.+0.5*z)
> erfcc=t*exp(-z*z-1.26551223+t*(1.00002368+t*(.37409196+ &
> t*(.09678418+t*(-.18628806+t*(.27886807+t*(-1.13520398+ &
> t*(1.48851587+t*(-.82215223+t*.17087277)))))))))
> if (x.lt.0.) erfcc=2.-erfcc
> end function erfcc
ew.f90
----------------------------------------------
1,47c1,49
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< real function ew(x)
<
< !****************************************************************
< !SAETTIGUNGSDAMPFDRUCK UEBER WASSER IN PA. X IN KELVIN.
< !NACH DER GOFF-GRATCH-FORMEL.
< !****************************************************************
<
< implicit none
<
< real :: x, y, a, c, d
<
< ew=0.
< if(x.le.0.) stop 'sorry: t not in [k]'
< y=373.16/x
< a=-7.90298*(y-1.)
< a=a+(5.02808*0.43429*alog(y))
< c=(1.-(1./y))*11.344
< c=-1.+(10.**c)
< c=-1.3816*c/(10.**7)
< d=(1.-y)*3.49149
< d=-1.+(10.**d)
< d=8.1328*d/(10.**3)
< y=a+c+d
< ew=101324.6*(10.**y) ! Saettigungsdampfdruck in Pa
<
< end function ew
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> real function ew(x)
>
> !****************************************************************
> !SAETTIGUNGSDAMPFDRUCK UEBER WASSER IN PA. X IN KELVIN.
> !NACH DER GOFF-GRATCH-FORMEL.
> !****************************************************************
>
> implicit none
>
> real :: x, y, a, c, d
>
> ew=0.
> if (x.le.0.) then
> stop 'sorry: t not in [k]'
> endif
> y=373.16/x
> a=-7.90298*(y-1.)
> a=a+(5.02808*0.43429*alog(y))
> c=(1.-(1./y))*11.344
> c=-1.+(10.**c)
> c=-1.3816*c/(10.**7)
> d=(1.-y)*3.49149
> d=-1.+(10.**d)
> d=8.1328*d/(10.**3)
> y=a+c+d
> ew=101324.6*(10.**y) ! Saettigungsdampfdruck in Pa
>
> end function ew
FLEXPART.f90
----------------------------------------------
1,235c1,268
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< program flexpart
<
< !*****************************************************************************
< ! *
< ! This is the Lagrangian Particle Dispersion Model FLEXPART. *
< ! The main program manages the reading of model run specifications, etc. *
< ! All actual computing is done within subroutine timemanager. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 18 May 1996 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use point_mod
< use par_mod
< use com_mod
< use conv_mod
<
< implicit none
<
< integer :: i,j,ix,jy,inest
< integer :: idummy = -320
< character(256) :: pathfile
<
< ! Generate a large number of random numbers
< !******************************************
<
< do i=1,maxrand-1,2
< call gasdev1(idummy,rannumb(i),rannumb(i+1))
< end do
< call gasdev1(idummy,rannumb(maxrand),rannumb(maxrand-1))
<
< ! Print the GPL License statement
< !*******************************************************
< print*,'Welcome to FLEXPART Version 9.1 (Build 20121029)'
< print*,'FLEXPART is free software released under the GNU Genera'// &
< 'l Public License.'
<
< ! Read the pathnames where input/output files are stored
< !*******************************************************
<
< select case (iargc())
< case (1)
< call getarg(1,pathfile)
< case (0)
< write(pathfile,'(a11)') './pathnames'
< end select
<
< call readpaths(pathfile)
< print*,length(4)
<
< ! Read the user specifications for the current model run
< !*******************************************************
<
< call readcommand
<
<
< ! Read the age classes to be used
< !********************************
<
< call readageclasses
<
<
< ! Read, which wind fields are available within the modelling period
< !******************************************************************
<
< call readavailable
<
<
< ! Read the model grid specifications,
< ! both for the mother domain and eventual nests
< !**********************************************
<
< call gridcheck
< call gridcheck_nests
<
<
< ! Read the output grid specifications
< !************************************
<
< call readoutgrid
< if (nested_output.eq.1) call readoutgrid_nest
<
<
< ! Read the receptor points for which extra concentrations are to be calculated
< !*****************************************************************************
<
< call readreceptors
<
<
< ! Read the physico-chemical species property table
< !*************************************************
< !SEC: now only needed SPECIES are read in readreleases.f
< !call readspecies
<
<
< ! Read the landuse inventory
< !***************************
<
< call readlanduse
<
<
< ! Assign fractional cover of landuse classes to each ECMWF grid point
< !********************************************************************
<
< call assignland
<
<
<
< ! Read the coordinates of the release locations
< !**********************************************
<
< call readreleases
<
< ! Read and compute surface resistances to dry deposition of gases
< !****************************************************************
<
< call readdepo
<
<
< ! Convert the release point coordinates from geografical to grid coordinates
< !***************************************************************************
<
< call coordtrafo
<
<
< ! Initialize all particles to non-existent
< !*****************************************
<
< do j=1,maxpart
< itra1(j)=-999999999
< end do
<
< ! For continuation of previous run, read in particle positions
< !*************************************************************
<
< if (ipin.eq.1) then
< call readpartpositions
< else
< numpart=0
< numparticlecount=0
< endif
<
<
< ! Calculate volume, surface area, etc., of all output grid cells
< ! Allocate fluxes and OHfield if necessary
< !***************************************************************
<
< call outgrid_init
< if (nested_output.eq.1) call outgrid_init_nest
<
<
< ! Read the OH field
< !******************
<
< if (OHREA.eqv..TRUE.) &
< call readOHfield
<
< ! Write basic information on the simulation to a file "header"
< ! and open files that are to be kept open throughout the simulation
< !******************************************************************
<
< call writeheader
< if (nested_output.eq.1) call writeheader_nest
< open(unitdates,file=path(2)(1:length(2))//'dates')
< call openreceptors
< if ((iout.eq.4).or.(iout.eq.5)) call openouttraj
<
<
< ! Releases can only start and end at discrete times (multiples of lsynctime)
< !***************************************************************************
<
< do i=1,numpoint
< ireleasestart(i)=nint(real(ireleasestart(i))/ &
< real(lsynctime))*lsynctime
< ireleaseend(i)=nint(real(ireleaseend(i))/ &
< real(lsynctime))*lsynctime
< end do
<
<
< ! Initialize cloud-base mass fluxes for the convection scheme
< !************************************************************
<
< do jy=0,nymin1
< do ix=0,nxmin1
< cbaseflux(ix,jy)=0.
< end do
< end do
< do inest=1,numbnests
< do jy=0,nyn(inest)-1
< do ix=0,nxn(inest)-1
< cbasefluxn(ix,jy,inest)=0.
< end do
< end do
< end do
<
<
< ! Calculate particle trajectories
< !********************************
<
< call timemanager
<
<
< write(*,*) 'CONGRATULATIONS: YOU HAVE SUCCESSFULLY COMPLETED A FLE&
< &XPART MODEL RUN!'
<
< end program flexpart
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> program flexpart
>
> !*****************************************************************************
> ! *
> ! This is the Lagrangian Particle Dispersion Model FLEXPART. *
> ! The main program manages the reading of model run specifications, etc. *
> ! All actual computing is done within subroutine timemanager. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 18 May 1996 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use point_mod
> use par_mod
> use com_mod
> use conv_mod
> use random_mod, only: gasdev1
> #if (defined _OPENMP)
> use omp_lib, only: OMP_GET_MAX_THREADS
> #endif
>
> implicit none
>
> integer :: i,j,ix,jy,inest
> integer :: idummy = -320
> #if (defined _OPENMP)
> integer :: numthreads
> #endif
>
> ! Generate a large number of random numbers
> !******************************************
>
> do i=1,maxrand-1,2
> call gasdev1(idummy,rannumb(i),rannumb(i+1))
> end do
> call gasdev1(idummy,rannumb(maxrand),rannumb(maxrand-1))
>
> ! Print the GPL License statement
> !*******************************************************
> print*,'Welcome to FLEXPART Version 9.0'
> print*,'FLEXPART is free software released under the GNU Genera'// &
> 'l Public License.'
>
> ! Read the pathnames where input/output files are stored
> !*******************************************************
>
> if (iargc().eq.0) then
> call readpaths
> else
> call get_args()
> endif
>
> ! Read the user specifications for the current model run
> !*******************************************************
>
> call readcommand
>
>
> ! Check how many threads are available in parallel section
> ! If more than one thread, set ngriclunc (number of uncertainty classes in grid output)
> ! to number of threads.
> !********************************************************
>
> #if (defined _OPENMP)
> numthreads = OMP_GET_MAX_THREADS()
>
> if (numthreads.gt.1) then
>
> write(*,*)
> write(*,*) "*********** WARNING *********************************"
> write(*,*) "* FLEXPART running in parallel mode *"
> write(*,*) "* Number of uncertainty classes is *"
> write(*,*) "* set to number of threads:", numthreads, ". Setting *"
> write(*,*) "* in par_mod.f90 overwritten. *"
> write(*,*) "******************************************************"
> write(*,*)
> nclassunc = numthreads
> endif
>
> #endif
>
>
> ! Read the age classes to be used
> !********************************
>
> call readageclasses
>
>
> ! Read, which wind fields are available within the modelling period
> !******************************************************************
>
> call readavailable
>
>
> ! Read the model grid specifications,
> ! both for the mother domain and eventual nests
> !**********************************************
>
> call gridcheck
> call gridcheck_nests
>
>
> ! Read the output grid specifications
> !************************************
>
> call readoutgrid
> if (nested_output.eq.1) call readoutgrid_nest
>
>
> ! Read the receptor points for which extra concentrations are to be calculated
> !*****************************************************************************
>
> call readreceptors
>
>
> ! Read the physico-chemical species property table
> !*************************************************
> !SEC: now only needed SPECIES are read in readreleases.f
> !call readspecies
>
>
> ! Read the landuse inventory
> !***************************
>
> call readlanduse
>
>
> ! Assign fractional cover of landuse classes to each ECMWF grid point
> !********************************************************************
>
> call assignland
>
>
>
> ! Read the coordinates of the release locations
> !**********************************************
>
> call readreleases
>
> ! Read and compute surface resistances to dry deposition of gases
> !****************************************************************
>
> call readdepo
>
>
> ! Convert the release point coordinates from geografical to grid coordinates
> !***************************************************************************
>
> call coordtrafo
>
>
> ! Initialize all particles to non-existent
> !*****************************************
>
> do j=1,maxpart
> itra1(j)=-999999999
> end do
>
> ! For continuation of previous run, read in particle positions
> !*************************************************************
>
> if (ipin.eq.1) then
> call readpartpositions
> else
> numpart=0
> numparticlecount=0
> endif
>
>
> ! Calculate volume, surface area, etc., of all output grid cells
> ! Allocate fluxes and OHfield if necessary
> !***************************************************************
>
> call outgrid_init
> if (nested_output.eq.1) call outgrid_init_nest
>
>
> ! Read the OH field
> !******************
>
> if (OHREA.eqv..TRUE.) &
> call readOHfield
>
> ! Write basic information on the simulation to a file "header"
> ! and open files that are to be kept open throughout the simulation
> !******************************************************************
>
> call writeheader
> if (nested_output.eq.1) call writeheader_nest
> open(unitdates,file=path(2)(1:length(2))//'dates')
> call openreceptors
> if ((iout.eq.4).or.(iout.eq.5)) call openouttraj
>
>
> ! Releases can only start and end at discrete times (multiples of lsynctime)
> !***************************************************************************
>
> do i=1,numpoint
> ireleasestart(i)=nint(real(ireleasestart(i))/ &
> real(lsynctime))*lsynctime
> ireleaseend(i)=nint(real(ireleaseend(i))/ &
> real(lsynctime))*lsynctime
> end do
>
>
> ! Initialize cloud-base mass fluxes for the convection scheme
> !************************************************************
>
> do jy=0,nymin1
> do ix=0,nxmin1
> cbaseflux(ix,jy)=0.
> end do
> end do
> do inest=1,numbnests
> do jy=0,nyn(inest)-1
> do ix=0,nxn(inest)-1
> cbasefluxn(ix,jy,inest)=0.
> end do
> end do
> end do
>
>
> ! Calculate particle trajectories
> !********************************
> write(*,*) " INFO: Starting integration"
> call timemanager
>
> ! close dates output
> close(unitdates)
>
> ! write job_status file
> open(unitdates,file=path(2)(1:length(2))//'job_status')
> write(unitdates,'(a)') 'finished'
> close(unitdates)
>
> write(*,*) 'CONGRATULATIONS: YOU HAVE SUCCESSFULLY COMPLETED A FLE&
> &XPART MODEL RUN!'
>
> end program flexpart
flux_mod.f90
----------------------------------------------
1,41c1,41
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< module flux_mod
<
< ! flux eastward, westward, northward, southward, upward and downward
< ! fluxes of all species and all ageclasses
< ! areaeast,areanorth [m2] side areas of each grid cell
<
< implicit none
<
< real,allocatable, dimension (:,:,:,:,:,:,:) :: flux
<
< !1 fluxw west - east
< !2 fluxe east - west
< !3 fluxs south - north
< !4 fluxn north - south
< !5 fluxu upward
< !6 fluxd downward
< !real,allocatable, dimension (:,:,:) :: areanorth
< !real,allocatable, dimension (:,:,:) :: areaeast
<
< end module flux_mod
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> module flux_mod
>
> ! flux eastward, westward, northward, southward, upward and downward
> ! fluxes of all species and all ageclasses
> ! areaeast,areanorth [m2] side areas of each grid cell
>
> implicit none
>
> real,allocatable, dimension (:,:,:,:,:,:,:) :: flux
>
> !1 fluxw west - east
> !2 fluxe east - west
> !3 fluxs south - north
> !4 fluxn north - south
> !5 fluxu upward
> !6 fluxd downward
> !real,allocatable, dimension (:,:,:) :: areanorth
> !real,allocatable, dimension (:,:,:) :: areaeast
>
> end module flux_mod
fluxoutput.f90
----------------------------------------------
1,324c1,324
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine fluxoutput(itime)
< ! i
< !*****************************************************************************
< ! *
< ! Output of the gridded fluxes. *
< ! Eastward, westward, northward, southward, upward and downward gross *
< ! fluxes are written to output file in either sparse matrix or grid dump *
< ! format, whichever is more efficient. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 04 April 2000 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! ncellse number of cells with non-zero values for eastward fluxes *
< ! sparsee .true. if in sparse matrix format, else .false. *
< ! *
< !*****************************************************************************
<
< use flux_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< real(kind=dp) :: jul
< integer :: itime,ix,jy,kz,k,nage,jjjjmmdd,ihmmss,kp,i
< integer :: ncellse(maxspec,maxageclass),ncellsw(maxspec,maxageclass)
< integer :: ncellss(maxspec,maxageclass),ncellsn(maxspec,maxageclass)
< integer :: ncellsu(maxspec,maxageclass),ncellsd(maxspec,maxageclass)
< logical :: sparsee(maxspec,maxageclass),sparsew(maxspec,maxageclass)
< logical :: sparses(maxspec,maxageclass),sparsen(maxspec,maxageclass)
< logical :: sparseu(maxspec,maxageclass),sparsed(maxspec,maxageclass)
< character :: adate*8,atime*6
<
<
< ! Determine current calendar date, needed for the file name
< !**********************************************************
<
< jul=bdate+real(itime,kind=dp)/86400._dp
< call caldate(jul,jjjjmmdd,ihmmss)
< write(adate,'(i8.8)') jjjjmmdd
< write(atime,'(i6.6)') ihmmss
<
<
< open(unitflux,file=path(2)(1:length(2))//'grid_flux_'//adate// &
< atime,form='unformatted')
<
< !**************************************************************
< ! Check, whether output of full grid or sparse matrix format is
< ! more efficient in terms of storage space. This is checked for
< ! every species and for every age class
< !**************************************************************
<
< do k=1,nspec
< do nage=1,nageclass
< ncellse(k,nage)=0
< ncellsw(k,nage)=0
< ncellsn(k,nage)=0
< ncellss(k,nage)=0
< ncellsu(k,nage)=0
< ncellsd(k,nage)=0
< end do
< end do
<
< do k=1,nspec
< do kp=1,maxpointspec_act
< do nage=1,nageclass
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< do kz=1,numzgrid
< if (flux(2,ix,jy,kz,k,kp,nage).gt.0) ncellse(k,nage)= &
< ncellse(k,nage)+1
< if (flux(1,ix,jy,kz,k,kp,nage).gt.0) ncellsw(k,nage)= &
< ncellsw(k,nage)+1
< if (flux(4,ix,jy,kz,k,kp,nage).gt.0) ncellsn(k,nage)= &
< ncellsn(k,nage)+1
< if (flux(3,ix,jy,kz,k,kp,nage).gt.0) ncellss(k,nage)= &
< ncellss(k,nage)+1
< if (flux(5,ix,jy,kz,k,kp,nage).gt.0) ncellsu(k,nage)= &
< ncellsu(k,nage)+1
< if (flux(6,ix,jy,kz,k,kp,nage).gt.0) ncellsd(k,nage)= &
< ncellsd(k,nage)+1
< end do
< end do
< end do
< end do
< end do
< end do
<
< ! Output in sparse matrix format more efficient, if less than
< ! 2/5 of all cells contains concentrations>0
< !************************************************************
<
< do k=1,nspec
< do nage=1,nageclass
< if (4*ncellse(k,nage).lt.numxgrid*numygrid*numzgrid) then
< sparsee(k,nage)=.true.
< else
< sparsee(k,nage)=.false.
< endif
< if (4*ncellsw(k,nage).lt.numxgrid*numygrid*numzgrid) then
< sparsew(k,nage)=.true.
< else
< sparsew(k,nage)=.false.
< endif
< if (4*ncellsn(k,nage).lt.numxgrid*numygrid*numzgrid) then
< sparsen(k,nage)=.true.
< else
< sparsen(k,nage)=.false.
< endif
< if (4*ncellss(k,nage).lt.numxgrid*numygrid*numzgrid) then
< sparses(k,nage)=.true.
< else
< sparses(k,nage)=.false.
< endif
< if (4*ncellsu(k,nage).lt.numxgrid*numygrid*numzgrid) then
< sparseu(k,nage)=.true.
< else
< sparseu(k,nage)=.false.
< endif
< if (4*ncellsd(k,nage).lt.numxgrid*numygrid*numzgrid) then
< sparsed(k,nage)=.true.
< else
< sparsed(k,nage)=.false.
< endif
< end do
< end do
<
<
<
< ! Flux output: divide by area and time to get flux in ng/m2/s
< !************************************************************
<
< write(unitflux) itime
< do k=1,nspec
< do kp=1,maxpointspec_act
< do nage=1,nageclass
<
< if (sparsee(k,nage)) then
< write(unitflux) 1
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (flux(2,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
< ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
< flux(2,ix,jy,kz,k,kp,nage)/areaeast(ix,jy,kz)/outstep
< end do
< end do
< end do
< write(unitflux) -999,999.
< else
< write(unitflux) 2
< do kz=1,numzgrid
< do ix=0,numxgrid-1
< write(unitflux) (1.e12*flux(2,ix,jy,kz,k,kp,nage)/ &
< areaeast(ix,jy,kz)/outstep,jy=0,numygrid-1)
< end do
< end do
< endif
<
< if (sparsew(k,nage)) then
< write(unitflux) 1
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (flux(1,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
< ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
< flux(1,ix,jy,kz,k,kp,nage)/areaeast(ix,jy,kz)/outstep
< end do
< end do
< end do
< write(unitflux) -999,999.
< else
< write(unitflux) 2
< do kz=1,numzgrid
< do ix=0,numxgrid-1
< write(unitflux) (1.e12*flux(1,ix,jy,kz,k,kp,nage)/ &
< areaeast(ix,jy,kz)/outstep,jy=0,numygrid-1)
< end do
< end do
< endif
<
< if (sparses(k,nage)) then
< write(unitflux) 1
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (flux(3,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
< ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
< flux(3,ix,jy,kz,k,kp,nage)/areanorth(ix,jy,kz)/outstep
< end do
< end do
< end do
< write(unitflux) -999,999.
< else
< write(unitflux) 2
< do kz=1,numzgrid
< do ix=0,numxgrid-1
< write(unitflux) (1.e12*flux(3,ix,jy,kz,k,kp,nage)/ &
< areanorth(ix,jy,kz)/outstep,jy=0,numygrid-1)
< end do
< end do
< endif
<
< if (sparsen(k,nage)) then
< write(unitflux) 1
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1 ! north
< if (flux(4,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
< ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
< flux(4,ix,jy,kz,k,kp,nage)/areanorth(ix,jy,kz)/outstep
< end do
< end do
< end do
< write(unitflux) -999,999.
< else
< write(unitflux) 2
< do kz=1,numzgrid
< do ix=0,numxgrid-1
< write(unitflux) (1.e12*flux(4,ix,jy,kz,k,kp,nage)/ &
< areanorth(ix,jy,kz)/outstep,jy=0,numygrid-1)
< end do
< end do
< endif
<
< if (sparseu(k,nage)) then
< write(unitflux) 1
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (flux(5,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
< ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
< flux(5,ix,jy,kz,k,kp,nage)/area(ix,jy)/outstep
< end do
< end do
< end do
< write(unitflux) -999,999.
< else
< write(unitflux) 2
< do kz=1,numzgrid
< do ix=0,numxgrid-1
< write(unitflux) (1.e12*flux(5,ix,jy,kz,k,kp,nage)/ &
< area(ix,jy)/outstep,jy=0,numygrid-1)
< end do
< end do
< endif
<
< if (sparsed(k,nage)) then
< write(unitflux) 1
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (flux(6,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
< ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
< flux(6,ix,jy,kz,k,kp,nage)/area(ix,jy)/outstep
< end do
< end do
< end do
< write(unitflux) -999,999.
< else
< write(unitflux) 2
< do kz=1,numzgrid
< do ix=0,numxgrid-1
< write(unitflux) (1.e12*flux(6,ix,jy,kz,k,kp,nage)/ &
< area(ix,jy)/outstep,jy=0,numygrid-1)
< end do
< end do
< endif
<
< end do
< end do
< end do
<
<
< close(unitflux)
<
<
< ! Reinitialization of grid
< !*************************
<
< do k=1,nspec
< do kp=1,maxpointspec_act
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< do kz=1,numzgrid
< do nage=1,nageclass
< do i=1,6
< flux(i,ix,jy,kz,k,kp,nage)=0.
< end do
< end do
< end do
< end do
< end do
< end do
< end do
<
<
< end subroutine fluxoutput
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine fluxoutput(itime)
> ! i
> !*****************************************************************************
> ! *
> ! Output of the gridded fluxes. *
> ! Eastward, westward, northward, southward, upward and downward gross *
> ! fluxes are written to output file in either sparse matrix or grid dump *
> ! format, whichever is more efficient. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 04 April 2000 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! ncellse number of cells with non-zero values for eastward fluxes *
> ! sparsee .true. if in sparse matrix format, else .false. *
> ! *
> !*****************************************************************************
>
> use flux_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> real(kind=dp) :: jul
> integer :: itime,ix,jy,kz,k,nage,jjjjmmdd,ihmmss,kp,i
> integer :: ncellse(maxspec,maxageclass),ncellsw(maxspec,maxageclass)
> integer :: ncellss(maxspec,maxageclass),ncellsn(maxspec,maxageclass)
> integer :: ncellsu(maxspec,maxageclass),ncellsd(maxspec,maxageclass)
> logical :: sparsee(maxspec,maxageclass),sparsew(maxspec,maxageclass)
> logical :: sparses(maxspec,maxageclass),sparsen(maxspec,maxageclass)
> logical :: sparseu(maxspec,maxageclass),sparsed(maxspec,maxageclass)
> character :: adate*8,atime*6
>
>
> ! Determine current calendar date, needed for the file name
> !**********************************************************
>
> jul=bdate+real(itime,kind=dp)/86400._dp
> call caldate(jul,jjjjmmdd,ihmmss)
> write(adate,'(i8.8)') jjjjmmdd
> write(atime,'(i6.6)') ihmmss
>
>
> open(unitflux,file=path(2)(1:length(2))//'grid_flux_'//adate// &
> atime,form='unformatted')
>
> !**************************************************************
> ! Check, whether output of full grid or sparse matrix format is
> ! more efficient in terms of storage space. This is checked for
> ! every species and for every age class
> !**************************************************************
>
> do k=1,nspec
> do nage=1,nageclass
> ncellse(k,nage)=0
> ncellsw(k,nage)=0
> ncellsn(k,nage)=0
> ncellss(k,nage)=0
> ncellsu(k,nage)=0
> ncellsd(k,nage)=0
> end do
> end do
>
> do k=1,nspec
> do kp=1,maxpointspec_act
> do nage=1,nageclass
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> do kz=1,numzgrid
> if (flux(2,ix,jy,kz,k,kp,nage).gt.0) ncellse(k,nage)= &
> ncellse(k,nage)+1
> if (flux(1,ix,jy,kz,k,kp,nage).gt.0) ncellsw(k,nage)= &
> ncellsw(k,nage)+1
> if (flux(4,ix,jy,kz,k,kp,nage).gt.0) ncellsn(k,nage)= &
> ncellsn(k,nage)+1
> if (flux(3,ix,jy,kz,k,kp,nage).gt.0) ncellss(k,nage)= &
> ncellss(k,nage)+1
> if (flux(5,ix,jy,kz,k,kp,nage).gt.0) ncellsu(k,nage)= &
> ncellsu(k,nage)+1
> if (flux(6,ix,jy,kz,k,kp,nage).gt.0) ncellsd(k,nage)= &
> ncellsd(k,nage)+1
> end do
> end do
> end do
> end do
> end do
> end do
>
> ! Output in sparse matrix format more efficient, if less than
> ! 2/5 of all cells contains concentrations>0
> !************************************************************
>
> do k=1,nspec
> do nage=1,nageclass
> if (4*ncellse(k,nage).lt.numxgrid*numygrid*numzgrid) then
> sparsee(k,nage)=.true.
> else
> sparsee(k,nage)=.false.
> endif
> if (4*ncellsw(k,nage).lt.numxgrid*numygrid*numzgrid) then
> sparsew(k,nage)=.true.
> else
> sparsew(k,nage)=.false.
> endif
> if (4*ncellsn(k,nage).lt.numxgrid*numygrid*numzgrid) then
> sparsen(k,nage)=.true.
> else
> sparsen(k,nage)=.false.
> endif
> if (4*ncellss(k,nage).lt.numxgrid*numygrid*numzgrid) then
> sparses(k,nage)=.true.
> else
> sparses(k,nage)=.false.
> endif
> if (4*ncellsu(k,nage).lt.numxgrid*numygrid*numzgrid) then
> sparseu(k,nage)=.true.
> else
> sparseu(k,nage)=.false.
> endif
> if (4*ncellsd(k,nage).lt.numxgrid*numygrid*numzgrid) then
> sparsed(k,nage)=.true.
> else
> sparsed(k,nage)=.false.
> endif
> end do
> end do
>
>
>
> ! Flux output: divide by area and time to get flux in ng/m2/s
> !************************************************************
>
> write(unitflux) itime
> do k=1,nspec
> do kp=1,maxpointspec_act
> do nage=1,nageclass
>
> if (sparsee(k,nage)) then
> write(unitflux) 1
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (flux(2,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
> ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
> flux(2,ix,jy,kz,k,kp,nage)/areaeast(ix,jy,kz)/outstep
> end do
> end do
> end do
> write(unitflux) -999,999.
> else
> write(unitflux) 2
> do kz=1,numzgrid
> do ix=0,numxgrid-1
> write(unitflux) (1.e12*flux(2,ix,jy,kz,k,kp,nage)/ &
> areaeast(ix,jy,kz)/outstep,jy=0,numygrid-1)
> end do
> end do
> endif
>
> if (sparsew(k,nage)) then
> write(unitflux) 1
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (flux(1,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
> ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
> flux(1,ix,jy,kz,k,kp,nage)/areaeast(ix,jy,kz)/outstep
> end do
> end do
> end do
> write(unitflux) -999,999.
> else
> write(unitflux) 2
> do kz=1,numzgrid
> do ix=0,numxgrid-1
> write(unitflux) (1.e12*flux(1,ix,jy,kz,k,kp,nage)/ &
> areaeast(ix,jy,kz)/outstep,jy=0,numygrid-1)
> end do
> end do
> endif
>
> if (sparses(k,nage)) then
> write(unitflux) 1
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (flux(3,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
> ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
> flux(3,ix,jy,kz,k,kp,nage)/areanorth(ix,jy,kz)/outstep
> end do
> end do
> end do
> write(unitflux) -999,999.
> else
> write(unitflux) 2
> do kz=1,numzgrid
> do ix=0,numxgrid-1
> write(unitflux) (1.e12*flux(3,ix,jy,kz,k,kp,nage)/ &
> areanorth(ix,jy,kz)/outstep,jy=0,numygrid-1)
> end do
> end do
> endif
>
> if (sparsen(k,nage)) then
> write(unitflux) 1
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1 ! north
> if (flux(4,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
> ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
> flux(4,ix,jy,kz,k,kp,nage)/areanorth(ix,jy,kz)/outstep
> end do
> end do
> end do
> write(unitflux) -999,999.
> else
> write(unitflux) 2
> do kz=1,numzgrid
> do ix=0,numxgrid-1
> write(unitflux) (1.e12*flux(4,ix,jy,kz,k,kp,nage)/ &
> areanorth(ix,jy,kz)/outstep,jy=0,numygrid-1)
> end do
> end do
> endif
>
> if (sparseu(k,nage)) then
> write(unitflux) 1
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (flux(5,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
> ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
> flux(5,ix,jy,kz,k,kp,nage)/area(ix,jy)/outstep
> end do
> end do
> end do
> write(unitflux) -999,999.
> else
> write(unitflux) 2
> do kz=1,numzgrid
> do ix=0,numxgrid-1
> write(unitflux) (1.e12*flux(5,ix,jy,kz,k,kp,nage)/ &
> area(ix,jy)/outstep,jy=0,numygrid-1)
> end do
> end do
> endif
>
> if (sparsed(k,nage)) then
> write(unitflux) 1
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (flux(6,ix,jy,kz,k,kp,nage).gt.0.) write(unitflux) &
> ix+jy*numxgrid+kz*numxgrid*numygrid,1.e12* &
> flux(6,ix,jy,kz,k,kp,nage)/area(ix,jy)/outstep
> end do
> end do
> end do
> write(unitflux) -999,999.
> else
> write(unitflux) 2
> do kz=1,numzgrid
> do ix=0,numxgrid-1
> write(unitflux) (1.e12*flux(6,ix,jy,kz,k,kp,nage)/ &
> area(ix,jy)/outstep,jy=0,numygrid-1)
> end do
> end do
> endif
>
> end do
> end do
> end do
>
>
> close(unitflux)
>
>
> ! Reinitialization of grid
> !*************************
>
> do k=1,nspec
> do kp=1,maxpointspec_act
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> do kz=1,numzgrid
> do nage=1,nageclass
> do i=1,6
> flux(i,ix,jy,kz,k,kp,nage)=0.
> end do
> end do
> end do
> end do
> end do
> end do
> end do
>
>
> end subroutine fluxoutput
getfields.f90
----------------------------------------------
1,177c1,186
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine getfields(itime,nstop)
< ! i o
< !*****************************************************************************
< ! *
< ! This subroutine manages the 3 data fields to be kept in memory. *
< ! During the first time step of petterssen it has to be fulfilled that the *
< ! first data field must have |wftime| 0, if trajectory has to be terminated *
< ! nx,ny,nuvz,nwz field dimensions in x,y and z direction *
< ! uu(0:nxmax,0:nymax,nuvzmax,2) wind components in x-direction [m/s] *
< ! vv(0:nxmax,0:nymax,nuvzmax,2) wind components in y-direction [m/s] *
< ! ww(0:nxmax,0:nymax,nwzmax,2) wind components in z-direction [deltaeta/s]*
< ! tt(0:nxmax,0:nymax,nuvzmax,2) temperature [K] *
< ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
< ! *
< ! Constants: *
< ! idiffmax maximum allowable time difference between 2 wind *
< ! fields *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: indj,itime,nstop,memaux
<
< real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
< real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
<
< integer :: indmin = 1
<
<
< ! Check, if wind fields are available for the current time step
< !**************************************************************
<
< nstop=0
<
< if ((ldirect*wftime(1).gt.ldirect*itime).or. &
< (ldirect*wftime(numbwf).lt.ldirect*itime)) then
< write(*,*) 'FLEXPART WARNING: NO WIND FIELDS ARE AVAILABLE.'
< write(*,*) 'A TRAJECTORY HAS TO BE TERMINATED.'
< nstop=4
< return
< endif
<
<
< if ((ldirect*memtime(1).le.ldirect*itime).and. &
< (ldirect*memtime(2).gt.ldirect*itime)) then
<
< ! The right wind fields are already in memory -> don't do anything
< !*****************************************************************
<
< continue
<
< else if ((ldirect*memtime(2).le.ldirect*itime).and. &
< (memtime(2).ne.999999999)) then
<
<
< ! Current time is after 2nd wind field
< ! -> Resort wind field pointers, so that current time is between 1st and 2nd
< !***************************************************************************
<
< memaux=memind(1)
< memind(1)=memind(2)
< memind(2)=memaux
< memtime(1)=memtime(2)
<
<
< ! Read a new wind field and store it on place memind(2)
< !******************************************************
<
< do indj=indmin,numbwf-1
< if (ldirect*wftime(indj+1).gt.ldirect*itime) then
< call readwind(indj+1,memind(2),uuh,vvh,wwh)
< call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn)
< call calcpar(memind(2),uuh,vvh,pvh)
< call calcpar_nests(memind(2),uuhn,vvhn,pvhn)
< call verttransform(memind(2),uuh,vvh,wwh,pvh)
< call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn)
< memtime(2)=wftime(indj+1)
< nstop = 1
< goto 40
< endif
< end do
< 40 indmin=indj
<
< else
<
< ! No wind fields, which can be used, are currently in memory
< ! -> read both wind fields
< !***********************************************************
<
< do indj=indmin,numbwf-1
< if ((ldirect*wftime(indj).le.ldirect*itime).and. &
< (ldirect*wftime(indj+1).gt.ldirect*itime)) then
< memind(1)=1
< call readwind(indj,memind(1),uuh,vvh,wwh)
< call readwind_nests(indj,memind(1),uuhn,vvhn,wwhn)
< call calcpar(memind(1),uuh,vvh,pvh)
< call calcpar_nests(memind(1),uuhn,vvhn,pvhn)
< call verttransform(memind(1),uuh,vvh,wwh,pvh)
< call verttransform_nests(memind(1),uuhn,vvhn,wwhn,pvhn)
< memtime(1)=wftime(indj)
< memind(2)=2
< call readwind(indj+1,memind(2),uuh,vvh,wwh)
< call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn)
< call calcpar(memind(2),uuh,vvh,pvh)
< call calcpar_nests(memind(2),uuhn,vvhn,pvhn)
< call verttransform(memind(2),uuh,vvh,wwh,pvh)
< call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn)
< memtime(2)=wftime(indj+1)
< nstop = 1
< goto 60
< endif
< end do
< 60 indmin=indj
<
< endif
<
< lwindinterv=abs(memtime(2)-memtime(1))
<
< if (lwindinterv.gt.idiffmax) nstop=3
<
< end subroutine getfields
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine getfields(itime,nstop)
> ! i o
> !*****************************************************************************
> ! *
> ! This subroutine manages the 3 data fields to be kept in memory. *
> ! During the first time step of petterssen it has to be fulfilled that the *
> ! first data field must have |wftime| ! wftime must be smaller than the absolute value of the current time in [s].*
> ! The other 2 fields are the next in time after the first one. *
> ! Pointers (memind) are used, because otherwise one would have to resort the*
> ! wind fields, which costs a lot of computing time. Here only the pointers *
> ! are resorted. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 29 April 1994 *
> ! *
> !*****************************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001:
> ! Variables tth,qvh,tthn,qvhn (on eta coordinates) in common block.
> ! Function of nstop extended.
> !*****************************************************************************
> ! *
> ! Variables: *
> ! lwindinterval [s] time difference between the two wind fields read in *
> ! indj indicates the number of the wind field to be read in *
> ! indmin remembers the number of wind fields already treated *
> ! memind(2) pointer, on which place the wind fields are stored *
> ! memtime(2) [s] times of the wind fields, which are kept in memory *
> ! itime [s] current time since start date of trajectory calcu- *
> ! lation *
> ! nstop > 0, if trajectory has to be terminated *
> ! nx,ny,nuvz,nwz field dimensions in x,y and z direction *
> ! uu(0:nxmax,0:nymax,nuvzmax,2) wind components in x-direction [m/s] *
> ! vv(0:nxmax,0:nymax,nuvzmax,2) wind components in y-direction [m/s] *
> ! ww(0:nxmax,0:nymax,nwzmax,2) wind components in z-direction [deltaeta/s]*
> ! tt(0:nxmax,0:nymax,nuvzmax,2) temperature [K] *
> ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
> ! *
> ! Constants: *
> ! idiffmax maximum allowable time difference between 2 wind *
> ! fields *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: indj,itime,nstop,memaux
>
> real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
> real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
>
> integer :: indmin = 1
>
>
> ! Check, if wind fields are available for the current time step
> !**************************************************************
>
> nstop=0
>
> if ((ldirect*wftime(1).gt.ldirect*itime).or. &
> (ldirect*wftime(numbwf).lt.ldirect*itime)) then
> write(*,*) 'FLEXPART WARNING: NO WIND FIELDS ARE AVAILABLE.'
> write(*,*) 'A TRAJECTORY HAS TO BE TERMINATED.'
> nstop=4
> return
> endif
>
>
> if ((ldirect*memtime(1).le.ldirect*itime).and. &
> (ldirect*memtime(2).gt.ldirect*itime)) then
>
> ! The right wind fields are already in memory -> don't do anything
> !*****************************************************************
>
> continue
>
> else if ((ldirect*memtime(2).le.ldirect*itime).and. &
> (memtime(2).ne.999999999)) then
>
>
> ! Current time is after 2nd wind field
> !***************************************************************************
>
>
> ! Read a new wind field and store it on place memind(2)
> !******************************************************
>
> do indj=indmin,numbwf-1
> if (ldirect*wftime(indj+1).gt.ldirect*itime) then
> ! -> Resort wind field pointers, so that current time is between
> !1st and 2nd
> !*********************************************************************
>
> memaux=memind(1)
> memind(1)=memind(2)
> memind(2)=memaux
> memtime(1)=memtime(2)
> call readwind(indj+1,memind(2),uuh,vvh,wwh)
> call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn)
> call calcpar(memind(2),uuh,vvh,pvh)
> call calcpar_nests(memind(2),uuhn,vvhn,pvhn)
> call verttransform(memind(2),uuh,vvh,wwh,pvh)
> call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn)
> memtime(2)=wftime(indj+1)
> nstop = 1
> goto 40
> endif
> end do
> 40 indmin=indj
>
> else
>
> ! No wind fields, which can be used, are currently in memory
> ! -> read both wind fields
> !***********************************************************
>
> do indj=indmin,numbwf-1
> if ((ldirect*wftime(indj).le.ldirect*itime).and. &
> (ldirect*wftime(indj+1).gt.ldirect*itime)) then
> memind(1)=1
> call readwind(indj,memind(1),uuh,vvh,wwh)
> call readwind_nests(indj,memind(1),uuhn,vvhn,wwhn)
> call calcpar(memind(1),uuh,vvh,pvh)
> call calcpar_nests(memind(1),uuhn,vvhn,pvhn)
> call verttransform(memind(1),uuh,vvh,wwh,pvh)
> call verttransform_nests(memind(1),uuhn,vvhn,wwhn,pvhn)
> memtime(1)=wftime(indj)
> memind(2)=2
> call readwind(indj+1,memind(2),uuh,vvh,wwh)
> call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn)
> call calcpar(memind(2),uuh,vvh,pvh)
> call calcpar_nests(memind(2),uuhn,vvhn,pvhn)
> call verttransform(memind(2),uuh,vvh,wwh,pvh)
> call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn)
> memtime(2)=wftime(indj+1)
> nstop = 1
>
> #ifdef WELL_MIXED_TEST
> memtime(1) = 0
> memtime(2) = ideltas
> #endif
>
> goto 60
> endif
> end do
> 60 indmin=indj
>
> endif
>
> #ifndef WELL_MIXED_TEST
> lwindinterv=abs(memtime(2)-memtime(1))
> if (lwindinterv.gt.idiffmax) nstop=3
> #endif
>
> end subroutine getfields
getrb.f90
----------------------------------------------
1,61c1,61
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine getrb(nc,ustar,nyl,diffh2o,reldiff,rb)
< ! i i i i i o
< !*****************************************************************************
< ! *
< ! Calculation of the quasilaminar sublayer resistance to dry deposition. *
< ! *
< ! AUTHOR: Andreas Stohl, 20 May 1995 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! rb(ncmax) sublayer resistance *
< ! schmidt Schmidt number *
< ! ustar [m/s] friction velocity *
< ! diffh20 [m2/s] diffusivity of water vapor in air *
< ! reldiff diffusivity relative to H2O *
< ! *
< ! Constants: *
< ! karman von Karman constant *
< ! pr Prandtl number *
< ! *
< !*****************************************************************************
<
< use par_mod
<
< implicit none
<
< real :: ustar,diffh2o,rb(maxspec),schmidt,nyl
< real :: reldiff(maxspec)
< integer :: ic,nc
< real,parameter :: pr=0.72
<
< do ic=1,nc
< if (reldiff(ic).gt.0.) then
< schmidt=nyl/diffh2o*reldiff(ic)
< rb(ic)=2.0*(schmidt/pr)**0.67/(karman*ustar)
< endif
< end do
<
< end subroutine getrb
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine getrb(nc,ustar,nyl,diffh2o,reldiff,rb)
> ! i i i i i o
> !*****************************************************************************
> ! *
> ! Calculation of the quasilaminar sublayer resistance to dry deposition. *
> ! *
> ! AUTHOR: Andreas Stohl, 20 May 1995 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! rb(ncmax) sublayer resistance *
> ! schmidt Schmidt number *
> ! ustar [m/s] friction velocity *
> ! diffh20 [m2/s] diffusivity of water vapor in air *
> ! reldiff diffusivity relative to H2O *
> ! *
> ! Constants: *
> ! karman von Karman constant *
> ! pr Prandtl number *
> ! *
> !*****************************************************************************
>
> use par_mod
>
> implicit none
>
> real :: ustar,diffh2o,rb(maxspec),schmidt,nyl
> real :: reldiff(maxspec)
> integer :: ic,nc
> real,parameter :: pr=0.72
>
> do ic=1,nc
> if (reldiff(ic).gt.0.) then
> schmidt=nyl/diffh2o*reldiff(ic)
> rb(ic)=2.0*(schmidt/pr)**0.67/(karman*ustar)
> endif
> end do
>
> end subroutine getrb
getrc.f90
----------------------------------------------
1,122c1,122
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine getrc(nc,i,j,t,gr,rh,rr,rc)
< ! i i i i i i i o
< !*****************************************************************************
< ! *
< ! Calculation of the surface resistance according to the procedure given *
< ! in: *
< ! Wesely (1989): Parameterization of surface resistances to gaseous *
< ! dry deposition in regional-scale numerical models. *
< ! Atmos. Environ. 23, 1293-1304. *
< ! *
< ! *
< ! AUTHOR: Andreas Stohl, 19 May 1995 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! reldiff(maxspec) diffusivity of H2O/diffusivity of component i *
< ! gr [W/m2] global radiation *
< ! i index of seasonal category *
< ! j index of landuse class *
< ! ldep(maxspec) 1, if deposition shall be calculated for species i *
< ! nc actual number of chemical components *
< ! rcl(maxspec,5,8) [s/m] Lower canopy resistance *
< ! rgs(maxspec,5,8) [s/m] Ground resistance *
< ! rlu(maxspec,5,8) [s/m] Leaf cuticular resistance *
< ! rm(maxspec) [s/m] Mesophyll resistance *
< ! t [C] temperature *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: i,j,ic,nc
< real :: gr,rh,rr,t,rs,rsm,corr,rluc,rclc,rgsc,rdc,rluo
< real :: rc(maxspec)
<
<
< ! Compute stomatal resistance
< !****************************
< ! Sabine Eckhardt, Dec 06: use 1E25 instead of 99999. for infinite res.
<
< if ((t.gt.0.).and.(t.lt.40.)) then
< rs=ri(i,j)*(1.+(200./(gr+0.1))**2)*(400./(t*(40.-t)))
< else
< rs=1.E25
< ! rs=99999.
< endif
<
<
< ! Correct stomatal resistance for effect of dew and rain
< !*******************************************************
<
< if ((rh.gt.0.9).or.(rr.gt.0.)) rs=rs*3.
<
< ! Compute the lower canopy resistance
< !************************************
<
< rdc=100.*(1.+1000./(gr+10.))
<
<
< corr=1000.*exp(-1.*t-4.)
< do ic=1,nc
< if (reldiff(ic).gt.0.) then
<
< ! Compute combined stomatal and mesophyll resistance
< !***************************************************
<
< rsm=rs*reldiff(ic)+rm(ic)
<
< ! Correct leaf cuticular, lower canopy and ground resistance
< !***********************************************************
<
< rluc=rlu(ic,i,j)+corr
< rclc=rcl(ic,i,j)+corr
< rgsc=rgs(ic,i,j)+corr
<
< ! Correct leaf cuticular resistance for effect of dew and rain
< !*************************************************************
<
< if (rr.gt.0.) then
< rluo=1./(1./1000.+1./(3.*rluc))
< rluc=1./(1./(3.*rluc)+1.e-7*henry(ic)+f0(ic)/rluo)
< else if (rh.gt.0.9) then
< rluo=1./(1./3000.+1./(3.*rluc))
< rluc=1./(1./(3.*rluc)+1.e-7*henry(ic)+f0(ic)/rluo)
< endif
<
< ! Combine resistances to give total resistance
< !*********************************************
<
< rc(ic)=1./(1./rsm+1./rluc+1./(rdc+rclc)+1./(rac(i,j)+rgsc))
< ! Sabine Eckhardt, Dec 06: avoid possible excessively high vdep
< if (rc(ic).lt.10.) rc(ic)=10.
< endif
< end do
<
< end subroutine getrc
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine getrc(nc,i,j,t,gr,rh,rr,rc)
> ! i i i i i i i o
> !*****************************************************************************
> ! *
> ! Calculation of the surface resistance according to the procedure given *
> ! in: *
> ! Wesely (1989): Parameterization of surface resistances to gaseous *
> ! dry deposition in regional-scale numerical models. *
> ! Atmos. Environ. 23, 1293-1304. *
> ! *
> ! *
> ! AUTHOR: Andreas Stohl, 19 May 1995 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! reldiff(maxspec) diffusivity of H2O/diffusivity of component i *
> ! gr [W/m2] global radiation *
> ! i index of seasonal category *
> ! j index of landuse class *
> ! ldep(maxspec) 1, if deposition shall be calculated for species i *
> ! nc actual number of chemical components *
> ! rcl(maxspec,5,8) [s/m] Lower canopy resistance *
> ! rgs(maxspec,5,8) [s/m] Ground resistance *
> ! rlu(maxspec,5,8) [s/m] Leaf cuticular resistance *
> ! rm(maxspec) [s/m] Mesophyll resistance *
> ! t [C] temperature *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: i,j,ic,nc
> real :: gr,rh,rr,t,rs,rsm,corr,rluc,rclc,rgsc,rdc,rluo
> real :: rc(maxspec)
>
>
> ! Compute stomatal resistance
> !****************************
> ! Sabine Eckhardt, Dec 06: use 1E25 instead of 99999. for infinite res.
>
> if ((t.gt.0.).and.(t.lt.40.)) then
> rs=ri(i,j)*(1.+(200./(gr+0.1))**2)*(400./(t*(40.-t)))
> else
> rs=1.E25
> ! rs=99999.
> endif
>
>
> ! Correct stomatal resistance for effect of dew and rain
> !*******************************************************
>
> if ((rh.gt.0.9).or.(rr.gt.0.)) rs=rs*3.
>
> ! Compute the lower canopy resistance
> !************************************
>
> rdc=100.*(1.+1000./(gr+10.))
>
>
> corr=1000.*exp(-1.*t-4.)
> do ic=1,nc
> if (reldiff(ic).gt.0.) then
>
> ! Compute combined stomatal and mesophyll resistance
> !***************************************************
>
> rsm=rs*reldiff(ic)+rm(ic)
>
> ! Correct leaf cuticular, lower canopy and ground resistance
> !***********************************************************
>
> rluc=rlu(ic,i,j)+corr
> rclc=rcl(ic,i,j)+corr
> rgsc=rgs(ic,i,j)+corr
>
> ! Correct leaf cuticular resistance for effect of dew and rain
> !*************************************************************
>
> if (rr.gt.0.) then
> rluo=1./(1./1000.+1./(3.*rluc))
> rluc=1./(1./(3.*rluc)+1.e-7*henry(ic)+f0(ic)/rluo)
> else if (rh.gt.0.9) then
> rluo=1./(1./3000.+1./(3.*rluc))
> rluc=1./(1./(3.*rluc)+1.e-7*henry(ic)+f0(ic)/rluo)
> endif
>
> ! Combine resistances to give total resistance
> !*********************************************
>
> rc(ic)=1./(1./rsm+1./rluc+1./(rdc+rclc)+1./(rac(i,j)+rgsc))
> ! Sabine Eckhardt, Dec 06: avoid possible excessively high vdep
> if (rc(ic).lt.10.) rc(ic)=10.
> endif
> end do
>
> end subroutine getrc
get_settling.f90
----------------------------------------------
1,147c1,147
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine get_settling(itime,xt,yt,zt,nsp,settling)
< ! i i i i i o
< !*****************************************************************************
< ! *
< ! This subroutine calculates particle settling velocity. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! May 2010 *
< ! *
< ! Improvement over traditional settling calculation in FLEXPART: *
< ! generalize to higher Reynolds numbers and also take into account the *
< ! temperature dependence of dynamic viscosity. *
< ! *
< ! Based on: *
< ! Naeslund E., and Thaning, L. (1991): On the settling velocity in a *
< ! nonstationary atmosphere, Aerosol Science and Technology 14, 247-256. *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! itime [s] current temporal position *
< ! xt,yt,zt coordinates position for which wind data shall be cal- *
< ! culated *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: itime,indz
< real :: xt,yt,zt
<
< ! Auxiliary variables needed for interpolation
< real :: dz1,dz2,dz
< real :: rho1(2),tt1(2),temperature,airdens,vis_dyn,vis_kin,viscosity
< real :: settling,settling_old,reynolds,c_d
< integer :: i,n,nix,njy,indzh,nsp
<
<
< !*****************************************************************************
< ! 1. Interpolate temperature and density: nearest neighbor interpolation sufficient
< !*****************************************************************************
<
< nix=int(xt)
< njy=int(yt)
<
< ! Determine the level below the current position for u,v
< !*******************************************************
<
< do i=2,nz
< if (height(i).gt.zt) then
< indz=i-1
< goto 6
< endif
< end do
< 6 continue
<
<
< ! Vertical distance to the level below and above current position
< !****************************************************************
<
< dz=1./(height(indz+1)-height(indz))
< dz1=(zt-height(indz))*dz
< dz2=(height(indz+1)-zt)*dz
<
<
< ! Bilinear horizontal interpolation
< !**********************************
<
< ! Loop over 2 levels
< !*******************
<
< do n=1,2
< indzh=indz+n-1
< rho1(n)=rho(nix,njy,indzh,1)
< tt1(n)=tt(nix,njy,indzh,1)
< end do
<
<
< ! Linear vertical interpolation
< !******************************
<
< temperature=dz2*tt1(1)+dz1*tt1(2)
< airdens=dz2*rho1(1)+dz1*rho1(2)
<
<
< vis_dyn=viscosity(temperature)
< vis_kin=vis_dyn/airdens
<
< reynolds=dquer(nsp)/1.e6*abs(vsetaver(nsp))/vis_kin
<
<
<
< ! Iteration to determine both Reynolds number and settling velocity
< !******************************************************************
<
< settling_old=vsetaver(nsp) ! initialize iteration with Stokes' law, constant viscosity estimate
<
< do i=1,20 ! do a few iterations
<
< if (reynolds.lt.1.917) then
< c_d=24./reynolds
< else if (reynolds.lt.500.) then
< c_d=18.5/(reynolds**0.6)
< else
< c_d=0.44
< endif
<
< settling=-1.* &
< sqrt(4*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ &
< (3.*c_d*airdens))
<
< if (abs((settling-settling_old)/settling).lt.0.01) goto 11 ! stop iteration
<
< reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin
< settling_old=settling
< end do
<
< 11 continue
<
< end subroutine get_settling
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine get_settling(itime,xt,yt,zt,nsp,settling)
> ! i i i i i o
> !*****************************************************************************
> ! *
> ! This subroutine calculates particle settling velocity. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! May 2010 *
> ! *
> ! Improvement over traditional settling calculation in FLEXPART: *
> ! generalize to higher Reynolds numbers and also take into account the *
> ! temperature dependence of dynamic viscosity. *
> ! *
> ! Based on: *
> ! Naeslund E., and Thaning, L. (1991): On the settling velocity in a *
> ! nonstationary atmosphere, Aerosol Science and Technology 14, 247-256. *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! itime [s] current temporal position *
> ! xt,yt,zt coordinates position for which wind data shall be cal- *
> ! culated *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: itime,indz
> real :: xt,yt,zt
>
> ! Auxiliary variables needed for interpolation
> real :: dz1,dz2,dz
> real :: rho1(2),tt1(2),temperature,airdens,vis_dyn,vis_kin,viscosity
> real :: settling,settling_old,reynolds,c_d
> integer :: i,n,nix,njy,indzh,nsp
>
>
> !*****************************************************************************
> ! 1. Interpolate temperature and density: nearest neighbor interpolation sufficient
> !*****************************************************************************
>
> nix=int(xt)
> njy=int(yt)
>
> ! Determine the level below the current position for u,v
> !*******************************************************
>
> do i=2,nz
> if (height(i).gt.zt) then
> indz=i-1
> goto 6
> endif
> end do
> 6 continue
>
>
> ! Vertical distance to the level below and above current position
> !****************************************************************
>
> dz=1./(height(indz+1)-height(indz))
> dz1=(zt-height(indz))*dz
> dz2=(height(indz+1)-zt)*dz
>
>
> ! Bilinear horizontal interpolation
> !**********************************
>
> ! Loop over 2 levels
> !*******************
>
> do n=1,2
> indzh=indz+n-1
> rho1(n)=rho(nix,njy,indzh,1)
> tt1(n)=tt(nix,njy,indzh,1)
> end do
>
>
> ! Linear vertical interpolation
> !******************************
>
> temperature=dz2*tt1(1)+dz1*tt1(2)
> airdens=dz2*rho1(1)+dz1*rho1(2)
>
>
> vis_dyn=viscosity(temperature)
> vis_kin=vis_dyn/airdens
>
> reynolds=dquer(nsp)/1.e6*abs(vsetaver(nsp))/vis_kin
>
>
>
> ! Iteration to determine both Reynolds number and settling velocity
> !******************************************************************
>
> settling_old=vsetaver(nsp) ! initialize iteration with Stokes' law, constant viscosity estimate
>
> do i=1,20 ! do a few iterations
>
> if (reynolds.lt.1.917) then
> c_d=24./reynolds
> else if (reynolds.lt.500.) then
> c_d=18.5/(reynolds**0.6)
> else
> c_d=0.44
> endif
>
> settling=-1.* &
> sqrt(4*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ &
> (3.*c_d*airdens))
>
> if (abs((settling-settling_old)/settling).lt.0.01) goto 11 ! stop iteration
>
> reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin
> settling_old=settling
> end do
>
> 11 continue
>
> end subroutine get_settling
getvdep.f90
----------------------------------------------
1,203c1,203
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine getvdep(n,ix,jy,ust,temp,pa,L,gr,rh,rr,snow,vdepo)
< ! i i i i i i i i i i i o
< !*****************************************************************************
< ! *
< ! This routine calculates the dry deposition velocities. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 20 December 1996 *
< ! Sabine Eckhardt, Jan 07 *
< ! if the latitude is negative: add half a year to the julian day *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! gr [W/m2] global radiation *
< ! L [m] Obukhov length *
< ! nyl kinematic viscosity *
< ! pa [Pa] surface air pressure *
< ! ra [s/m] aerodynamic resistance *
< ! raquer [s/m] average aerodynamic resistance *
< ! rh [0-1] relative humidity *
< ! rhoa density of the air *
< ! rr [mm/h] precipitation rate *
< ! temp [K] 2m temperature *
< ! tc [C] 2m temperature *
< ! ust [m/s] friction velocity *
< ! snow [m of water equivalent] snow depth *
< ! xlanduse fractions of numclasS landuses for each model grid point *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: yyyymmdd,hhmmss,yyyy,mmdd,n,lseason,i,j,ix,jy
< real :: vdepo(maxspec),vd,rb(maxspec),rc(maxspec),raquer,ylat
< real :: raerod,ra,ust,temp,tc,pa,L,gr,rh,rr,myl,nyl,rhoa,diffh2o,snow
< real :: slanduse(numclass)
< real,parameter :: eps=1.e-5
< real(kind=dp) :: jul
<
< ! Calculate month and determine the seasonal category
< !****************************************************
<
< jul=bdate+real(wftime(n),kind=dp)/86400._dp
<
< ylat=jy*dy+ylat0
< if (ylat.lt.0) then
< jul=jul+365/2
< endif
<
<
< call caldate(jul,yyyymmdd,hhmmss)
< yyyy=yyyymmdd/10000
< mmdd=yyyymmdd-10000*yyyy
<
< if ((ylat.gt.-20).and.(ylat.lt.20)) then
< mmdd=600 ! summer
< endif
<
< if ((mmdd.ge.1201).or.(mmdd.le.301)) then
< lseason=4
< else if ((mmdd.ge.1101).or.(mmdd.le.331)) then
< lseason=3
< else if ((mmdd.ge.401).and.(mmdd.le.515)) then
< lseason=5
< else if ((mmdd.ge.516).and.(mmdd.le.915)) then
< lseason=1
< else
< lseason=2
< endif
<
< ! Calculate diffusivity of water vapor
< !************************************
< diffh2o=2.11e-5*(temp/273.15)**1.94*(101325/pa)
<
< ! Conversion of temperature from K to C
< !**************************************
<
< tc=temp-273.15
<
< ! Calculate dynamic viscosity
< !****************************
<
< if (tc.lt.0) then
< myl=(1.718+0.0049*tc-1.2e-05*tc**2)*1.e-05
< else
< myl=(1.718+0.0049*tc)*1.e-05
< endif
<
< ! Calculate kinematic viscosity
< !******************************
<
< rhoa=pa/(287.*temp)
< nyl=myl/rhoa
<
<
< ! 0. Set all deposition velocities zero
< !**************************************
<
< do i=1,nspec
< vdepo(i)=0.
< end do
<
<
< ! 1. Compute surface layer resistances rb
< !****************************************
<
< call getrb(nspec,ust,nyl,diffh2o,reldiff,rb)
<
< ! change for snow
< do j=1,numclass
< if (snow.gt.0.001) then ! 10 mm
< if (j.eq.12) then
< slanduse(j)=1.
< else
< slanduse(j)=0.
< endif
< else
< slanduse(j)=xlanduse(ix,jy,j)
< endif
< end do
<
< raquer=0.
< do j=1,numclass ! loop over all landuse classes
<
< if (slanduse(j).gt.eps) then
<
< ! 2. Calculate aerodynamic resistance ra
< !***************************************
<
< ra=raerod(L,ust,z0(j))
< raquer=raquer+ra*slanduse(j)
<
< ! 3. Calculate surface resistance for gases
< !******************************************
<
< call getrc(nspec,lseason,j,tc,gr,rh,rr,rc)
<
< ! 4. Calculate deposition velocities for gases and ...
< ! 5. ... sum deposition velocities for all landuse classes
< !*********************************************************
<
< do i=1,nspec
< if (reldiff(i).gt.0.) then
< if ((ra+rb(i)+rc(i)).gt.0.) then
< vd=1./(ra+rb(i)+rc(i))
< ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
< ! vd=1./rc(i)
< ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
< else
< vd=9.999
< endif
< vdepo(i)=vdepo(i)+vd*slanduse(j)
< endif
< end do
< endif
< end do
<
<
< ! 6. Calculate deposition velocities for particles
< !*************************************************
<
< call partdep(nspec,density,fract,schmi,vset,raquer,ust,nyl,vdepo)
<
<
< ! 7. If no detailed parameterization available, take constant deposition
< ! velocity if that is available
< !***********************************************************************
<
< do i=1,nspec
< if ((reldiff(i).lt.0.).and.(density(i).lt.0.).and. &
< (dryvel(i).gt.0.)) then
< vdepo(i)=dryvel(i)
< endif
< end do
<
<
< end subroutine getvdep
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine getvdep(n,ix,jy,ust,temp,pa,L,gr,rh,rr,snow,vdepo)
> ! i i i i i i i i i i i o
> !*****************************************************************************
> ! *
> ! This routine calculates the dry deposition velocities. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 20 December 1996 *
> ! Sabine Eckhardt, Jan 07 *
> ! if the latitude is negative: add half a year to the julian day *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! gr [W/m2] global radiation *
> ! L [m] Obukhov length *
> ! nyl kinematic viscosity *
> ! pa [Pa] surface air pressure *
> ! ra [s/m] aerodynamic resistance *
> ! raquer [s/m] average aerodynamic resistance *
> ! rh [0-1] relative humidity *
> ! rhoa density of the air *
> ! rr [mm/h] precipitation rate *
> ! temp [K] 2m temperature *
> ! tc [C] 2m temperature *
> ! ust [m/s] friction velocity *
> ! snow [m of water equivalent] snow depth *
> ! xlanduse fractions of numclasS landuses for each model grid point *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: yyyymmdd,hhmmss,yyyy,mmdd,n,lseason,i,j,ix,jy
> real :: vdepo(maxspec),vd,rb(maxspec),rc(maxspec),raquer,ylat
> real :: raerod,ra,ust,temp,tc,pa,L,gr,rh,rr,myl,nyl,rhoa,diffh2o,snow
> real :: slanduse(numclass)
> real,parameter :: eps=1.e-5
> real(kind=dp) :: jul
>
> ! Calculate month and determine the seasonal category
> !****************************************************
>
> jul=bdate+real(wftime(n),kind=dp)/86400._dp
>
> ylat=jy*dy+ylat0
> if (ylat.lt.0) then
> jul=jul+365/2
> endif
>
>
> call caldate(jul,yyyymmdd,hhmmss)
> yyyy=yyyymmdd/10000
> mmdd=yyyymmdd-10000*yyyy
>
> if ((ylat.gt.-20).and.(ylat.lt.20)) then
> mmdd=600 ! summer
> endif
>
> if ((mmdd.ge.1201).or.(mmdd.le.301)) then
> lseason=4
> else if ((mmdd.ge.1101).or.(mmdd.le.331)) then
> lseason=3
> else if ((mmdd.ge.401).and.(mmdd.le.515)) then
> lseason=5
> else if ((mmdd.ge.516).and.(mmdd.le.915)) then
> lseason=1
> else
> lseason=2
> endif
>
> ! Calculate diffusivity of water vapor
> !************************************
> diffh2o=2.11e-5*(temp/273.15)**1.94*(101325/pa)
>
> ! Conversion of temperature from K to C
> !**************************************
>
> tc=temp-273.15
>
> ! Calculate dynamic viscosity
> !****************************
>
> if (tc.lt.0) then
> myl=(1.718+0.0049*tc-1.2e-05*tc**2)*1.e-05
> else
> myl=(1.718+0.0049*tc)*1.e-05
> endif
>
> ! Calculate kinematic viscosity
> !******************************
>
> rhoa=pa/(287.*temp)
> nyl=myl/rhoa
>
>
> ! 0. Set all deposition velocities zero
> !**************************************
>
> do i=1,nspec
> vdepo(i)=0.
> end do
>
>
> ! 1. Compute surface layer resistances rb
> !****************************************
>
> call getrb(nspec,ust,nyl,diffh2o,reldiff,rb)
>
> ! change for snow
> do j=1,numclass
> if (snow.gt.0.001) then ! 10 mm
> if (j.eq.12) then
> slanduse(j)=1.
> else
> slanduse(j)=0.
> endif
> else
> slanduse(j)=xlanduse(ix,jy,j)
> endif
> end do
>
> raquer=0.
> do j=1,numclass ! loop over all landuse classes
>
> if (slanduse(j).gt.eps) then
>
> ! 2. Calculate aerodynamic resistance ra
> !***************************************
>
> ra=raerod(L,ust,z0(j))
> raquer=raquer+ra*slanduse(j)
>
> ! 3. Calculate surface resistance for gases
> !******************************************
>
> call getrc(nspec,lseason,j,tc,gr,rh,rr,rc)
>
> ! 4. Calculate deposition velocities for gases and ...
> ! 5. ... sum deposition velocities for all landuse classes
> !*********************************************************
>
> do i=1,nspec
> if (reldiff(i).gt.0.) then
> if ((ra+rb(i)+rc(i)).gt.0.) then
> vd=1./(ra+rb(i)+rc(i))
> ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
> ! vd=1./rc(i)
> ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
> else
> vd=9.999
> endif
> vdepo(i)=vdepo(i)+vd*slanduse(j)
> endif
> end do
> endif
> end do
>
>
> ! 6. Calculate deposition velocities for particles
> !*************************************************
>
> call partdep(nspec,density,fract,schmi,vset,raquer,ust,nyl,vdepo)
>
>
> ! 7. If no detailed parameterization available, take constant deposition
> ! velocity if that is available
> !***********************************************************************
>
> do i=1,nspec
> if ((reldiff(i).lt.0.).and.(density(i).lt.0.).and. &
> (dryvel(i).gt.0.)) then
> vdepo(i)=dryvel(i)
> endif
> end do
>
>
> end subroutine getvdep
getvdep_nests.f90
----------------------------------------------
1,204c1,204
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine getvdep_nests(n,ix,jy,ust,temp,pa, &
< L,gr,rh,rr,snow,vdepo,lnest)
< ! i i i i i i i i i i i o i
< !*****************************************************************************
< ! *
< ! This routine calculates the dry deposition velocities. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 20 December 1996 *
< ! Sabine Eckhardt, Jan 07 *
< ! if the latitude is negative: add half a year to the julian day *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! gr [W/m2] global radiation *
< ! L [m] Obukhov length *
< ! nyl kinematic viscosity *
< ! pa [Pa] surface air pressure *
< ! ra [s/m] aerodynamic resistance *
< ! raquer [s/m] average aerodynamic resistance *
< ! rh [0-1] relative humidity *
< ! rhoa density of the air *
< ! rr [mm/h] precipitation rate *
< ! temp [K] 2m temperature *
< ! tc [C] 2m temperature *
< ! ust [m/s] friction velocity *
< ! snow [m of water equivalent] snow depth *
< ! xlanduse fractions of numclasS landuses for each model grid point *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: yyyymmdd,hhmmss,yyyy,mmdd,n,lseason,i,j,ix,jy,lnest
< real :: vdepo(maxspec),vd,rb(maxspec),rc(maxspec),raquer,ylat
< real :: raerod,ra,ust,temp,tc,pa,L,gr,rh,rr,myl,nyl,rhoa,diffh2o,snow
< real :: slanduse(numclass)
< real,parameter :: eps=1.e-5
< real(kind=dp) :: jul
<
< ! Calculate month and determine the seasonal category
< !****************************************************
<
< jul=bdate+real(wftime(n),kind=dp)/86400._dp
<
< ylat=jy*dy+ylat0
< if (ylat.lt.0) then
< jul=jul+365/2
< endif
<
<
< call caldate(jul,yyyymmdd,hhmmss)
< yyyy=yyyymmdd/10000
< mmdd=yyyymmdd-10000*yyyy
<
< if ((ylat.gt.-20).and.(ylat.lt.20)) then
< mmdd=600 ! summer
< endif
<
< if ((mmdd.ge.1201).or.(mmdd.le.301)) then
< lseason=4
< else if ((mmdd.ge.1101).or.(mmdd.le.331)) then
< lseason=3
< else if ((mmdd.ge.401).and.(mmdd.le.515)) then
< lseason=5
< else if ((mmdd.ge.516).and.(mmdd.le.915)) then
< lseason=1
< else
< lseason=2
< endif
<
< ! Calculate diffusivity of water vapor
< !************************************
< diffh2o=2.11e-5*(temp/273.15)**1.94*(101325/pa)
<
< ! Conversion of temperature from K to C
< !**************************************
<
< tc=temp-273.15
<
< ! Calculate dynamic viscosity
< !****************************
<
< if (tc.lt.0) then
< myl=(1.718+0.0049*tc-1.2e-05*tc**2)*1.e-05
< else
< myl=(1.718+0.0049*tc)*1.e-05
< endif
<
< ! Calculate kinematic viscosity
< !******************************
<
< rhoa=pa/(287.*temp)
< nyl=myl/rhoa
<
<
< ! 0. Set all deposition velocities zero
< !**************************************
<
< do i=1,nspec
< vdepo(i)=0.
< end do
<
<
< ! 1. Compute surface layer resistances rb
< !****************************************
<
< call getrb(nspec,ust,nyl,diffh2o,reldiff,rb)
<
< ! change for snow
< do j=1,numclass
< if (snow.gt.0.001) then ! 10 mm
< if (j.eq.12) then
< slanduse(j)=1.
< else
< slanduse(j)=0.
< endif
< else
< slanduse(j)=xlandusen(ix,jy,j,lnest)
< endif
< end do
<
< raquer=0.
< do j=1,numclass ! loop over all landuse classes
<
< if (slanduse(j).gt.eps) then
<
< ! 2. Calculate aerodynamic resistance ra
< !***************************************
<
< ra=raerod(L,ust,z0(j))
< raquer=raquer+ra*slanduse(j)
<
< ! 3. Calculate surface resistance for gases
< !******************************************
<
< call getrc(nspec,lseason,j,tc,gr,rh,rr,rc)
<
< ! 4. Calculate deposition velocities for gases and ...
< ! 5. ... sum deposition velocities for all landuse classes
< !*********************************************************
<
< do i=1,nspec
< if (reldiff(i).gt.0.) then
< if ((ra+rb(i)+rc(i)).gt.0.) then
< vd=1./(ra+rb(i)+rc(i))
< ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
< ! vd=1./rc(i)
< ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
< else
< vd=9.999
< endif
< vdepo(i)=vdepo(i)+vd*slanduse(j)
< endif
< end do
< endif
< end do
<
<
< ! 6. Calculate deposition velocities for particles
< !*************************************************
<
< call partdep(nspec,density,fract,schmi,vset,raquer,ust,nyl,vdepo)
<
<
< ! 7. If no detailed parameterization available, take constant deposition
< ! velocity if that is available
< !***********************************************************************
<
< do i=1,nspec
< if ((reldiff(i).lt.0.).and.(density(i).lt.0.).and. &
< (dryvel(i).gt.0.)) then
< vdepo(i)=dryvel(i)
< endif
< end do
<
<
< end subroutine getvdep_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine getvdep_nests(n,ix,jy,ust,temp,pa, &
> L,gr,rh,rr,snow,vdepo,lnest)
> ! i i i i i i i i i i i o i
> !*****************************************************************************
> ! *
> ! This routine calculates the dry deposition velocities. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 20 December 1996 *
> ! Sabine Eckhardt, Jan 07 *
> ! if the latitude is negative: add half a year to the julian day *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! gr [W/m2] global radiation *
> ! L [m] Obukhov length *
> ! nyl kinematic viscosity *
> ! pa [Pa] surface air pressure *
> ! ra [s/m] aerodynamic resistance *
> ! raquer [s/m] average aerodynamic resistance *
> ! rh [0-1] relative humidity *
> ! rhoa density of the air *
> ! rr [mm/h] precipitation rate *
> ! temp [K] 2m temperature *
> ! tc [C] 2m temperature *
> ! ust [m/s] friction velocity *
> ! snow [m of water equivalent] snow depth *
> ! xlanduse fractions of numclasS landuses for each model grid point *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: yyyymmdd,hhmmss,yyyy,mmdd,n,lseason,i,j,ix,jy,lnest
> real :: vdepo(maxspec),vd,rb(maxspec),rc(maxspec),raquer,ylat
> real :: raerod,ra,ust,temp,tc,pa,L,gr,rh,rr,myl,nyl,rhoa,diffh2o,snow
> real :: slanduse(numclass)
> real,parameter :: eps=1.e-5
> real(kind=dp) :: jul
>
> ! Calculate month and determine the seasonal category
> !****************************************************
>
> jul=bdate+real(wftime(n),kind=dp)/86400._dp
>
> ylat=jy*dy+ylat0
> if (ylat.lt.0) then
> jul=jul+365/2
> endif
>
>
> call caldate(jul,yyyymmdd,hhmmss)
> yyyy=yyyymmdd/10000
> mmdd=yyyymmdd-10000*yyyy
>
> if ((ylat.gt.-20).and.(ylat.lt.20)) then
> mmdd=600 ! summer
> endif
>
> if ((mmdd.ge.1201).or.(mmdd.le.301)) then
> lseason=4
> else if ((mmdd.ge.1101).or.(mmdd.le.331)) then
> lseason=3
> else if ((mmdd.ge.401).and.(mmdd.le.515)) then
> lseason=5
> else if ((mmdd.ge.516).and.(mmdd.le.915)) then
> lseason=1
> else
> lseason=2
> endif
>
> ! Calculate diffusivity of water vapor
> !************************************
> diffh2o=2.11e-5*(temp/273.15)**1.94*(101325/pa)
>
> ! Conversion of temperature from K to C
> !**************************************
>
> tc=temp-273.15
>
> ! Calculate dynamic viscosity
> !****************************
>
> if (tc.lt.0) then
> myl=(1.718+0.0049*tc-1.2e-05*tc**2)*1.e-05
> else
> myl=(1.718+0.0049*tc)*1.e-05
> endif
>
> ! Calculate kinematic viscosity
> !******************************
>
> rhoa=pa/(287.*temp)
> nyl=myl/rhoa
>
>
> ! 0. Set all deposition velocities zero
> !**************************************
>
> do i=1,nspec
> vdepo(i)=0.
> end do
>
>
> ! 1. Compute surface layer resistances rb
> !****************************************
>
> call getrb(nspec,ust,nyl,diffh2o,reldiff,rb)
>
> ! change for snow
> do j=1,numclass
> if (snow.gt.0.001) then ! 10 mm
> if (j.eq.12) then
> slanduse(j)=1.
> else
> slanduse(j)=0.
> endif
> else
> slanduse(j)=xlandusen(ix,jy,j,lnest)
> endif
> end do
>
> raquer=0.
> do j=1,numclass ! loop over all landuse classes
>
> if (slanduse(j).gt.eps) then
>
> ! 2. Calculate aerodynamic resistance ra
> !***************************************
>
> ra=raerod(L,ust,z0(j))
> raquer=raquer+ra*slanduse(j)
>
> ! 3. Calculate surface resistance for gases
> !******************************************
>
> call getrc(nspec,lseason,j,tc,gr,rh,rr,rc)
>
> ! 4. Calculate deposition velocities for gases and ...
> ! 5. ... sum deposition velocities for all landuse classes
> !*********************************************************
>
> do i=1,nspec
> if (reldiff(i).gt.0.) then
> if ((ra+rb(i)+rc(i)).gt.0.) then
> vd=1./(ra+rb(i)+rc(i))
> ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
> ! vd=1./rc(i)
> ! XXXXXXXXXXXXXXXXXXXXXXXXXX TEST
> else
> vd=9.999
> endif
> vdepo(i)=vdepo(i)+vd*slanduse(j)
> endif
> end do
> endif
> end do
>
>
> ! 6. Calculate deposition velocities for particles
> !*************************************************
>
> call partdep(nspec,density,fract,schmi,vset,raquer,ust,nyl,vdepo)
>
>
> ! 7. If no detailed parameterization available, take constant deposition
> ! velocity if that is available
> !***********************************************************************
>
> do i=1,nspec
> if ((reldiff(i).lt.0.).and.(density(i).lt.0.).and. &
> (dryvel(i).gt.0.)) then
> vdepo(i)=dryvel(i)
> endif
> end do
>
>
> end subroutine getvdep_nests
gridcheck.f90
----------------------------------------------
1,554c1,554
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine gridcheck
<
< !**********************************************************************
< ! *
< ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
< ! *
< !**********************************************************************
< ! *
< ! AUTHOR: G. WOTAWA *
< ! DATE: 1997-08-06 *
< ! LAST UPDATE: 1997-10-10 *
< ! *
< ! Update: 1999-02-08, global fields allowed, A. Stohl*
< ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
< ! ECMWF grib_api *
< ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
< ! ECMWF grib_api *
< ! *
< !**********************************************************************
< ! *
< ! DESCRIPTION: *
< ! *
< ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
< ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
< ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
< ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
< ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
< ! ANY CALL. *
< ! *
< ! XLON0 geographical longitude of lower left gridpoint *
< ! YLAT0 geographical latitude of lower left gridpoint *
< ! NX number of grid points x-direction *
< ! NY number of grid points y-direction *
< ! DX grid distance x-direction *
< ! DY grid distance y-direction *
< ! NUVZ number of grid points for horizontal wind *
< ! components in z direction *
< ! NWZ number of grid points for vertical wind *
< ! component in z direction *
< ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
< ! points of the polar stereographic grid): *
< ! used to check the CFL criterion *
< ! UVHEIGHT(1)- heights of gridpoints where u and v are *
< ! UVHEIGHT(NUVZ) given *
< ! WHEIGHT(1)- heights of gridpoints where w is given *
< ! WHEIGHT(NWZ) *
< ! *
< !**********************************************************************
<
< use grib_api
< use par_mod
< use com_mod
< use conv_mod
< use cmapf_mod, only: stlmbr,stcm2p
<
< implicit none
<
< !HSO parameters for grib_api
< integer :: ifile
< integer :: iret
< integer :: igrib
< integer :: gotGrid
< real(kind=4) :: xaux1,xaux2,yaux1,yaux2
< real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
< integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
< !HSO end
< integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
< real :: sizesouth,sizenorth,xauxa,pint
<
< ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
<
< ! dimension of isec2 at least (22+n), where n is the number of parallels or
< ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
<
< ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
< ! coordinate parameters
<
< integer :: isec1(56),isec2(22+nxmax+nymax)
< !real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp)
< real(kind=4) :: zsec2(184),zsec4(jpunp)
< character(len=1) :: opt
<
< !HSO grib api error messages
< character(len=24) :: gribErrorMsg = 'Error reading grib file'
< character(len=20) :: gribFunction = 'gridcheck'
<
< iumax=0
< iwmax=0
<
< if(ideltas.gt.0) then
< ifn=1
< else
< ifn=numbwf
< endif
< !
< ! OPENING OF DATA FILE (GRIB CODE)
< !
< 5 call grib_open_file(ifile,path(3)(1:length(3)) &
< //trim(wfname(ifn)),'r',iret)
< if (iret.ne.GRIB_SUCCESS) then
< goto 999 ! ERROR DETECTED
< endif
< !turn on support for multi fields messages
< !call grib_multi_support_on
<
< gotGrid=0
< ifield=0
< 10 ifield=ifield+1
<
< !
< ! GET NEXT FIELDS
< !
< call grib_new_from_file(ifile,igrib,iret)
< if (iret.eq.GRIB_END_OF_FILE ) then
< goto 30 ! EOF DETECTED
< elseif (iret.ne.GRIB_SUCCESS) then
< goto 999 ! ERROR DETECTED
< endif
<
< !first see if we read GRIB1 or GRIB2
< call grib_get_int(igrib,'editionNumber',gribVer,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< if (gribVer.eq.1) then ! GRIB Edition 1
<
< !print*,'GRiB Edition 1'
< !read the grib2 identifiers
< call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',isec1(8),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !change code for etadot to code for omega
< if (isec1(6).eq.77) then
< isec1(6)=135
< endif
<
< !print*,isec1(6),isec1(8)
<
< else
<
< !print*,'GRiB Edition 2'
< !read the grib2 identifiers
< call grib_get_int(igrib,'discipline',discipl,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterCategory',parCat,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterNumber',parNum,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',valSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !print*,discipl,parCat,parNum,typSurf,valSurf
<
< !convert to grib1 identifiers
< isec1(6)=-1
< isec1(7)=-1
< isec1(8)=-1
< isec1(8)=valSurf ! level
< if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
< isec1(6)=130 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
< isec1(6)=131 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
< isec1(6)=132 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
< isec1(6)=133 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
< isec1(6)=134 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
< isec1(6)=135 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
< isec1(6)=151 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
< isec1(6)=165 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
< isec1(6)=166 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
< isec1(6)=167 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
< isec1(6)=168 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
< isec1(6)=141 ! indicatorOfParameter
< elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
< isec1(6)=164 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
< isec1(6)=142 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
< isec1(6)=143 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
< isec1(6)=146 ! indicatorOfParameter
< elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
< isec1(6)=176 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
< isec1(6)=180 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
< isec1(6)=181 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
< isec1(6)=129 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
< isec1(6)=160 ! indicatorOfParameter
< elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
< (typSurf.eq.1)) then ! LSM
< isec1(6)=172 ! indicatorOfParameter
< else
< print*,'***ERROR: undefined GRiB2 message found!',discipl, &
< parCat,parNum,typSurf
< endif
<
< endif
<
< !get the size and data of the values array
< if (isec1(6).ne.-1) then
< call grib_get_real4_array(igrib,'values',zsec4,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< endif
<
< if (ifield.eq.1) then
<
< !HSO get the required fields from section 2 in a gribex compatible manner
< call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
< isec2(2),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
< isec2(3),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
< xaux1in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
< isec2(12),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< ! get the size and data of the vertical coordinate array
< call grib_get_real4_array(igrib,'pv',zsec2,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< nxfield=isec2(2)
< ny=isec2(3)
< nlev_ec=isec2(12)/2-1
< endif
<
< !HSO get the second part of the grid dimensions only from GRiB1 messages
< if ((gribVer.eq.1).and.(gotGrid.eq.0)) then
< call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
< xaux2in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
< yaux1in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
< yaux2in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< xaux1=xaux1in
< xaux2=xaux2in
< yaux1=yaux1in
< yaux2=yaux2in
< if (xaux1.gt.180.) xaux1=xaux1-360.0
< if (xaux2.gt.180.) xaux2=xaux2-360.0
< if (xaux1.lt.-180.) xaux1=xaux1+360.0
< if (xaux2.lt.-180.) xaux2=xaux2+360.0
< if (xaux2.lt.xaux1) xaux2=xaux2+360.0
< xlon0=xaux1
< ylat0=yaux1
< dx=(xaux2-xaux1)/real(nxfield-1)
< dy=(yaux2-yaux1)/real(ny-1)
< dxconst=180./(dx*r_earth*pi)
< dyconst=180./(dy*r_earth*pi)
< gotGrid=1
<
< ! Check whether fields are global
< ! If they contain the poles, specify polar stereographic map
< ! projections using the stlmbr- and stcm2p-calls
< !***********************************************************
<
< xauxa=abs(xaux2+dx-360.-xaux1)
< if (xauxa.lt.0.001) then
< nx=nxfield+1 ! field is cyclic
< xglobal=.true.
< if (abs(nxshift).ge.nx) &
< stop 'nxshift in file par_mod is too large'
< xlon0=xlon0+real(nxshift)*dx
< else
< nx=nxfield
< xglobal=.false.
< if (nxshift.ne.0) &
< stop 'nxshift (par_mod) must be zero for non-global domain'
< endif
< nxmin1=nx-1
< nymin1=ny-1
< if (xlon0.gt.180.) xlon0=xlon0-360.
< xauxa=abs(yaux1+90.)
< if (xglobal.and.xauxa.lt.0.001) then
< sglobal=.true. ! field contains south pole
< ! Enhance the map scale by factor 3 (*2=6) compared to north-south
< ! map scale
< sizesouth=6.*(switchsouth+90.)/dy
< call stlmbr(southpolemap,-90.,0.)
< call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
< sizesouth,switchsouth,180.)
< switchsouthg=(switchsouth-ylat0)/dy
< else
< sglobal=.false.
< switchsouthg=999999.
< endif
< xauxa=abs(yaux2-90.)
< if (xglobal.and.xauxa.lt.0.001) then
< nglobal=.true. ! field contains north pole
< ! Enhance the map scale by factor 3 (*2=6) compared to north-south
< ! map scale
< sizenorth=6.*(90.-switchnorth)/dy
< call stlmbr(northpolemap,90.,0.)
< call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
< sizenorth,switchnorth,180.)
< switchnorthg=(switchnorth-ylat0)/dy
< else
< nglobal=.false.
< switchnorthg=999999.
< endif
< if (nxshift.lt.0) &
< stop 'nxshift (par_mod) must not be negative'
< if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
< endif ! gotGrid
<
< k=isec1(8)
< if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
< if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
<
< if(isec1(6).eq.129) then
< do jy=0,ny-1
< do ix=0,nxfield-1
< oro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)/ga
< end do
< end do
< endif
< if(isec1(6).eq.172) then
< do jy=0,ny-1
< do ix=0,nxfield-1
< lsm(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
< end do
< end do
< endif
< if(isec1(6).eq.160) then
< do jy=0,ny-1
< do ix=0,nxfield-1
< excessoro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
< end do
< end do
< endif
<
< call grib_release(igrib)
< goto 10 !! READ NEXT LEVEL OR PARAMETER
< !
< ! CLOSING OF INPUT DATA FILE
< !
<
< 30 call grib_close_file(ifile)
<
< !error message if no fields found with correct first longitude in it
< if (gotGrid.eq.0) then
< print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
< 'messages'
< stop
< endif
<
< nuvz=iumax
< nwz =iwmax
< if(nuvz.eq.nlev_ec) nwz=nlev_ec+1
<
< if (nx.gt.nxmax) then
< write(*,*) 'FLEXPART error: Too many grid points in x direction.'
< write(*,*) 'Reduce resolution of wind fields.'
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) nx,nxmax
< stop
< endif
<
< if (ny.gt.nymax) then
< write(*,*) 'FLEXPART error: Too many grid points in y direction.'
< write(*,*) 'Reduce resolution of wind fields.'
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) ny,nymax
< stop
< endif
<
< if (nuvz+1.gt.nuvzmax) then
< write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
< 'direction.'
< write(*,*) 'Reduce resolution of wind fields.'
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) nuvz+1,nuvzmax
< stop
< endif
<
< if (nwz.gt.nwzmax) then
< write(*,*) 'FLEXPART error: Too many w grid points in z '// &
< 'direction.'
< write(*,*) 'Reduce resolution of wind fields.'
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) nwz,nwzmax
< stop
< endif
<
< ! If desired, shift all grids by nxshift grid cells
< !**************************************************
<
< if (xglobal) then
< call shift_field_0(oro,nxfield,ny)
< call shift_field_0(lsm,nxfield,ny)
< call shift_field_0(excessoro,nxfield,ny)
< endif
<
< ! Output of grid info
< !********************
<
< write(*,*)
< write(*,*)
< write(*,'(a,2i7)') '# of vertical levels in ECMWF data: ', &
< nuvz+1,nwz
< write(*,*)
< write(*,'(a)') 'Mother domain:'
< write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
< xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
< write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
< ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
< write(*,*)
<
<
< ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
< ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
<
< numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
< ! by trajectory model
< !do 8940 i=1,244
< ! write (*,*) 'zsec2:',i,ifield,zsec2(i),numskip
< !940 continue
< ! stop
< ! SEC SEC SEC
< ! for unknown reason zsec 1 to 10 is filled in this version
< ! compared to the old one
< ! SEC SEC SE
< do i=1,nwz
< j=numskip+i
< k=nlev_ec+1+numskip+i
< akm(nwz-i+1)=zsec2(j)
< bkm(nwz-i+1)=zsec2(k)
< end do
<
< !
< ! CALCULATION OF AKZ, BKZ
< ! AKZ,BKZ: model discretization parameters at the center of each model
< ! layer
< !
< ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
< ! i.e. ground level
< !*****************************************************************************
<
< akz(1)=0.
< bkz(1)=1.0
< do i=1,nuvz
< akz(i+1)=0.5*(akm(i+1)+akm(i))
< bkz(i+1)=0.5*(bkm(i+1)+bkm(i))
< end do
< nuvz=nuvz+1
<
< ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
< ! upon the transformation to z levels. In order to save computer memory, this is
< ! not done anymore in the standard version. However, this option can still be
< ! switched on by replacing the following lines with those below, that are
< ! currently commented out. For this, similar changes are necessary in
< ! verttransform.f and verttranform_nests.f
< !*****************************************************************************
<
< nz=nuvz
< if (nz.gt.nzmax) stop 'nzmax too small'
< do i=1,nuvz
< aknew(i)=akz(i)
< bknew(i)=bkz(i)
< end do
<
< ! Switch on following lines to use doubled vertical resolution
< !*************************************************************
< !nz=nuvz+nwz-1
< !if (nz.gt.nzmax) stop 'nzmax too small'
< !do 100 i=1,nwz
< ! aknew(2*(i-1)+1)=akm(i)
< !00 bknew(2*(i-1)+1)=bkm(i)
< !do 110 i=2,nuvz
< ! aknew(2*(i-1))=akz(i)
< !10 bknew(2*(i-1))=bkz(i)
< ! End doubled vertical resolution
<
<
< ! Determine the uppermost level for which the convection scheme shall be applied
< ! by assuming that there is no convection above 50 hPa (for standard SLP)
< !*****************************************************************************
<
< do i=1,nuvz-2
< pint=akz(i)+bkz(i)*101325.
< if (pint.lt.5000.) goto 96
< end do
< 96 nconvlev=i
< if (nconvlev.gt.nconvlevmax-1) then
< nconvlev=nconvlevmax-1
< write(*,*) 'Attention, convection only calculated up to ', &
< akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
< endif
<
< return
<
< 999 write(*,*)
< write(*,*) ' ###########################################'// &
< '###### '
< write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
< write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
< write(*,*) ' ###########################################'// &
< '###### '
< write(*,*)
< write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
< write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
< write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
< write(*,'(a)') '!!! THE "X" KEY... !!!'
< write(*,*)
< read(*,'(a)') opt
< if(opt.eq.'X') then
< stop
< else
< goto 5
< endif
<
< end subroutine gridcheck
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine gridcheck
>
> !**********************************************************************
> ! *
> ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
> ! *
> !**********************************************************************
> ! *
> ! AUTHOR: G. WOTAWA *
> ! DATE: 1997-08-06 *
> ! LAST UPDATE: 1997-10-10 *
> ! *
> ! Update: 1999-02-08, global fields allowed, A. Stohl*
> ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
> ! ECMWF grib_api *
> ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
> ! ECMWF grib_api *
> ! *
> !**********************************************************************
> ! *
> ! DESCRIPTION: *
> ! *
> ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
> ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
> ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
> ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
> ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
> ! ANY CALL. *
> ! *
> ! XLON0 geographical longitude of lower left gridpoint *
> ! YLAT0 geographical latitude of lower left gridpoint *
> ! NX number of grid points x-direction *
> ! NY number of grid points y-direction *
> ! DX grid distance x-direction *
> ! DY grid distance y-direction *
> ! NUVZ number of grid points for horizontal wind *
> ! components in z direction *
> ! NWZ number of grid points for vertical wind *
> ! component in z direction *
> ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
> ! points of the polar stereographic grid): *
> ! used to check the CFL criterion *
> ! UVHEIGHT(1)- heights of gridpoints where u and v are *
> ! UVHEIGHT(NUVZ) given *
> ! WHEIGHT(1)- heights of gridpoints where w is given *
> ! WHEIGHT(NWZ) *
> ! *
> !**********************************************************************
>
> use grib_api
> use par_mod
> use com_mod
> use conv_mod
> use cmapf_mod, only: stlmbr,stcm2p
>
> implicit none
>
> !HSO parameters for grib_api
> integer :: ifile
> integer :: iret
> integer :: igrib
> integer :: gotGrid
> real(kind=4) :: xaux1,xaux2,yaux1,yaux2
> real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
> integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
> !HSO end
> integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
> real :: sizesouth,sizenorth,xauxa,pint
>
> ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
>
> ! dimension of isec2 at least (22+n), where n is the number of parallels or
> ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
>
> ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
> ! coordinate parameters
>
> integer :: isec1(56),isec2(22+nxmax+nymax)
> real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp)
> character(len=1) :: opt
>
> !HSO grib api error messages
> character(len=24) :: gribErrorMsg = 'Error reading grib file'
> character(len=20) :: gribFunction = 'gridcheck'
>
> iumax=0
> iwmax=0
>
> if(ideltas.gt.0) then
> ifn=1
> else
> ifn=numbwf
> endif
> !
> ! OPENING OF DATA FILE (GRIB CODE)
> !
> 5 call grib_open_file(ifile,path(3)(1:length(3)) &
> //trim(wfname(ifn)),'r',iret)
> if (iret.ne.GRIB_SUCCESS) then
> goto 999 ! ERROR DETECTED
> endif
> !turn on support for multi fields messages
> !call grib_multi_support_on
>
> gotGrid=0
> ifield=0
> 10 ifield=ifield+1
>
> !
> ! GET NEXT FIELDS
> !
> call grib_new_from_file(ifile,igrib,iret)
> if (iret.eq.GRIB_END_OF_FILE ) then
> goto 30 ! EOF DETECTED
> elseif (iret.ne.GRIB_SUCCESS) then
> goto 999 ! ERROR DETECTED
> endif
>
> !first see if we read GRIB1 or GRIB2
> call grib_get_int(igrib,'editionNumber',gribVer,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> if (gribVer.eq.1) then ! GRIB Edition 1
>
> !print*,'GRiB Edition 1'
> !read the grib2 identifiers
> call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',isec1(8),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !change code for etadot to code for omega
> if (isec1(6).eq.77) then
> isec1(6)=135
> endif
>
> !print*,isec1(6),isec1(8)
>
> else
>
> !print*,'GRiB Edition 2'
> !read the grib2 identifiers
> call grib_get_int(igrib,'discipline',discipl,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterCategory',parCat,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterNumber',parNum,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',valSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !print*,discipl,parCat,parNum,typSurf,valSurf
>
> !convert to grib1 identifiers
> isec1(6)=-1
> isec1(7)=-1
> isec1(8)=-1
> isec1(8)=valSurf ! level
> if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
> isec1(6)=130 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
> isec1(6)=131 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
> isec1(6)=132 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
> isec1(6)=133 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
> isec1(6)=134 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
> isec1(6)=135 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
> isec1(6)=151 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
> isec1(6)=165 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
> isec1(6)=166 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
> isec1(6)=167 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
> isec1(6)=168 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
> isec1(6)=141 ! indicatorOfParameter
> elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
> isec1(6)=164 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
> isec1(6)=142 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
> isec1(6)=143 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
> isec1(6)=146 ! indicatorOfParameter
> elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
> isec1(6)=176 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
> isec1(6)=180 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
> isec1(6)=181 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
> isec1(6)=129 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
> isec1(6)=160 ! indicatorOfParameter
> elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
> (typSurf.eq.1)) then ! LSM
> isec1(6)=172 ! indicatorOfParameter
> else
> print*,'***ERROR: undefined GRiB2 message found!',discipl, &
> parCat,parNum,typSurf
> endif
>
> endif
>
> !get the size and data of the values array
> if (isec1(6).ne.-1) then
> call grib_get_real4_array(igrib,'values',zsec4,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> endif
>
> if (ifield.eq.1) then
>
> !HSO get the required fields from section 2 in a gribex compatible manner
> call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
> isec2(2),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
> isec2(3),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
> xaux1in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
> isec2(12),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> ! get the size and data of the vertical coordinate array
> call grib_get_real4_array(igrib,'pv',zsec2,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> nxfield=isec2(2)
> ny=isec2(3)
> nlev_ec=isec2(12)/2-1
> endif
>
> !HSO get the second part of the grid dimensions only from GRiB1 messages
> if ((gribVer.eq.1).and.(gotGrid.eq.0)) then
> call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
> xaux2in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
> yaux1in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
> yaux2in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> xaux1=xaux1in
> xaux2=xaux2in
> yaux1=yaux1in
> yaux2=yaux2in
> if (xaux1.gt.180.) xaux1=xaux1-360.0
> if (xaux2.gt.180.) xaux2=xaux2-360.0
> if (xaux1.lt.-180.) xaux1=xaux1+360.0
> if (xaux2.lt.-180.) xaux2=xaux2+360.0
> if (xaux2.lt.xaux1) xaux2=xaux2+360.0
> xlon0=xaux1
> ylat0=yaux1
> dx=(xaux2-xaux1)/real(nxfield-1)
> dy=(yaux2-yaux1)/real(ny-1)
> dxconst=180./(dx*r_earth*pi)
> dyconst=180./(dy*r_earth*pi)
> gotGrid=1
>
> ! Check whether fields are global
> ! If they contain the poles, specify polar stereographic map
> ! projections using the stlmbr- and stcm2p-calls
> !***********************************************************
>
> xauxa=abs(xaux2+dx-360.-xaux1)
> if (xauxa.lt.0.001) then
> nx=nxfield+1 ! field is cyclic
> xglobal=.true.
> if (abs(nxshift).ge.nx) &
> stop 'nxshift in file par_mod is too large'
> xlon0=xlon0+real(nxshift)*dx
> else
> nx=nxfield
> xglobal=.false.
> if (nxshift.ne.0) &
> stop 'nxshift (par_mod) must be zero for non-global domain'
> endif
> nxmin1=nx-1
> nymin1=ny-1
> if (xlon0.gt.180.) xlon0=xlon0-360.
> xauxa=abs(yaux1+90.)
> if (xglobal.and.xauxa.lt.0.001) then
> sglobal=.true. ! field contains south pole
> ! Enhance the map scale by factor 3 (*2=6) compared to north-south
> ! map scale
> sizesouth=6.*(switchsouth+90.)/dy
> call stlmbr(southpolemap,-90.,0.)
> call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
> sizesouth,switchsouth,180.)
> switchsouthg=(switchsouth-ylat0)/dy
> else
> sglobal=.false.
> switchsouthg=999999.
> endif
> xauxa=abs(yaux2-90.)
> if (xglobal.and.xauxa.lt.0.001) then
> nglobal=.true. ! field contains north pole
> ! Enhance the map scale by factor 3 (*2=6) compared to north-south
> ! map scale
> sizenorth=6.*(90.-switchnorth)/dy
> call stlmbr(northpolemap,90.,0.)
> call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
> sizenorth,switchnorth,180.)
> switchnorthg=(switchnorth-ylat0)/dy
> else
> nglobal=.false.
> switchnorthg=999999.
> endif
> if (nxshift.lt.0) &
> stop 'nxshift (par_mod) must not be negative'
> if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
> endif ! gotGrid
>
> k=isec1(8)
> if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
> if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
>
> if(isec1(6).eq.129) then
> do jy=0,ny-1
> do ix=0,nxfield-1
> oro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)/ga
> end do
> end do
> endif
> if(isec1(6).eq.172) then
> do jy=0,ny-1
> do ix=0,nxfield-1
> lsm(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
> end do
> end do
> endif
> if(isec1(6).eq.160) then
> do jy=0,ny-1
> do ix=0,nxfield-1
> excessoro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)
> end do
> end do
> endif
>
> call grib_release(igrib)
> goto 10 !! READ NEXT LEVEL OR PARAMETER
> !
> ! CLOSING OF INPUT DATA FILE
> !
>
> 30 call grib_close_file(ifile)
>
> !error message if no fields found with correct first longitude in it
> if (gotGrid.eq.0) then
> print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
> 'messages'
> stop
> endif
>
> nuvz=iumax
> nwz =iwmax
> if(nuvz.eq.nlev_ec) nwz=nlev_ec+1
>
> if (nx.gt.nxmax) then
> write(*,*) 'FLEXPART error: Too many grid points in x direction.'
> write(*,*) 'Reduce resolution of wind fields.'
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) nx,nxmax
> stop
> endif
>
> if (ny.gt.nymax) then
> write(*,*) 'FLEXPART error: Too many grid points in y direction.'
> write(*,*) 'Reduce resolution of wind fields.'
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) ny,nymax
> stop
> endif
>
> if (nuvz+1.gt.nuvzmax) then
> write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
> 'direction.'
> write(*,*) 'Reduce resolution of wind fields.'
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) nuvz+1,nuvzmax
> stop
> endif
>
> if (nwz.gt.nwzmax) then
> write(*,*) 'FLEXPART error: Too many w grid points in z '// &
> 'direction.'
> write(*,*) 'Reduce resolution of wind fields.'
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) nwz,nwzmax
> stop
> endif
>
> ! If desired, shift all grids by nxshift grid cells
> !**************************************************
>
> if (xglobal) then
> call shift_field_0(oro,nxfield,ny)
> call shift_field_0(lsm,nxfield,ny)
> call shift_field_0(excessoro,nxfield,ny)
> endif
>
> ! Output of grid info
> !********************
>
> write(*,*)
> write(*,*)
> write(*,'(a,2i7)') '# of vertical levels in ECMWF data: ', &
> nuvz+1,nwz
> write(*,*)
> write(*,'(a)') 'Mother domain:'
> write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
> xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
> write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
> ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
> write(*,*)
>
>
> ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
> ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
>
> numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
> ! by trajectory model
> !do 8940 i=1,244
> ! write (*,*) 'zsec2:',i,ifield,zsec2(i),numskip
> !940 continue
> ! stop
> ! SEC SEC SEC
> ! for unknown reason zsec 1 to 10 is filled in this version
> ! compared to the old one
> ! SEC SEC SE
> do i=1,nwz
> j=numskip+i
> k=nlev_ec+1+numskip+i
> akm(nwz-i+1)=zsec2(j)
> ! write (*,*) 'ifield:',ifield,k,j,zsec2(10+j)
> bkm(nwz-i+1)=zsec2(k)
> end do
>
> !
> ! CALCULATION OF AKZ, BKZ
> ! AKZ,BKZ: model discretization parameters at the center of each model
> ! layer
> !
> ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
> ! i.e. ground level
> !*****************************************************************************
>
> akz(1)=0.
> bkz(1)=1.0
> do i=1,nuvz
> akz(i+1)=0.5*(akm(i+1)+akm(i))
> bkz(i+1)=0.5*(bkm(i+1)+bkm(i))
> end do
> nuvz=nuvz+1
>
> ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
> ! upon the transformation to z levels. In order to save computer memory, this is
> ! not done anymore in the standard version. However, this option can still be
> ! switched on by replacing the following lines with those below, that are
> ! currently commented out. For this, similar changes are necessary in
> ! verttransform.f and verttranform_nests.f
> !*****************************************************************************
>
> nz=nuvz
> if (nz.gt.nzmax) stop 'nzmax too small'
> do i=1,nuvz
> aknew(i)=akz(i)
> bknew(i)=bkz(i)
> end do
>
> ! Switch on following lines to use doubled vertical resolution
> !*************************************************************
> !nz=nuvz+nwz-1
> !if (nz.gt.nzmax) stop 'nzmax too small'
> !do 100 i=1,nwz
> ! aknew(2*(i-1)+1)=akm(i)
> !00 bknew(2*(i-1)+1)=bkm(i)
> !do 110 i=2,nuvz
> ! aknew(2*(i-1))=akz(i)
> !10 bknew(2*(i-1))=bkz(i)
> ! End doubled vertical resolution
>
>
> ! Determine the uppermost level for which the convection scheme shall be applied
> ! by assuming that there is no convection above 50 hPa (for standard SLP)
> !*****************************************************************************
>
> do i=1,nuvz-2
> pint=akz(i)+bkz(i)*101325.
> if (pint.lt.5000.) goto 96
> end do
> 96 nconvlev=i
> if (nconvlev.gt.nconvlevmax-1) then
> nconvlev=nconvlevmax-1
> write(*,*) 'Attention, convection only calculated up to ', &
> akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
> endif
>
> return
>
> 999 write(*,*)
> write(*,*) ' ###########################################'// &
> '###### '
> write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
> write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
> write(*,*) ' ###########################################'// &
> '###### '
> write(*,*)
> write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
> write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
> write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
> write(*,'(a)') '!!! THE "X" KEY... !!!'
> write(*,*)
> read(*,'(a)') opt
> if(opt.eq.'X') then
> stop
> else
> goto 5
> endif
>
> end subroutine gridcheck
gridcheck_gfs.f90
----------------------------------------------
1,538c1,543
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine gridcheck
<
< !**********************************************************************
< ! *
< ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
< ! *
< !**********************************************************************
< ! *
< ! AUTHOR: G. WOTAWA *
< ! DATE: 1997-08-06 *
< ! LAST UPDATE: 1997-10-10 *
< ! *
< ! Update: 1999-02-08, global fields allowed, A. Stohl*
< ! CHANGE: 17/11/2005, Caroline Forster, GFS data *
< ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
< ! ECMWF grib_api *
< ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
< ! ECMWF grib_api *
< ! *
< !**********************************************************************
< ! *
< ! DESCRIPTION: *
< ! *
< ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
< ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
< ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
< ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
< ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
< ! ANY CALL. *
< ! *
< ! XLON0 geographical longitude of lower left gridpoint *
< ! YLAT0 geographical latitude of lower left gridpoint *
< ! NX number of grid points x-direction *
< ! NY number of grid points y-direction *
< ! DX grid distance x-direction *
< ! DY grid distance y-direction *
< ! NUVZ number of grid points for horizontal wind *
< ! components in z direction *
< ! NWZ number of grid points for vertical wind *
< ! component in z direction *
< ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
< ! points of the polar stereographic grid): *
< ! used to check the CFL criterion *
< ! UVHEIGHT(1)- heights of gridpoints where u and v are *
< ! UVHEIGHT(NUVZ) given *
< ! WHEIGHT(1)- heights of gridpoints where w is given *
< ! WHEIGHT(NWZ) *
< ! *
< !**********************************************************************
<
< use grib_api
< use par_mod
< use com_mod
< use conv_mod
< use cmapf_mod, only: stlmbr,stcm2p
<
< implicit none
<
< !HSO parameters for grib_api
< integer :: ifile
< integer :: iret
< integer :: igrib
< real(kind=4) :: xaux1,xaux2,yaux1,yaux2
< real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
< integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
< !HSO end
< integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
< real :: sizesouth,sizenorth,xauxa,pint
< real :: akm_usort(nwzmax)
< real,parameter :: eps=0.0001
<
< ! NCEP GFS
< real :: pres(nwzmax), help
<
< integer :: i179,i180,i181
<
< ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
<
< integer :: isec1(8),isec2(3)
< real(kind=4) :: zsec4(jpunp)
< character(len=1) :: opt
<
< !HSO grib api error messages
< character(len=24) :: gribErrorMsg = 'Error reading grib file'
< character(len=20) :: gribFunction = 'gridcheckwind_gfs'
< !
< if (numbnests.ge.1) then
< write(*,*) ' ###########################################'
< write(*,*) ' FLEXPART ERROR SUBROUTINE GRIDCHECK:'
< write(*,*) ' NO NESTED WINDFIELDAS ALLOWED FOR GFS! '
< write(*,*) ' ###########################################'
< stop
< endif
<
< iumax=0
< iwmax=0
<
< if(ideltas.gt.0) then
< ifn=1
< else
< ifn=numbwf
< endif
< !
< ! OPENING OF DATA FILE (GRIB CODE)
< !
< 5 call grib_open_file(ifile,path(3)(1:length(3)) &
< //trim(wfname(ifn)),'r',iret)
< if (iret.ne.GRIB_SUCCESS) then
< goto 999 ! ERROR DETECTED
< endif
< !turn on support for multi fields messages
< call grib_multi_support_on
<
< ifield=0
< 10 ifield=ifield+1
< !
< ! GET NEXT FIELDS
< !
< call grib_new_from_file(ifile,igrib,iret)
< if (iret.eq.GRIB_END_OF_FILE ) then
< goto 30 ! EOF DETECTED
< elseif (iret.ne.GRIB_SUCCESS) then
< goto 999 ! ERROR DETECTED
< endif
<
< !first see if we read GRIB1 or GRIB2
< call grib_get_int(igrib,'editionNumber',gribVer,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< if (gribVer.eq.1) then ! GRIB Edition 1
<
< !read the grib1 identifiers
< call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',isec1(8),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !get the size and data of the values array
< call grib_get_real4_array(igrib,'values',zsec4,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< else ! GRIB Edition 2
<
< !read the grib2 identifiers
< call grib_get_int(igrib,'discipline',discipl,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterCategory',parCat,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterNumber',parNum,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', &
< valSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !convert to grib1 identifiers
< isec1(6)=-1
< isec1(7)=-1
< isec1(8)=-1
< if ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.100)) then ! U
< isec1(6)=33 ! indicatorOfParameter
< isec1(7)=100 ! indicatorOfTypeOfLevel
< isec1(8)=valSurf/100 ! level, convert to hPa
< elseif ((parCat.eq.3).and.(parNum.eq.5).and.(typSurf.eq.1)) then ! TOPO
< isec1(6)=7 ! indicatorOfParameter
< isec1(7)=1 ! indicatorOfTypeOfLevel
< isec1(8)=0
< elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.1) &
< .and.(discipl.eq.2)) then ! LSM
< isec1(6)=81 ! indicatorOfParameter
< isec1(7)=1 ! indicatorOfTypeOfLevel
< isec1(8)=0
< endif
<
< if (isec1(6).ne.-1) then
< ! get the size and data of the values array
< call grib_get_real4_array(igrib,'values',zsec4,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< endif
<
< endif ! gribVer
<
< if(ifield.eq.1) then
<
< !get the required fields from section 2
< !store compatible to gribex input
< call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
< isec2(2),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
< isec2(3),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
< xaux1in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
< xaux2in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
< yaux1in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
< yaux2in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< xaux1=xaux1in
< xaux2=xaux2in
< yaux1=yaux1in
< yaux2=yaux2in
<
< nxfield=isec2(2)
< ny=isec2(3)
< if((abs(xaux1).lt.eps).and.(xaux2.ge.359)) then ! NCEP DATA FROM 0 TO
< xaux1=-179.0 ! 359 DEG EAST ->
< xaux2=-179.0+360.-360./real(nxfield) ! TRANSFORMED TO -179
< endif ! TO 180 DEG EAST
< if (xaux1.gt.180) xaux1=xaux1-360.0
< if (xaux2.gt.180) xaux2=xaux2-360.0
< if (xaux1.lt.-180) xaux1=xaux1+360.0
< if (xaux2.lt.-180) xaux2=xaux2+360.0
< if (xaux2.lt.xaux1) xaux2=xaux2+360.
< xlon0=xaux1
< ylat0=yaux1
< dx=(xaux2-xaux1)/real(nxfield-1)
< dy=(yaux2-yaux1)/real(ny-1)
< dxconst=180./(dx*r_earth*pi)
< dyconst=180./(dy*r_earth*pi)
< !HSO end edits
<
<
< ! Check whether fields are global
< ! If they contain the poles, specify polar stereographic map
< ! projections using the stlmbr- and stcm2p-calls
< !***********************************************************
<
< xauxa=abs(xaux2+dx-360.-xaux1)
< if (xauxa.lt.0.001) then
< nx=nxfield+1 ! field is cyclic
< xglobal=.true.
< if (abs(nxshift).ge.nx) &
< stop 'nxshift in file par_mod is too large'
< xlon0=xlon0+real(nxshift)*dx
< else
< nx=nxfield
< xglobal=.false.
< if (nxshift.ne.0) &
< stop 'nxshift (par_mod) must be zero for non-global domain'
< endif
< nxmin1=nx-1
< nymin1=ny-1
< if (xlon0.gt.180.) xlon0=xlon0-360.
< xauxa=abs(yaux1+90.)
< if (xglobal.and.xauxa.lt.0.001) then
< sglobal=.true. ! field contains south pole
< ! Enhance the map scale by factor 3 (*2=6) compared to north-south
< ! map scale
< sizesouth=6.*(switchsouth+90.)/dy
< call stlmbr(southpolemap,-90.,0.)
< call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
< sizesouth,switchsouth,180.)
< switchsouthg=(switchsouth-ylat0)/dy
< else
< sglobal=.false.
< switchsouthg=999999.
< endif
< xauxa=abs(yaux2-90.)
< if (xglobal.and.xauxa.lt.0.001) then
< nglobal=.true. ! field contains north pole
< ! Enhance the map scale by factor 3 (*2=6) compared to north-south
< ! map scale
< sizenorth=6.*(90.-switchnorth)/dy
< call stlmbr(northpolemap,90.,0.)
< call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
< sizenorth,switchnorth,180.)
< switchnorthg=(switchnorth-ylat0)/dy
< else
< nglobal=.false.
< switchnorthg=999999.
< endif
< endif ! ifield.eq.1
<
< if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative'
< if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
<
< ! NCEP ISOBARIC LEVELS
< !*********************
<
< if((isec1(6).eq.33).and.(isec1(7).eq.100)) then ! check for U wind
< iumax=iumax+1
< pres(iumax)=real(isec1(8))*100.0
< endif
<
<
< i179=nint(179./dx)
< if (dx.lt.0.7) then
< i180=nint(180./dx)+1 ! 0.5 deg data
< else
< i180=nint(179./dx)+1 ! 1 deg data
< endif
< i181=i180+1
<
<
< ! NCEP TERRAIN
< !*************
<
< if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
< do jy=0,ny-1
< do ix=0,nxfield-1
< help=zsec4(nxfield*(ny-jy-1)+ix+1)
< if(ix.le.i180) then
< oro(i179+ix,jy)=help
< excessoro(i179+ix,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
< else
< oro(ix-i181,jy)=help
< excessoro(ix-i181,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
< endif
< end do
< end do
< endif
<
< ! NCEP LAND SEA MASK
< !*******************
<
< if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
< do jy=0,ny-1
< do ix=0,nxfield-1
< help=zsec4(nxfield*(ny-jy-1)+ix+1)
< if(ix.le.i180) then
< lsm(i179+ix,jy)=help
< else
< lsm(ix-i181,jy)=help
< endif
< end do
< end do
< endif
<
< call grib_release(igrib)
<
< goto 10 !! READ NEXT LEVEL OR PARAMETER
< !
< ! CLOSING OF INPUT DATA FILE
< !
<
< ! HSO
< 30 continue
< call grib_close_file(ifile)
< ! HSO end edits
<
< nuvz=iumax
< nwz =iumax
< nlev_ec=iumax
<
< if (nx.gt.nxmax) then
< write(*,*) 'FLEXPART error: Too many grid points in x direction.'
< write(*,*) 'Reduce resolution of wind fields.'
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) nx,nxmax
< stop
< endif
<
< if (ny.gt.nymax) then
< write(*,*) 'FLEXPART error: Too many grid points in y direction.'
< write(*,*) 'Reduce resolution of wind fields.'
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) ny,nymax
< stop
< endif
<
< if (nuvz.gt.nuvzmax) then
< write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
< 'direction.'
< write(*,*) 'Reduce resolution of wind fields.'
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) nuvz,nuvzmax
< stop
< endif
<
< if (nwz.gt.nwzmax) then
< write(*,*) 'FLEXPART error: Too many w grid points in z '// &
< 'direction.'
< write(*,*) 'Reduce resolution of wind fields.'
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) nwz,nwzmax
< stop
< endif
<
< ! If desired, shift all grids by nxshift grid cells
< !**************************************************
<
< if (xglobal) then
< call shift_field_0(oro,nxfield,ny)
< call shift_field_0(lsm,nxfield,ny)
< call shift_field_0(excessoro,nxfield,ny)
< endif
<
< ! Output of grid info
< !********************
<
< write(*,*)
< write(*,*)
< write(*,'(a,2i7)') '# of vertical levels in NCEP data: ', &
< nuvz,nwz
< write(*,*)
< write(*,'(a)') 'Mother domain:'
< write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
< xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
< write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
< ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
< write(*,*)
<
<
< ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
< ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
<
< numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
< ! by trajectory model
< do i=1,nwz
< j=numskip+i
< k=nlev_ec+1+numskip+i
< akm_usort(nwz-i+1)=pres(nwz-i+1)
< bkm(nwz-i+1)=0.0
< end do
<
< !******************************
< ! change Sabine Eckhardt: akm should always be in descending order ... readwind adapted!
< !******************************
< do i=1,nwz
< if (akm_usort(1).gt.akm_usort(2)) then
< akm(i)=akm_usort(i)
< else
< akm(i)=akm_usort(nwz-i+1)
< endif
< end do
<
< !
< ! CALCULATION OF AKZ, BKZ
< ! AKZ,BKZ: model discretization parameters at the center of each model
< ! layer
< !
< ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
< ! i.e. ground level
< !*****************************************************************************
<
< do i=1,nuvz
< akz(i)=akm(i)
< bkz(i)=bkm(i)
< end do
<
< ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
< ! upon the transformation to z levels. In order to save computer memory, this is
< ! not done anymore in the standard version. However, this option can still be
< ! switched on by replacing the following lines with those below, that are
< ! currently commented out. For this, similar changes are necessary in
< ! verttransform.f and verttranform_nests.f
< !*****************************************************************************
<
< nz=nuvz
< if (nz.gt.nzmax) stop 'nzmax too small'
< do i=1,nuvz
< aknew(i)=akz(i)
< bknew(i)=bkz(i)
< end do
<
< ! Switch on following lines to use doubled vertical resolution
< !*************************************************************
< !nz=nuvz+nwz-1
< !if (nz.gt.nzmax) stop 'nzmax too small'
< !do 100 i=1,nwz
< ! aknew(2*(i-1)+1)=akm(i)
< !00 bknew(2*(i-1)+1)=bkm(i)
< !do 110 i=2,nuvz
< ! aknew(2*(i-1))=akz(i)
< !10 bknew(2*(i-1))=bkz(i)
< ! End doubled vertical resolution
<
<
< ! Determine the uppermost level for which the convection scheme shall be applied
< ! by assuming that there is no convection above 50 hPa (for standard SLP)
< !*****************************************************************************
<
< do i=1,nuvz-2
< pint=akz(i)+bkz(i)*101325.
< if (pint.lt.5000.) goto 96
< end do
< 96 nconvlev=i
< if (nconvlev.gt.nconvlevmax-1) then
< nconvlev=nconvlevmax-1
< write(*,*) 'Attention, convection only calculated up to ', &
< akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
< endif
<
< return
<
< 999 write(*,*)
< write(*,*) ' ###########################################'// &
< '###### '
< write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
< write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
< write(*,*) ' ###########################################'// &
< '###### '
< write(*,*)
< write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
< write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
< write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
< write(*,'(a)') '!!! THE "X" KEY... !!!'
< write(*,*)
< read(*,'(a)') opt
< if(opt.eq.'X') then
< stop
< else
< goto 5
< endif
<
< end subroutine gridcheck
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine gridcheck
>
> !**********************************************************************
> ! *
> ! FLEXPART MODEL SUBROUTINE GRIDCHECK *
> ! *
> !**********************************************************************
> ! *
> ! AUTHOR: G. WOTAWA *
> ! DATE: 1997-08-06 *
> ! LAST UPDATE: 1997-10-10 *
> ! *
> ! Update: 1999-02-08, global fields allowed, A. Stohl*
> ! CHANGE: 17/11/2005, Caroline Forster, GFS data *
> ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
> ! ECMWF grib_api *
> ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
> ! ECMWF grib_api *
> ! *
> !**********************************************************************
> ! *
> ! DESCRIPTION: *
> ! *
> ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT *
> ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- *
> ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE *
> ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES *
> ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT *
> ! ANY CALL. *
> ! *
> ! XLON0 geographical longitude of lower left gridpoint *
> ! YLAT0 geographical latitude of lower left gridpoint *
> ! NX number of grid points x-direction *
> ! NY number of grid points y-direction *
> ! DX grid distance x-direction *
> ! DY grid distance y-direction *
> ! NUVZ number of grid points for horizontal wind *
> ! components in z direction *
> ! NWZ number of grid points for vertical wind *
> ! component in z direction *
> ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid*
> ! points of the polar stereographic grid): *
> ! used to check the CFL criterion *
> ! UVHEIGHT(1)- heights of gridpoints where u and v are *
> ! UVHEIGHT(NUVZ) given *
> ! WHEIGHT(1)- heights of gridpoints where w is given *
> ! WHEIGHT(NWZ) *
> ! *
> !**********************************************************************
>
> use grib_api
> use par_mod
> use com_mod
> use conv_mod
> use cmapf_mod, only: stlmbr,stcm2p
>
> implicit none
>
> !HSO parameters for grib_api
> integer :: ifile
> integer :: iret
> integer :: igrib
> real(kind=4) :: xaux1,xaux2,yaux1,yaux2
> real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
> integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
> !HSO end
> integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip
> real :: sizesouth,sizenorth,xauxa,pint
> real :: akm_usort(nwzmax)
> real,parameter :: eps=0.0001
>
> ! NCEP GFS
> real :: pres(nwzmax), help
>
> integer :: i179,i180,i181
>
> ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
>
> integer :: isec1(8),isec2(3)
> real(kind=4) :: zsec4(jpunp)
> character(len=1) :: opt
>
> !HSO grib api error messages
> character(len=24) :: gribErrorMsg = 'Error reading grib file'
> character(len=20) :: gribFunction = 'gridcheckwind_gfs'
> !
> if (numbnests.ge.1) then
> write(*,*) ' ###########################################'
> write(*,*) ' FLEXPART ERROR SUBROUTINE GRIDCHECK:'
> write(*,*) ' NO NESTED WINDFIELDAS ALLOWED FOR GFS! '
> write(*,*) ' ###########################################'
> stop
> endif
>
> iumax=0
> iwmax=0
>
> if(ideltas.gt.0) then
> ifn=1
> else
> ifn=numbwf
> endif
> !
> ! OPENING OF DATA FILE (GRIB CODE)
> !
> 5 call grib_open_file(ifile,path(3)(1:length(3)) &
> //trim(wfname(ifn)),'r',iret)
> if (iret.ne.GRIB_SUCCESS) then
> goto 999 ! ERROR DETECTED
> endif
> !turn on support for multi fields messages
> call grib_multi_support_on
>
> ifield=0
> 10 ifield=ifield+1
> !
> ! GET NEXT FIELDS
> !
> call grib_new_from_file(ifile,igrib,iret)
> if (iret.eq.GRIB_END_OF_FILE ) then
> goto 30 ! EOF DETECTED
> elseif (iret.ne.GRIB_SUCCESS) then
> goto 999 ! ERROR DETECTED
> endif
>
> !first see if we read GRIB1 or GRIB2
> call grib_get_int(igrib,'editionNumber',gribVer,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> if (gribVer.eq.1) then ! GRIB Edition 1
>
> !read the grib1 identifiers
> call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',isec1(8),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !get the size and data of the values array
> call grib_get_real4_array(igrib,'values',zsec4,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> else ! GRIB Edition 2
>
> !read the grib2 identifiers
> call grib_get_int(igrib,'discipline',discipl,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterCategory',parCat,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterNumber',parNum,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', &
> valSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !convert to grib1 identifiers
> isec1(6)=-1
> isec1(7)=-1
> isec1(8)=-1
> if ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.100)) then ! U
> isec1(6)=33 ! indicatorOfParameter
> isec1(7)=100 ! indicatorOfTypeOfLevel
> isec1(8)=valSurf/100 ! level, convert to hPa
> elseif ((parCat.eq.3).and.(parNum.eq.5).and.(typSurf.eq.1)) then ! TOPO
> isec1(6)=7 ! indicatorOfParameter
> isec1(7)=1 ! indicatorOfTypeOfLevel
> isec1(8)=0
> elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.1) &
> .and.(discipl.eq.2)) then ! LSM
> isec1(6)=81 ! indicatorOfParameter
> isec1(7)=1 ! indicatorOfTypeOfLevel
> isec1(8)=0
> endif
>
> if (isec1(6).ne.-1) then
> ! get the size and data of the values array
> call grib_get_real4_array(igrib,'values',zsec4,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> endif
>
> endif ! gribVer
>
> if(ifield.eq.1) then
>
> !get the required fields from section 2
> !store compatible to gribex input
> call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
> isec2(2),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
> isec2(3),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
> xaux1in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
> xaux2in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
> yaux1in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
> yaux2in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> xaux1=xaux1in
> xaux2=xaux2in
> yaux1=yaux1in
> yaux2=yaux2in
>
> nxfield=isec2(2)
> ny=isec2(3)
> write(*,*) "xaux1:", xaux1
> write(*,*) "xaux2:", xaux2
>
> if( ((abs(xaux1).lt.eps).and.(xaux2.ge.359)) .or. &
> ((abs(xaux1).lt.eps).and.(xaux2.lt.0)) & ! hes134: some GFS data contain 0 to -1 as longitude limits
> ) then ! NCEP DATA FROM 0 TO
> xaux1=-179.0 ! 359 DEG EAST ->
> xaux2=-179.0+360.-360./real(nxfield) ! TRANSFORMED TO -179
> endif ! TO 180 DEG EAST
> if (xaux1.gt.180) xaux1=xaux1-360.0
> if (xaux2.gt.180) xaux2=xaux2-360.0
> if (xaux1.lt.-180) xaux1=xaux1+360.0
> if (xaux2.lt.-180) xaux2=xaux2+360.0
> if (xaux2.lt.xaux1) xaux2=xaux2+360.
> xlon0=xaux1
> ylat0=yaux1
> dx=(xaux2-xaux1)/real(nxfield-1)
> dy=(yaux2-yaux1)/real(ny-1)
> dxconst=180./(dx*r_earth*pi)
> dyconst=180./(dy*r_earth*pi)
> !HSO end edits
>
>
> ! Check whether fields are global
> ! If they contain the poles, specify polar stereographic map
> ! projections using the stlmbr- and stcm2p-calls
> !***********************************************************
>
> xauxa=abs(xaux2+dx-360.-xaux1)
> if (xauxa.lt.0.001) then
> nx=nxfield+1 ! field is cyclic
> xglobal=.true.
> if (abs(nxshift).ge.nx) &
> stop 'nxshift in file par_mod is too large'
> xlon0=xlon0+real(nxshift)*dx
> else
> nx=nxfield
> xglobal=.false.
> if (nxshift.ne.0) &
> stop 'nxshift (par_mod) must be zero for non-global domain'
> endif
> nxmin1=nx-1
> nymin1=ny-1
> if (xlon0.gt.180.) xlon0=xlon0-360.
> xauxa=abs(yaux1+90.)
> if (xglobal.and.xauxa.lt.0.001) then
> sglobal=.true. ! field contains south pole
> ! Enhance the map scale by factor 3 (*2=6) compared to north-south
> ! map scale
> sizesouth=6.*(switchsouth+90.)/dy
> call stlmbr(southpolemap,-90.,0.)
> call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, &
> sizesouth,switchsouth,180.)
> switchsouthg=(switchsouth-ylat0)/dy
> else
> sglobal=.false.
> switchsouthg=999999.
> endif
> xauxa=abs(yaux2-90.)
> if (xglobal.and.xauxa.lt.0.001) then
> nglobal=.true. ! field contains north pole
> ! Enhance the map scale by factor 3 (*2=6) compared to north-south
> ! map scale
> sizenorth=6.*(90.-switchnorth)/dy
> call stlmbr(northpolemap,90.,0.)
> call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, &
> sizenorth,switchnorth,180.)
> switchnorthg=(switchnorth-ylat0)/dy
> else
> nglobal=.false.
> switchnorthg=999999.
> endif
> endif ! ifield.eq.1
>
> if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative'
> if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large'
>
> ! NCEP ISOBARIC LEVELS
> !*********************
>
> if((isec1(6).eq.33).and.(isec1(7).eq.100)) then ! check for U wind
> iumax=iumax+1
> pres(iumax)=real(isec1(8))*100.0
> endif
>
>
> i179=nint(179./dx)
> if (dx.lt.0.7) then
> i180=nint(180./dx)+1 ! 0.5 deg data
> else
> i180=nint(179./dx)+1 ! 1 deg data
> endif
> i181=i180+1
>
>
> ! NCEP TERRAIN
> !*************
>
> if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
> do jy=0,ny-1
> do ix=0,nxfield-1
> help=zsec4(nxfield*(ny-jy-1)+ix+1)
> if(ix.le.i180) then
> oro(i179+ix,jy)=help
> excessoro(i179+ix,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
> else
> oro(ix-i181,jy)=help
> excessoro(ix-i181,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
> endif
> end do
> end do
> endif
>
> ! NCEP LAND SEA MASK
> !*******************
>
> if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
> do jy=0,ny-1
> do ix=0,nxfield-1
> help=zsec4(nxfield*(ny-jy-1)+ix+1)
> if(ix.le.i180) then
> lsm(i179+ix,jy)=help
> else
> lsm(ix-i181,jy)=help
> endif
> end do
> end do
> endif
>
> call grib_release(igrib)
>
> goto 10 !! READ NEXT LEVEL OR PARAMETER
> !
> ! CLOSING OF INPUT DATA FILE
> !
>
> ! HSO
> 30 continue
> call grib_close_file(ifile)
> ! HSO end edits
>
> nuvz=iumax
> nwz =iumax
> nlev_ec=iumax
>
> if (nx.gt.nxmax) then
> write(*,*) 'FLEXPART error: Too many grid points in x direction.'
> write(*,*) 'Reduce resolution of wind fields.'
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) nx,nxmax
> stop
> endif
>
> if (ny.gt.nymax) then
> write(*,*) 'FLEXPART error: Too many grid points in y direction.'
> write(*,*) 'Reduce resolution of wind fields.'
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) ny,nymax
> stop
> endif
>
> if (nuvz.gt.nuvzmax) then
> write(*,*) 'FLEXPART error: Too many u,v grid points in z '// &
> 'direction.'
> write(*,*) 'Reduce resolution of wind fields.'
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) nuvz,nuvzmax
> stop
> endif
>
> if (nwz.gt.nwzmax) then
> write(*,*) 'FLEXPART error: Too many w grid points in z '// &
> 'direction.'
> write(*,*) 'Reduce resolution of wind fields.'
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) nwz,nwzmax
> stop
> endif
>
> ! If desired, shift all grids by nxshift grid cells
> !**************************************************
>
> if (xglobal) then
> call shift_field_0(oro,nxfield,ny)
> call shift_field_0(lsm,nxfield,ny)
> call shift_field_0(excessoro,nxfield,ny)
> endif
>
> ! Output of grid info
> !********************
>
> write(*,*)
> write(*,*)
> write(*,'(a,2i7)') '# of vertical levels in ECMWF data: ', &
> nuvz,nwz
> write(*,*)
> write(*,'(a)') 'Mother domain:'
> write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
> xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx
> write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
> ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy
> write(*,*)
>
>
> ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
> ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
>
> numskip=nlev_ec-nuvz ! number of ecmwf model layers not used
> ! by trajectory model
> do i=1,nwz
> j=numskip+i
> k=nlev_ec+1+numskip+i
> akm_usort(nwz-i+1)=pres(nwz-i+1)
> bkm(nwz-i+1)=0.0
> end do
>
> !******************************
> ! change Sabine Eckhardt: akm should always be in descending order ... readwind adapted!
> !******************************
> do i=1,nwz
> if (akm_usort(1).gt.akm_usort(2)) then
> akm(i)=akm_usort(i)
> else
> akm(i)=akm_usort(nwz-i+1)
> endif
> end do
>
> !
> ! CALCULATION OF AKZ, BKZ
> ! AKZ,BKZ: model discretization parameters at the center of each model
> ! layer
> !
> ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
> ! i.e. ground level
> !*****************************************************************************
>
> do i=1,nuvz
> akz(i)=akm(i)
> bkz(i)=bkm(i)
> end do
>
> ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
> ! upon the transformation to z levels. In order to save computer memory, this is
> ! not done anymore in the standard version. However, this option can still be
> ! switched on by replacing the following lines with those below, that are
> ! currently commented out. For this, similar changes are necessary in
> ! verttransform.f and verttranform_nests.f
> !*****************************************************************************
>
> nz=nuvz
> if (nz.gt.nzmax) stop 'nzmax too small'
> do i=1,nuvz
> aknew(i)=akz(i)
> bknew(i)=bkz(i)
> end do
>
> ! Switch on following lines to use doubled vertical resolution
> !*************************************************************
> !nz=nuvz+nwz-1
> !if (nz.gt.nzmax) stop 'nzmax too small'
> !do 100 i=1,nwz
> ! aknew(2*(i-1)+1)=akm(i)
> !00 bknew(2*(i-1)+1)=bkm(i)
> !do 110 i=2,nuvz
> ! aknew(2*(i-1))=akz(i)
> !10 bknew(2*(i-1))=bkz(i)
> ! End doubled vertical resolution
>
>
> ! Determine the uppermost level for which the convection scheme shall be applied
> ! by assuming that there is no convection above 50 hPa (for standard SLP)
> !*****************************************************************************
>
> do i=1,nuvz-2
> pint=akz(i)+bkz(i)*101325.
> if (pint.lt.5000.) goto 96
> end do
> 96 nconvlev=i
> if (nconvlev.gt.nconvlevmax-1) then
> nconvlev=nconvlevmax-1
> write(*,*) 'Attention, convection only calculated up to ', &
> akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa'
> endif
>
> return
>
> 999 write(*,*)
> write(*,*) ' ###########################################'// &
> '###### '
> write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:'
> write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn)
> write(*,*) ' ###########################################'// &
> '###### '
> write(*,*)
> write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!'
> write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!'
> write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!'
> write(*,'(a)') '!!! THE "X" KEY... !!!'
> write(*,*)
> read(*,'(a)') opt
> if(opt.eq.'X') then
> stop
> else
> goto 5
> endif
>
> end subroutine gridcheck
gridcheck_nests.f90
----------------------------------------------
1,450c1,450
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine gridcheck_nests
<
< !*****************************************************************************
< ! *
< ! This routine checks the grid specification for the nested model *
< ! domains. It is similar to subroutine gridcheck, which checks the *
< ! mother domain. *
< ! *
< ! Authors: A. Stohl, G. Wotawa *
< ! *
< ! 8 February 1999 *
< ! *
< !*****************************************************************************
< ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api *
< ! CHANGE: 03/12/2008, Harald Sodemann, change to f90 grib_api *
< !*****************************************************************************
<
< use grib_api
< use par_mod
< use com_mod
<
< implicit none
<
< !HSO parameters for grib_api
< integer :: ifile
< integer :: iret
< integer :: igrib
< integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
< integer :: gotGrib
< !HSO end
< integer :: i,j,k,l,ifn,ifield,iumax,iwmax,numskip,nlev_ecn
< integer :: nuvzn,nwzn
< real :: akmn(nwzmax),bkmn(nwzmax),akzn(nuvzmax),bkzn(nuvzmax)
< real(kind=4) :: xaux1,xaux2,yaux1,yaux2
< real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
<
< ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
<
< ! dimension of isec2 at least (22+n), where n is the number of parallels or
< ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
<
< ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
< ! coordinate parameters
<
< integer :: isec1(56),isec2(22+nxmaxn+nymaxn)
< real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp)
<
< !HSO grib api error messages
< character(len=24) :: gribErrorMsg = 'Error reading grib file'
< character(len=20) :: gribFunction = 'gridcheck_nests'
<
< xresoln(0)=1. ! resolution enhancement for mother grid
< yresoln(0)=1. ! resolution enhancement for mother grid
<
< ! Loop about all nesting levels
< !******************************
<
< do l=1,numbnests
<
< iumax=0
< iwmax=0
<
< if(ideltas.gt.0) then
< ifn=1
< else
< ifn=numbwf
< endif
< !
< ! OPENING OF DATA FILE (GRIB CODE)
< !
< ifile=0
< igrib=0
< iret=0
<
< 5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) &
< (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,ifn)),'r',iret)
< if (iret.ne.GRIB_SUCCESS) then
< goto 999 ! ERROR DETECTED
< endif
< !turn on support for multi fields messages
< !call grib_multi_support_on
<
< gotGrib=0
< ifield=0
< 10 ifield=ifield+1
<
< !
< ! GET NEXT FIELDS
< !
< call grib_new_from_file(ifile,igrib,iret)
< if (iret.eq.GRIB_END_OF_FILE) then
< goto 30 ! EOF DETECTED
< elseif (iret.ne.GRIB_SUCCESS) then
< goto 999 ! ERROR DETECTED
< endif
<
< !first see if we read GRIB1 or GRIB2
< call grib_get_int(igrib,'editionNumber',gribVer,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< if (gribVer.eq.1) then ! GRIB Edition 1
<
< !print*,'GRiB Edition 1'
< !read the grib2 identifiers
< call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',isec1(8),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !change code for etadot to code for omega
< if (isec1(6).eq.77) then
< isec1(6)=135
< endif
<
< !print*,isec1(6),isec1(8)
<
< else
<
< !print*,'GRiB Edition 2'
< !read the grib2 identifiers
< call grib_get_int(igrib,'discipline',discipl,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterCategory',parCat,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterNumber',parNum,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',valSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !print*,discipl,parCat,parNum,typSurf,valSurf
<
< !convert to grib1 identifiers
< isec1(6)=-1
< isec1(7)=-1
< isec1(8)=-1
< isec1(8)=valSurf ! level
< if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
< isec1(6)=130 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
< isec1(6)=131 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
< isec1(6)=132 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
< isec1(6)=133 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
< isec1(6)=134 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
< isec1(6)=135 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
< isec1(6)=151 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
< isec1(6)=165 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
< isec1(6)=166 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
< isec1(6)=167 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
< isec1(6)=168 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
< isec1(6)=141 ! indicatorOfParameter
< elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
< isec1(6)=164 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
< isec1(6)=142 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
< isec1(6)=143 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
< isec1(6)=146 ! indicatorOfParameter
< elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
< isec1(6)=176 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
< isec1(6)=180 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
< isec1(6)=181 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
< isec1(6)=129 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
< isec1(6)=160 ! indicatorOfParameter
< elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
< (typSurf.eq.1)) then ! LSM
< isec1(6)=172 ! indicatorOfParameter
< else
< print*,'***ERROR: undefined GRiB2 message found!',discipl, &
< parCat,parNum,typSurf
< endif
<
< endif
<
< !get the size and data of the values array
< if (isec1(6).ne.-1) then
< call grib_get_real4_array(igrib,'values',zsec4,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< endif
<
< !HSO get the required fields from section 2 in a gribex compatible manner
< if (ifield.eq.1) then
< call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
< isec2(2),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
< isec2(3),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
< isec2(12),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< !HSO get the size and data of the vertical coordinate array
< call grib_get_real4_array(igrib,'pv',zsec2,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< nxn(l)=isec2(2)
< nyn(l)=isec2(3)
< nlev_ecn=isec2(12)/2-1
< endif ! ifield
<
< !HSO get the second part of the grid dimensions only from GRiB1 messages
< if ((gribVer.eq.1).and.(gotGrib.eq.0)) then
< call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
< xaux1in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
< xaux2in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
< yaux1in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
< yaux2in,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< xaux1=xaux1in
< xaux2=xaux2in
< yaux1=yaux1in
< yaux2=yaux2in
< if(xaux1.gt.180) xaux1=xaux1-360.0
< if(xaux2.gt.180) xaux2=xaux2-360.0
< if(xaux1.lt.-180) xaux1=xaux1+360.0
< if(xaux2.lt.-180) xaux2=xaux2+360.0
< if (xaux2.lt.xaux1) xaux2=xaux2+360.
< xlon0n(l)=xaux1
< ylat0n(l)=yaux1
< dxn(l)=(xaux2-xaux1)/real(nxn(l)-1)
< dyn(l)=(yaux2-yaux1)/real(nyn(l)-1)
< gotGrib=1
< endif ! ifield.eq.1
<
< k=isec1(8)
< if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
< if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
<
< if(isec1(6).eq.129) then
< do j=0,nyn(l)-1
< do i=0,nxn(l)-1
< oron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
< end do
< end do
< endif
< if(isec1(6).eq.172) then
< do j=0,nyn(l)-1
< do i=0,nxn(l)-1
< lsmn(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
< end do
< end do
< endif
< if(isec1(6).eq.160) then
< do j=0,nyn(l)-1
< do i=0,nxn(l)-1
< excessoron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
< end do
< end do
< endif
<
< call grib_release(igrib)
< goto 10 !! READ NEXT LEVEL OR PARAMETER
< !
< ! CLOSING OF INPUT DATA FILE
< !
<
< 30 call grib_close_file(ifile)
<
< !error message if no fields found with correct first longitude in it
< if (gotGrib.eq.0) then
< print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
< 'messages'
< stop
< endif
<
< nuvzn=iumax
< nwzn=iwmax
< if(nuvzn.eq.nlev_ec) nwzn=nlev_ecn+1
<
< if (nxn(l).gt.nxmaxn) then
< write(*,*) 'FLEXPART error: Too many grid points in x direction.'
< write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
< write(*,*) 'for nesting level ',l
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) nxn(l),nxmaxn
< stop
< endif
<
< if (nyn(l).gt.nymaxn) then
< write(*,*) 'FLEXPART error: Too many grid points in y direction.'
< write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
< write(*,*) 'for nesting level ',l
< write(*,*) 'Or change parameter settings in file par_mod.'
< write(*,*) nyn(l),nymaxn
< stop
< endif
<
< if ((nuvzn.gt.nuvzmax).or.(nwzn.gt.nwzmax)) then
< write(*,*) 'FLEXPART error: Nested wind fields have too many'// &
< 'vertical levels.'
< write(*,*) 'Problem was encountered for nesting level ',l
< stop
< endif
<
<
< ! Output of grid info
< !********************
<
< write(*,'(a,i2)') 'Nested domain #: ',l
< write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
< xlon0n(l),' to ',xlon0n(l)+(nxn(l)-1)*dxn(l), &
< ' Grid distance: ',dxn(l)
< write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
< ylat0n(l),' to ',ylat0n(l)+(nyn(l)-1)*dyn(l), &
< ' Grid distance: ',dyn(l)
< write(*,*)
<
< ! Determine, how much the resolutions in the nests are enhanced as
< ! compared to the mother grid
< !*****************************************************************
<
< xresoln(l)=dx/dxn(l)
< yresoln(l)=dy/dyn(l)
<
< ! Determine the mother grid coordinates of the corner points of the
< ! nested grids
< ! Convert first to geographical coordinates, then to grid coordinates
< !********************************************************************
<
< xaux1=xlon0n(l)
< xaux2=xlon0n(l)+real(nxn(l)-1)*dxn(l)
< yaux1=ylat0n(l)
< yaux2=ylat0n(l)+real(nyn(l)-1)*dyn(l)
<
< xln(l)=(xaux1-xlon0)/dx
< xrn(l)=(xaux2-xlon0)/dx
< yln(l)=(yaux1-ylat0)/dy
< yrn(l)=(yaux2-ylat0)/dy
<
<
< if ((xln(l).lt.0.).or.(yln(l).lt.0.).or. &
< (xrn(l).gt.real(nxmin1)).or.(yrn(l).gt.real(nymin1))) then
< write(*,*) 'Nested domain does not fit into mother domain'
< write(*,*) 'For global mother domain fields, you can shift'
< write(*,*) 'shift the mother domain into x-direction'
< write(*,*) 'by setting nxshift (file par_mod) to a'
< write(*,*) 'positive value. Execution is terminated.'
< stop
< endif
<
<
< ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
< ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
<
< numskip=nlev_ecn-nuvzn ! number of ecmwf model layers not used by FLEXPART
< do i=1,nwzn
< j=numskip+i
< k=nlev_ecn+1+numskip+i
< akmn(nwzn-i+1)=zsec2(j)
< bkmn(nwzn-i+1)=zsec2(k)
< end do
<
< !
< ! CALCULATION OF AKZ, BKZ
< ! AKZ,BKZ: model discretization parameters at the center of each model
< ! layer
< !
< ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
< ! i.e. ground level
< !*****************************************************************************
<
< akzn(1)=0.
< bkzn(1)=1.0
< do i=1,nuvzn
< akzn(i+1)=0.5*(akmn(i+1)+akmn(i))
< bkzn(i+1)=0.5*(bkmn(i+1)+bkmn(i))
< end do
< nuvzn=nuvzn+1
<
< ! Check, whether the heights of the model levels of the nested
< ! wind fields are consistent with those of the mother domain.
< ! If not, terminate model run.
< !*************************************************************
<
< do i=1,nuvz
< if ((akzn(i).ne.akz(i)).or.(bkzn(i).ne.bkz(i))) then
< write(*,*) 'FLEXPART error: The wind fields of nesting level',l
< write(*,*) 'are not consistent with the mother domain:'
< write(*,*) 'Differences in vertical levels detected.'
< stop
< endif
< end do
<
< do i=1,nwz
< if ((akmn(i).ne.akm(i)).or.(bkmn(i).ne.bkm(i))) then
< write(*,*) 'FLEXPART error: The wind fields of nesting level',l
< write(*,*) 'are not consistent with the mother domain:'
< write(*,*) 'Differences in vertical levels detected.'
< stop
< endif
< end do
<
< end do
<
< return
<
< 999 write(*,*)
< write(*,*) ' ###########################################'// &
< '###### '
< write(*,*) ' FLEXPART SUBROUTINE GRIDCHECK:'
< write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfnamen(l,ifn)
< write(*,*) ' FOR NESTING LEVEL ',k
< write(*,*) ' ###########################################'// &
< '###### '
< stop
<
< end subroutine gridcheck_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine gridcheck_nests
>
> !*****************************************************************************
> ! *
> ! This routine checks the grid specification for the nested model *
> ! domains. It is similar to subroutine gridcheck, which checks the *
> ! mother domain. *
> ! *
> ! Authors: A. Stohl, G. Wotawa *
> ! *
> ! 8 February 1999 *
> ! *
> !*****************************************************************************
> ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api *
> ! CHANGE: 03/12/2008, Harald Sodemann, change to f90 grib_api *
> !*****************************************************************************
>
> use grib_api
> use par_mod
> use com_mod
>
> implicit none
>
> !HSO parameters for grib_api
> integer :: ifile
> integer :: iret
> integer :: igrib
> integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
> integer :: gotGrib
> !HSO end
> integer :: i,j,k,l,ifn,ifield,iumax,iwmax,numskip,nlev_ecn
> integer :: nuvzn,nwzn
> real :: akmn(nwzmax),bkmn(nwzmax),akzn(nuvzmax),bkzn(nuvzmax)
> real(kind=4) :: xaux1,xaux2,yaux1,yaux2
> real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in
>
> ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
>
> ! dimension of isec2 at least (22+n), where n is the number of parallels or
> ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
>
> ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
> ! coordinate parameters
>
> integer :: isec1(56),isec2(22+nxmaxn+nymaxn)
> real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp)
>
> !HSO grib api error messages
> character(len=24) :: gribErrorMsg = 'Error reading grib file'
> character(len=20) :: gribFunction = 'gridcheck_nests'
>
> xresoln(0)=1. ! resolution enhancement for mother grid
> yresoln(0)=1. ! resolution enhancement for mother grid
>
> ! Loop about all nesting levels
> !******************************
>
> do l=1,numbnests
>
> iumax=0
> iwmax=0
>
> if(ideltas.gt.0) then
> ifn=1
> else
> ifn=numbwf
> endif
> !
> ! OPENING OF DATA FILE (GRIB CODE)
> !
> ifile=0
> igrib=0
> iret=0
>
> 5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) &
> (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,ifn)),'r',iret)
> if (iret.ne.GRIB_SUCCESS) then
> goto 999 ! ERROR DETECTED
> endif
> !turn on support for multi fields messages
> !call grib_multi_support_on
>
> gotGrib=0
> ifield=0
> 10 ifield=ifield+1
>
> !
> ! GET NEXT FIELDS
> !
> call grib_new_from_file(ifile,igrib,iret)
> if (iret.eq.GRIB_END_OF_FILE) then
> goto 30 ! EOF DETECTED
> elseif (iret.ne.GRIB_SUCCESS) then
> goto 999 ! ERROR DETECTED
> endif
>
> !first see if we read GRIB1 or GRIB2
> call grib_get_int(igrib,'editionNumber',gribVer,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> if (gribVer.eq.1) then ! GRIB Edition 1
>
> !print*,'GRiB Edition 1'
> !read the grib2 identifiers
> call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',isec1(8),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !change code for etadot to code for omega
> if (isec1(6).eq.77) then
> isec1(6)=135
> endif
>
> !print*,isec1(6),isec1(8)
>
> else
>
> !print*,'GRiB Edition 2'
> !read the grib2 identifiers
> call grib_get_int(igrib,'discipline',discipl,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterCategory',parCat,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterNumber',parNum,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',valSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !print*,discipl,parCat,parNum,typSurf,valSurf
>
> !convert to grib1 identifiers
> isec1(6)=-1
> isec1(7)=-1
> isec1(8)=-1
> isec1(8)=valSurf ! level
> if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
> isec1(6)=130 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
> isec1(6)=131 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
> isec1(6)=132 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
> isec1(6)=133 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
> isec1(6)=134 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
> isec1(6)=135 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
> isec1(6)=151 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
> isec1(6)=165 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
> isec1(6)=166 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
> isec1(6)=167 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
> isec1(6)=168 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
> isec1(6)=141 ! indicatorOfParameter
> elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
> isec1(6)=164 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
> isec1(6)=142 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
> isec1(6)=143 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
> isec1(6)=146 ! indicatorOfParameter
> elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
> isec1(6)=176 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
> isec1(6)=180 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
> isec1(6)=181 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
> isec1(6)=129 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
> isec1(6)=160 ! indicatorOfParameter
> elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
> (typSurf.eq.1)) then ! LSM
> isec1(6)=172 ! indicatorOfParameter
> else
> print*,'***ERROR: undefined GRiB2 message found!',discipl, &
> parCat,parNum,typSurf
> endif
>
> endif
>
> !get the size and data of the values array
> if (isec1(6).ne.-1) then
> call grib_get_real4_array(igrib,'values',zsec4,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> endif
>
> !HSO get the required fields from section 2 in a gribex compatible manner
> if (ifield.eq.1) then
> call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
> isec2(2),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
> isec2(3),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
> isec2(12),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> !HSO get the size and data of the vertical coordinate array
> call grib_get_real4_array(igrib,'pv',zsec2,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> nxn(l)=isec2(2)
> nyn(l)=isec2(3)
> nlev_ecn=isec2(12)/2-1
> endif ! ifield
>
> !HSO get the second part of the grid dimensions only from GRiB1 messages
> if ((gribVer.eq.1).and.(gotGrib.eq.0)) then
> call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
> xaux1in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', &
> xaux2in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
> yaux1in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', &
> yaux2in,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> xaux1=xaux1in
> xaux2=xaux2in
> yaux1=yaux1in
> yaux2=yaux2in
> if(xaux1.gt.180) xaux1=xaux1-360.0
> if(xaux2.gt.180) xaux2=xaux2-360.0
> if(xaux1.lt.-180) xaux1=xaux1+360.0
> if(xaux2.lt.-180) xaux2=xaux2+360.0
> if (xaux2.lt.xaux1) xaux2=xaux2+360.
> xlon0n(l)=xaux1
> ylat0n(l)=yaux1
> dxn(l)=(xaux2-xaux1)/real(nxn(l)-1)
> dyn(l)=(yaux2-yaux1)/real(nyn(l)-1)
> gotGrib=1
> endif ! ifield.eq.1
>
> k=isec1(8)
> if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
> if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
>
> if(isec1(6).eq.129) then
> do j=0,nyn(l)-1
> do i=0,nxn(l)-1
> oron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
> end do
> end do
> endif
> if(isec1(6).eq.172) then
> do j=0,nyn(l)-1
> do i=0,nxn(l)-1
> lsmn(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
> end do
> end do
> endif
> if(isec1(6).eq.160) then
> do j=0,nyn(l)-1
> do i=0,nxn(l)-1
> excessoron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
> end do
> end do
> endif
>
> call grib_release(igrib)
> goto 10 !! READ NEXT LEVEL OR PARAMETER
> !
> ! CLOSING OF INPUT DATA FILE
> !
>
> 30 call grib_close_file(ifile)
>
> !error message if no fields found with correct first longitude in it
> if (gotGrib.eq.0) then
> print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
> 'messages'
> stop
> endif
>
> nuvzn=iumax
> nwzn=iwmax
> if(nuvzn.eq.nlev_ec) nwzn=nlev_ecn+1
>
> if (nxn(l).gt.nxmaxn) then
> write(*,*) 'FLEXPART error: Too many grid points in x direction.'
> write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
> write(*,*) 'for nesting level ',l
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) nxn(l),nxmaxn
> stop
> endif
>
> if (nyn(l).gt.nymaxn) then
> write(*,*) 'FLEXPART error: Too many grid points in y direction.'
> write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)'
> write(*,*) 'for nesting level ',l
> write(*,*) 'Or change parameter settings in file par_mod.'
> write(*,*) nyn(l),nymaxn
> stop
> endif
>
> if ((nuvzn.gt.nuvzmax).or.(nwzn.gt.nwzmax)) then
> write(*,*) 'FLEXPART error: Nested wind fields have too many'// &
> 'vertical levels.'
> write(*,*) 'Problem was encountered for nesting level ',l
> stop
> endif
>
>
> ! Output of grid info
> !********************
>
> write(*,'(a,i2)') 'Nested domain #: ',l
> write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', &
> xlon0n(l),' to ',xlon0n(l)+(nxn(l)-1)*dxn(l), &
> ' Grid distance: ',dxn(l)
> write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range: ', &
> ylat0n(l),' to ',ylat0n(l)+(nyn(l)-1)*dyn(l), &
> ' Grid distance: ',dyn(l)
> write(*,*)
>
> ! Determine, how much the resolutions in the nests are enhanced as
> ! compared to the mother grid
> !*****************************************************************
>
> xresoln(l)=dx/dxn(l)
> yresoln(l)=dy/dyn(l)
>
> ! Determine the mother grid coordinates of the corner points of the
> ! nested grids
> ! Convert first to geographical coordinates, then to grid coordinates
> !********************************************************************
>
> xaux1=xlon0n(l)
> xaux2=xlon0n(l)+real(nxn(l)-1)*dxn(l)
> yaux1=ylat0n(l)
> yaux2=ylat0n(l)+real(nyn(l)-1)*dyn(l)
>
> xln(l)=(xaux1-xlon0)/dx
> xrn(l)=(xaux2-xlon0)/dx
> yln(l)=(yaux1-ylat0)/dy
> yrn(l)=(yaux2-ylat0)/dy
>
>
> if ((xln(l).lt.0.).or.(yln(l).lt.0.).or. &
> (xrn(l).gt.real(nxmin1)).or.(yrn(l).gt.real(nymin1))) then
> write(*,*) 'Nested domain does not fit into mother domain'
> write(*,*) 'For global mother domain fields, you can shift'
> write(*,*) 'shift the mother domain into x-direction'
> write(*,*) 'by setting nxshift (file par_mod) to a'
> write(*,*) 'positive value. Execution is terminated.'
> stop
> endif
>
>
> ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL
> ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM
>
> numskip=nlev_ecn-nuvzn ! number of ecmwf model layers not used by FLEXPART
> do i=1,nwzn
> j=numskip+i
> k=nlev_ecn+1+numskip+i
> akmn(nwzn-i+1)=zsec2(j)
> bkmn(nwzn-i+1)=zsec2(k)
> end do
>
> !
> ! CALCULATION OF AKZ, BKZ
> ! AKZ,BKZ: model discretization parameters at the center of each model
> ! layer
> !
> ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0,
> ! i.e. ground level
> !*****************************************************************************
>
> akzn(1)=0.
> bkzn(1)=1.0
> do i=1,nuvzn
> akzn(i+1)=0.5*(akmn(i+1)+akmn(i))
> bkzn(i+1)=0.5*(bkmn(i+1)+bkmn(i))
> end do
> nuvzn=nuvzn+1
>
> ! Check, whether the heights of the model levels of the nested
> ! wind fields are consistent with those of the mother domain.
> ! If not, terminate model run.
> !*************************************************************
>
> do i=1,nuvz
> if ((akzn(i).ne.akz(i)).or.(bkzn(i).ne.bkz(i))) then
> write(*,*) 'FLEXPART error: The wind fields of nesting level',l
> write(*,*) 'are not consistent with the mother domain:'
> write(*,*) 'Differences in vertical levels detected.'
> stop
> endif
> end do
>
> do i=1,nwz
> if ((akmn(i).ne.akm(i)).or.(bkmn(i).ne.bkm(i))) then
> write(*,*) 'FLEXPART error: The wind fields of nesting level',l
> write(*,*) 'are not consistent with the mother domain:'
> write(*,*) 'Differences in vertical levels detected.'
> stop
> endif
> end do
>
> end do
>
> return
>
> 999 write(*,*)
> write(*,*) ' ###########################################'// &
> '###### '
> write(*,*) ' FLEXPART SUBROUTINE GRIDCHECK:'
> write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfnamen(l,ifn)
> write(*,*) ' FOR NESTING LEVEL ',k
> write(*,*) ' ###########################################'// &
> '###### '
> stop
>
> end subroutine gridcheck_nests
hanna1.f90
----------------------------------------------
1,149c1,149
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine hanna1(z)
< ! i
< !*****************************************************************************
< ! *
< ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 4 December 1997 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! dsigwdz [1/s] vertical gradient of sigw *
< ! ol [m] Obukhov length *
< ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
< ! tlu [s] Lagrangian time scale for the along wind component. *
< ! tlv [s] Lagrangian time scale for the cross wind component. *
< ! tlw [s] Lagrangian time scale for the vertical wind component. *
< ! ust, ustar [m/s] friction velocity *
< ! wst, wstar [m/s] convective velocity scale *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use hanna_mod
<
< implicit none
<
< real :: z,s1,s2
<
<
<
< !**********************
< ! 1. Neutral conditions
< !**********************
<
< if (h/abs(ol).lt.1.) then
<
< ust=max(1.e-4,ust)
< sigu=2.0*ust*exp(-3.e-4*z/ust)
< sigu=max(sigu,1.e-5)
< sigv=1.3*ust*exp(-2.e-4*z/ust)
< sigv=max(sigv,1.e-5)
< sigw=sigv
< dsigw2dz=-6.76e-4*ust*exp(-4.e-4*z/ust)
< tlu=0.5*z/sigw/(1.+1.5e-3*z/ust)
< tlv=tlu
< tlw=tlu
<
<
< !***********************
< ! 2. Unstable conditions
< !***********************
<
< else if (ol.lt.0.) then
<
<
< ! Determine sigmas
< !*****************
<
< sigu=ust*(12-0.5*h/ol)**0.33333
< sigu=max(sigu,1.e-6)
< sigv=sigu
<
< if (zeta.lt.0.03) then
< sigw=0.96*wst*(3*zeta-ol/h)**0.33333
< dsigw2dz=1.8432*wst*wst/h*(3*zeta-ol/h)**(-0.33333)
< else if (zeta.lt.0.4) then
< s1=0.96*(3*zeta-ol/h)**0.33333
< s2=0.763*zeta**0.175
< if (s1.lt.s2) then
< sigw=wst*s1
< dsigw2dz=1.8432*wst*wst/h*(3*zeta-ol/h)**(-0.33333)
< else
< sigw=wst*s2
< dsigw2dz=0.203759*wst*wst/h*zeta**(-0.65)
< endif
< else if (zeta.lt.0.96) then
< sigw=0.722*wst*(1-zeta)**0.207
< dsigw2dz=-.215812*wst*wst/h*(1-zeta)**(-0.586)
< else if (zeta.lt.1.00) then
< sigw=0.37*wst
< dsigw2dz=0.
< endif
< sigw=max(sigw,1.e-6)
<
<
< ! Determine average Lagrangian time scale
< !****************************************
<
< tlu=0.15*h/sigu
< tlv=tlu
< if (z.lt.abs(ol)) then
< tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
< else if (zeta.lt.0.1) then
< tlw=0.59*z/sigw
< else
< tlw=0.15*h/sigw*(1.-exp(-5*zeta))
< endif
<
<
< !*********************
< ! 3. Stable conditions
< !*********************
<
< else
< sigu=2.*ust*(1.-zeta)
< sigv=1.3*ust*(1.-zeta)
< sigu=max(sigu,1.e-6)
< sigv=max(sigv,1.e-6)
< sigw=sigv
< dsigw2dz=3.38*ust*ust*(zeta-1.)/h
< tlu=0.15*h/sigu*(sqrt(zeta))
< tlv=0.467*tlu
< tlw=0.1*h/sigw*zeta**0.8
< endif
<
<
<
<
< tlu=max(10.,tlu)
< tlv=max(10.,tlv)
< tlw=max(30.,tlw)
<
<
< end subroutine hanna1
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine hanna1(z)
> ! i
> !*****************************************************************************
> ! *
> ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 4 December 1997 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! dsigwdz [1/s] vertical gradient of sigw *
> ! ol [m] Obukhov length *
> ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
> ! tlu [s] Lagrangian time scale for the along wind component. *
> ! tlv [s] Lagrangian time scale for the cross wind component. *
> ! tlw [s] Lagrangian time scale for the vertical wind component. *
> ! ust, ustar [m/s] friction velocity *
> ! wst, wstar [m/s] convective velocity scale *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use hanna_mod
>
> implicit none
>
> real :: z,s1,s2
>
>
>
> !**********************
> ! 1. Neutral conditions
> !**********************
>
> if (h/abs(ol).lt.1.) then
>
> ust=max(1.e-4,ust)
> sigu=2.0*ust*exp(-3.e-4*z/ust)
> sigu=max(sigu,1.e-5)
> sigv=1.3*ust*exp(-2.e-4*z/ust)
> sigv=max(sigv,1.e-5)
> sigw=sigv
> dsigw2dz=-6.76e-4*ust*exp(-4.e-4*z/ust)
> tlu=0.5*z/sigw/(1.+1.5e-3*z/ust)
> tlv=tlu
> tlw=tlu
>
>
> !***********************
> ! 2. Unstable conditions
> !***********************
>
> else if (ol.lt.0.) then
>
>
> ! Determine sigmas
> !*****************
>
> sigu=ust*(12-0.5*h/ol)**0.33333
> sigu=max(sigu,1.e-6)
> sigv=sigu
>
> if (zeta.lt.0.03) then
> sigw=0.96*wst*(3*zeta-ol/h)**0.33333
> dsigw2dz=1.8432*wst*wst/h*(3*zeta-ol/h)**(-0.33333)
> else if (zeta.lt.0.4) then
> s1=0.96*(3*zeta-ol/h)**0.33333
> s2=0.763*zeta**0.175
> if (s1.lt.s2) then
> sigw=wst*s1
> dsigw2dz=1.8432*wst*wst/h*(3*zeta-ol/h)**(-0.33333)
> else
> sigw=wst*s2
> dsigw2dz=0.203759*wst*wst/h*zeta**(-0.65)
> endif
> else if (zeta.lt.0.96) then
> sigw=0.722*wst*(1-zeta)**0.207
> dsigw2dz=-.215812*wst*wst/h*(1-zeta)**(-0.586)
> else if (zeta.lt.1.00) then
> sigw=0.37*wst
> dsigw2dz=0.
> endif
> sigw=max(sigw,1.e-6)
>
>
> ! Determine average Lagrangian time scale
> !****************************************
>
> tlu=0.15*h/sigu
> tlv=tlu
> if (z.lt.abs(ol)) then
> tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
> else if (zeta.lt.0.1) then
> tlw=0.59*z/sigw
> else
> tlw=0.15*h/sigw*(1.-exp(-5*zeta))
> endif
>
>
> !*********************
> ! 3. Stable conditions
> !*********************
>
> else
> sigu=2.*ust*(1.-zeta)
> sigv=1.3*ust*(1.-zeta)
> sigu=max(sigu,1.e-6)
> sigv=max(sigv,1.e-6)
> sigw=sigv
> dsigw2dz=3.38*ust*ust*(zeta-1.)/h
> tlu=0.15*h/sigu*(sqrt(zeta))
> tlv=0.467*tlu
> tlw=0.1*h/sigw*zeta**0.8
> endif
>
>
>
>
> tlu=max(10.,tlu)
> tlv=max(10.,tlv)
> tlw=max(30.,tlw)
>
>
> end subroutine hanna1
hanna.f90
----------------------------------------------
1,126c1,126
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine hanna(z)
< ! i
< !*****************************************************************************
< ! *
< ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 4 December 1997 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! dsigwdz [1/s] vertical gradient of sigw *
< ! ol [m] Obukhov length *
< ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
< ! tlu [s] Lagrangian time scale for the along wind component. *
< ! tlv [s] Lagrangian time scale for the cross wind component. *
< ! tlw [s] Lagrangian time scale for the vertical wind component. *
< ! ust, ustar [m/s] friction velocity *
< ! wst, wstar [m/s] convective velocity scale *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use hanna_mod
<
< implicit none
<
< real :: corr,z
<
<
<
< !**********************
< ! 1. Neutral conditions
< !**********************
<
< if (h/abs(ol).lt.1.) then
< ust=max(1.e-4,ust)
< corr=z/ust
< sigu=1.e-2+2.0*ust*exp(-3.e-4*corr)
< sigw=1.3*ust*exp(-2.e-4*corr)
< dsigwdz=-2.e-4*sigw
< sigw=sigw+1.e-2
< sigv=sigw
< tlu=0.5*z/sigw/(1.+1.5e-3*corr)
< tlv=tlu
< tlw=tlu
<
<
< !***********************
< ! 2. Unstable conditions
< !***********************
<
< else if (ol.lt.0.) then
<
<
< ! Determine sigmas
< !*****************
<
< sigu=1.e-2+ust*(12-0.5*h/ol)**0.33333
< sigv=sigu
< sigw=sqrt(1.2*wst**2*(1.-.9*zeta)*zeta**0.66666+ &
< (1.8-1.4*zeta)*ust**2)+1.e-2
< dsigwdz=0.5/sigw/h*(-1.4*ust**2+wst**2* &
< (0.8*max(zeta,1.e-3)**(-.33333)-1.8*zeta**0.66666))
<
<
< ! Determine average Lagrangian time scale
< !****************************************
<
< tlu=0.15*h/sigu
< tlv=tlu
< if (z.lt.abs(ol)) then
< tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
< else if (zeta.lt.0.1) then
< tlw=0.59*z/sigw
< else
< tlw=0.15*h/sigw*(1.-exp(-5*zeta))
< endif
<
<
< !*********************
< ! 3. Stable conditions
< !*********************
<
< else
< sigu=1.e-2+2.*ust*(1.-zeta)
< sigv=1.e-2+1.3*ust*(1.-zeta)
< sigw=sigv
< dsigwdz=-1.3*ust/h
< tlu=0.15*h/sigu*(sqrt(zeta))
< tlv=0.467*tlu
< tlw=0.1*h/sigw*zeta**0.8
< endif
<
<
< tlu=max(10.,tlu)
< tlv=max(10.,tlv)
< tlw=max(30.,tlw)
<
< if (dsigwdz.eq.0.) dsigwdz=1.e-10
<
< end subroutine hanna
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine hanna(z)
> ! i
> !*****************************************************************************
> ! *
> ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 4 December 1997 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! dsigwdz [1/s] vertical gradient of sigw *
> ! ol [m] Obukhov length *
> ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
> ! tlu [s] Lagrangian time scale for the along wind component. *
> ! tlv [s] Lagrangian time scale for the cross wind component. *
> ! tlw [s] Lagrangian time scale for the vertical wind component. *
> ! ust, ustar [m/s] friction velocity *
> ! wst, wstar [m/s] convective velocity scale *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use hanna_mod
>
> implicit none
>
> real :: corr,z
>
>
>
> !**********************
> ! 1. Neutral conditions
> !**********************
>
> if (h/abs(ol).lt.1.) then
> ust=max(1.e-4,ust)
> corr=z/ust
> sigu=1.e-2+2.0*ust*exp(-3.e-4*corr)
> sigw=1.3*ust*exp(-2.e-4*corr)
> dsigwdz=-2.e-4*sigw
> sigw=sigw+1.e-2
> sigv=sigw
> tlu=0.5*z/sigw/(1.+1.5e-3*corr)
> tlv=tlu
> tlw=tlu
>
>
> !***********************
> ! 2. Unstable conditions
> !***********************
>
> else if (ol.lt.0.) then
>
>
> ! Determine sigmas
> !*****************
>
> sigu=1.e-2+ust*(12-0.5*h/ol)**0.33333
> sigv=sigu
> sigw=sqrt(1.2*wst**2*(1.-.9*zeta)*zeta**0.66666+ &
> (1.8-1.4*zeta)*ust**2)+1.e-2
> dsigwdz=0.5/sigw/h*(-1.4*ust**2+wst**2* &
> (0.8*max(zeta,1.e-3)**(-.33333)-1.8*zeta**0.66666))
>
>
> ! Determine average Lagrangian time scale
> !****************************************
>
> tlu=0.15*h/sigu
> tlv=tlu
> if (z.lt.abs(ol)) then
> tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
> else if (zeta.lt.0.1) then
> tlw=0.59*z/sigw
> else
> tlw=0.15*h/sigw*(1.-exp(-5*zeta))
> endif
>
>
> !*********************
> ! 3. Stable conditions
> !*********************
>
> else
> sigu=1.e-2+2.*ust*(1.-zeta)
> sigv=1.e-2+1.3*ust*(1.-zeta)
> sigw=sigv
> dsigwdz=-1.3*ust/h
> tlu=0.15*h/sigu*(sqrt(zeta))
> tlv=0.467*tlu
> tlw=0.1*h/sigw*zeta**0.8
> endif
>
>
> tlu=max(10.,tlu)
> tlv=max(10.,tlv)
> tlw=max(30.,tlw)
>
> if (dsigwdz.eq.0.) dsigwdz=1.e-10
>
> end subroutine hanna
hanna_mod.f90
----------------------------------------------
1,8c1,12
< module hanna_mod
<
< implicit none
<
< real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw
< real :: sigw,dsigwdz,dsigw2dz
<
< end module hanna_mod
---
> module hanna_mod
>
> implicit none
>
> real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw
> real :: sigw,dsigwdz,dsigw2dz
>
> !$OMP THREADPRIVATE(ust, wst, ol, h, zeta, sigu, sigv, tlu, tlv, tlw, &
> !$OMP sigw, dsigwdz, dsigw2dz)
>
>
> end module hanna_mod
hanna_short.f90
----------------------------------------------
1,112c1,112
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine hanna_short(z)
< ! i
< !*****************************************************************************
< ! *
< ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 4 December 1997 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! dsigwdz [1/s] vertical gradient of sigw *
< ! ol [m] Obukhov length *
< ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
< ! tlu [s] Lagrangian time scale for the along wind component. *
< ! tlv [s] Lagrangian time scale for the cross wind component. *
< ! tlw [s] Lagrangian time scale for the vertical wind component. *
< ! ust, ustar [m/s] friction velocity *
< ! wst, wstar [m/s] convective velocity scale *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use hanna_mod
<
< implicit none
<
< real :: z
<
<
<
< !**********************
< ! 1. Neutral conditions
< !**********************
<
< if (h/abs(ol).lt.1.) then
< ust=max(1.e-4,ust)
< sigw=1.3*exp(-2.e-4*z/ust)
< dsigwdz=-2.e-4*sigw
< sigw=sigw*ust+1.e-2
< tlw=0.5*z/sigw/(1.+1.5e-3*z/ust)
<
<
< !***********************
< ! 2. Unstable conditions
< !***********************
<
< else if (ol.lt.0.) then
<
<
< ! Determine sigmas
< !*****************
<
< sigw=sqrt(1.2*wst**2*(1.-.9*zeta)*zeta**0.66666+ &
< (1.8-1.4*zeta)*ust**2)+1.e-2
< dsigwdz=0.5/sigw/h*(-1.4*ust**2+wst**2* &
< (0.8*max(zeta,1.e-3)**(-.33333)-1.8*zeta**0.66666))
<
<
< ! Determine average Lagrangian time scale
< !****************************************
<
< if (z.lt.abs(ol)) then
< tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
< else if (zeta.lt.0.1) then
< tlw=0.59*z/sigw
< else
< tlw=0.15*h/sigw*(1.-exp(-5*zeta))
< endif
<
<
< !*********************
< ! 3. Stable conditions
< !*********************
<
< else
< sigw=1.e-2+1.3*ust*(1.-zeta)
< dsigwdz=-1.3*ust/h
< tlw=0.1*h/sigw*zeta**0.8
< endif
<
<
< tlu=max(10.,tlu)
< tlv=max(10.,tlv)
< tlw=max(30.,tlw)
< if (dsigwdz.eq.0.) dsigwdz=1.e-10
<
< end subroutine hanna_short
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine hanna_short(z)
> ! i
> !*****************************************************************************
> ! *
> ! Computation of \sigma_i and \tau_L based on the scheme of Hanna (1982) *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 4 December 1997 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! dsigwdz [1/s] vertical gradient of sigw *
> ! ol [m] Obukhov length *
> ! sigu, sigv, sigw standard deviations of turbulent velocity fluctuations *
> ! tlu [s] Lagrangian time scale for the along wind component. *
> ! tlv [s] Lagrangian time scale for the cross wind component. *
> ! tlw [s] Lagrangian time scale for the vertical wind component. *
> ! ust, ustar [m/s] friction velocity *
> ! wst, wstar [m/s] convective velocity scale *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use hanna_mod
>
> implicit none
>
> real :: z
>
>
>
> !**********************
> ! 1. Neutral conditions
> !**********************
>
> if (h/abs(ol).lt.1.) then
> ust=max(1.e-4,ust)
> sigw=1.3*exp(-2.e-4*z/ust)
> dsigwdz=-2.e-4*sigw
> sigw=sigw*ust+1.e-2
> tlw=0.5*z/sigw/(1.+1.5e-3*z/ust)
>
>
> !***********************
> ! 2. Unstable conditions
> !***********************
>
> else if (ol.lt.0.) then
>
>
> ! Determine sigmas
> !*****************
>
> sigw=sqrt(1.2*wst**2*(1.-.9*zeta)*zeta**0.66666+ &
> (1.8-1.4*zeta)*ust**2)+1.e-2
> dsigwdz=0.5/sigw/h*(-1.4*ust**2+wst**2* &
> (0.8*max(zeta,1.e-3)**(-.33333)-1.8*zeta**0.66666))
>
>
> ! Determine average Lagrangian time scale
> !****************************************
>
> if (z.lt.abs(ol)) then
> tlw=0.1*z/(sigw*(0.55-0.38*abs(z/ol)))
> else if (zeta.lt.0.1) then
> tlw=0.59*z/sigw
> else
> tlw=0.15*h/sigw*(1.-exp(-5*zeta))
> endif
>
>
> !*********************
> ! 3. Stable conditions
> !*********************
>
> else
> sigw=1.e-2+1.3*ust*(1.-zeta)
> dsigwdz=-1.3*ust/h
> tlw=0.1*h/sigw*zeta**0.8
> endif
>
>
> tlu=max(10.,tlu)
> tlv=max(10.,tlv)
> tlw=max(30.,tlw)
> if (dsigwdz.eq.0.) dsigwdz=1.e-10
>
> end subroutine hanna_short
init_domainfill.f90
----------------------------------------------
1,416c1,417
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine init_domainfill
< !
< !*****************************************************************************
< ! *
< ! Initializes particles equally distributed over the first release location *
< ! specified in file RELEASES. This box is assumed to be the domain for doing *
< ! domain-filling trajectory calculations. *
< ! All particles carry the same amount of mass which alltogether comprises the*
< ! mass of air within the box. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 15 October 2002 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! numparticlecount consecutively counts the number of particles released *
< ! nx_we(2) grid indices for western and eastern boundary of domain- *
< ! filling trajectory calculations *
< ! ny_sn(2) grid indices for southern and northern boundary of domain- *
< ! filling trajectory calculations *
< ! *
< !*****************************************************************************
<
< use point_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: j,ix,jy,kz,ncolumn,numparttot
< real :: gridarea(0:nymax-1),pp(nzmax),ylat,ylatp,ylatm,hzone,ran1
< real :: cosfactm,cosfactp,deltacol,dz1,dz2,dz,pnew,fractus
< real,parameter :: pih=pi/180.
< real :: colmass(0:nxmax-1,0:nymax-1),colmasstotal,zposition
<
< integer :: ixm,ixp,jym,jyp,indzm,indzp,in,indzh,i,jj
< real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2)
<
< integer :: idummy = -11
<
<
< ! Determine the release region (only full grid cells), over which particles
< ! shall be initialized
< ! Use 2 fields for west/east and south/north boundary
< !**************************************************************************
<
< nx_we(1)=max(int(xpoint1(1)),0)
< nx_we(2)=min((int(xpoint2(1))+1),nxmin1)
< ny_sn(1)=max(int(ypoint1(1)),0)
< ny_sn(2)=min((int(ypoint2(1))+1),nymin1)
<
< ! For global simulations (both global wind data and global domain-filling),
< ! set a switch, such that no boundary conditions are used
< !**************************************************************************
< if (xglobal.and.sglobal.and.nglobal) then
< if ((nx_we(1).eq.0).and.(nx_we(2).eq.nxmin1).and. &
< (ny_sn(1).eq.0).and.(ny_sn(2).eq.nymin1)) then
< gdomainfill=.true.
< else
< gdomainfill=.false.
< endif
< endif
<
< ! Do not release particles twice (i.e., not at both in the leftmost and rightmost
< ! grid cell) for a global domain
< !*****************************************************************************
< if (xglobal) nx_we(2)=min(nx_we(2),nx-2)
<
<
< ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
< ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
< !************************************************************
<
< do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
< ylat=ylat0+real(jy)*dy
< ylatp=ylat+0.5*dy
< ylatm=ylat-0.5*dy
< if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
< hzone=1./dyconst
< else
< cosfactp=cos(ylatp*pih)*r_earth
< cosfactm=cos(ylatm*pih)*r_earth
< if (cosfactp.lt.cosfactm) then
< hzone=sqrt(r_earth**2-cosfactp**2)- &
< sqrt(r_earth**2-cosfactm**2)
< else
< hzone=sqrt(r_earth**2-cosfactm**2)- &
< sqrt(r_earth**2-cosfactp**2)
< endif
< endif
< gridarea(jy)=2.*pi*r_earth*hzone*dx/360.
< end do
<
< ! Do the same for the south pole
<
< if (sglobal) then
< ylat=ylat0
< ylatp=ylat+0.5*dy
< ylatm=ylat
< cosfactm=0.
< cosfactp=cos(ylatp*pih)*r_earth
< hzone=sqrt(r_earth**2-cosfactm**2)- &
< sqrt(r_earth**2-cosfactp**2)
< gridarea(0)=2.*pi*r_earth*hzone*dx/360.
< endif
<
< ! Do the same for the north pole
<
< if (nglobal) then
< ylat=ylat0+real(nymin1)*dy
< ylatp=ylat
< ylatm=ylat-0.5*dy
< cosfactp=0.
< cosfactm=cos(ylatm*pih)*r_earth
< hzone=sqrt(r_earth**2-cosfactp**2)- &
< sqrt(r_earth**2-cosfactm**2)
< gridarea(nymin1)=2.*pi*r_earth*hzone*dx/360.
< endif
<
<
< ! Calculate total mass of each grid column and of the whole atmosphere
< !*********************************************************************
<
< colmasstotal=0.
< do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
< do ix=nx_we(1),nx_we(2) ! loop about longitudes
< pp(1)=rho(ix,jy,1,1)*r_air*tt(ix,jy,1,1)
< pp(nz)=rho(ix,jy,nz,1)*r_air*tt(ix,jy,nz,1)
< colmass(ix,jy)=(pp(1)-pp(nz))/ga*gridarea(jy)
< colmasstotal=colmasstotal+colmass(ix,jy)
< end do
< end do
<
< write(*,*) 'Atm. mass: ',colmasstotal
<
<
< if (ipin.eq.0) numpart=0
<
< ! Determine the particle positions
< !*********************************
<
< numparttot=0
< numcolumn=0
< do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
< ylat=ylat0+real(jy)*dy
< do ix=nx_we(1),nx_we(2) ! loop about longitudes
< ncolumn=nint(0.999*real(npart(1))*colmass(ix,jy)/ &
< colmasstotal)
< if (ncolumn.eq.0) goto 30
< if (ncolumn.gt.numcolumn) numcolumn=ncolumn
<
< ! Calculate pressure at the altitudes of model surfaces, using the air density
< ! information, which is stored as a 3-d field
< !*****************************************************************************
<
< do kz=1,nz
< pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
< end do
<
<
< deltacol=(pp(1)-pp(nz))/real(ncolumn)
< pnew=pp(1)+deltacol/2.
< jj=0
< do j=1,ncolumn
< jj=jj+1
<
<
< ! For columns with many particles (i.e. around the equator), distribute
< ! the particles equally, for columns with few particles (i.e. around the
< ! poles), distribute the particles randomly
< !***********************************************************************
<
<
< if (ncolumn.gt.20) then
< pnew=pnew-deltacol
< else
< pnew=pp(1)-ran1(idummy)*(pp(1)-pp(nz))
< endif
<
< do kz=1,nz-1
< if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
< dz1=pp(kz)-pnew
< dz2=pnew-pp(kz+1)
< dz=1./(dz1+dz2)
<
< ! Assign particle position
< !*************************
< ! Do the following steps only if particles are not read in from previous model run
< !*****************************************************************************
< if (ipin.eq.0) then
< xtra1(numpart+jj)=real(ix)-0.5+ran1(idummy)
< if (ix.eq.0) xtra1(numpart+jj)=ran1(idummy)
< if (ix.eq.nxmin1) xtra1(numpart+jj)= &
< real(nxmin1)-ran1(idummy)
< ytra1(numpart+jj)=real(jy)-0.5+ran1(idummy)
< ztra1(numpart+jj)=(height(kz)*dz2+height(kz+1)*dz1)*dz
< if (ztra1(numpart+jj).gt.height(nz)-0.5) &
< ztra1(numpart+jj)=height(nz)-0.5
<
<
< ! Interpolate PV to the particle position
< !****************************************
< ixm=int(xtra1(numpart+jj))
< jym=int(ytra1(numpart+jj))
< ixp=ixm+1
< jyp=jym+1
< ddx=xtra1(numpart+jj)-real(ixm)
< ddy=ytra1(numpart+jj)-real(jym)
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
< do i=2,nz
< if (height(i).gt.ztra1(numpart+jj)) then
< indzm=i-1
< indzp=i
< goto 6
< endif
< end do
< 6 continue
< dz1=ztra1(numpart+jj)-height(indzm)
< dz2=height(indzp)-ztra1(numpart+jj)
< dz=1./(dz1+dz2)
< do in=1,2
< indzh=indzm+in-1
< y1(in)=p1*pv(ixm,jym,indzh,1) &
< +p2*pv(ixp,jym,indzh,1) &
< +p3*pv(ixm,jyp,indzh,1) &
< +p4*pv(ixp,jyp,indzh,1)
< end do
< pvpart=(dz2*y1(1)+dz1*y1(2))*dz
< if (ylat.lt.0.) pvpart=-1.*pvpart
<
<
< ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
< !*****************************************************************************
<
< if (((ztra1(numpart+jj).gt.3000.).and. &
< (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
<
< ! Assign certain properties to the particle
< !******************************************
< nclass(numpart+jj)=min(int(ran1(idummy)* &
< real(nclassunc))+1,nclassunc)
< numparticlecount=numparticlecount+1
< npoint(numpart+jj)=numparticlecount
< idt(numpart+jj)=mintime
< itra1(numpart+jj)=0
< itramem(numpart+jj)=0
< itrasplit(numpart+jj)=itra1(numpart+jj)+ldirect* &
< itsplit
< xmass1(numpart+jj,1)=colmass(ix,jy)/real(ncolumn)
< if (mdomainfill.eq.2) xmass1(numpart+jj,1)= &
< xmass1(numpart+jj,1)*pvpart*48./29.*ozonescale/10.**9
< else
< jj=jj-1
< endif
< endif
< endif
< end do
< end do
< numparttot=numparttot+ncolumn
< if (ipin.eq.0) numpart=numpart+jj
< 30 continue
< end do
< end do
<
<
< ! Check whether numpart is really smaller than maxpart
< !*****************************************************
<
< if (numpart.gt.maxpart) then
< write(*,*) 'numpart too large: change source in init_atm_mass.f'
< write(*,*) 'numpart: ',numpart,' maxpart: ',maxpart
< endif
<
<
< xmassperparticle=colmasstotal/real(numparttot)
<
<
< ! Make sure that all particles are within domain
< !***********************************************
<
< do j=1,numpart
< if ((xtra1(j).lt.0.).or.(xtra1(j).ge.real(nxmin1)).or. &
< (ytra1(j).lt.0.).or.(ytra1(j).ge.real(nymin1))) then
< itra1(j)=-999999999
< endif
< end do
<
<
<
<
< ! For boundary conditions, we need fewer particle release heights per column,
< ! because otherwise it takes too long until enough mass has accumulated to
< ! release a particle at the boundary (would take dx/u seconds), leading to
< ! relatively large position errors of the order of one grid distance.
< ! It's better to release fewer particles per column, but to do so more often.
< ! Thus, use on the order of nz starting heights per column.
< ! We thus repeat the above to determine fewer starting heights, that are
< ! used furtheron in subroutine boundcond_domainfill.f.
< !****************************************************************************
<
< fractus=real(numcolumn)/real(nz)
< write(*,*) 'Total number of particles at model start: ',numpart
< write(*,*) 'Maximum number of particles per column: ',numcolumn
< write(*,*) 'If ',fractus,' <1, better use more particles'
< fractus=sqrt(max(fractus,1.))/2.
<
< do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
< do ix=nx_we(1),nx_we(2) ! loop about longitudes
< ncolumn=nint(0.999/fractus*real(npart(1))*colmass(ix,jy) &
< /colmasstotal)
< if (ncolumn.gt.maxcolumn) stop 'maxcolumn too small'
< if (ncolumn.eq.0) goto 80
<
<
< ! Memorize how many particles per column shall be used for all boundaries
< ! This is further used in subroutine boundcond_domainfill.f
< ! Use 2 fields for west/east and south/north boundary
< !************************************************************************
<
< if (ix.eq.nx_we(1)) numcolumn_we(1,jy)=ncolumn
< if (ix.eq.nx_we(2)) numcolumn_we(2,jy)=ncolumn
< if (jy.eq.ny_sn(1)) numcolumn_sn(1,ix)=ncolumn
< if (jy.eq.ny_sn(2)) numcolumn_sn(2,ix)=ncolumn
<
< ! Calculate pressure at the altitudes of model surfaces, using the air density
< ! information, which is stored as a 3-d field
< !*****************************************************************************
<
< do kz=1,nz
< pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
< end do
<
< ! Determine the reference starting altitudes
< !*******************************************
<
< deltacol=(pp(1)-pp(nz))/real(ncolumn)
< pnew=pp(1)+deltacol/2.
< do j=1,ncolumn
< pnew=pnew-deltacol
< do kz=1,nz-1
< if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
< dz1=pp(kz)-pnew
< dz2=pnew-pp(kz+1)
< dz=1./(dz1+dz2)
< zposition=(height(kz)*dz2+height(kz+1)*dz1)*dz
< if (zposition.gt.height(nz)-0.5) zposition=height(nz)-0.5
<
< ! Memorize vertical positions where particles are introduced
< ! This is further used in subroutine boundcond_domainfill.f
< !***********************************************************
<
< if (ix.eq.nx_we(1)) zcolumn_we(1,jy,j)=zposition
< if (ix.eq.nx_we(2)) zcolumn_we(2,jy,j)=zposition
< if (jy.eq.ny_sn(1)) zcolumn_sn(1,ix,j)=zposition
< if (jy.eq.ny_sn(2)) zcolumn_sn(2,ix,j)=zposition
<
< ! Initialize mass that has accumulated at boundary to zero
< !*********************************************************
<
< acc_mass_we(1,jy,j)=0.
< acc_mass_we(2,jy,j)=0.
< acc_mass_sn(1,jy,j)=0.
< acc_mass_sn(2,jy,j)=0.
< endif
< end do
< end do
< 80 continue
< end do
< end do
<
< ! If particles shall be read in to continue an existing run,
< ! then the accumulated masses at the domain boundaries must be read in, too.
< ! This overrides any previous calculations.
< !***************************************************************************
<
< if (ipin.eq.1) then
< open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
< form='unformatted')
< read(unitboundcond) numcolumn_we,numcolumn_sn, &
< zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
< close(unitboundcond)
< endif
<
<
<
<
< end subroutine init_domainfill
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine init_domainfill
> !
> !*****************************************************************************
> ! *
> ! Initializes particles equally distributed over the first release location *
> ! specified in file RELEASES. This box is assumed to be the domain for doing *
> ! domain-filling trajectory calculations. *
> ! All particles carry the same amount of mass which alltogether comprises the*
> ! mass of air within the box. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 15 October 2002 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! numparticlecount consecutively counts the number of particles released *
> ! nx_we(2) grid indices for western and eastern boundary of domain- *
> ! filling trajectory calculations *
> ! ny_sn(2) grid indices for southern and northern boundary of domain- *
> ! filling trajectory calculations *
> ! *
> !*****************************************************************************
>
> use point_mod
> use par_mod
> use com_mod
> use random_mod, only : ran1
>
> implicit none
>
> integer :: j,ix,jy,kz,ncolumn,numparttot
> real :: gridarea(0:nymax-1),pp(nzmax),ylat,ylatp,ylatm,hzone
> real :: cosfactm,cosfactp,deltacol,dz1,dz2,dz,pnew,fractus
> real,parameter :: pih=pi/180.
> real :: colmass(0:nxmax-1,0:nymax-1),colmasstotal,zposition
>
> integer :: ixm,ixp,jym,jyp,indzm,indzp,in,indzh,i,jj
> real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2)
>
> integer :: idummy = -11
>
>
> ! Determine the release region (only full grid cells), over which particles
> ! shall be initialized
> ! Use 2 fields for west/east and south/north boundary
> !**************************************************************************
>
> nx_we(1)=max(int(xpoint1(1)),0)
> nx_we(2)=min((int(xpoint2(1))+1),nxmin1)
> ny_sn(1)=max(int(ypoint1(1)),0)
> ny_sn(2)=min((int(ypoint2(1))+1),nymin1)
>
> ! For global simulations (both global wind data and global domain-filling),
> ! set a switch, such that no boundary conditions are used
> !**************************************************************************
> if (xglobal.and.sglobal.and.nglobal) then
> if ((nx_we(1).eq.0).and.(nx_we(2).eq.nxmin1).and. &
> (ny_sn(1).eq.0).and.(ny_sn(2).eq.nymin1)) then
> gdomainfill=.true.
> else
> gdomainfill=.false.
> endif
> endif
>
> ! Do not release particles twice (i.e., not at both in the leftmost and rightmost
> ! grid cell) for a global domain
> !*****************************************************************************
> if (xglobal) nx_we(2)=min(nx_we(2),nx-2)
>
>
> ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
> ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
> !************************************************************
>
> do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
> ylat=ylat0+real(jy)*dy
> ylatp=ylat+0.5*dy
> ylatm=ylat-0.5*dy
> if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
> hzone=1./dyconst
> else
> cosfactp=cos(ylatp*pih)*r_earth
> cosfactm=cos(ylatm*pih)*r_earth
> if (cosfactp.lt.cosfactm) then
> hzone=sqrt(r_earth**2-cosfactp**2)- &
> sqrt(r_earth**2-cosfactm**2)
> else
> hzone=sqrt(r_earth**2-cosfactm**2)- &
> sqrt(r_earth**2-cosfactp**2)
> endif
> endif
> gridarea(jy)=2.*pi*r_earth*hzone*dx/360.
> end do
>
> ! Do the same for the south pole
>
> if (sglobal) then
> ylat=ylat0
> ylatp=ylat+0.5*dy
> ylatm=ylat
> cosfactm=0.
> cosfactp=cos(ylatp*pih)*r_earth
> hzone=sqrt(r_earth**2-cosfactm**2)- &
> sqrt(r_earth**2-cosfactp**2)
> gridarea(0)=2.*pi*r_earth*hzone*dx/360.
> endif
>
> ! Do the same for the north pole
>
> if (nglobal) then
> ylat=ylat0+real(nymin1)*dy
> ylatp=ylat
> ylatm=ylat-0.5*dy
> cosfactp=0.
> cosfactm=cos(ylatm*pih)*r_earth
> hzone=sqrt(r_earth**2-cosfactp**2)- &
> sqrt(r_earth**2-cosfactm**2)
> gridarea(nymin1)=2.*pi*r_earth*hzone*dx/360.
> endif
>
>
> ! Calculate total mass of each grid column and of the whole atmosphere
> !*********************************************************************
>
> colmasstotal=0.
> do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
> do ix=nx_we(1),nx_we(2) ! loop about longitudes
> pp(1)=rho(ix,jy,1,1)*r_air*tt(ix,jy,1,1)
> pp(nz)=rho(ix,jy,nz,1)*r_air*tt(ix,jy,nz,1)
> colmass(ix,jy)=(pp(1)-pp(nz))/ga*gridarea(jy)
> colmasstotal=colmasstotal+colmass(ix,jy)
> end do
> end do
>
> write(*,*) 'Atm. mass: ',colmasstotal
>
>
> if (ipin.eq.0) numpart=0
>
> ! Determine the particle positions
> !*********************************
>
> numparttot=0
> numcolumn=0
> do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
> ylat=ylat0+real(jy)*dy
> do ix=nx_we(1),nx_we(2) ! loop about longitudes
> ncolumn=nint(0.999*real(npart(1))*colmass(ix,jy)/ &
> colmasstotal)
> if (ncolumn.eq.0) goto 30
> if (ncolumn.gt.numcolumn) numcolumn=ncolumn
>
> ! Calculate pressure at the altitudes of model surfaces, using the air density
> ! information, which is stored as a 3-d field
> !*****************************************************************************
>
> do kz=1,nz
> pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
> end do
>
>
> deltacol=(pp(1)-pp(nz))/real(ncolumn)
> pnew=pp(1)+deltacol/2.
> jj=0
> do j=1,ncolumn
> jj=jj+1
>
>
> ! For columns with many particles (i.e. around the equator), distribute
> ! the particles equally, for columns with few particles (i.e. around the
> ! poles), distribute the particles randomly
> !***********************************************************************
>
>
> if (ncolumn.gt.20) then
> pnew=pnew-deltacol
> else
> pnew=pp(1)-ran1(idummy)*(pp(1)-pp(nz))
> endif
>
> do kz=1,nz-1
> if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
> dz1=pp(kz)-pnew
> dz2=pnew-pp(kz+1)
> dz=1./(dz1+dz2)
>
> ! Assign particle position
> !*************************
> ! Do the following steps only if particles are not read in from previous model run
> !*****************************************************************************
> if (ipin.eq.0) then
> xtra1(numpart+jj)=real(ix)-0.5+ran1(idummy)
> if (ix.eq.0) xtra1(numpart+jj)=ran1(idummy)
> if (ix.eq.nxmin1) xtra1(numpart+jj)= &
> real(nxmin1)-ran1(idummy)
> ytra1(numpart+jj)=real(jy)-0.5+ran1(idummy)
> ztra1(numpart+jj)=(height(kz)*dz2+height(kz+1)*dz1)*dz
> if (ztra1(numpart+jj).gt.height(nz)-0.5) &
> ztra1(numpart+jj)=height(nz)-0.5
>
>
> ! Interpolate PV to the particle position
> !****************************************
> ixm=int(xtra1(numpart+jj))
> jym=int(ytra1(numpart+jj))
> ixp=ixm+1
> jyp=jym+1
> ddx=xtra1(numpart+jj)-real(ixm)
> ddy=ytra1(numpart+jj)-real(jym)
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
> do i=2,nz
> if (height(i).gt.ztra1(numpart+jj)) then
> indzm=i-1
> indzp=i
> goto 6
> endif
> end do
> 6 continue
> dz1=ztra1(numpart+jj)-height(indzm)
> dz2=height(indzp)-ztra1(numpart+jj)
> dz=1./(dz1+dz2)
> do in=1,2
> indzh=indzm+in-1
> y1(in)=p1*pv(ixm,jym,indzh,1) &
> +p2*pv(ixp,jym,indzh,1) &
> +p3*pv(ixm,jyp,indzh,1) &
> +p4*pv(ixp,jyp,indzh,1)
> end do
> pvpart=(dz2*y1(1)+dz1*y1(2))*dz
> if (ylat.lt.0.) pvpart=-1.*pvpart
>
>
> ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
> !*****************************************************************************
>
> if (((ztra1(numpart+jj).gt.3000.).and. &
> (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
>
> ! Assign certain properties to the particle
> !******************************************
> nclass(numpart+jj)=min(int(ran1(idummy)* &
> real(nclassunc))+1,nclassunc)
> numparticlecount=numparticlecount+1
> npoint(numpart+jj)=numparticlecount
> idt(numpart+jj)=mintime
> itra1(numpart+jj)=0
> itramem(numpart+jj)=0
> itrasplit(numpart+jj)=itra1(numpart+jj)+ldirect* &
> itsplit
> xmass1(numpart+jj,1)=colmass(ix,jy)/real(ncolumn)
> if (mdomainfill.eq.2) xmass1(numpart+jj,1)= &
> xmass1(numpart+jj,1)*pvpart*48./29.*ozonescale/10.**9
> else
> jj=jj-1
> endif
> endif
> endif
> end do
> end do
> numparttot=numparttot+ncolumn
> if (ipin.eq.0) numpart=numpart+jj
> 30 continue
> end do
> end do
>
>
> ! Check whether numpart is really smaller than maxpart
> !*****************************************************
>
> if (numpart.gt.maxpart) then
> write(*,*) 'numpart too large: change source in init_atm_mass.f'
> write(*,*) 'numpart: ',numpart,' maxpart: ',maxpart
> endif
>
>
> xmassperparticle=colmasstotal/real(numparttot)
>
>
> ! Make sure that all particles are within domain
> !***********************************************
>
> do j=1,numpart
> if ((xtra1(j).lt.0.).or.(xtra1(j).ge.real(nxmin1)).or. &
> (ytra1(j).lt.0.).or.(ytra1(j).ge.real(nymin1))) then
> itra1(j)=-999999999
> endif
> end do
>
>
>
>
> ! For boundary conditions, we need fewer particle release heights per column,
> ! because otherwise it takes too long until enough mass has accumulated to
> ! release a particle at the boundary (would take dx/u seconds), leading to
> ! relatively large position errors of the order of one grid distance.
> ! It's better to release fewer particles per column, but to do so more often.
> ! Thus, use on the order of nz starting heights per column.
> ! We thus repeat the above to determine fewer starting heights, that are
> ! used furtheron in subroutine boundcond_domainfill.f.
> !****************************************************************************
>
> fractus=real(numcolumn)/real(nz)
> write(*,*) 'Total number of particles at model start: ',numpart
> write(*,*) 'Maximum number of particles per column: ',numcolumn
> write(*,*) 'If ',fractus,' <1, better use more particles'
> fractus=sqrt(max(fractus,1.))/2.
>
> do jy=ny_sn(1),ny_sn(2) ! loop about latitudes
> do ix=nx_we(1),nx_we(2) ! loop about longitudes
> ncolumn=nint(0.999/fractus*real(npart(1))*colmass(ix,jy) &
> /colmasstotal)
> if (ncolumn.gt.maxcolumn) stop 'maxcolumn too small'
> if (ncolumn.eq.0) goto 80
>
>
> ! Memorize how many particles per column shall be used for all boundaries
> ! This is further used in subroutine boundcond_domainfill.f
> ! Use 2 fields for west/east and south/north boundary
> !************************************************************************
>
> if (ix.eq.nx_we(1)) numcolumn_we(1,jy)=ncolumn
> if (ix.eq.nx_we(2)) numcolumn_we(2,jy)=ncolumn
> if (jy.eq.ny_sn(1)) numcolumn_sn(1,ix)=ncolumn
> if (jy.eq.ny_sn(2)) numcolumn_sn(2,ix)=ncolumn
>
> ! Calculate pressure at the altitudes of model surfaces, using the air density
> ! information, which is stored as a 3-d field
> !*****************************************************************************
>
> do kz=1,nz
> pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
> end do
>
> ! Determine the reference starting altitudes
> !*******************************************
>
> deltacol=(pp(1)-pp(nz))/real(ncolumn)
> pnew=pp(1)+deltacol/2.
> do j=1,ncolumn
> pnew=pnew-deltacol
> do kz=1,nz-1
> if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
> dz1=pp(kz)-pnew
> dz2=pnew-pp(kz+1)
> dz=1./(dz1+dz2)
> zposition=(height(kz)*dz2+height(kz+1)*dz1)*dz
> if (zposition.gt.height(nz)-0.5) zposition=height(nz)-0.5
>
> ! Memorize vertical positions where particles are introduced
> ! This is further used in subroutine boundcond_domainfill.f
> !***********************************************************
>
> if (ix.eq.nx_we(1)) zcolumn_we(1,jy,j)=zposition
> if (ix.eq.nx_we(2)) zcolumn_we(2,jy,j)=zposition
> if (jy.eq.ny_sn(1)) zcolumn_sn(1,ix,j)=zposition
> if (jy.eq.ny_sn(2)) zcolumn_sn(2,ix,j)=zposition
>
> ! Initialize mass that has accumulated at boundary to zero
> !*********************************************************
>
> acc_mass_we(1,jy,j)=0.
> acc_mass_we(2,jy,j)=0.
> acc_mass_sn(1,jy,j)=0.
> acc_mass_sn(2,jy,j)=0.
> endif
> end do
> end do
> 80 continue
> end do
> end do
>
> ! If particles shall be read in to continue an existing run,
> ! then the accumulated masses at the domain boundaries must be read in, too.
> ! This overrides any previous calculations.
> !***************************************************************************
>
> if (ipin.eq.1) then
> open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
> form='unformatted')
> read(unitboundcond) numcolumn_we,numcolumn_sn, &
> zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
> close(unitboundcond)
> endif
>
>
>
>
> end subroutine init_domainfill
initial_cond_calc.f90
----------------------------------------------
1,213c1,213
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine initial_cond_calc(itime,i)
< ! i i
< !*****************************************************************************
< ! *
< ! Calculation of the sensitivity to initial conditions for BW runs *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 15 January 2010 *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: itime,i,ix,jy,ixp,jyp,kz,ks
< integer :: il,ind,indz,indzp,nrelpointer
< real :: rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
< real :: ddx,ddy
< real :: rhoprof(2),rhoi,xl,yl,wx,wy,w
<
<
< ! For forward simulations, make a loop over the number of species;
< ! for backward simulations, make an additional loop over the release points
< !**************************************************************************
<
<
< if (itra1(i).ne.itime) return
<
< ! Depending on output option, calculate air density or set it to 1
< ! linit_cond: 1=mass unit, 2=mass mixing ratio unit
< !*****************************************************************
<
<
< if (linit_cond.eq.1) then ! mass unit
<
< ix=int(xtra1(i))
< jy=int(ytra1(i))
< ixp=ix+1
< jyp=jy+1
< ddx=xtra1(i)-real(ix)
< ddy=ytra1(i)-real(jy)
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
<
< do il=2,nz
< if (height(il).gt.ztra1(i)) then
< indz=il-1
< indzp=il
< goto 6
< endif
< end do
< 6 continue
<
< dz1=ztra1(i)-height(indz)
< dz2=height(indzp)-ztra1(i)
< dz=1./(dz1+dz2)
<
< ! Take density from 2nd wind field in memory (accurate enough, no time interpolation needed)
< !*****************************************************************************
< do ind=indz,indzp
< rhoprof(ind-indz+1)=p1*rho(ix ,jy ,ind,2) &
< +p2*rho(ixp,jy ,ind,2) &
< +p3*rho(ix ,jyp,ind,2) &
< +p4*rho(ixp,jyp,ind,2)
< end do
< rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
< elseif (linit_cond.eq.2) then ! mass mixing ratio unit
< rhoi=1.
< endif
<
<
< !****************************************************************************
< ! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
< !****************************************************************************
<
<
< ! For backward simulations, look from which release point the particle comes from
< ! For domain-filling trajectory option, npoint contains a consecutive particle
< ! number, not the release point information. Therefore, nrelpointer is set to 1
< ! for the domain-filling option.
< !*****************************************************************************
<
< if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
< nrelpointer=1
< else
< nrelpointer=npoint(i)
< endif
<
< do kz=1,numzgrid ! determine height of cell
< if (outheight(kz).gt.ztra1(i)) goto 21
< end do
< 21 continue
< if (kz.le.numzgrid) then ! inside output domain
<
<
< xl=(xtra1(i)*dx+xoutshift)/dxout
< yl=(ytra1(i)*dy+youtshift)/dyout
< ix=int(xl)
< if (xl.lt.0.) ix=ix-1
< jy=int(yl)
< if (yl.lt.0.) jy=jy-1
<
<
< ! If a particle is close to the domain boundary, do not use the kernel either
< !****************************************************************************
<
< if ((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
< if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
< (jy.le.numygrid-1)) then
< do ks=1,nspec
< init_cond(ix,jy,kz,ks,nrelpointer)= &
< init_cond(ix,jy,kz,ks,nrelpointer)+ &
< xmass1(i,ks)/rhoi
< end do
< endif
<
< else ! attribution via uniform kernel
<
< ddx=xl-real(ix) ! distance to left cell border
< ddy=yl-real(jy) ! distance to lower cell border
< if (ddx.gt.0.5) then
< ixp=ix+1
< wx=1.5-ddx
< else
< ixp=ix-1
< wx=0.5+ddx
< endif
<
< if (ddy.gt.0.5) then
< jyp=jy+1
< wy=1.5-ddy
< else
< jyp=jy-1
< wy=0.5+ddy
< endif
<
<
< ! Determine mass fractions for four grid points
< !**********************************************
<
< if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
< if ((jy.ge.0).and.(jy.le.numygrid-1)) then
< w=wx*wy
< do ks=1,nspec
< init_cond(ix,jy,kz,ks,nrelpointer)= &
< init_cond(ix,jy,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
< end do
< endif
<
< if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
< w=wx*(1.-wy)
< do ks=1,nspec
< init_cond(ix,jyp,kz,ks,nrelpointer)= &
< init_cond(ix,jyp,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
< end do
< endif
< endif
<
<
< 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)
< do ks=1,nspec
< init_cond(ixp,jyp,kz,ks,nrelpointer)= &
< init_cond(ixp,jyp,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
< end do
< endif
<
< if ((jy.ge.0).and.(jy.le.numygrid-1)) then
< w=(1.-wx)*wy
< do ks=1,nspec
< init_cond(ixp,jy,kz,ks,nrelpointer)= &
< init_cond(ixp,jy,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
< end do
< endif
< endif
< endif
<
< endif
<
< end subroutine initial_cond_calc
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine initial_cond_calc(itime,i)
> ! i i
> !*****************************************************************************
> ! *
> ! Calculation of the sensitivity to initial conditions for BW runs *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 15 January 2010 *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: itime,i,ix,jy,ixp,jyp,kz,ks
> integer :: il,ind,indz,indzp,nrelpointer
> real :: rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
> real :: ddx,ddy
> real :: rhoprof(2),rhoi,xl,yl,wx,wy,w
>
>
> ! For forward simulations, make a loop over the number of species;
> ! for backward simulations, make an additional loop over the release points
> !**************************************************************************
>
>
> if (itra1(i).ne.itime) return
>
> ! Depending on output option, calculate air density or set it to 1
> ! linit_cond: 1=mass unit, 2=mass mixing ratio unit
> !*****************************************************************
>
>
> if (linit_cond.eq.1) then ! mass unit
>
> ix=int(xtra1(i))
> jy=int(ytra1(i))
> ixp=ix+1
> jyp=jy+1
> ddx=xtra1(i)-real(ix)
> ddy=ytra1(i)-real(jy)
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
>
> do il=2,nz
> if (height(il).gt.ztra1(i)) then
> indz=il-1
> indzp=il
> goto 6
> endif
> end do
> 6 continue
>
> dz1=ztra1(i)-height(indz)
> dz2=height(indzp)-ztra1(i)
> dz=1./(dz1+dz2)
>
> ! Take density from 2nd wind field in memory (accurate enough, no time interpolation needed)
> !*****************************************************************************
> do ind=indz,indzp
> rhoprof(ind-indz+1)=p1*rho(ix ,jy ,ind,2) &
> +p2*rho(ixp,jy ,ind,2) &
> +p3*rho(ix ,jyp,ind,2) &
> +p4*rho(ixp,jyp,ind,2)
> end do
> rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
> elseif (linit_cond.eq.2) then ! mass mixing ratio unit
> rhoi=1.
> endif
>
>
> !****************************************************************************
> ! 1. Evaluate grid concentrations using a uniform kernel of bandwidths dx, dy
> !****************************************************************************
>
>
> ! For backward simulations, look from which release point the particle comes from
> ! For domain-filling trajectory option, npoint contains a consecutive particle
> ! number, not the release point information. Therefore, nrelpointer is set to 1
> ! for the domain-filling option.
> !*****************************************************************************
>
> if ((ioutputforeachrelease.eq.0).or.(mdomainfill.eq.1)) then
> nrelpointer=1
> else
> nrelpointer=npoint(i)
> endif
>
> do kz=1,numzgrid ! determine height of cell
> if (outheight(kz).gt.ztra1(i)) goto 21
> end do
> 21 continue
> if (kz.le.numzgrid) then ! inside output domain
>
>
> xl=(xtra1(i)*dx+xoutshift)/dxout
> yl=(ytra1(i)*dy+youtshift)/dyout
> ix=int(xl)
> if (xl.lt.0.) ix=ix-1
> jy=int(yl)
> if (yl.lt.0.) jy=jy-1
>
>
> ! If a particle is close to the domain boundary, do not use the kernel either
> !****************************************************************************
>
> if ((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
> if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
> (jy.le.numygrid-1)) then
> do ks=1,nspec
> init_cond(ix,jy,kz,ks,nrelpointer)= &
> init_cond(ix,jy,kz,ks,nrelpointer)+ &
> xmass1(i,ks)/rhoi
> end do
> endif
>
> else ! attribution via uniform kernel
>
> ddx=xl-real(ix) ! distance to left cell border
> ddy=yl-real(jy) ! distance to lower cell border
> if (ddx.gt.0.5) then
> ixp=ix+1
> wx=1.5-ddx
> else
> ixp=ix-1
> wx=0.5+ddx
> endif
>
> if (ddy.gt.0.5) then
> jyp=jy+1
> wy=1.5-ddy
> else
> jyp=jy-1
> wy=0.5+ddy
> endif
>
>
> ! Determine mass fractions for four grid points
> !**********************************************
>
> if ((ix.ge.0).and.(ix.le.numxgrid-1)) then
> if ((jy.ge.0).and.(jy.le.numygrid-1)) then
> w=wx*wy
> do ks=1,nspec
> init_cond(ix,jy,kz,ks,nrelpointer)= &
> init_cond(ix,jy,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
> end do
> endif
>
> if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then
> w=wx*(1.-wy)
> do ks=1,nspec
> init_cond(ix,jyp,kz,ks,nrelpointer)= &
> init_cond(ix,jyp,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
> end do
> endif
> endif
>
>
> 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)
> do ks=1,nspec
> init_cond(ixp,jyp,kz,ks,nrelpointer)= &
> init_cond(ixp,jyp,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
> end do
> endif
>
> if ((jy.ge.0).and.(jy.le.numygrid-1)) then
> w=(1.-wx)*wy
> do ks=1,nspec
> init_cond(ixp,jy,kz,ks,nrelpointer)= &
> init_cond(ixp,jy,kz,ks,nrelpointer)+xmass1(i,ks)/rhoi*w
> end do
> endif
> endif
> endif
>
> endif
>
> end subroutine initial_cond_calc
initial_cond_output.f90
----------------------------------------------
1,151c1,151
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine initial_cond_output(itime)
< ! i
< !*****************************************************************************
< ! *
< ! Output of the initial condition sensitivity field. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 24 May 1995 *
< ! *
< ! 13 April 1999, Major update: if output size is smaller, dump output *
< ! in sparse matrix format; additional output of *
< ! uncertainty *
< ! *
< ! 05 April 2000, Major update: output of age classes; output for backward*
< ! runs is time spent in grid cell times total mass of *
< ! species. *
< ! *
< ! 17 February 2002, Appropriate dimensions for backward and forward runs *
< ! are now specified in file par_mod *
< ! *
< ! June 2006, write grid in sparse matrix with a single write command *
< ! in order to save disk space *
< ! *
< ! 2008 new sparse matrix format *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! ncells number of cells with non-zero concentrations *
< ! sparse .true. if in sparse matrix format, else .false. *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use point_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: itime,i,ix,jy,kz,ks,kp,sp_count_i,sp_count_r
< real :: sp_fact,fact_recept
< real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
< logical :: sp_zer
< character(len=3) :: anspec
<
<
< !*********************************************************************
< ! Determine the standard deviation of the mean concentration or mixing
< ! ratio (uncertainty of the output) and the dry and wet deposition
< !*********************************************************************
<
< do ks=1,nspec
<
< write(anspec,'(i3.3)') ks
< open(97,file=path(2)(1:length(2))//'grid_initial'// &
< '_'//anspec,form='unformatted')
< write(97) itime
<
< do kp=1,maxpointspec_act
<
< if (ind_rel.eq.1) then
< fact_recept=rho_rel(kp)
< else
< fact_recept=1.
< endif
<
< !*******************************************************************
< ! Generate output: may be in concentration (ng/m3) or in mixing
< ! ratio (ppt) or both
< ! Output the position and the values alternated multiplied by
< ! 1 or -1, first line is number of values, number of positions
< ! For backward simulations, the unit is seconds, stored in grid_time
< !*******************************************************************
<
< ! Write out dummy "wet and dry deposition" fields, to keep same format
< ! as for concentration output
< sp_count_i=0
< sp_count_r=0
< write(97) sp_count_i
< write(97) (sparse_dump_i(i),i=1,sp_count_i)
< write(97) sp_count_r
< write(97) (sparse_dump_r(i),i=1,sp_count_r)
< write(97) sp_count_i
< write(97) (sparse_dump_i(i),i=1,sp_count_i)
< write(97) sp_count_r
< write(97) (sparse_dump_r(i),i=1,sp_count_r)
<
<
< ! Write out sensitivity to initial conditions
< sp_count_i=0
< sp_count_r=0
< sp_fact=-1.
< sp_zer=.true.
< do kz=1,numzgrid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< if (init_cond(ix,jy,kz,ks,kp).gt.smallnum) then
< if (sp_zer.eqv..true.) then ! first non zero value
< sp_count_i=sp_count_i+1
< sparse_dump_i(sp_count_i)= &
< ix+jy*numxgrid+kz*numxgrid*numygrid
< sp_zer=.false.
< sp_fact=sp_fact*(-1.)
< endif
< sp_count_r=sp_count_r+1
< sparse_dump_r(sp_count_r)=sp_fact* &
< init_cond(ix,jy,kz,ks,kp)/xmass(kp,ks)*fact_recept
< else ! concentration is zero
< sp_zer=.true.
< endif
< end do
< end do
< end do
< write(97) sp_count_i
< write(97) (sparse_dump_i(i),i=1,sp_count_i)
< write(97) sp_count_r
< write(97) (sparse_dump_r(i),i=1,sp_count_r)
<
<
< end do
<
< close(97)
<
< end do
<
<
< end subroutine initial_cond_output
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine initial_cond_output(itime)
> ! i
> !*****************************************************************************
> ! *
> ! Output of the initial condition sensitivity field. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 24 May 1995 *
> ! *
> ! 13 April 1999, Major update: if output size is smaller, dump output *
> ! in sparse matrix format; additional output of *
> ! uncertainty *
> ! *
> ! 05 April 2000, Major update: output of age classes; output for backward*
> ! runs is time spent in grid cell times total mass of *
> ! species. *
> ! *
> ! 17 February 2002, Appropriate dimensions for backward and forward runs *
> ! are now specified in file par_mod *
> ! *
> ! June 2006, write grid in sparse matrix with a single write command *
> ! in order to save disk space *
> ! *
> ! 2008 new sparse matrix format *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! ncells number of cells with non-zero concentrations *
> ! sparse .true. if in sparse matrix format, else .false. *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use point_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: itime,i,ix,jy,kz,ks,kp,sp_count_i,sp_count_r
> real :: sp_fact,fact_recept
> real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
> logical :: sp_zer
> character(len=3) :: anspec
>
>
> !*********************************************************************
> ! Determine the standard deviation of the mean concentration or mixing
> ! ratio (uncertainty of the output) and the dry and wet deposition
> !*********************************************************************
>
> do ks=1,nspec
>
> write(anspec,'(i3.3)') ks
> open(97,file=path(2)(1:length(2))//'grid_initial'// &
> '_'//anspec,form='unformatted')
> write(97) itime
>
> do kp=1,maxpointspec_act
>
> if (ind_rel.eq.1) then
> fact_recept=rho_rel(kp)
> else
> fact_recept=1.
> endif
>
> !*******************************************************************
> ! Generate output: may be in concentration (ng/m3) or in mixing
> ! ratio (ppt) or both
> ! Output the position and the values alternated multiplied by
> ! 1 or -1, first line is number of values, number of positions
> ! For backward simulations, the unit is seconds, stored in grid_time
> !*******************************************************************
>
> ! Write out dummy "wet and dry deposition" fields, to keep same format
> ! as for concentration output
> sp_count_i=0
> sp_count_r=0
> write(97) sp_count_i
> write(97) (sparse_dump_i(i),i=1,sp_count_i)
> write(97) sp_count_r
> write(97) (sparse_dump_r(i),i=1,sp_count_r)
> write(97) sp_count_i
> write(97) (sparse_dump_i(i),i=1,sp_count_i)
> write(97) sp_count_r
> write(97) (sparse_dump_r(i),i=1,sp_count_r)
>
>
> ! Write out sensitivity to initial conditions
> sp_count_i=0
> sp_count_r=0
> sp_fact=-1.
> sp_zer=.true.
> do kz=1,numzgrid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> if (init_cond(ix,jy,kz,ks,kp).gt.smallnum) then
> if (sp_zer.eqv..true.) then ! first non zero value
> sp_count_i=sp_count_i+1
> sparse_dump_i(sp_count_i)= &
> ix+jy*numxgrid+kz*numxgrid*numygrid
> sp_zer=.false.
> sp_fact=sp_fact*(-1.)
> endif
> sp_count_r=sp_count_r+1
> sparse_dump_r(sp_count_r)=sp_fact* &
> init_cond(ix,jy,kz,ks,kp)/xmass(kp,ks)*fact_recept
> else ! concentration is zero
> sp_zer=.true.
> endif
> end do
> end do
> end do
> write(97) sp_count_i
> write(97) (sparse_dump_i(i),i=1,sp_count_i)
> write(97) sp_count_r
> write(97) (sparse_dump_r(i),i=1,sp_count_r)
>
>
> end do
>
> close(97)
>
> end do
>
>
> end subroutine initial_cond_output
initialize.f90
----------------------------------------------
1,226c1,230
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine initialize(itime,ldt,up,vp,wp, &
< usigold,vsigold,wsigold,xt,yt,zt,icbt)
< ! i i o o o
< ! o o o i i i o
< !*****************************************************************************
< ! *
< ! Calculation of trajectories utilizing a zero-acceleration scheme. The time*
< ! step is determined by the Courant-Friedrichs-Lewy (CFL) criterion. This *
< ! means that the time step must be so small that the displacement within *
< ! this time step is smaller than 1 grid distance. Additionally, a temporal *
< ! CFL criterion is introduced: the time step must be smaller than the time *
< ! interval of the wind fields used for interpolation. *
< ! For random walk simulations, these are the only time step criteria. *
< ! For the other options, the time step is also limited by the Lagrangian *
< ! time scale. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 December 1997 *
< ! *
< ! Literature: *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! h [m] Mixing height *
< ! lwindinterv [s] time interval between two wind fields *
< ! itime [s] current temporal position *
< ! ldt [s] Suggested time step for next integration *
< ! ladvance [s] Total integration time period *
< ! rannumb(maxrand) normally distributed random variables *
< ! up,vp,wp random velocities due to turbulence *
< ! usig,vsig,wsig uncertainties of wind velocities due to interpolation *
< ! usigold,vsigold,wsigold like usig, etc., but for the last time step *
< ! xt,yt,zt Next time step's spatial position of trajectory *
< ! *
< ! *
< ! Constants: *
< ! cfl factor, by which the time step has to be smaller than *
< ! the spatial CFL-criterion *
< ! cflt factor, by which the time step has to be smaller than *
< ! the temporal CFL-criterion *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
< use hanna_mod
<
< implicit none
<
< integer :: itime
< integer :: ldt,nrand
< integer(kind=2) :: icbt
< real :: zt,dz,dz1,dz2,up,vp,wp,usigold,vsigold,wsigold,ran3
< real(kind=dp) :: xt,yt
< save idummy
<
< integer :: idummy = -7
<
< icbt=1 ! initialize particle to "no reflection"
<
< nrand=int(ran3(idummy)*real(maxrand-1))+1
<
<
< !******************************
< ! 2. Interpolate necessary data
< !******************************
<
< ! Compute maximum mixing height around particle position
< !*******************************************************
<
< ix=int(xt)
< jy=int(yt)
< ixp=ix+1
< jyp=jy+1
<
< h=max(hmix(ix ,jy ,1,memind(1)), &
< hmix(ixp,jy ,1,memind(1)), &
< hmix(ix ,jyp,1,memind(1)), &
< hmix(ixp,jyp,1,memind(1)), &
< hmix(ix ,jy ,1,memind(2)), &
< hmix(ixp,jy ,1,memind(2)), &
< hmix(ix ,jyp,1,memind(2)), &
< hmix(ixp,jyp,1,memind(2)))
<
< zeta=zt/h
<
<
< !*************************************************************
< ! If particle is in the PBL, interpolate once and then make a
< ! time loop until end of interval is reached
< !*************************************************************
<
< if (zeta.le.1.) then
<
< call interpol_all(itime,real(xt),real(yt),zt)
<
<
< ! Vertical interpolation of u,v,w,rho and drhodz
< !***********************************************
<
< ! Vertical distance to the level below and above current position
< ! both in terms of (u,v) and (w) fields
< !****************************************************************
<
< dz1=zt-height(indz)
< dz2=height(indzp)-zt
< dz=1./(dz1+dz2)
<
< u=(dz1*uprof(indzp)+dz2*uprof(indz))*dz
< v=(dz1*vprof(indzp)+dz2*vprof(indz))*dz
< w=(dz1*wprof(indzp)+dz2*wprof(indz))*dz
<
<
< ! Compute the turbulent disturbances
<
< ! Determine the sigmas and the timescales
< !****************************************
<
< if (turbswitch) then
< call hanna(zt)
< else
< call hanna1(zt)
< endif
<
<
< ! Determine the new diffusivity velocities
< !*****************************************
<
< if (nrand+2.gt.maxrand) nrand=1
< up=rannumb(nrand)*sigu
< vp=rannumb(nrand+1)*sigv
< wp=rannumb(nrand+2)
< if (.not.turbswitch) wp=wp*sigw
<
<
< ! Determine time step for next integration
< !*****************************************
<
< if (turbswitch) then
< ldt=int(min(tlw,h/max(2.*abs(wp*sigw),1.e-5), &
< 0.5/abs(dsigwdz),600.)*ctl)
< else
< ldt=int(min(tlw,h/max(2.*abs(wp),1.e-5),600.)*ctl)
< endif
< ldt=max(ldt,mintime)
<
<
< usig=(usigprof(indzp)+usigprof(indz))/2.
< vsig=(vsigprof(indzp)+vsigprof(indz))/2.
< wsig=(wsigprof(indzp)+wsigprof(indz))/2.
<
< else
<
<
<
< !**********************************************************
< ! For all particles that are outside the PBL, make a single
< ! time step. Only horizontal turbulent disturbances are
< ! calculated. Vertical disturbances are reset.
< !**********************************************************
<
<
< ! Interpolate the wind
< !*********************
<
< call interpol_wind(itime,real(xt),real(yt),zt)
<
<
< ! Compute everything for above the PBL
<
< ! Assume constant turbulent perturbations
< !****************************************
<
< ldt=abs(lsynctime)
<
< if (nrand+1.gt.maxrand) nrand=1
< up=rannumb(nrand)*0.3
< vp=rannumb(nrand+1)*0.3
< nrand=nrand+2
< wp=0.
< sigw=0.
<
< endif
<
< !****************************************************************
< ! Add mesoscale random disturbances
< ! This is done only once for the whole lsynctime interval to save
< ! computation time
< !****************************************************************
<
<
< ! It is assumed that the average interpolation error is 1/2 sigma
< ! of the surrounding points, autocorrelation time constant is
< ! 1/2 of time interval between wind fields
< !****************************************************************
<
< if (nrand+2.gt.maxrand) nrand=1
< usigold=rannumb(nrand)*usig
< vsigold=rannumb(nrand+1)*vsig
< wsigold=rannumb(nrand+2)*wsig
<
< end subroutine initialize
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine initialize(pj, itime,ldt,up,vp,wp, &
> usigold,vsigold,wsigold,xt,yt,zt,icbt)
> ! i i o o o
> ! o o o i i i o
> !*****************************************************************************
> ! *
> ! Calculation of trajectories utilizing a zero-acceleration scheme. The time*
> ! step is determined by the Courant-Friedrichs-Lewy (CFL) criterion. This *
> ! means that the time step must be so small that the displacement within *
> ! this time step is smaller than 1 grid distance. Additionally, a temporal *
> ! CFL criterion is introduced: the time step must be smaller than the time *
> ! interval of the wind fields used for interpolation. *
> ! For random walk simulations, these are the only time step criteria. *
> ! For the other options, the time step is also limited by the Lagrangian *
> ! time scale. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 December 1997 *
> ! *
> ! Literature: *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! h [m] Mixing height *
> ! lwindinterv [s] time interval between two wind fields *
> ! itime [s] current temporal position *
> ! ldt [s] Suggested time step for next integration *
> ! ladvance [s] Total integration time period *
> ! rannumb(maxrand) normally distributed random variables *
> ! up,vp,wp random velocities due to turbulence *
> ! usig,vsig,wsig uncertainties of wind velocities due to interpolation *
> ! usigold,vsigold,wsigold like usig, etc., but for the last time step *
> ! xt,yt,zt Next time step's spatial position of trajectory *
> ! *
> ! *
> ! Constants: *
> ! cfl factor, by which the time step has to be smaller than *
> ! the spatial CFL-criterion *
> ! cflt factor, by which the time step has to be smaller than *
> ! the temporal CFL-criterion *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
> use hanna_mod
> use random_mod, only : ran3_initialize
> ! reads: ran3_initialize
> ! writes:
>
> implicit none
>
> integer, intent(in) :: pj
> integer, intent(in) :: itime
> integer :: ldt,nrand
> integer(kind=2) :: icbt
> real :: zt,dz,dz1,dz2,up,vp,wp,usigold,vsigold,wsigold,ran3
> real(kind=dp) :: xt,yt
> save idummy
>
> integer :: idummy = -7
>
> icbt=1 ! initialize particle to "no reflection"
>
> nrand=int(ran3_initialize(pj)*real(maxrand-1))+1
>
>
> !******************************
> ! 2. Interpolate necessary data
> !******************************
>
> ! Compute maximum mixing height around particle position
> !*******************************************************
>
> ix=int(xt)
> jy=int(yt)
> ixp=ix+1
> jyp=jy+1
>
> h=max(hmix(ix ,jy ,1,memind(1)), &
> hmix(ixp,jy ,1,memind(1)), &
> hmix(ix ,jyp,1,memind(1)), &
> hmix(ixp,jyp,1,memind(1)), &
> hmix(ix ,jy ,1,memind(2)), &
> hmix(ixp,jy ,1,memind(2)), &
> hmix(ix ,jyp,1,memind(2)), &
> hmix(ixp,jyp,1,memind(2)))
>
> zeta=zt/h
>
>
> !*************************************************************
> ! If particle is in the PBL, interpolate once and then make a
> ! time loop until end of interval is reached
> !*************************************************************
>
> if (zeta.le.1.) then
>
> call interpol_all(itime,real(xt),real(yt),zt)
>
>
> ! Vertical interpolation of u,v,w,rho and drhodz
> !***********************************************
>
> ! Vertical distance to the level below and above current position
> ! both in terms of (u,v) and (w) fields
> !****************************************************************
>
> dz1=zt-height(indz)
> dz2=height(indzp)-zt
> dz=1./(dz1+dz2)
>
> u=(dz1*uprof(indzp)+dz2*uprof(indz))*dz
> v=(dz1*vprof(indzp)+dz2*vprof(indz))*dz
> w=(dz1*wprof(indzp)+dz2*wprof(indz))*dz
>
>
> ! Compute the turbulent disturbances
>
> ! Determine the sigmas and the timescales
> !****************************************
>
> if (turbswitch) then
> call hanna(zt)
> else
> call hanna1(zt)
> endif
>
>
> ! Determine the new diffusivity velocities
> !*****************************************
>
> if (nrand+2.gt.maxrand) nrand=1
> up=rannumb(nrand)*sigu
> vp=rannumb(nrand+1)*sigv
> wp=rannumb(nrand+2)
> if (.not.turbswitch) wp=wp*sigw
>
>
> ! Determine time step for next integration
> !*****************************************
>
> if (turbswitch) then
> ldt=int(min(tlw,h/max(2.*abs(wp*sigw),1.e-5), &
> 0.5/abs(dsigwdz),600.)*ctl)
> else
> ldt=int(min(tlw,h/max(2.*abs(wp),1.e-5),600.)*ctl)
> endif
> ldt=max(ldt,mintime)
>
>
> usig=(usigprof(indzp)+usigprof(indz))/2.
> vsig=(vsigprof(indzp)+vsigprof(indz))/2.
> wsig=(wsigprof(indzp)+wsigprof(indz))/2.
>
> else
>
>
>
> !**********************************************************
> ! For all particles that are outside the PBL, make a single
> ! time step. Only horizontal turbulent disturbances are
> ! calculated. Vertical disturbances are reset.
> !**********************************************************
>
>
> ! Interpolate the wind
> !*********************
>
> call interpol_wind(itime,real(xt),real(yt),zt)
>
>
> ! Compute everything for above the PBL
>
> ! Assume constant turbulent perturbations
> !****************************************
>
> ldt=abs(lsynctime)
>
> if (nrand+1.gt.maxrand) nrand=1
> up=rannumb(nrand)*0.3
> vp=rannumb(nrand+1)*0.3
> nrand=nrand+2
> wp=0.
> sigw=0.
>
> endif
>
> !****************************************************************
> ! Add mesoscale random disturbances
> ! This is done only once for the whole lsynctime interval to save
> ! computation time
> !****************************************************************
>
>
> ! It is assumed that the average interpolation error is 1/2 sigma
> ! of the surrounding points, autocorrelation time constant is
> ! 1/2 of time interval between wind fields
> !****************************************************************
>
> if (nrand+2.gt.maxrand) nrand=1
> usigold=rannumb(nrand)*usig
> vsigold=rannumb(nrand+1)*vsig
> wsigold=rannumb(nrand+2)*wsig
>
> end subroutine initialize
interpol_all.f90
----------------------------------------------
1,261c1,261
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_all(itime,xt,yt,zt)
< ! i i i i
< !*****************************************************************************
< ! *
< ! This subroutine interpolates everything that is needed for calculating the*
< ! dispersion. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 December 1997 *
< ! *
< ! Revision March 2005 by AST : all output variables in common block cal- *
< ! culation of standard deviation done in this *
< ! routine rather than subroutine call in order *
< ! to save computation time *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! itime [s] current temporal position *
< ! memtime(3) [s] times of the wind fields in memory *
< ! xt,yt,zt coordinates position for which wind data shall be *
< ! culated *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
< use hanna_mod
<
< implicit none
<
< integer :: itime
< real :: xt,yt,zt
<
< ! Auxiliary variables needed for interpolation
< real :: ust1(2),wst1(2),oli1(2),oliaux
< real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
< real :: usl,vsl,wsl,usq,vsq,wsq,xaux
< integer :: i,m,n,indexh
< real,parameter :: eps=1.0e-30
<
<
< !********************************************
< ! Multilinear interpolation in time and space
< !********************************************
<
< ! 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)
<
<
< !*****************************************
< ! 1. Interpolate u*, w* and Obukhov length
< !*****************************************
<
< ! a) Bilinear horizontal interpolation
<
< do m=1,2
< indexh=memind(m)
<
< ust1(m)=p1*ustar(ix ,jy ,1,indexh) &
< + p2*ustar(ixp,jy ,1,indexh) &
< + p3*ustar(ix ,jyp,1,indexh) &
< + p4*ustar(ixp,jyp,1,indexh)
< wst1(m)=p1*wstar(ix ,jy ,1,indexh) &
< + p2*wstar(ixp,jy ,1,indexh) &
< + p3*wstar(ix ,jyp,1,indexh) &
< + p4*wstar(ixp,jyp,1,indexh)
< oli1(m)=p1*oli(ix ,jy ,1,indexh) &
< + p2*oli(ixp,jy ,1,indexh) &
< + p3*oli(ix ,jyp,1,indexh) &
< + p4*oli(ixp,jyp,1,indexh)
< end do
<
< ! b) Temporal interpolation
<
< ust=(ust1(1)*dt2+ust1(2)*dt1)*dtt
< wst=(wst1(1)*dt2+wst1(2)*dt1)*dtt
< oliaux=(oli1(1)*dt2+oli1(2)*dt1)*dtt
<
< if (oliaux.ne.0.) then
< ol=1./oliaux
< else
< ol=99999.
< endif
<
<
< !*****************************************************
< ! 2. Interpolate vertical profiles of u,v,w,rho,drhodz
< !*****************************************************
<
<
< ! Determine the level below the current position
< !***********************************************
<
< do i=2,nz
< if (height(i).gt.zt) then
< indz=i-1
< indzp=i
< goto 6
< endif
< end do
< 6 continue
<
< !**************************************
< ! 1.) Bilinear horizontal interpolation
< ! 2.) Temporal interpolation (linear)
< !**************************************
<
< ! Loop over 2 time steps and indz levels
< !***************************************
<
< do n=indz,indzp
< usl=0.
< vsl=0.
< wsl=0.
< usq=0.
< vsq=0.
< wsq=0.
< do m=1,2
< indexh=memind(m)
< if (ngrid.lt.0) then
< y1(m)=p1*uupol(ix ,jy ,n,indexh) &
< +p2*uupol(ixp,jy ,n,indexh) &
< +p3*uupol(ix ,jyp,n,indexh) &
< +p4*uupol(ixp,jyp,n,indexh)
< y2(m)=p1*vvpol(ix ,jy ,n,indexh) &
< +p2*vvpol(ixp,jy ,n,indexh) &
< +p3*vvpol(ix ,jyp,n,indexh) &
< +p4*vvpol(ixp,jyp,n,indexh)
< usl=usl+uupol(ix ,jy ,n,indexh)+uupol(ixp,jy ,n,indexh) &
< +uupol(ix ,jyp,n,indexh)+uupol(ixp,jyp,n,indexh)
< vsl=vsl+vvpol(ix ,jy ,n,indexh)+vvpol(ixp,jy ,n,indexh) &
< +vvpol(ix ,jyp,n,indexh)+vvpol(ixp,jyp,n,indexh)
<
< usq=usq+uupol(ix ,jy ,n,indexh)*uupol(ix ,jy ,n,indexh)+ &
< uupol(ixp,jy ,n,indexh)*uupol(ixp,jy ,n,indexh)+ &
< uupol(ix ,jyp,n,indexh)*uupol(ix ,jyp,n,indexh)+ &
< uupol(ixp,jyp,n,indexh)*uupol(ixp,jyp,n,indexh)
< vsq=vsq+vvpol(ix ,jy ,n,indexh)*vvpol(ix ,jy ,n,indexh)+ &
< vvpol(ixp,jy ,n,indexh)*vvpol(ixp,jy ,n,indexh)+ &
< vvpol(ix ,jyp,n,indexh)*vvpol(ix ,jyp,n,indexh)+ &
< vvpol(ixp,jyp,n,indexh)*vvpol(ixp,jyp,n,indexh)
< else
< y1(m)=p1*uu(ix ,jy ,n,indexh) &
< +p2*uu(ixp,jy ,n,indexh) &
< +p3*uu(ix ,jyp,n,indexh) &
< +p4*uu(ixp,jyp,n,indexh)
< y2(m)=p1*vv(ix ,jy ,n,indexh) &
< +p2*vv(ixp,jy ,n,indexh) &
< +p3*vv(ix ,jyp,n,indexh) &
< +p4*vv(ixp,jyp,n,indexh)
< usl=usl+uu(ix ,jy ,n,indexh)+uu(ixp,jy ,n,indexh) &
< +uu(ix ,jyp,n,indexh)+uu(ixp,jyp,n,indexh)
< vsl=vsl+vv(ix ,jy ,n,indexh)+vv(ixp,jy ,n,indexh) &
< +vv(ix ,jyp,n,indexh)+vv(ixp,jyp,n,indexh)
<
< usq=usq+uu(ix ,jy ,n,indexh)*uu(ix ,jy ,n,indexh)+ &
< uu(ixp,jy ,n,indexh)*uu(ixp,jy ,n,indexh)+ &
< uu(ix ,jyp,n,indexh)*uu(ix ,jyp,n,indexh)+ &
< uu(ixp,jyp,n,indexh)*uu(ixp,jyp,n,indexh)
< vsq=vsq+vv(ix ,jy ,n,indexh)*vv(ix ,jy ,n,indexh)+ &
< vv(ixp,jy ,n,indexh)*vv(ixp,jy ,n,indexh)+ &
< vv(ix ,jyp,n,indexh)*vv(ix ,jyp,n,indexh)+ &
< vv(ixp,jyp,n,indexh)*vv(ixp,jyp,n,indexh)
< endif
< y3(m)=p1*ww(ix ,jy ,n,indexh) &
< +p2*ww(ixp,jy ,n,indexh) &
< +p3*ww(ix ,jyp,n,indexh) &
< +p4*ww(ixp,jyp,n,indexh)
< rhograd1(m)=p1*drhodz(ix ,jy ,n,indexh) &
< +p2*drhodz(ixp,jy ,n,indexh) &
< +p3*drhodz(ix ,jyp,n,indexh) &
< +p4*drhodz(ixp,jyp,n,indexh)
< rho1(m)=p1*rho(ix ,jy ,n,indexh) &
< +p2*rho(ixp,jy ,n,indexh) &
< +p3*rho(ix ,jyp,n,indexh) &
< +p4*rho(ixp,jyp,n,indexh)
< wsl=wsl+ww(ix ,jy ,n,indexh)+ww(ixp,jy ,n,indexh) &
< +ww(ix ,jyp,n,indexh)+ww(ixp,jyp,n,indexh)
< wsq=wsq+ww(ix ,jy ,n,indexh)*ww(ix ,jy ,n,indexh)+ &
< ww(ixp,jy ,n,indexh)*ww(ixp,jy ,n,indexh)+ &
< ww(ix ,jyp,n,indexh)*ww(ix ,jyp,n,indexh)+ &
< ww(ixp,jyp,n,indexh)*ww(ixp,jyp,n,indexh)
< end do
< uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
< vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
< wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
< rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
< rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
< indzindicator(n)=.false.
<
< ! Compute standard deviations
< !****************************
<
< xaux=usq-usl*usl/8.
< if (xaux.lt.eps) then
< usigprof(n)=0.
< else
< usigprof(n)=sqrt(xaux/7.)
< endif
<
< xaux=vsq-vsl*vsl/8.
< if (xaux.lt.eps) then
< vsigprof(n)=0.
< else
< vsigprof(n)=sqrt(xaux/7.)
< endif
<
<
< xaux=wsq-wsl*wsl/8.
< if (xaux.lt.eps) then
< wsigprof(n)=0.
< else
< wsigprof(n)=sqrt(xaux/7.)
< endif
<
< end do
<
<
< end subroutine interpol_all
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_all(itime,xt,yt,zt)
> ! i i i i
> !*****************************************************************************
> ! *
> ! This subroutine interpolates everything that is needed for calculating the*
> ! dispersion. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 December 1997 *
> ! *
> ! Revision March 2005 by AST : all output variables in common block cal- *
> ! culation of standard deviation done in this *
> ! routine rather than subroutine call in order *
> ! to save computation time *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! itime [s] current temporal position *
> ! memtime(3) [s] times of the wind fields in memory *
> ! xt,yt,zt coordinates position for which wind data shall be *
> ! culated *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
> use hanna_mod
>
> implicit none
>
> integer :: itime
> real :: xt,yt,zt
>
> ! Auxiliary variables needed for interpolation
> real :: ust1(2),wst1(2),oli1(2),oliaux
> real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
> real :: usl,vsl,wsl,usq,vsq,wsq,xaux
> integer :: i,m,n,indexh
> real,parameter :: eps=1.0e-30
>
>
> !********************************************
> ! Multilinear interpolation in time and space
> !********************************************
>
> ! 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)
>
>
> !*****************************************
> ! 1. Interpolate u*, w* and Obukhov length
> !*****************************************
>
> ! a) Bilinear horizontal interpolation
>
> do m=1,2
> indexh=memind(m)
>
> ust1(m)=p1*ustar(ix ,jy ,1,indexh) &
> + p2*ustar(ixp,jy ,1,indexh) &
> + p3*ustar(ix ,jyp,1,indexh) &
> + p4*ustar(ixp,jyp,1,indexh)
> wst1(m)=p1*wstar(ix ,jy ,1,indexh) &
> + p2*wstar(ixp,jy ,1,indexh) &
> + p3*wstar(ix ,jyp,1,indexh) &
> + p4*wstar(ixp,jyp,1,indexh)
> oli1(m)=p1*oli(ix ,jy ,1,indexh) &
> + p2*oli(ixp,jy ,1,indexh) &
> + p3*oli(ix ,jyp,1,indexh) &
> + p4*oli(ixp,jyp,1,indexh)
> end do
>
> ! b) Temporal interpolation
>
> ust=(ust1(1)*dt2+ust1(2)*dt1)*dtt
> wst=(wst1(1)*dt2+wst1(2)*dt1)*dtt
> oliaux=(oli1(1)*dt2+oli1(2)*dt1)*dtt
>
> if (oliaux.ne.0.) then
> ol=1./oliaux
> else
> ol=99999.
> endif
>
>
> !*****************************************************
> ! 2. Interpolate vertical profiles of u,v,w,rho,drhodz
> !*****************************************************
>
>
> ! Determine the level below the current position
> !***********************************************
>
> do i=2,nz
> if (height(i).gt.zt) then
> indz=i-1
> indzp=i
> goto 6
> endif
> end do
> 6 continue
>
> !**************************************
> ! 1.) Bilinear horizontal interpolation
> ! 2.) Temporal interpolation (linear)
> !**************************************
>
> ! Loop over 2 time steps and indz levels
> !***************************************
>
> do n=indz,indzp
> usl=0.
> vsl=0.
> wsl=0.
> usq=0.
> vsq=0.
> wsq=0.
> do m=1,2
> indexh=memind(m)
> if (ngrid.lt.0) then
> y1(m)=p1*uupol(ix ,jy ,n,indexh) &
> +p2*uupol(ixp,jy ,n,indexh) &
> +p3*uupol(ix ,jyp,n,indexh) &
> +p4*uupol(ixp,jyp,n,indexh)
> y2(m)=p1*vvpol(ix ,jy ,n,indexh) &
> +p2*vvpol(ixp,jy ,n,indexh) &
> +p3*vvpol(ix ,jyp,n,indexh) &
> +p4*vvpol(ixp,jyp,n,indexh)
> usl=usl+uupol(ix ,jy ,n,indexh)+uupol(ixp,jy ,n,indexh) &
> +uupol(ix ,jyp,n,indexh)+uupol(ixp,jyp,n,indexh)
> vsl=vsl+vvpol(ix ,jy ,n,indexh)+vvpol(ixp,jy ,n,indexh) &
> +vvpol(ix ,jyp,n,indexh)+vvpol(ixp,jyp,n,indexh)
>
> usq=usq+uupol(ix ,jy ,n,indexh)*uupol(ix ,jy ,n,indexh)+ &
> uupol(ixp,jy ,n,indexh)*uupol(ixp,jy ,n,indexh)+ &
> uupol(ix ,jyp,n,indexh)*uupol(ix ,jyp,n,indexh)+ &
> uupol(ixp,jyp,n,indexh)*uupol(ixp,jyp,n,indexh)
> vsq=vsq+vvpol(ix ,jy ,n,indexh)*vvpol(ix ,jy ,n,indexh)+ &
> vvpol(ixp,jy ,n,indexh)*vvpol(ixp,jy ,n,indexh)+ &
> vvpol(ix ,jyp,n,indexh)*vvpol(ix ,jyp,n,indexh)+ &
> vvpol(ixp,jyp,n,indexh)*vvpol(ixp,jyp,n,indexh)
> else
> y1(m)=p1*uu(ix ,jy ,n,indexh) &
> +p2*uu(ixp,jy ,n,indexh) &
> +p3*uu(ix ,jyp,n,indexh) &
> +p4*uu(ixp,jyp,n,indexh)
> y2(m)=p1*vv(ix ,jy ,n,indexh) &
> +p2*vv(ixp,jy ,n,indexh) &
> +p3*vv(ix ,jyp,n,indexh) &
> +p4*vv(ixp,jyp,n,indexh)
> usl=usl+uu(ix ,jy ,n,indexh)+uu(ixp,jy ,n,indexh) &
> +uu(ix ,jyp,n,indexh)+uu(ixp,jyp,n,indexh)
> vsl=vsl+vv(ix ,jy ,n,indexh)+vv(ixp,jy ,n,indexh) &
> +vv(ix ,jyp,n,indexh)+vv(ixp,jyp,n,indexh)
>
> usq=usq+uu(ix ,jy ,n,indexh)*uu(ix ,jy ,n,indexh)+ &
> uu(ixp,jy ,n,indexh)*uu(ixp,jy ,n,indexh)+ &
> uu(ix ,jyp,n,indexh)*uu(ix ,jyp,n,indexh)+ &
> uu(ixp,jyp,n,indexh)*uu(ixp,jyp,n,indexh)
> vsq=vsq+vv(ix ,jy ,n,indexh)*vv(ix ,jy ,n,indexh)+ &
> vv(ixp,jy ,n,indexh)*vv(ixp,jy ,n,indexh)+ &
> vv(ix ,jyp,n,indexh)*vv(ix ,jyp,n,indexh)+ &
> vv(ixp,jyp,n,indexh)*vv(ixp,jyp,n,indexh)
> endif
> y3(m)=p1*ww(ix ,jy ,n,indexh) &
> +p2*ww(ixp,jy ,n,indexh) &
> +p3*ww(ix ,jyp,n,indexh) &
> +p4*ww(ixp,jyp,n,indexh)
> rhograd1(m)=p1*drhodz(ix ,jy ,n,indexh) &
> +p2*drhodz(ixp,jy ,n,indexh) &
> +p3*drhodz(ix ,jyp,n,indexh) &
> +p4*drhodz(ixp,jyp,n,indexh)
> rho1(m)=p1*rho(ix ,jy ,n,indexh) &
> +p2*rho(ixp,jy ,n,indexh) &
> +p3*rho(ix ,jyp,n,indexh) &
> +p4*rho(ixp,jyp,n,indexh)
> wsl=wsl+ww(ix ,jy ,n,indexh)+ww(ixp,jy ,n,indexh) &
> +ww(ix ,jyp,n,indexh)+ww(ixp,jyp,n,indexh)
> wsq=wsq+ww(ix ,jy ,n,indexh)*ww(ix ,jy ,n,indexh)+ &
> ww(ixp,jy ,n,indexh)*ww(ixp,jy ,n,indexh)+ &
> ww(ix ,jyp,n,indexh)*ww(ix ,jyp,n,indexh)+ &
> ww(ixp,jyp,n,indexh)*ww(ixp,jyp,n,indexh)
> end do
> uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
> vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
> wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
> rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
> rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
> indzindicator(n)=.false.
>
> ! Compute standard deviations
> !****************************
>
> xaux=usq-usl*usl/8.
> if (xaux.lt.eps) then
> usigprof(n)=0.
> else
> usigprof(n)=sqrt(xaux/7.)
> endif
>
> xaux=vsq-vsl*vsl/8.
> if (xaux.lt.eps) then
> vsigprof(n)=0.
> else
> vsigprof(n)=sqrt(xaux/7.)
> endif
>
>
> xaux=wsq-wsl*wsl/8.
> if (xaux.lt.eps) then
> wsigprof(n)=0.
> else
> wsigprof(n)=sqrt(xaux/7.)
> endif
>
> end do
>
>
> end subroutine interpol_all
interpol_all_nests.f90
----------------------------------------------
1,239c1,239
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_all_nests(itime,xt,yt,zt)
< ! i i i i
< !*****************************************************************************
< ! *
< ! This subroutine interpolates everything that is needed for calculating the*
< ! dispersion. *
< ! Version for interpolating nested grids. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 9 February 1999 *
< ! 16 December 1997 *
< ! *
< ! Revision March 2005 by AST : all output variables in common block cal- *
< ! culation of standard deviation done in this *
< ! routine rather than subroutine call in order *
< ! to save computation time *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! itime [s] current temporal position *
< ! memtime(3) [s] times of the wind fields in memory *
< ! xt,yt,zt coordinates position for which wind data shall be *
< ! calculated *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
< use hanna_mod
<
< implicit none
<
< integer :: itime
< real :: xt,yt,zt
<
< ! Auxiliary variables needed for interpolation
< real :: ust1(2),wst1(2),oli1(2),oliaux
< real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
< real :: usl,vsl,wsl,usq,vsq,wsq,xaux
< integer :: i,m,n,indexh
< real,parameter :: eps=1.0e-30
<
<
< !********************************************
< ! Multilinear interpolation in time and space
< !********************************************
<
< ! 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)
<
<
< !*****************************************
< ! 1. Interpolate u*, w* and Obukhov length
< !*****************************************
<
< ! a) Bilinear horizontal interpolation
<
< do m=1,2
< indexh=memind(m)
<
< ust1(m)=p1*ustarn(ix ,jy ,1,indexh,ngrid) &
< + p2*ustarn(ixp,jy ,1,indexh,ngrid) &
< + p3*ustarn(ix ,jyp,1,indexh,ngrid) &
< + p4*ustarn(ixp,jyp,1,indexh,ngrid)
< wst1(m)=p1*wstarn(ix ,jy ,1,indexh,ngrid) &
< + p2*wstarn(ixp,jy ,1,indexh,ngrid) &
< + p3*wstarn(ix ,jyp,1,indexh,ngrid) &
< + p4*wstarn(ixp,jyp,1,indexh,ngrid)
< oli1(m)=p1*olin(ix ,jy ,1,indexh,ngrid) &
< + p2*olin(ixp,jy ,1,indexh,ngrid) &
< + p3*olin(ix ,jyp,1,indexh,ngrid) &
< + p4*olin(ixp,jyp,1,indexh,ngrid)
< end do
<
< ! b) Temporal interpolation
<
< ust=(ust1(1)*dt2+ust1(2)*dt1)*dtt
< wst=(wst1(1)*dt2+wst1(2)*dt1)*dtt
< oliaux=(oli1(1)*dt2+oli1(2)*dt1)*dtt
<
< if (oliaux.ne.0.) then
< ol=1./oliaux
< else
< ol=99999.
< endif
<
<
< !*****************************************************
< ! 2. Interpolate vertical profiles of u,v,w,rho,drhodz
< !*****************************************************
<
<
< ! Determine the level below the current position
< !***********************************************
<
< do i=2,nz
< if (height(i).gt.zt) then
< indz=i-1
< indzp=i
< goto 6
< endif
< end do
< 6 continue
<
< !**************************************
< ! 1.) Bilinear horizontal interpolation
< ! 2.) Temporal interpolation (linear)
< !**************************************
<
< ! Loop over 2 time steps and indz levels
< !***************************************
<
< do n=indz,indz+1
< usl=0.
< vsl=0.
< wsl=0.
< usq=0.
< vsq=0.
< wsq=0.
< do m=1,2
< indexh=memind(m)
< y1(m)=p1*uun(ix ,jy ,n,indexh,ngrid) &
< +p2*uun(ixp,jy ,n,indexh,ngrid) &
< +p3*uun(ix ,jyp,n,indexh,ngrid) &
< +p4*uun(ixp,jyp,n,indexh,ngrid)
< y2(m)=p1*vvn(ix ,jy ,n,indexh,ngrid) &
< +p2*vvn(ixp,jy ,n,indexh,ngrid) &
< +p3*vvn(ix ,jyp,n,indexh,ngrid) &
< +p4*vvn(ixp,jyp,n,indexh,ngrid)
< y3(m)=p1*wwn(ix ,jy ,n,indexh,ngrid) &
< +p2*wwn(ixp,jy ,n,indexh,ngrid) &
< +p3*wwn(ix ,jyp,n,indexh,ngrid) &
< +p4*wwn(ixp,jyp,n,indexh,ngrid)
< rhograd1(m)=p1*drhodzn(ix ,jy ,n,indexh,ngrid) &
< +p2*drhodzn(ixp,jy ,n,indexh,ngrid) &
< +p3*drhodzn(ix ,jyp,n,indexh,ngrid) &
< +p4*drhodzn(ixp,jyp,n,indexh,ngrid)
< rho1(m)=p1*rhon(ix ,jy ,n,indexh,ngrid) &
< +p2*rhon(ixp,jy ,n,indexh,ngrid) &
< +p3*rhon(ix ,jyp,n,indexh,ngrid) &
< +p4*rhon(ixp,jyp,n,indexh,ngrid)
<
< usl=usl+uun(ix ,jy ,n,indexh,ngrid)+uun(ixp,jy ,n,indexh,ngrid) &
< +uun(ix ,jyp,n,indexh,ngrid)+uun(ixp,jyp,n,indexh,ngrid)
< vsl=vsl+vvn(ix ,jy ,n,indexh,ngrid)+vvn(ixp,jy ,n,indexh,ngrid) &
< +vvn(ix ,jyp,n,indexh,ngrid)+vvn(ixp,jyp,n,indexh,ngrid)
< wsl=wsl+wwn(ix ,jy ,n,indexh,ngrid)+wwn(ixp,jy ,n,indexh,ngrid) &
< +wwn(ix ,jyp,n,indexh,ngrid)+wwn(ixp,jyp,n,indexh,ngrid)
<
< usq=usq+uun(ix ,jy ,n,indexh,ngrid)*uun(ix ,jy ,n,indexh,ngrid)+ &
< uun(ixp,jy ,n,indexh,ngrid)*uun(ixp,jy ,n,indexh,ngrid)+ &
< uun(ix ,jyp,n,indexh,ngrid)*uun(ix ,jyp,n,indexh,ngrid)+ &
< uun(ixp,jyp,n,indexh,ngrid)*uun(ixp,jyp,n,indexh,ngrid)
< vsq=vsq+vvn(ix ,jy ,n,indexh,ngrid)*vvn(ix ,jy ,n,indexh,ngrid)+ &
< vvn(ixp,jy ,n,indexh,ngrid)*vvn(ixp,jy ,n,indexh,ngrid)+ &
< vvn(ix ,jyp,n,indexh,ngrid)*vvn(ix ,jyp,n,indexh,ngrid)+ &
< vvn(ixp,jyp,n,indexh,ngrid)*vvn(ixp,jyp,n,indexh,ngrid)
< wsq=wsq+wwn(ix ,jy ,n,indexh,ngrid)*wwn(ix ,jy ,n,indexh,ngrid)+ &
< wwn(ixp,jy ,n,indexh,ngrid)*wwn(ixp,jy ,n,indexh,ngrid)+ &
< wwn(ix ,jyp,n,indexh,ngrid)*wwn(ix ,jyp,n,indexh,ngrid)+ &
< wwn(ixp,jyp,n,indexh,ngrid)*wwn(ixp,jyp,n,indexh,ngrid)
< end do
< uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
< vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
< wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
< rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
< rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
< indzindicator(n)=.false.
<
< ! Compute standard deviations
< !****************************
<
< xaux=usq-usl*usl/8.
< if (xaux.lt.eps) then
< usigprof(n)=0.
< else
< usigprof(n)=sqrt(xaux/7.)
< endif
<
< xaux=vsq-vsl*vsl/8.
< if (xaux.lt.eps) then
< vsigprof(n)=0.
< else
< vsigprof(n)=sqrt(xaux/7.)
< endif
<
<
< xaux=wsq-wsl*wsl/8.
< if (xaux.lt.eps) then
< wsigprof(n)=0.
< else
< wsigprof(n)=sqrt(xaux/7.)
< endif
<
< end do
<
< end subroutine interpol_all_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_all_nests(itime,xt,yt,zt)
> ! i i i i
> !*****************************************************************************
> ! *
> ! This subroutine interpolates everything that is needed for calculating the*
> ! dispersion. *
> ! Version for interpolating nested grids. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 9 February 1999 *
> ! 16 December 1997 *
> ! *
> ! Revision March 2005 by AST : all output variables in common block cal- *
> ! culation of standard deviation done in this *
> ! routine rather than subroutine call in order *
> ! to save computation time *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! itime [s] current temporal position *
> ! memtime(3) [s] times of the wind fields in memory *
> ! xt,yt,zt coordinates position for which wind data shall be *
> ! calculated *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
> use hanna_mod
>
> implicit none
>
> integer :: itime
> real :: xt,yt,zt
>
> ! Auxiliary variables needed for interpolation
> real :: ust1(2),wst1(2),oli1(2),oliaux
> real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
> real :: usl,vsl,wsl,usq,vsq,wsq,xaux
> integer :: i,m,n,indexh
> real,parameter :: eps=1.0e-30
>
>
> !********************************************
> ! Multilinear interpolation in time and space
> !********************************************
>
> ! 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)
>
>
> !*****************************************
> ! 1. Interpolate u*, w* and Obukhov length
> !*****************************************
>
> ! a) Bilinear horizontal interpolation
>
> do m=1,2
> indexh=memind(m)
>
> ust1(m)=p1*ustarn(ix ,jy ,1,indexh,ngrid) &
> + p2*ustarn(ixp,jy ,1,indexh,ngrid) &
> + p3*ustarn(ix ,jyp,1,indexh,ngrid) &
> + p4*ustarn(ixp,jyp,1,indexh,ngrid)
> wst1(m)=p1*wstarn(ix ,jy ,1,indexh,ngrid) &
> + p2*wstarn(ixp,jy ,1,indexh,ngrid) &
> + p3*wstarn(ix ,jyp,1,indexh,ngrid) &
> + p4*wstarn(ixp,jyp,1,indexh,ngrid)
> oli1(m)=p1*olin(ix ,jy ,1,indexh,ngrid) &
> + p2*olin(ixp,jy ,1,indexh,ngrid) &
> + p3*olin(ix ,jyp,1,indexh,ngrid) &
> + p4*olin(ixp,jyp,1,indexh,ngrid)
> end do
>
> ! b) Temporal interpolation
>
> ust=(ust1(1)*dt2+ust1(2)*dt1)*dtt
> wst=(wst1(1)*dt2+wst1(2)*dt1)*dtt
> oliaux=(oli1(1)*dt2+oli1(2)*dt1)*dtt
>
> if (oliaux.ne.0.) then
> ol=1./oliaux
> else
> ol=99999.
> endif
>
>
> !*****************************************************
> ! 2. Interpolate vertical profiles of u,v,w,rho,drhodz
> !*****************************************************
>
>
> ! Determine the level below the current position
> !***********************************************
>
> do i=2,nz
> if (height(i).gt.zt) then
> indz=i-1
> indzp=i
> goto 6
> endif
> end do
> 6 continue
>
> !**************************************
> ! 1.) Bilinear horizontal interpolation
> ! 2.) Temporal interpolation (linear)
> !**************************************
>
> ! Loop over 2 time steps and indz levels
> !***************************************
>
> do n=indz,indz+1
> usl=0.
> vsl=0.
> wsl=0.
> usq=0.
> vsq=0.
> wsq=0.
> do m=1,2
> indexh=memind(m)
> y1(m)=p1*uun(ix ,jy ,n,indexh,ngrid) &
> +p2*uun(ixp,jy ,n,indexh,ngrid) &
> +p3*uun(ix ,jyp,n,indexh,ngrid) &
> +p4*uun(ixp,jyp,n,indexh,ngrid)
> y2(m)=p1*vvn(ix ,jy ,n,indexh,ngrid) &
> +p2*vvn(ixp,jy ,n,indexh,ngrid) &
> +p3*vvn(ix ,jyp,n,indexh,ngrid) &
> +p4*vvn(ixp,jyp,n,indexh,ngrid)
> y3(m)=p1*wwn(ix ,jy ,n,indexh,ngrid) &
> +p2*wwn(ixp,jy ,n,indexh,ngrid) &
> +p3*wwn(ix ,jyp,n,indexh,ngrid) &
> +p4*wwn(ixp,jyp,n,indexh,ngrid)
> rhograd1(m)=p1*drhodzn(ix ,jy ,n,indexh,ngrid) &
> +p2*drhodzn(ixp,jy ,n,indexh,ngrid) &
> +p3*drhodzn(ix ,jyp,n,indexh,ngrid) &
> +p4*drhodzn(ixp,jyp,n,indexh,ngrid)
> rho1(m)=p1*rhon(ix ,jy ,n,indexh,ngrid) &
> +p2*rhon(ixp,jy ,n,indexh,ngrid) &
> +p3*rhon(ix ,jyp,n,indexh,ngrid) &
> +p4*rhon(ixp,jyp,n,indexh,ngrid)
>
> usl=usl+uun(ix ,jy ,n,indexh,ngrid)+uun(ixp,jy ,n,indexh,ngrid) &
> +uun(ix ,jyp,n,indexh,ngrid)+uun(ixp,jyp,n,indexh,ngrid)
> vsl=vsl+vvn(ix ,jy ,n,indexh,ngrid)+vvn(ixp,jy ,n,indexh,ngrid) &
> +vvn(ix ,jyp,n,indexh,ngrid)+vvn(ixp,jyp,n,indexh,ngrid)
> wsl=wsl+wwn(ix ,jy ,n,indexh,ngrid)+wwn(ixp,jy ,n,indexh,ngrid) &
> +wwn(ix ,jyp,n,indexh,ngrid)+wwn(ixp,jyp,n,indexh,ngrid)
>
> usq=usq+uun(ix ,jy ,n,indexh,ngrid)*uun(ix ,jy ,n,indexh,ngrid)+ &
> uun(ixp,jy ,n,indexh,ngrid)*uun(ixp,jy ,n,indexh,ngrid)+ &
> uun(ix ,jyp,n,indexh,ngrid)*uun(ix ,jyp,n,indexh,ngrid)+ &
> uun(ixp,jyp,n,indexh,ngrid)*uun(ixp,jyp,n,indexh,ngrid)
> vsq=vsq+vvn(ix ,jy ,n,indexh,ngrid)*vvn(ix ,jy ,n,indexh,ngrid)+ &
> vvn(ixp,jy ,n,indexh,ngrid)*vvn(ixp,jy ,n,indexh,ngrid)+ &
> vvn(ix ,jyp,n,indexh,ngrid)*vvn(ix ,jyp,n,indexh,ngrid)+ &
> vvn(ixp,jyp,n,indexh,ngrid)*vvn(ixp,jyp,n,indexh,ngrid)
> wsq=wsq+wwn(ix ,jy ,n,indexh,ngrid)*wwn(ix ,jy ,n,indexh,ngrid)+ &
> wwn(ixp,jy ,n,indexh,ngrid)*wwn(ixp,jy ,n,indexh,ngrid)+ &
> wwn(ix ,jyp,n,indexh,ngrid)*wwn(ix ,jyp,n,indexh,ngrid)+ &
> wwn(ixp,jyp,n,indexh,ngrid)*wwn(ixp,jyp,n,indexh,ngrid)
> end do
> uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
> vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
> wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
> rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
> rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
> indzindicator(n)=.false.
>
> ! Compute standard deviations
> !****************************
>
> xaux=usq-usl*usl/8.
> if (xaux.lt.eps) then
> usigprof(n)=0.
> else
> usigprof(n)=sqrt(xaux/7.)
> endif
>
> xaux=vsq-vsl*vsl/8.
> if (xaux.lt.eps) then
> vsigprof(n)=0.
> else
> vsigprof(n)=sqrt(xaux/7.)
> endif
>
>
> xaux=wsq-wsl*wsl/8.
> if (xaux.lt.eps) then
> wsigprof(n)=0.
> else
> wsigprof(n)=sqrt(xaux/7.)
> endif
>
> end do
>
> end subroutine interpol_all_nests
interpol_misslev.f90
----------------------------------------------
1,180c1,180
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_misslev(n)
< ! i
< !*****************************************************************************
< ! *
< ! This subroutine interpolates u,v,w, density and density gradients. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 December 1997 *
< ! Update: 2 March 1999 *
< ! *
< ! Revision March 2005 by AST : all output variables in common block cal- *
< ! culation of standard deviation done in this *
< ! routine rather than subroutine call in order *
< ! to save computation time *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! n level *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
< use hanna_mod
<
< implicit none
<
< ! Auxiliary variables needed for interpolation
< real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
< real :: usl,vsl,wsl,usq,vsq,wsq,xaux
< integer :: m,n,indexh
< real,parameter :: eps=1.0e-30
<
<
< !********************************************
< ! Multilinear interpolation in time and space
< !********************************************
<
<
< !**************************************
< ! 1.) Bilinear horizontal interpolation
< ! 2.) Temporal interpolation (linear)
< !**************************************
<
< ! Loop over 2 time steps
< !***********************
<
< usl=0.
< vsl=0.
< wsl=0.
< usq=0.
< vsq=0.
< wsq=0.
< do m=1,2
< indexh=memind(m)
< if (ngrid.lt.0) then
< y1(m)=p1*uupol(ix ,jy ,n,indexh) &
< +p2*uupol(ixp,jy ,n,indexh) &
< +p3*uupol(ix ,jyp,n,indexh) &
< +p4*uupol(ixp,jyp,n,indexh)
< y2(m)=p1*vvpol(ix ,jy ,n,indexh) &
< +p2*vvpol(ixp,jy ,n,indexh) &
< +p3*vvpol(ix ,jyp,n,indexh) &
< +p4*vvpol(ixp,jyp,n,indexh)
< usl=usl+uupol(ix ,jy ,n,indexh)+uupol(ixp,jy ,n,indexh) &
< +uupol(ix ,jyp,n,indexh)+uupol(ixp,jyp,n,indexh)
< vsl=vsl+vvpol(ix ,jy ,n,indexh)+vvpol(ixp,jy ,n,indexh) &
< +vvpol(ix ,jyp,n,indexh)+vvpol(ixp,jyp,n,indexh)
<
< usq=usq+uupol(ix ,jy ,n,indexh)*uupol(ix ,jy ,n,indexh)+ &
< uupol(ixp,jy ,n,indexh)*uupol(ixp,jy ,n,indexh)+ &
< uupol(ix ,jyp,n,indexh)*uupol(ix ,jyp,n,indexh)+ &
< uupol(ixp,jyp,n,indexh)*uupol(ixp,jyp,n,indexh)
< vsq=vsq+vvpol(ix ,jy ,n,indexh)*vvpol(ix ,jy ,n,indexh)+ &
< vvpol(ixp,jy ,n,indexh)*vvpol(ixp,jy ,n,indexh)+ &
< vvpol(ix ,jyp,n,indexh)*vvpol(ix ,jyp,n,indexh)+ &
< vvpol(ixp,jyp,n,indexh)*vvpol(ixp,jyp,n,indexh)
< else
< y1(m)=p1*uu(ix ,jy ,n,indexh) &
< +p2*uu(ixp,jy ,n,indexh) &
< +p3*uu(ix ,jyp,n,indexh) &
< +p4*uu(ixp,jyp,n,indexh)
< y2(m)=p1*vv(ix ,jy ,n,indexh) &
< +p2*vv(ixp,jy ,n,indexh) &
< +p3*vv(ix ,jyp,n,indexh) &
< +p4*vv(ixp,jyp,n,indexh)
< usl=usl+uu(ix ,jy ,n,indexh)+uu(ixp,jy ,n,indexh) &
< +uu(ix ,jyp,n,indexh)+uu(ixp,jyp,n,indexh)
< vsl=vsl+vv(ix ,jy ,n,indexh)+vv(ixp,jy ,n,indexh) &
< +vv(ix ,jyp,n,indexh)+vv(ixp,jyp,n,indexh)
<
< usq=usq+uu(ix ,jy ,n,indexh)*uu(ix ,jy ,n,indexh)+ &
< uu(ixp,jy ,n,indexh)*uu(ixp,jy ,n,indexh)+ &
< uu(ix ,jyp,n,indexh)*uu(ix ,jyp,n,indexh)+ &
< uu(ixp,jyp,n,indexh)*uu(ixp,jyp,n,indexh)
< vsq=vsq+vv(ix ,jy ,n,indexh)*vv(ix ,jy ,n,indexh)+ &
< vv(ixp,jy ,n,indexh)*vv(ixp,jy ,n,indexh)+ &
< vv(ix ,jyp,n,indexh)*vv(ix ,jyp,n,indexh)+ &
< vv(ixp,jyp,n,indexh)*vv(ixp,jyp,n,indexh)
< endif
< y3(m)=p1*ww(ix ,jy ,n,indexh) &
< +p2*ww(ixp,jy ,n,indexh) &
< +p3*ww(ix ,jyp,n,indexh) &
< +p4*ww(ixp,jyp,n,indexh)
< rhograd1(m)=p1*drhodz(ix ,jy ,n,indexh) &
< +p2*drhodz(ixp,jy ,n,indexh) &
< +p3*drhodz(ix ,jyp,n,indexh) &
< +p4*drhodz(ixp,jyp,n,indexh)
< rho1(m)=p1*rho(ix ,jy ,n,indexh) &
< +p2*rho(ixp,jy ,n,indexh) &
< +p3*rho(ix ,jyp,n,indexh) &
< +p4*rho(ixp,jyp,n,indexh)
< wsl=wsl+ww(ix ,jy ,n,indexh)+ww(ixp,jy ,n,indexh) &
< +ww(ix ,jyp,n,indexh)+ww(ixp,jyp,n,indexh)
< wsq=wsq+ww(ix ,jy ,n,indexh)*ww(ix ,jy ,n,indexh)+ &
< ww(ixp,jy ,n,indexh)*ww(ixp,jy ,n,indexh)+ &
< ww(ix ,jyp,n,indexh)*ww(ix ,jyp,n,indexh)+ &
< ww(ixp,jyp,n,indexh)*ww(ixp,jyp,n,indexh)
< end do
< uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
< vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
< wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
< rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
< rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
< indzindicator(n)=.false.
<
<
< ! Compute standard deviations
< !****************************
<
< xaux=usq-usl*usl/8.
< if (xaux.lt.eps) then
< usigprof(n)=0.
< else
< usigprof(n)=sqrt(xaux/7.)
< endif
<
< xaux=vsq-vsl*vsl/8.
< if (xaux.lt.eps) then
< vsigprof(n)=0.
< else
< vsigprof(n)=sqrt(xaux/7.)
< endif
<
<
< xaux=wsq-wsl*wsl/8.
< if (xaux.lt.eps) then
< wsigprof(n)=0.
< else
< wsigprof(n)=sqrt(xaux/7.)
< endif
<
<
< end subroutine interpol_misslev
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_misslev(n)
> ! i
> !*****************************************************************************
> ! *
> ! This subroutine interpolates u,v,w, density and density gradients. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 December 1997 *
> ! Update: 2 March 1999 *
> ! *
> ! Revision March 2005 by AST : all output variables in common block cal- *
> ! culation of standard deviation done in this *
> ! routine rather than subroutine call in order *
> ! to save computation time *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! n level *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
> use hanna_mod
>
> implicit none
>
> ! Auxiliary variables needed for interpolation
> real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
> real :: usl,vsl,wsl,usq,vsq,wsq,xaux
> integer :: m,n,indexh
> real,parameter :: eps=1.0e-30
>
>
> !********************************************
> ! Multilinear interpolation in time and space
> !********************************************
>
>
> !**************************************
> ! 1.) Bilinear horizontal interpolation
> ! 2.) Temporal interpolation (linear)
> !**************************************
>
> ! Loop over 2 time steps
> !***********************
>
> usl=0.
> vsl=0.
> wsl=0.
> usq=0.
> vsq=0.
> wsq=0.
> do m=1,2
> indexh=memind(m)
> if (ngrid.lt.0) then
> y1(m)=p1*uupol(ix ,jy ,n,indexh) &
> +p2*uupol(ixp,jy ,n,indexh) &
> +p3*uupol(ix ,jyp,n,indexh) &
> +p4*uupol(ixp,jyp,n,indexh)
> y2(m)=p1*vvpol(ix ,jy ,n,indexh) &
> +p2*vvpol(ixp,jy ,n,indexh) &
> +p3*vvpol(ix ,jyp,n,indexh) &
> +p4*vvpol(ixp,jyp,n,indexh)
> usl=usl+uupol(ix ,jy ,n,indexh)+uupol(ixp,jy ,n,indexh) &
> +uupol(ix ,jyp,n,indexh)+uupol(ixp,jyp,n,indexh)
> vsl=vsl+vvpol(ix ,jy ,n,indexh)+vvpol(ixp,jy ,n,indexh) &
> +vvpol(ix ,jyp,n,indexh)+vvpol(ixp,jyp,n,indexh)
>
> usq=usq+uupol(ix ,jy ,n,indexh)*uupol(ix ,jy ,n,indexh)+ &
> uupol(ixp,jy ,n,indexh)*uupol(ixp,jy ,n,indexh)+ &
> uupol(ix ,jyp,n,indexh)*uupol(ix ,jyp,n,indexh)+ &
> uupol(ixp,jyp,n,indexh)*uupol(ixp,jyp,n,indexh)
> vsq=vsq+vvpol(ix ,jy ,n,indexh)*vvpol(ix ,jy ,n,indexh)+ &
> vvpol(ixp,jy ,n,indexh)*vvpol(ixp,jy ,n,indexh)+ &
> vvpol(ix ,jyp,n,indexh)*vvpol(ix ,jyp,n,indexh)+ &
> vvpol(ixp,jyp,n,indexh)*vvpol(ixp,jyp,n,indexh)
> else
> y1(m)=p1*uu(ix ,jy ,n,indexh) &
> +p2*uu(ixp,jy ,n,indexh) &
> +p3*uu(ix ,jyp,n,indexh) &
> +p4*uu(ixp,jyp,n,indexh)
> y2(m)=p1*vv(ix ,jy ,n,indexh) &
> +p2*vv(ixp,jy ,n,indexh) &
> +p3*vv(ix ,jyp,n,indexh) &
> +p4*vv(ixp,jyp,n,indexh)
> usl=usl+uu(ix ,jy ,n,indexh)+uu(ixp,jy ,n,indexh) &
> +uu(ix ,jyp,n,indexh)+uu(ixp,jyp,n,indexh)
> vsl=vsl+vv(ix ,jy ,n,indexh)+vv(ixp,jy ,n,indexh) &
> +vv(ix ,jyp,n,indexh)+vv(ixp,jyp,n,indexh)
>
> usq=usq+uu(ix ,jy ,n,indexh)*uu(ix ,jy ,n,indexh)+ &
> uu(ixp,jy ,n,indexh)*uu(ixp,jy ,n,indexh)+ &
> uu(ix ,jyp,n,indexh)*uu(ix ,jyp,n,indexh)+ &
> uu(ixp,jyp,n,indexh)*uu(ixp,jyp,n,indexh)
> vsq=vsq+vv(ix ,jy ,n,indexh)*vv(ix ,jy ,n,indexh)+ &
> vv(ixp,jy ,n,indexh)*vv(ixp,jy ,n,indexh)+ &
> vv(ix ,jyp,n,indexh)*vv(ix ,jyp,n,indexh)+ &
> vv(ixp,jyp,n,indexh)*vv(ixp,jyp,n,indexh)
> endif
> y3(m)=p1*ww(ix ,jy ,n,indexh) &
> +p2*ww(ixp,jy ,n,indexh) &
> +p3*ww(ix ,jyp,n,indexh) &
> +p4*ww(ixp,jyp,n,indexh)
> rhograd1(m)=p1*drhodz(ix ,jy ,n,indexh) &
> +p2*drhodz(ixp,jy ,n,indexh) &
> +p3*drhodz(ix ,jyp,n,indexh) &
> +p4*drhodz(ixp,jyp,n,indexh)
> rho1(m)=p1*rho(ix ,jy ,n,indexh) &
> +p2*rho(ixp,jy ,n,indexh) &
> +p3*rho(ix ,jyp,n,indexh) &
> +p4*rho(ixp,jyp,n,indexh)
> wsl=wsl+ww(ix ,jy ,n,indexh)+ww(ixp,jy ,n,indexh) &
> +ww(ix ,jyp,n,indexh)+ww(ixp,jyp,n,indexh)
> wsq=wsq+ww(ix ,jy ,n,indexh)*ww(ix ,jy ,n,indexh)+ &
> ww(ixp,jy ,n,indexh)*ww(ixp,jy ,n,indexh)+ &
> ww(ix ,jyp,n,indexh)*ww(ix ,jyp,n,indexh)+ &
> ww(ixp,jyp,n,indexh)*ww(ixp,jyp,n,indexh)
> end do
> uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
> vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
> wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
> rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
> rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
> indzindicator(n)=.false.
>
>
> ! Compute standard deviations
> !****************************
>
> xaux=usq-usl*usl/8.
> if (xaux.lt.eps) then
> usigprof(n)=0.
> else
> usigprof(n)=sqrt(xaux/7.)
> endif
>
> xaux=vsq-vsl*vsl/8.
> if (xaux.lt.eps) then
> vsigprof(n)=0.
> else
> vsigprof(n)=sqrt(xaux/7.)
> endif
>
>
> xaux=wsq-wsl*wsl/8.
> if (xaux.lt.eps) then
> wsigprof(n)=0.
> else
> wsigprof(n)=sqrt(xaux/7.)
> endif
>
>
> end subroutine interpol_misslev
interpol_misslev_nests.f90
----------------------------------------------
1,149c1,149
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_misslev_nests(n)
< ! i
< !*****************************************************************************
< ! *
< ! This subroutine interpolates u,v,w, density and density gradients. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 December 1997 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! n level *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
< use hanna_mod
<
< implicit none
<
< ! Auxiliary variables needed for interpolation
< real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
< real :: usl,vsl,wsl,usq,vsq,wsq,xaux
< integer :: m,n,indexh
< real,parameter :: eps=1.0e-30
<
<
< !********************************************
< ! Multilinear interpolation in time and space
< !********************************************
<
<
< !**************************************
< ! 1.) Bilinear horizontal interpolation
< ! 2.) Temporal interpolation (linear)
< !**************************************
<
< ! Loop over 2 time steps
< !***********************
<
< usl=0.
< vsl=0.
< wsl=0.
< usq=0.
< vsq=0.
< wsq=0.
< do m=1,2
< indexh=memind(m)
< y1(m)=p1*uun(ix ,jy ,n,indexh,ngrid) &
< +p2*uun(ixp,jy ,n,indexh,ngrid) &
< +p3*uun(ix ,jyp,n,indexh,ngrid) &
< +p4*uun(ixp,jyp,n,indexh,ngrid)
< y2(m)=p1*vvn(ix ,jy ,n,indexh,ngrid) &
< +p2*vvn(ixp,jy ,n,indexh,ngrid) &
< +p3*vvn(ix ,jyp,n,indexh,ngrid) &
< +p4*vvn(ixp,jyp,n,indexh,ngrid)
< y3(m)=p1*wwn(ix ,jy ,n,indexh,ngrid) &
< +p2*wwn(ixp,jy ,n,indexh,ngrid) &
< +p3*wwn(ix ,jyp,n,indexh,ngrid) &
< +p4*wwn(ixp,jyp,n,indexh,ngrid)
< rho1(m)=p1*rhon(ix ,jy ,n,indexh,ngrid) &
< +p2*rhon(ixp,jy ,n,indexh,ngrid) &
< +p3*rhon(ix ,jyp,n,indexh,ngrid) &
< +p4*rhon(ixp,jyp,n,indexh,ngrid)
< rhograd1(m)=p1*drhodzn(ix ,jy ,n,indexh,ngrid) &
< +p2*drhodzn(ixp,jy ,n,indexh,ngrid) &
< +p3*drhodzn(ix ,jyp,n,indexh,ngrid) &
< +p4*drhodzn(ixp,jyp,n,indexh,ngrid)
<
< usl=usl+uun(ix ,jy ,n,indexh,ngrid)+uun(ixp,jy ,n,indexh,ngrid) &
< +uun(ix ,jyp,n,indexh,ngrid)+uun(ixp,jyp,n,indexh,ngrid)
< vsl=vsl+vvn(ix ,jy ,n,indexh,ngrid)+vvn(ixp,jy ,n,indexh,ngrid) &
< +vvn(ix ,jyp,n,indexh,ngrid)+vvn(ixp,jyp,n,indexh,ngrid)
< wsl=wsl+wwn(ix ,jy ,n,indexh,ngrid)+wwn(ixp,jy ,n,indexh,ngrid) &
< +wwn(ix ,jyp,n,indexh,ngrid)+wwn(ixp,jyp,n,indexh,ngrid)
<
< usq=usq+uun(ix ,jy ,n,indexh,ngrid)*uun(ix ,jy ,n,indexh,ngrid)+ &
< uun(ixp,jy ,n,indexh,ngrid)*uun(ixp,jy ,n,indexh,ngrid)+ &
< uun(ix ,jyp,n,indexh,ngrid)*uun(ix ,jyp,n,indexh,ngrid)+ &
< uun(ixp,jyp,n,indexh,ngrid)*uun(ixp,jyp,n,indexh,ngrid)
< vsq=vsq+vvn(ix ,jy ,n,indexh,ngrid)*vvn(ix ,jy ,n,indexh,ngrid)+ &
< vvn(ixp,jy ,n,indexh,ngrid)*vvn(ixp,jy ,n,indexh,ngrid)+ &
< vvn(ix ,jyp,n,indexh,ngrid)*vvn(ix ,jyp,n,indexh,ngrid)+ &
< vvn(ixp,jyp,n,indexh,ngrid)*vvn(ixp,jyp,n,indexh,ngrid)
< wsq=wsq+wwn(ix ,jy ,n,indexh,ngrid)*wwn(ix ,jy ,n,indexh,ngrid)+ &
< wwn(ixp,jy ,n,indexh,ngrid)*wwn(ixp,jy ,n,indexh,ngrid)+ &
< wwn(ix ,jyp,n,indexh,ngrid)*wwn(ix ,jyp,n,indexh,ngrid)+ &
< wwn(ixp,jyp,n,indexh,ngrid)*wwn(ixp,jyp,n,indexh,ngrid)
< end do
< uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
< vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
< wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
< rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
< rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
< indzindicator(n)=.false.
<
< ! Compute standard deviations
< !****************************
<
< xaux=usq-usl*usl/8.
< if (xaux.lt.eps) then
< usigprof(n)=0.
< else
< usigprof(n)=sqrt(xaux/7.)
< endif
<
< xaux=vsq-vsl*vsl/8.
< if (xaux.lt.eps) then
< vsigprof(n)=0.
< else
< vsigprof(n)=sqrt(xaux/7.)
< endif
<
<
< xaux=wsq-wsl*wsl/8.
< if (xaux.lt.eps) then
< wsigprof(n)=0.
< else
< wsigprof(n)=sqrt(xaux/7.)
< endif
<
< end subroutine interpol_misslev_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_misslev_nests(n)
> ! i
> !*****************************************************************************
> ! *
> ! This subroutine interpolates u,v,w, density and density gradients. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 December 1997 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! n level *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
> use hanna_mod
>
> implicit none
>
> ! Auxiliary variables needed for interpolation
> real :: y1(2),y2(2),y3(2),rho1(2),rhograd1(2)
> real :: usl,vsl,wsl,usq,vsq,wsq,xaux
> integer :: m,n,indexh
> real,parameter :: eps=1.0e-30
>
>
> !********************************************
> ! Multilinear interpolation in time and space
> !********************************************
>
>
> !**************************************
> ! 1.) Bilinear horizontal interpolation
> ! 2.) Temporal interpolation (linear)
> !**************************************
>
> ! Loop over 2 time steps
> !***********************
>
> usl=0.
> vsl=0.
> wsl=0.
> usq=0.
> vsq=0.
> wsq=0.
> do m=1,2
> indexh=memind(m)
> y1(m)=p1*uun(ix ,jy ,n,indexh,ngrid) &
> +p2*uun(ixp,jy ,n,indexh,ngrid) &
> +p3*uun(ix ,jyp,n,indexh,ngrid) &
> +p4*uun(ixp,jyp,n,indexh,ngrid)
> y2(m)=p1*vvn(ix ,jy ,n,indexh,ngrid) &
> +p2*vvn(ixp,jy ,n,indexh,ngrid) &
> +p3*vvn(ix ,jyp,n,indexh,ngrid) &
> +p4*vvn(ixp,jyp,n,indexh,ngrid)
> y3(m)=p1*wwn(ix ,jy ,n,indexh,ngrid) &
> +p2*wwn(ixp,jy ,n,indexh,ngrid) &
> +p3*wwn(ix ,jyp,n,indexh,ngrid) &
> +p4*wwn(ixp,jyp,n,indexh,ngrid)
> rho1(m)=p1*rhon(ix ,jy ,n,indexh,ngrid) &
> +p2*rhon(ixp,jy ,n,indexh,ngrid) &
> +p3*rhon(ix ,jyp,n,indexh,ngrid) &
> +p4*rhon(ixp,jyp,n,indexh,ngrid)
> rhograd1(m)=p1*drhodzn(ix ,jy ,n,indexh,ngrid) &
> +p2*drhodzn(ixp,jy ,n,indexh,ngrid) &
> +p3*drhodzn(ix ,jyp,n,indexh,ngrid) &
> +p4*drhodzn(ixp,jyp,n,indexh,ngrid)
>
> usl=usl+uun(ix ,jy ,n,indexh,ngrid)+uun(ixp,jy ,n,indexh,ngrid) &
> +uun(ix ,jyp,n,indexh,ngrid)+uun(ixp,jyp,n,indexh,ngrid)
> vsl=vsl+vvn(ix ,jy ,n,indexh,ngrid)+vvn(ixp,jy ,n,indexh,ngrid) &
> +vvn(ix ,jyp,n,indexh,ngrid)+vvn(ixp,jyp,n,indexh,ngrid)
> wsl=wsl+wwn(ix ,jy ,n,indexh,ngrid)+wwn(ixp,jy ,n,indexh,ngrid) &
> +wwn(ix ,jyp,n,indexh,ngrid)+wwn(ixp,jyp,n,indexh,ngrid)
>
> usq=usq+uun(ix ,jy ,n,indexh,ngrid)*uun(ix ,jy ,n,indexh,ngrid)+ &
> uun(ixp,jy ,n,indexh,ngrid)*uun(ixp,jy ,n,indexh,ngrid)+ &
> uun(ix ,jyp,n,indexh,ngrid)*uun(ix ,jyp,n,indexh,ngrid)+ &
> uun(ixp,jyp,n,indexh,ngrid)*uun(ixp,jyp,n,indexh,ngrid)
> vsq=vsq+vvn(ix ,jy ,n,indexh,ngrid)*vvn(ix ,jy ,n,indexh,ngrid)+ &
> vvn(ixp,jy ,n,indexh,ngrid)*vvn(ixp,jy ,n,indexh,ngrid)+ &
> vvn(ix ,jyp,n,indexh,ngrid)*vvn(ix ,jyp,n,indexh,ngrid)+ &
> vvn(ixp,jyp,n,indexh,ngrid)*vvn(ixp,jyp,n,indexh,ngrid)
> wsq=wsq+wwn(ix ,jy ,n,indexh,ngrid)*wwn(ix ,jy ,n,indexh,ngrid)+ &
> wwn(ixp,jy ,n,indexh,ngrid)*wwn(ixp,jy ,n,indexh,ngrid)+ &
> wwn(ix ,jyp,n,indexh,ngrid)*wwn(ix ,jyp,n,indexh,ngrid)+ &
> wwn(ixp,jyp,n,indexh,ngrid)*wwn(ixp,jyp,n,indexh,ngrid)
> end do
> uprof(n)=(y1(1)*dt2+y1(2)*dt1)*dtt
> vprof(n)=(y2(1)*dt2+y2(2)*dt1)*dtt
> wprof(n)=(y3(1)*dt2+y3(2)*dt1)*dtt
> rhoprof(n)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
> rhogradprof(n)=(rhograd1(1)*dt2+rhograd1(2)*dt1)*dtt
> indzindicator(n)=.false.
>
> ! Compute standard deviations
> !****************************
>
> xaux=usq-usl*usl/8.
> if (xaux.lt.eps) then
> usigprof(n)=0.
> else
> usigprof(n)=sqrt(xaux/7.)
> endif
>
> xaux=vsq-vsl*vsl/8.
> if (xaux.lt.eps) then
> vsigprof(n)=0.
> else
> vsigprof(n)=sqrt(xaux/7.)
> endif
>
>
> xaux=wsq-wsl*wsl/8.
> if (xaux.lt.eps) then
> wsigprof(n)=0.
> else
> wsigprof(n)=sqrt(xaux/7.)
> endif
>
> end subroutine interpol_misslev_nests
interpol_mod.f90
----------------------------------------------
1,20c1,27
< module interpol_mod
<
< use par_mod, only: nzmax, maxspec
<
< implicit none
<
< real :: uprof(nzmax),vprof(nzmax),wprof(nzmax)
< real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax)
< real :: rhoprof(nzmax),rhogradprof(nzmax)
<
< real :: u,v,w,usig,vsig,wsig,pvi
<
< real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2
< integer :: ix,jy,ixp,jyp,ngrid,indz,indzp
< logical :: depoindicator(maxspec)
< logical :: indzindicator(nzmax)
<
< end module interpol_mod
<
<
---
> module interpol_mod
>
> use par_mod, only: nzmax, maxspec
>
> implicit none
>
> real :: uprof(nzmax),vprof(nzmax),wprof(nzmax)
> real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax)
> real :: rhoprof(nzmax),rhogradprof(nzmax)
>
> real :: u,v,w,usig,vsig,wsig,pvi
>
> real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2
> integer :: ix,jy,ixp,jyp,ngrid,indz,indzp
> logical :: depoindicator(maxspec)
> logical :: indzindicator(nzmax)
>
>
> !$OMP THREADPRIVATE(uprof,vprof,wprof,usigprof,vsigprof,wsigprof, &
> !$OMP rhoprof,rhogradprof,u,v,w,usig,vsig,wsig,pvi, &
> !$OMP p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2,ix,jy,ixp,jyp, &
> !$OMP ngrid,indz,indzp,depoindicator,indzindicator)
>
>
> end module interpol_mod
>
>
interpol_rain.f90
----------------------------------------------
1,145c1,145
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_rain(yy1,yy2,yy3,nxmax,nymax,nzmax,nx, &
< ny,memind,xt,yt,level,itime1,itime2,itime,yint1,yint2,yint3)
< ! i i i i i i i
< !i i i i i i i i o o o
< !****************************************************************************
< ! *
< ! Interpolation of meteorological fields on 2-d model layers. *
< ! In horizontal direction bilinear interpolation interpolation is used. *
< ! Temporally a linear interpolation is used. *
< ! Three fields are interpolated at the same time. *
< ! *
< ! This is a special version of levlininterpol to save CPU time. *
< ! *
< ! 1 first time *
< ! 2 second time *
< ! *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 30 August 1996 *
< ! *
< !****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! dt1,dt2 time differences between fields and current position *
< ! dz1,dz2 z distance between levels and current position *
< ! height(nzmax) heights of the model levels *
< ! indexh help variable *
< ! indz the level closest to the current trajectory position *
< ! indzh help variable *
< ! itime current time *
< ! itime1 time of the first wind field *
< ! itime2 time of the second wind field *
< ! ix,jy x,y coordinates of lower left subgrid point *
< ! level level at which interpolation shall be done *
< ! memind(3) points to the places of the wind fields *
< ! nx,ny actual field dimensions in x,y and z direction *
< ! nxmax,nymax,nzmax maximum field dimensions in x,y and z direction *
< ! xt current x coordinate *
< ! yint the final interpolated value *
< ! yt current y coordinate *
< ! yy(0:nxmax,0:nymax,nzmax,3) meteorological field used for interpolation *
< ! zt current z coordinate *
< ! *
< !****************************************************************************
<
< implicit none
<
< integer :: nx,ny,nxmax,nymax,nzmax,memind(2),m,ix,jy,ixp,jyp
< integer :: itime,itime1,itime2,level,indexh
< real :: yy1(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: yy2(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: yy3(0:nxmax-1,0:nymax-1,nzmax,2)
< real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2)
< real :: xt,yt,yint1,yint2,yint3,p1,p2,p3,p4
<
<
<
< ! If point at border of grid -> small displacement into grid
< !***********************************************************
<
< if (xt.ge.real(nx-1)) xt=real(nx-1)-0.00001
< if (yt.ge.real(ny-1)) yt=real(ny-1)-0.00001
<
<
<
< !**********************************************************************
< ! 1.) Bilinear horizontal interpolation
< ! This has to be done separately for 2 fields (Temporal)
< !*******************************************************
<
< ! Determine the lower left corner and its distance to the current position
< !*************************************************************************
<
< ix=int(xt)
< jy=int(yt)
< ixp=ix+1
< jyp=jy+1
< 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
<
<
< ! Loop over 2 time steps
< !***********************
<
< do m=1,2
< indexh=memind(m)
<
< y1(m)=p1*yy1(ix ,jy ,level,indexh) &
< + p2*yy1(ixp,jy ,level,indexh) &
< + p3*yy1(ix ,jyp,level,indexh) &
< + p4*yy1(ixp,jyp,level,indexh)
< y2(m)=p1*yy2(ix ,jy ,level,indexh) &
< + p2*yy2(ixp,jy ,level,indexh) &
< + p3*yy2(ix ,jyp,level,indexh) &
< + p4*yy2(ixp,jyp,level,indexh)
< y3(m)=p1*yy3(ix ,jy ,level,indexh) &
< + p2*yy3(ixp,jy ,level,indexh) &
< + p3*yy3(ix ,jyp,level,indexh) &
< + p4*yy3(ixp,jyp,level,indexh)
< end do
<
<
< !************************************
< ! 2.) Temporal interpolation (linear)
< !************************************
<
< dt1=real(itime-itime1)
< dt2=real(itime2-itime)
< dt=dt1+dt2
<
< yint1=(y1(1)*dt2+y1(2)*dt1)/dt
< yint2=(y2(1)*dt2+y2(2)*dt1)/dt
< yint3=(y3(1)*dt2+y3(2)*dt1)/dt
<
<
< end subroutine interpol_rain
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_rain(yy1,yy2,yy3,nxmax,nymax,nzmax,nx, &
> ny,memind,xt,yt,level,itime1,itime2,itime,yint1,yint2,yint3)
> ! i i i i i i i
> !i i i i i i i i o o o
> !****************************************************************************
> ! *
> ! Interpolation of meteorological fields on 2-d model layers. *
> ! In horizontal direction bilinear interpolation interpolation is used. *
> ! Temporally a linear interpolation is used. *
> ! Three fields are interpolated at the same time. *
> ! *
> ! This is a special version of levlininterpol to save CPU time. *
> ! *
> ! 1 first time *
> ! 2 second time *
> ! *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 30 August 1996 *
> ! *
> !****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! dt1,dt2 time differences between fields and current position *
> ! dz1,dz2 z distance between levels and current position *
> ! height(nzmax) heights of the model levels *
> ! indexh help variable *
> ! indz the level closest to the current trajectory position *
> ! indzh help variable *
> ! itime current time *
> ! itime1 time of the first wind field *
> ! itime2 time of the second wind field *
> ! ix,jy x,y coordinates of lower left subgrid point *
> ! level level at which interpolation shall be done *
> ! memind(3) points to the places of the wind fields *
> ! nx,ny actual field dimensions in x,y and z direction *
> ! nxmax,nymax,nzmax maximum field dimensions in x,y and z direction *
> ! xt current x coordinate *
> ! yint the final interpolated value *
> ! yt current y coordinate *
> ! yy(0:nxmax,0:nymax,nzmax,3) meteorological field used for interpolation *
> ! zt current z coordinate *
> ! *
> !****************************************************************************
>
> implicit none
>
> integer :: nx,ny,nxmax,nymax,nzmax,memind(2),m,ix,jy,ixp,jyp
> integer :: itime,itime1,itime2,level,indexh
> real :: yy1(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: yy2(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: yy3(0:nxmax-1,0:nymax-1,nzmax,2)
> real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2)
> real :: xt,yt,yint1,yint2,yint3,p1,p2,p3,p4
>
>
>
> ! If point at border of grid -> small displacement into grid
> !***********************************************************
>
> if (xt.ge.real(nx-1)) xt=real(nx-1)-0.00001
> if (yt.ge.real(ny-1)) yt=real(ny-1)-0.00001
>
>
>
> !**********************************************************************
> ! 1.) Bilinear horizontal interpolation
> ! This has to be done separately for 2 fields (Temporal)
> !*******************************************************
>
> ! Determine the lower left corner and its distance to the current position
> !*************************************************************************
>
> ix=int(xt)
> jy=int(yt)
> ixp=ix+1
> jyp=jy+1
> 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
>
>
> ! Loop over 2 time steps
> !***********************
>
> do m=1,2
> indexh=memind(m)
>
> y1(m)=p1*yy1(ix ,jy ,level,indexh) &
> + p2*yy1(ixp,jy ,level,indexh) &
> + p3*yy1(ix ,jyp,level,indexh) &
> + p4*yy1(ixp,jyp,level,indexh)
> y2(m)=p1*yy2(ix ,jy ,level,indexh) &
> + p2*yy2(ixp,jy ,level,indexh) &
> + p3*yy2(ix ,jyp,level,indexh) &
> + p4*yy2(ixp,jyp,level,indexh)
> y3(m)=p1*yy3(ix ,jy ,level,indexh) &
> + p2*yy3(ixp,jy ,level,indexh) &
> + p3*yy3(ix ,jyp,level,indexh) &
> + p4*yy3(ixp,jyp,level,indexh)
> end do
>
>
> !************************************
> ! 2.) Temporal interpolation (linear)
> !************************************
>
> dt1=real(itime-itime1)
> dt2=real(itime2-itime)
> dt=dt1+dt2
>
> yint1=(y1(1)*dt2+y1(2)*dt1)/dt
> yint2=(y2(1)*dt2+y2(2)*dt1)/dt
> yint3=(y3(1)*dt2+y3(2)*dt1)/dt
>
>
> end subroutine interpol_rain
interpol_rain_nests.f90
----------------------------------------------
1,152c1,152
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_rain_nests(yy1,yy2,yy3,nxmaxn,nymaxn,nzmax, &
< maxnests,ngrid,nxn,nyn,memind,xt,yt,level,itime1,itime2,itime, &
< yint1,yint2,yint3)
< ! i i i i i i
< ! i i i i i i i i i i i
< ! o o o
< !****************************************************************************
< ! *
< ! Interpolation of meteorological fields on 2-d model layers for nested *
< ! grids. This routine is related to levlin3interpol.f for the mother domain*
< ! *
< ! In horizontal direction bilinear interpolation interpolation is used. *
< ! Temporally a linear interpolation is used. *
< ! Three fields are interpolated at the same time. *
< ! *
< ! This is a special version of levlininterpol to save CPU time. *
< ! *
< ! 1 first time *
< ! 2 second time *
< ! *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 15 March 2000 *
< ! *
< !****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! dt1,dt2 time differences between fields and current position *
< ! dz1,dz2 z distance between levels and current position *
< ! height(nzmax) heights of the model levels *
< ! indexh help variable *
< ! indz the level closest to the current trajectory position *
< ! indzh help variable *
< ! itime current time *
< ! itime1 time of the first wind field *
< ! itime2 time of the second wind field *
< ! ix,jy x,y coordinates of lower left subgrid point *
< ! level level at which interpolation shall be done *
< ! memind(3) points to the places of the wind fields *
< ! nx,ny actual field dimensions in x,y and z direction *
< ! nxmax,nymax,nzmax maximum field dimensions in x,y and z direction *
< ! xt current x coordinate *
< ! yint the final interpolated value *
< ! yt current y coordinate *
< ! yy(0:nxmax,0:nymax,nzmax,3) meteorological field used for interpolation *
< ! zt current z coordinate *
< ! *
< !****************************************************************************
<
< implicit none
<
< integer :: maxnests,ngrid
< integer :: nxn(maxnests),nyn(maxnests),nxmaxn,nymaxn,nzmax,memind(2)
< integer :: m,ix,jy,ixp,jyp,itime,itime1,itime2,level,indexh
< real :: yy1(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: yy2(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: yy3(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
< real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2)
< real :: xt,yt,yint1,yint2,yint3,p1,p2,p3,p4
<
<
<
< ! If point at border of grid -> small displacement into grid
< !***********************************************************
<
< if (xt.ge.(real(nxn(ngrid)-1)-0.0001)) &
< xt=real(nxn(ngrid)-1)-0.0001
< if (yt.ge.(real(nyn(ngrid)-1)-0.0001)) &
< yt=real(nyn(ngrid)-1)-0.0001
<
<
<
< !**********************************************************************
< ! 1.) Bilinear horizontal interpolation
< ! This has to be done separately for 2 fields (Temporal)
< !*******************************************************
<
< ! Determine the lower left corner and its distance to the current position
< !*************************************************************************
<
< ix=int(xt)
< jy=int(yt)
< ixp=ix+1
< jyp=jy+1
< 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
<
<
< ! Loop over 2 time steps
< !***********************
<
< do m=1,2
< indexh=memind(m)
<
< y1(m)=p1*yy1(ix ,jy ,level,indexh,ngrid) &
< + p2*yy1(ixp,jy ,level,indexh,ngrid) &
< + p3*yy1(ix ,jyp,level,indexh,ngrid) &
< + p4*yy1(ixp,jyp,level,indexh,ngrid)
< y2(m)=p1*yy2(ix ,jy ,level,indexh,ngrid) &
< + p2*yy2(ixp,jy ,level,indexh,ngrid) &
< + p3*yy2(ix ,jyp,level,indexh,ngrid) &
< + p4*yy2(ixp,jyp,level,indexh,ngrid)
< y3(m)=p1*yy3(ix ,jy ,level,indexh,ngrid) &
< + p2*yy3(ixp,jy ,level,indexh,ngrid) &
< + p3*yy3(ix ,jyp,level,indexh,ngrid) &
< + p4*yy3(ixp,jyp,level,indexh,ngrid)
< end do
<
<
< !************************************
< ! 2.) Temporal interpolation (linear)
< !************************************
<
< dt1=real(itime-itime1)
< dt2=real(itime2-itime)
< dt=dt1+dt2
<
< yint1=(y1(1)*dt2+y1(2)*dt1)/dt
< yint2=(y2(1)*dt2+y2(2)*dt1)/dt
< yint3=(y3(1)*dt2+y3(2)*dt1)/dt
<
<
< end subroutine interpol_rain_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_rain_nests(yy1,yy2,yy3,nxmaxn,nymaxn,nzmax, &
> maxnests,ngrid,nxn,nyn,memind,xt,yt,level,itime1,itime2,itime, &
> yint1,yint2,yint3)
> ! i i i i i i
> ! i i i i i i i i i i i
> ! o o o
> !****************************************************************************
> ! *
> ! Interpolation of meteorological fields on 2-d model layers for nested *
> ! grids. This routine is related to levlin3interpol.f for the mother domain*
> ! *
> ! In horizontal direction bilinear interpolation interpolation is used. *
> ! Temporally a linear interpolation is used. *
> ! Three fields are interpolated at the same time. *
> ! *
> ! This is a special version of levlininterpol to save CPU time. *
> ! *
> ! 1 first time *
> ! 2 second time *
> ! *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 15 March 2000 *
> ! *
> !****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! dt1,dt2 time differences between fields and current position *
> ! dz1,dz2 z distance between levels and current position *
> ! height(nzmax) heights of the model levels *
> ! indexh help variable *
> ! indz the level closest to the current trajectory position *
> ! indzh help variable *
> ! itime current time *
> ! itime1 time of the first wind field *
> ! itime2 time of the second wind field *
> ! ix,jy x,y coordinates of lower left subgrid point *
> ! level level at which interpolation shall be done *
> ! memind(3) points to the places of the wind fields *
> ! nx,ny actual field dimensions in x,y and z direction *
> ! nxmax,nymax,nzmax maximum field dimensions in x,y and z direction *
> ! xt current x coordinate *
> ! yint the final interpolated value *
> ! yt current y coordinate *
> ! yy(0:nxmax,0:nymax,nzmax,3) meteorological field used for interpolation *
> ! zt current z coordinate *
> ! *
> !****************************************************************************
>
> implicit none
>
> integer :: maxnests,ngrid
> integer :: nxn(maxnests),nyn(maxnests),nxmaxn,nymaxn,nzmax,memind(2)
> integer :: m,ix,jy,ixp,jyp,itime,itime1,itime2,level,indexh
> real :: yy1(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: yy2(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: yy3(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests)
> real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2)
> real :: xt,yt,yint1,yint2,yint3,p1,p2,p3,p4
>
>
>
> ! If point at border of grid -> small displacement into grid
> !***********************************************************
>
> if (xt.ge.(real(nxn(ngrid)-1)-0.0001)) &
> xt=real(nxn(ngrid)-1)-0.0001
> if (yt.ge.(real(nyn(ngrid)-1)-0.0001)) &
> yt=real(nyn(ngrid)-1)-0.0001
>
>
>
> !**********************************************************************
> ! 1.) Bilinear horizontal interpolation
> ! This has to be done separately for 2 fields (Temporal)
> !*******************************************************
>
> ! Determine the lower left corner and its distance to the current position
> !*************************************************************************
>
> ix=int(xt)
> jy=int(yt)
> ixp=ix+1
> jyp=jy+1
> 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
>
>
> ! Loop over 2 time steps
> !***********************
>
> do m=1,2
> indexh=memind(m)
>
> y1(m)=p1*yy1(ix ,jy ,level,indexh,ngrid) &
> + p2*yy1(ixp,jy ,level,indexh,ngrid) &
> + p3*yy1(ix ,jyp,level,indexh,ngrid) &
> + p4*yy1(ixp,jyp,level,indexh,ngrid)
> y2(m)=p1*yy2(ix ,jy ,level,indexh,ngrid) &
> + p2*yy2(ixp,jy ,level,indexh,ngrid) &
> + p3*yy2(ix ,jyp,level,indexh,ngrid) &
> + p4*yy2(ixp,jyp,level,indexh,ngrid)
> y3(m)=p1*yy3(ix ,jy ,level,indexh,ngrid) &
> + p2*yy3(ixp,jy ,level,indexh,ngrid) &
> + p3*yy3(ix ,jyp,level,indexh,ngrid) &
> + p4*yy3(ixp,jyp,level,indexh,ngrid)
> end do
>
>
> !************************************
> ! 2.) Temporal interpolation (linear)
> !************************************
>
> dt1=real(itime-itime1)
> dt2=real(itime2-itime)
> dt=dt1+dt2
>
> yint1=(y1(1)*dt2+y1(2)*dt1)/dt
> yint2=(y2(1)*dt2+y2(2)*dt1)/dt
> yint3=(y3(1)*dt2+y3(2)*dt1)/dt
>
>
> end subroutine interpol_rain_nests
interpol_vdep.f90
----------------------------------------------
1,75c1,75
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_vdep(level,vdepo)
< ! i o
< !****************************************************************************
< ! *
< ! Interpolation of the deposition velocity on 2-d model layer. *
< ! In horizontal direction bilinear interpolation interpolation is used. *
< ! Temporally a linear interpolation is used. *
< ! *
< ! 1 first time *
< ! 2 second time *
< ! *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 30 May 1994 *
< ! *
< !****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! level number of species for which interpolation is done *
< ! *
< !****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
<
< implicit none
<
< integer :: level,indexh,m
< real :: y(2),vdepo
<
< ! a) Bilinear horizontal interpolation
<
< do m=1,2
< indexh=memind(m)
<
< y(m)=p1*vdep(ix ,jy ,level,indexh) &
< +p2*vdep(ixp,jy ,level,indexh) &
< +p3*vdep(ix ,jyp,level,indexh) &
< +p4*vdep(ixp,jyp,level,indexh)
< end do
<
<
<
< ! b) Temporal interpolation
<
< vdepo=(y(1)*dt2+y(2)*dt1)*dtt
<
< depoindicator(level)=.false.
<
<
< end subroutine interpol_vdep
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_vdep(level,vdepo)
> ! i o
> !****************************************************************************
> ! *
> ! Interpolation of the deposition velocity on 2-d model layer. *
> ! In horizontal direction bilinear interpolation interpolation is used. *
> ! Temporally a linear interpolation is used. *
> ! *
> ! 1 first time *
> ! 2 second time *
> ! *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 30 May 1994 *
> ! *
> !****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! level number of species for which interpolation is done *
> ! *
> !****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
>
> implicit none
>
> integer :: level,indexh,m
> real :: y(2),vdepo
>
> ! a) Bilinear horizontal interpolation
>
> do m=1,2
> indexh=memind(m)
>
> y(m)=p1*vdep(ix ,jy ,level,indexh) &
> +p2*vdep(ixp,jy ,level,indexh) &
> +p3*vdep(ix ,jyp,level,indexh) &
> +p4*vdep(ixp,jyp,level,indexh)
> end do
>
>
>
> ! b) Temporal interpolation
>
> vdepo=(y(1)*dt2+y(2)*dt1)*dtt
>
> depoindicator(level)=.false.
>
>
> end subroutine interpol_vdep
interpol_vdep_nests.f90
----------------------------------------------
1,74c1,74
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_vdep_nests(level,vdepo)
< ! i o
< !****************************************************************************
< ! *
< ! Interpolation of the deposition velocity on 2-d model layer. *
< ! In horizontal direction bilinear interpolation interpolation is used. *
< ! Temporally a linear interpolation is used. *
< ! *
< ! 1 first time *
< ! 2 second time *
< ! *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 30 May 1994 *
< ! *
< !****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! level number of species for which interpolation is done *
< ! *
< !****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
<
< implicit none
<
< integer :: level,indexh,m
< real :: y(2),vdepo
<
< ! a) Bilinear horizontal interpolation
<
< do m=1,2
< indexh=memind(m)
<
< y(m)=p1*vdepn(ix ,jy ,level,indexh,ngrid) &
< +p2*vdepn(ixp,jy ,level,indexh,ngrid) &
< +p3*vdepn(ix ,jyp,level,indexh,ngrid) &
< +p4*vdepn(ixp,jyp,level,indexh,ngrid)
< end do
<
<
< ! b) Temporal interpolation
<
< vdepo=(y(1)*dt2+y(2)*dt1)*dtt
<
< depoindicator(level)=.false.
<
<
< end subroutine interpol_vdep_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_vdep_nests(level,vdepo)
> ! i o
> !****************************************************************************
> ! *
> ! Interpolation of the deposition velocity on 2-d model layer. *
> ! In horizontal direction bilinear interpolation interpolation is used. *
> ! Temporally a linear interpolation is used. *
> ! *
> ! 1 first time *
> ! 2 second time *
> ! *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 30 May 1994 *
> ! *
> !****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! level number of species for which interpolation is done *
> ! *
> !****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
>
> implicit none
>
> integer :: level,indexh,m
> real :: y(2),vdepo
>
> ! a) Bilinear horizontal interpolation
>
> do m=1,2
> indexh=memind(m)
>
> y(m)=p1*vdepn(ix ,jy ,level,indexh,ngrid) &
> +p2*vdepn(ixp,jy ,level,indexh,ngrid) &
> +p3*vdepn(ix ,jyp,level,indexh,ngrid) &
> +p4*vdepn(ixp,jyp,level,indexh,ngrid)
> end do
>
>
> ! b) Temporal interpolation
>
> vdepo=(y(1)*dt2+y(2)*dt1)*dtt
>
> depoindicator(level)=.false.
>
>
> end subroutine interpol_vdep_nests
interpol_wind.f90
----------------------------------------------
1,234c1,234
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_wind(itime,xt,yt,zt)
< ! i i i i
< !*****************************************************************************
< ! *
< ! This subroutine interpolates the wind data to current trajectory position.*
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 December 1997 *
< ! *
< ! Revision March 2005 by AST : all output variables in common block cal- *
< ! culation of standard deviation done in this *
< ! routine rather than subroutine call in order *
< ! to save computation time *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! u,v,w wind components *
< ! itime [s] current temporal position *
< ! memtime(3) [s] times of the wind fields in memory *
< ! xt,yt,zt coordinates position for which wind data shall be *
< ! calculated *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
<
< implicit none
<
< integer :: itime
< real :: xt,yt,zt
<
< ! Auxiliary variables needed for interpolation
< real :: dz1,dz2,dz
< real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
< real :: usl,vsl,wsl,usq,vsq,wsq,xaux
< integer :: i,m,n,indexh,indzh
< real,parameter :: eps=1.0e-30
<
<
< !********************************************
< ! Multilinear interpolation in time and space
< !********************************************
<
< ! 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)
<
< ! Determine the level below the current position for u,v
< !*******************************************************
<
< do i=2,nz
< if (height(i).gt.zt) then
< indz=i-1
< goto 6
< endif
< end do
< 6 continue
<
<
< ! Vertical distance to the level below and above current position
< !****************************************************************
<
< dz=1./(height(indz+1)-height(indz))
< dz1=(zt-height(indz))*dz
< dz2=(height(indz+1)-zt)*dz
<
< !**********************************************************************
< ! 1.) Bilinear horizontal interpolation
< ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
< !**********************************************************************
<
< ! Loop over 2 time steps and 2 levels
< !************************************
<
< usl=0.
< vsl=0.
< wsl=0.
< usq=0.
< vsq=0.
< wsq=0.
< do m=1,2
< indexh=memind(m)
< do n=1,2
< indzh=indz+n-1
<
< if (ngrid.lt.0) then
< u1(n)=p1*uupol(ix ,jy ,indzh,indexh) &
< +p2*uupol(ixp,jy ,indzh,indexh) &
< +p3*uupol(ix ,jyp,indzh,indexh) &
< +p4*uupol(ixp,jyp,indzh,indexh)
< v1(n)=p1*vvpol(ix ,jy ,indzh,indexh) &
< +p2*vvpol(ixp,jy ,indzh,indexh) &
< +p3*vvpol(ix ,jyp,indzh,indexh) &
< +p4*vvpol(ixp,jyp,indzh,indexh)
< usl=usl+uupol(ix ,jy ,indzh,indexh)+ &
< uupol(ixp,jy ,indzh,indexh) &
< +uupol(ix ,jyp,indzh,indexh)+uupol(ixp,jyp,indzh,indexh)
< vsl=vsl+vvpol(ix ,jy ,indzh,indexh)+ &
< vvpol(ixp,jy ,indzh,indexh) &
< +vvpol(ix ,jyp,indzh,indexh)+vvpol(ixp,jyp,indzh,indexh)
<
< usq=usq+uupol(ix ,jy ,indzh,indexh)* &
< uupol(ix ,jy ,indzh,indexh)+ &
< uupol(ixp,jy ,indzh,indexh)*uupol(ixp,jy ,indzh,indexh)+ &
< uupol(ix ,jyp,indzh,indexh)*uupol(ix ,jyp,indzh,indexh)+ &
< uupol(ixp,jyp,indzh,indexh)*uupol(ixp,jyp,indzh,indexh)
< vsq=vsq+vvpol(ix ,jy ,indzh,indexh)* &
< vvpol(ix ,jy ,indzh,indexh)+ &
< vvpol(ixp,jy ,indzh,indexh)*vvpol(ixp,jy ,indzh,indexh)+ &
< vvpol(ix ,jyp,indzh,indexh)*vvpol(ix ,jyp,indzh,indexh)+ &
< vvpol(ixp,jyp,indzh,indexh)*vvpol(ixp,jyp,indzh,indexh)
< else
< u1(n)=p1*uu(ix ,jy ,indzh,indexh) &
< +p2*uu(ixp,jy ,indzh,indexh) &
< +p3*uu(ix ,jyp,indzh,indexh) &
< +p4*uu(ixp,jyp,indzh,indexh)
< v1(n)=p1*vv(ix ,jy ,indzh,indexh) &
< +p2*vv(ixp,jy ,indzh,indexh) &
< +p3*vv(ix ,jyp,indzh,indexh) &
< +p4*vv(ixp,jyp,indzh,indexh)
< usl=usl+uu(ix ,jy ,indzh,indexh)+uu(ixp,jy ,indzh,indexh) &
< +uu(ix ,jyp,indzh,indexh)+uu(ixp,jyp,indzh,indexh)
< vsl=vsl+vv(ix ,jy ,indzh,indexh)+vv(ixp,jy ,indzh,indexh) &
< +vv(ix ,jyp,indzh,indexh)+vv(ixp,jyp,indzh,indexh)
<
< usq=usq+uu(ix ,jy ,indzh,indexh)*uu(ix ,jy ,indzh,indexh)+ &
< uu(ixp,jy ,indzh,indexh)*uu(ixp,jy ,indzh,indexh)+ &
< uu(ix ,jyp,indzh,indexh)*uu(ix ,jyp,indzh,indexh)+ &
< uu(ixp,jyp,indzh,indexh)*uu(ixp,jyp,indzh,indexh)
< vsq=vsq+vv(ix ,jy ,indzh,indexh)*vv(ix ,jy ,indzh,indexh)+ &
< vv(ixp,jy ,indzh,indexh)*vv(ixp,jy ,indzh,indexh)+ &
< vv(ix ,jyp,indzh,indexh)*vv(ix ,jyp,indzh,indexh)+ &
< vv(ixp,jyp,indzh,indexh)*vv(ixp,jyp,indzh,indexh)
< endif
< w1(n)=p1*ww(ix ,jy ,indzh,indexh) &
< +p2*ww(ixp,jy ,indzh,indexh) &
< +p3*ww(ix ,jyp,indzh,indexh) &
< +p4*ww(ixp,jyp,indzh,indexh)
< wsl=wsl+ww(ix ,jy ,indzh,indexh)+ww(ixp,jy ,indzh,indexh) &
< +ww(ix ,jyp,indzh,indexh)+ww(ixp,jyp,indzh,indexh)
< wsq=wsq+ww(ix ,jy ,indzh,indexh)*ww(ix ,jy ,indzh,indexh)+ &
< ww(ixp,jy ,indzh,indexh)*ww(ixp,jy ,indzh,indexh)+ &
< ww(ix ,jyp,indzh,indexh)*ww(ix ,jyp,indzh,indexh)+ &
< ww(ixp,jyp,indzh,indexh)*ww(ixp,jyp,indzh,indexh)
< end do
<
<
< !**********************************
< ! 2.) Linear vertical interpolation
< !**********************************
<
< uh(m)=dz2*u1(1)+dz1*u1(2)
< vh(m)=dz2*v1(1)+dz1*v1(2)
< wh(m)=dz2*w1(1)+dz1*w1(2)
< end do
<
<
< !************************************
< ! 3.) Temporal interpolation (linear)
< !************************************
<
< u=(uh(1)*dt2+uh(2)*dt1)*dtt
< v=(vh(1)*dt2+vh(2)*dt1)*dtt
< w=(wh(1)*dt2+wh(2)*dt1)*dtt
<
<
< ! Compute standard deviations
< !****************************
<
< xaux=usq-usl*usl/16.
< if (xaux.lt.eps) then
< usig=0.
< else
< usig=sqrt(xaux/15.)
< endif
<
< xaux=vsq-vsl*vsl/16.
< if (xaux.lt.eps) then
< vsig=0.
< else
< vsig=sqrt(xaux/15.)
< endif
<
<
< xaux=wsq-wsl*wsl/16.
< if (xaux.lt.eps) then
< wsig=0.
< else
< wsig=sqrt(xaux/15.)
< endif
<
< end subroutine interpol_wind
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_wind(itime,xt,yt,zt)
> ! i i i i
> !*****************************************************************************
> ! *
> ! This subroutine interpolates the wind data to current trajectory position.*
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 December 1997 *
> ! *
> ! Revision March 2005 by AST : all output variables in common block cal- *
> ! culation of standard deviation done in this *
> ! routine rather than subroutine call in order *
> ! to save computation time *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! u,v,w wind components *
> ! itime [s] current temporal position *
> ! memtime(3) [s] times of the wind fields in memory *
> ! xt,yt,zt coordinates position for which wind data shall be *
> ! calculated *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
>
> implicit none
>
> integer :: itime
> real :: xt,yt,zt
>
> ! Auxiliary variables needed for interpolation
> real :: dz1,dz2,dz
> real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
> real :: usl,vsl,wsl,usq,vsq,wsq,xaux
> integer :: i,m,n,indexh,indzh
> real,parameter :: eps=1.0e-30
>
>
> !********************************************
> ! Multilinear interpolation in time and space
> !********************************************
>
> ! 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)
>
> ! Determine the level below the current position for u,v
> !*******************************************************
>
> do i=2,nz
> if (height(i).gt.zt) then
> indz=i-1
> goto 6
> endif
> end do
> 6 continue
>
>
> ! Vertical distance to the level below and above current position
> !****************************************************************
>
> dz=1./(height(indz+1)-height(indz))
> dz1=(zt-height(indz))*dz
> dz2=(height(indz+1)-zt)*dz
>
> !**********************************************************************
> ! 1.) Bilinear horizontal interpolation
> ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
> !**********************************************************************
>
> ! Loop over 2 time steps and 2 levels
> !************************************
>
> usl=0.
> vsl=0.
> wsl=0.
> usq=0.
> vsq=0.
> wsq=0.
> do m=1,2
> indexh=memind(m)
> do n=1,2
> indzh=indz+n-1
>
> if (ngrid.lt.0) then
> u1(n)=p1*uupol(ix ,jy ,indzh,indexh) &
> +p2*uupol(ixp,jy ,indzh,indexh) &
> +p3*uupol(ix ,jyp,indzh,indexh) &
> +p4*uupol(ixp,jyp,indzh,indexh)
> v1(n)=p1*vvpol(ix ,jy ,indzh,indexh) &
> +p2*vvpol(ixp,jy ,indzh,indexh) &
> +p3*vvpol(ix ,jyp,indzh,indexh) &
> +p4*vvpol(ixp,jyp,indzh,indexh)
> usl=usl+uupol(ix ,jy ,indzh,indexh)+ &
> uupol(ixp,jy ,indzh,indexh) &
> +uupol(ix ,jyp,indzh,indexh)+uupol(ixp,jyp,indzh,indexh)
> vsl=vsl+vvpol(ix ,jy ,indzh,indexh)+ &
> vvpol(ixp,jy ,indzh,indexh) &
> +vvpol(ix ,jyp,indzh,indexh)+vvpol(ixp,jyp,indzh,indexh)
>
> usq=usq+uupol(ix ,jy ,indzh,indexh)* &
> uupol(ix ,jy ,indzh,indexh)+ &
> uupol(ixp,jy ,indzh,indexh)*uupol(ixp,jy ,indzh,indexh)+ &
> uupol(ix ,jyp,indzh,indexh)*uupol(ix ,jyp,indzh,indexh)+ &
> uupol(ixp,jyp,indzh,indexh)*uupol(ixp,jyp,indzh,indexh)
> vsq=vsq+vvpol(ix ,jy ,indzh,indexh)* &
> vvpol(ix ,jy ,indzh,indexh)+ &
> vvpol(ixp,jy ,indzh,indexh)*vvpol(ixp,jy ,indzh,indexh)+ &
> vvpol(ix ,jyp,indzh,indexh)*vvpol(ix ,jyp,indzh,indexh)+ &
> vvpol(ixp,jyp,indzh,indexh)*vvpol(ixp,jyp,indzh,indexh)
> else
> u1(n)=p1*uu(ix ,jy ,indzh,indexh) &
> +p2*uu(ixp,jy ,indzh,indexh) &
> +p3*uu(ix ,jyp,indzh,indexh) &
> +p4*uu(ixp,jyp,indzh,indexh)
> v1(n)=p1*vv(ix ,jy ,indzh,indexh) &
> +p2*vv(ixp,jy ,indzh,indexh) &
> +p3*vv(ix ,jyp,indzh,indexh) &
> +p4*vv(ixp,jyp,indzh,indexh)
> usl=usl+uu(ix ,jy ,indzh,indexh)+uu(ixp,jy ,indzh,indexh) &
> +uu(ix ,jyp,indzh,indexh)+uu(ixp,jyp,indzh,indexh)
> vsl=vsl+vv(ix ,jy ,indzh,indexh)+vv(ixp,jy ,indzh,indexh) &
> +vv(ix ,jyp,indzh,indexh)+vv(ixp,jyp,indzh,indexh)
>
> usq=usq+uu(ix ,jy ,indzh,indexh)*uu(ix ,jy ,indzh,indexh)+ &
> uu(ixp,jy ,indzh,indexh)*uu(ixp,jy ,indzh,indexh)+ &
> uu(ix ,jyp,indzh,indexh)*uu(ix ,jyp,indzh,indexh)+ &
> uu(ixp,jyp,indzh,indexh)*uu(ixp,jyp,indzh,indexh)
> vsq=vsq+vv(ix ,jy ,indzh,indexh)*vv(ix ,jy ,indzh,indexh)+ &
> vv(ixp,jy ,indzh,indexh)*vv(ixp,jy ,indzh,indexh)+ &
> vv(ix ,jyp,indzh,indexh)*vv(ix ,jyp,indzh,indexh)+ &
> vv(ixp,jyp,indzh,indexh)*vv(ixp,jyp,indzh,indexh)
> endif
> w1(n)=p1*ww(ix ,jy ,indzh,indexh) &
> +p2*ww(ixp,jy ,indzh,indexh) &
> +p3*ww(ix ,jyp,indzh,indexh) &
> +p4*ww(ixp,jyp,indzh,indexh)
> wsl=wsl+ww(ix ,jy ,indzh,indexh)+ww(ixp,jy ,indzh,indexh) &
> +ww(ix ,jyp,indzh,indexh)+ww(ixp,jyp,indzh,indexh)
> wsq=wsq+ww(ix ,jy ,indzh,indexh)*ww(ix ,jy ,indzh,indexh)+ &
> ww(ixp,jy ,indzh,indexh)*ww(ixp,jy ,indzh,indexh)+ &
> ww(ix ,jyp,indzh,indexh)*ww(ix ,jyp,indzh,indexh)+ &
> ww(ixp,jyp,indzh,indexh)*ww(ixp,jyp,indzh,indexh)
> end do
>
>
> !**********************************
> ! 2.) Linear vertical interpolation
> !**********************************
>
> uh(m)=dz2*u1(1)+dz1*u1(2)
> vh(m)=dz2*v1(1)+dz1*v1(2)
> wh(m)=dz2*w1(1)+dz1*w1(2)
> end do
>
>
> !************************************
> ! 3.) Temporal interpolation (linear)
> !************************************
>
> u=(uh(1)*dt2+uh(2)*dt1)*dtt
> v=(vh(1)*dt2+vh(2)*dt1)*dtt
> w=(wh(1)*dt2+wh(2)*dt1)*dtt
>
>
> ! Compute standard deviations
> !****************************
>
> xaux=usq-usl*usl/16.
> if (xaux.lt.eps) then
> usig=0.
> else
> usig=sqrt(xaux/15.)
> endif
>
> xaux=vsq-vsl*vsl/16.
> if (xaux.lt.eps) then
> vsig=0.
> else
> vsig=sqrt(xaux/15.)
> endif
>
>
> xaux=wsq-wsl*wsl/16.
> if (xaux.lt.eps) then
> wsig=0.
> else
> wsig=sqrt(xaux/15.)
> endif
>
> end subroutine interpol_wind
interpol_wind_nests.f90
----------------------------------------------
1,218c1,218
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_wind_nests(itime,xt,yt,zt)
< ! i i i i
< !*****************************************************************************
< ! *
< ! This subroutine interpolates the wind data to current trajectory position.*
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 December 1997 *
< ! 16 December 1997 *
< ! *
< ! Revision March 2005 by AST : all output variables in common block cal- *
< ! culation of standard deviation done in this *
< ! routine rather than subroutine call in order *
< ! to save computation time *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! u,v,w wind components *
< ! itime [s] current temporal position *
< ! memtime(3) [s] times of the wind fields in memory *
< ! xt,yt,zt coordinates position for which wind data shall be *
< ! calculated *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
<
< implicit none
<
< integer :: itime
< real :: xt,yt,zt
<
< ! Auxiliary variables needed for interpolation
< real :: dz1,dz2,dz
< real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
< real :: usl,vsl,wsl,usq,vsq,wsq,xaux
< integer :: i,m,n,indexh,indzh
< real,parameter :: eps=1.0e-30
<
<
< !********************************************
< ! Multilinear interpolation in time and space
< !********************************************
<
< ! 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)
<
< ! Determine the level below the current position for u,v
< !*******************************************************
<
< do i=2,nz
< if (height(i).gt.zt) then
< indz=i-1
< goto 6
< endif
< end do
< 6 continue
<
<
< ! Vertical distance to the level below and above current position
< !****************************************************************
<
< dz=1./(height(indz+1)-height(indz))
< dz1=(zt-height(indz))*dz
< dz2=(height(indz+1)-zt)*dz
<
<
< !**********************************************************************
< ! 1.) Bilinear horizontal interpolation
< ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
< !**********************************************************************
<
< ! Loop over 2 time steps and 2 levels
< !************************************
<
< usl=0.
< vsl=0.
< wsl=0.
< usq=0.
< vsq=0.
< wsq=0.
< do m=1,2
< indexh=memind(m)
< do n=1,2
< indzh=indz+n-1
<
< u1(n)=p1*uun(ix ,jy ,indzh,indexh,ngrid) &
< +p2*uun(ixp,jy ,indzh,indexh,ngrid) &
< +p3*uun(ix ,jyp,indzh,indexh,ngrid) &
< +p4*uun(ixp,jyp,indzh,indexh,ngrid)
< v1(n)=p1*vvn(ix ,jy ,indzh,indexh,ngrid) &
< +p2*vvn(ixp,jy ,indzh,indexh,ngrid) &
< +p3*vvn(ix ,jyp,indzh,indexh,ngrid) &
< +p4*vvn(ixp,jyp,indzh,indexh,ngrid)
< w1(n)=p1*wwn(ix ,jy ,indzh,indexh,ngrid) &
< +p2*wwn(ixp,jy ,indzh,indexh,ngrid) &
< +p3*wwn(ix ,jyp,indzh,indexh,ngrid) &
< +p4*wwn(ixp,jyp,indzh,indexh,ngrid)
<
< usl=usl+uun(ix ,jy ,indzh,indexh,ngrid)+ &
< uun(ixp,jy ,indzh,indexh,ngrid) &
< +uun(ix ,jyp,indzh,indexh,ngrid)+ &
< uun(ixp,jyp,indzh,indexh,ngrid)
< vsl=vsl+vvn(ix ,jy ,indzh,indexh,ngrid)+ &
< vvn(ixp,jy ,indzh,indexh,ngrid) &
< +vvn(ix ,jyp,indzh,indexh,ngrid)+ &
< vvn(ixp,jyp,indzh,indexh,ngrid)
< wsl=wsl+wwn(ix ,jy ,indzh,indexh,ngrid)+ &
< wwn(ixp,jy ,indzh,indexh,ngrid) &
< +wwn(ix ,jyp,indzh,indexh,ngrid)+ &
< wwn(ixp,jyp,indzh,indexh,ngrid)
<
< usq=usq+uun(ix ,jy ,indzh,indexh,ngrid)* &
< uun(ix ,jy ,indzh,indexh,ngrid)+ &
< uun(ixp,jy ,indzh,indexh,ngrid)*uun(ixp,jy ,indzh,indexh,ngrid)+ &
< uun(ix ,jyp,indzh,indexh,ngrid)*uun(ix ,jyp,indzh,indexh,ngrid)+ &
< uun(ixp,jyp,indzh,indexh,ngrid)*uun(ixp,jyp,indzh,indexh,ngrid)
< vsq=vsq+vvn(ix ,jy ,indzh,indexh,ngrid)* &
< vvn(ix ,jy ,indzh,indexh,ngrid)+ &
< vvn(ixp,jy ,indzh,indexh,ngrid)*vvn(ixp,jy ,indzh,indexh,ngrid)+ &
< vvn(ix ,jyp,indzh,indexh,ngrid)*vvn(ix ,jyp,indzh,indexh,ngrid)+ &
< vvn(ixp,jyp,indzh,indexh,ngrid)*vvn(ixp,jyp,indzh,indexh,ngrid)
< wsq=wsq+wwn(ix ,jy ,indzh,indexh,ngrid)* &
< wwn(ix ,jy ,indzh,indexh,ngrid)+ &
< wwn(ixp,jy ,indzh,indexh,ngrid)*wwn(ixp,jy ,indzh,indexh,ngrid)+ &
< wwn(ix ,jyp,indzh,indexh,ngrid)*wwn(ix ,jyp,indzh,indexh,ngrid)+ &
< wwn(ixp,jyp,indzh,indexh,ngrid)*wwn(ixp,jyp,indzh,indexh,ngrid)
< end do
<
<
< !**********************************
< ! 2.) Linear vertical interpolation
< !**********************************
<
< uh(m)=dz2*u1(1)+dz1*u1(2)
< vh(m)=dz2*v1(1)+dz1*v1(2)
< wh(m)=dz2*w1(1)+dz1*w1(2)
< end do
<
<
< !************************************
< ! 3.) Temporal interpolation (linear)
< !************************************
<
< u=(uh(1)*dt2+uh(2)*dt1)*dtt
< v=(vh(1)*dt2+vh(2)*dt1)*dtt
< w=(wh(1)*dt2+wh(2)*dt1)*dtt
<
<
< ! Compute standard deviations
< !****************************
<
< xaux=usq-usl*usl/16.
< if (xaux.lt.eps) then
< usig=0.
< else
< usig=sqrt(xaux/15.)
< endif
<
< xaux=vsq-vsl*vsl/16.
< if (xaux.lt.eps) then
< vsig=0.
< else
< vsig=sqrt(xaux/15.)
< endif
<
<
< xaux=wsq-wsl*wsl/16.
< if (xaux.lt.eps) then
< wsig=0.
< else
< wsig=sqrt(xaux/15.)
< endif
<
< end subroutine interpol_wind_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_wind_nests(itime,xt,yt,zt)
> ! i i i i
> !*****************************************************************************
> ! *
> ! This subroutine interpolates the wind data to current trajectory position.*
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 December 1997 *
> ! 16 December 1997 *
> ! *
> ! Revision March 2005 by AST : all output variables in common block cal- *
> ! culation of standard deviation done in this *
> ! routine rather than subroutine call in order *
> ! to save computation time *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! u,v,w wind components *
> ! itime [s] current temporal position *
> ! memtime(3) [s] times of the wind fields in memory *
> ! xt,yt,zt coordinates position for which wind data shall be *
> ! calculated *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
>
> implicit none
>
> integer :: itime
> real :: xt,yt,zt
>
> ! Auxiliary variables needed for interpolation
> real :: dz1,dz2,dz
> real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
> real :: usl,vsl,wsl,usq,vsq,wsq,xaux
> integer :: i,m,n,indexh,indzh
> real,parameter :: eps=1.0e-30
>
>
> !********************************************
> ! Multilinear interpolation in time and space
> !********************************************
>
> ! 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)
>
> ! Determine the level below the current position for u,v
> !*******************************************************
>
> do i=2,nz
> if (height(i).gt.zt) then
> indz=i-1
> goto 6
> endif
> end do
> 6 continue
>
>
> ! Vertical distance to the level below and above current position
> !****************************************************************
>
> dz=1./(height(indz+1)-height(indz))
> dz1=(zt-height(indz))*dz
> dz2=(height(indz+1)-zt)*dz
>
>
> !**********************************************************************
> ! 1.) Bilinear horizontal interpolation
> ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
> !**********************************************************************
>
> ! Loop over 2 time steps and 2 levels
> !************************************
>
> usl=0.
> vsl=0.
> wsl=0.
> usq=0.
> vsq=0.
> wsq=0.
> do m=1,2
> indexh=memind(m)
> do n=1,2
> indzh=indz+n-1
>
> u1(n)=p1*uun(ix ,jy ,indzh,indexh,ngrid) &
> +p2*uun(ixp,jy ,indzh,indexh,ngrid) &
> +p3*uun(ix ,jyp,indzh,indexh,ngrid) &
> +p4*uun(ixp,jyp,indzh,indexh,ngrid)
> v1(n)=p1*vvn(ix ,jy ,indzh,indexh,ngrid) &
> +p2*vvn(ixp,jy ,indzh,indexh,ngrid) &
> +p3*vvn(ix ,jyp,indzh,indexh,ngrid) &
> +p4*vvn(ixp,jyp,indzh,indexh,ngrid)
> w1(n)=p1*wwn(ix ,jy ,indzh,indexh,ngrid) &
> +p2*wwn(ixp,jy ,indzh,indexh,ngrid) &
> +p3*wwn(ix ,jyp,indzh,indexh,ngrid) &
> +p4*wwn(ixp,jyp,indzh,indexh,ngrid)
>
> usl=usl+uun(ix ,jy ,indzh,indexh,ngrid)+ &
> uun(ixp,jy ,indzh,indexh,ngrid) &
> +uun(ix ,jyp,indzh,indexh,ngrid)+ &
> uun(ixp,jyp,indzh,indexh,ngrid)
> vsl=vsl+vvn(ix ,jy ,indzh,indexh,ngrid)+ &
> vvn(ixp,jy ,indzh,indexh,ngrid) &
> +vvn(ix ,jyp,indzh,indexh,ngrid)+ &
> vvn(ixp,jyp,indzh,indexh,ngrid)
> wsl=wsl+wwn(ix ,jy ,indzh,indexh,ngrid)+ &
> wwn(ixp,jy ,indzh,indexh,ngrid) &
> +wwn(ix ,jyp,indzh,indexh,ngrid)+ &
> wwn(ixp,jyp,indzh,indexh,ngrid)
>
> usq=usq+uun(ix ,jy ,indzh,indexh,ngrid)* &
> uun(ix ,jy ,indzh,indexh,ngrid)+ &
> uun(ixp,jy ,indzh,indexh,ngrid)*uun(ixp,jy ,indzh,indexh,ngrid)+ &
> uun(ix ,jyp,indzh,indexh,ngrid)*uun(ix ,jyp,indzh,indexh,ngrid)+ &
> uun(ixp,jyp,indzh,indexh,ngrid)*uun(ixp,jyp,indzh,indexh,ngrid)
> vsq=vsq+vvn(ix ,jy ,indzh,indexh,ngrid)* &
> vvn(ix ,jy ,indzh,indexh,ngrid)+ &
> vvn(ixp,jy ,indzh,indexh,ngrid)*vvn(ixp,jy ,indzh,indexh,ngrid)+ &
> vvn(ix ,jyp,indzh,indexh,ngrid)*vvn(ix ,jyp,indzh,indexh,ngrid)+ &
> vvn(ixp,jyp,indzh,indexh,ngrid)*vvn(ixp,jyp,indzh,indexh,ngrid)
> wsq=wsq+wwn(ix ,jy ,indzh,indexh,ngrid)* &
> wwn(ix ,jy ,indzh,indexh,ngrid)+ &
> wwn(ixp,jy ,indzh,indexh,ngrid)*wwn(ixp,jy ,indzh,indexh,ngrid)+ &
> wwn(ix ,jyp,indzh,indexh,ngrid)*wwn(ix ,jyp,indzh,indexh,ngrid)+ &
> wwn(ixp,jyp,indzh,indexh,ngrid)*wwn(ixp,jyp,indzh,indexh,ngrid)
> end do
>
>
> !**********************************
> ! 2.) Linear vertical interpolation
> !**********************************
>
> uh(m)=dz2*u1(1)+dz1*u1(2)
> vh(m)=dz2*v1(1)+dz1*v1(2)
> wh(m)=dz2*w1(1)+dz1*w1(2)
> end do
>
>
> !************************************
> ! 3.) Temporal interpolation (linear)
> !************************************
>
> u=(uh(1)*dt2+uh(2)*dt1)*dtt
> v=(vh(1)*dt2+vh(2)*dt1)*dtt
> w=(wh(1)*dt2+wh(2)*dt1)*dtt
>
>
> ! Compute standard deviations
> !****************************
>
> xaux=usq-usl*usl/16.
> if (xaux.lt.eps) then
> usig=0.
> else
> usig=sqrt(xaux/15.)
> endif
>
> xaux=vsq-vsl*vsl/16.
> if (xaux.lt.eps) then
> vsig=0.
> else
> vsig=sqrt(xaux/15.)
> endif
>
>
> xaux=wsq-wsl*wsl/16.
> if (xaux.lt.eps) then
> wsig=0.
> else
> wsig=sqrt(xaux/15.)
> endif
>
> end subroutine interpol_wind_nests
interpol_wind_short.f90
----------------------------------------------
1,160c1,160
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_wind_short(itime,xt,yt,zt)
< ! i i i i
< !*****************************************************************************
< ! *
< ! This subroutine interpolates the wind data to current trajectory position.*
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 December 1997 *
< ! *
< ! Revision March 2005 by AST : all output variables in common block *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! u,v,w wind components *
< ! itime [s] current temporal position *
< ! memtime(3) [s] times of the wind fields in memory *
< ! xt,yt,zt coordinates position for which wind data shall be *
< ! calculated *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
<
< implicit none
<
< integer :: itime
< real :: xt,yt,zt
<
< ! Auxiliary variables needed for interpolation
< real :: dz1,dz2,dz
< real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
< integer :: i,m,n,indexh,indzh
<
<
< !********************************************
< ! Multilinear interpolation in time and space
< !********************************************
<
< 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)
<
< ! Determine the level below the current position for u,v
< !*******************************************************
<
< do i=2,nz
< if (height(i).gt.zt) then
< indz=i-1
< goto 6
< endif
< end do
< 6 continue
<
<
< ! Vertical distance to the level below and above current position
< !****************************************************************
<
< dz=1./(height(indz+1)-height(indz))
< dz1=(zt-height(indz))*dz
< dz2=(height(indz+1)-zt)*dz
<
<
< !**********************************************************************
< ! 1.) Bilinear horizontal interpolation
< ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
< !**********************************************************************
<
< ! Loop over 2 time steps and 2 levels
< !************************************
<
< do m=1,2
< indexh=memind(m)
< do n=1,2
< indzh=indz+n-1
<
< if (ngrid.lt.0) then
< u1(n)=p1*uupol(ix ,jy ,indzh,indexh) &
< +p2*uupol(ixp,jy ,indzh,indexh) &
< +p3*uupol(ix ,jyp,indzh,indexh) &
< +p4*uupol(ixp,jyp,indzh,indexh)
< v1(n)=p1*vvpol(ix ,jy ,indzh,indexh) &
< +p2*vvpol(ixp,jy ,indzh,indexh) &
< +p3*vvpol(ix ,jyp,indzh,indexh) &
< +p4*vvpol(ixp,jyp,indzh,indexh)
< else
< u1(n)=p1*uu(ix ,jy ,indzh,indexh) &
< +p2*uu(ixp,jy ,indzh,indexh) &
< +p3*uu(ix ,jyp,indzh,indexh) &
< +p4*uu(ixp,jyp,indzh,indexh)
< v1(n)=p1*vv(ix ,jy ,indzh,indexh) &
< +p2*vv(ixp,jy ,indzh,indexh) &
< +p3*vv(ix ,jyp,indzh,indexh) &
< +p4*vv(ixp,jyp,indzh,indexh)
< endif
< w1(n)=p1*ww(ix ,jy ,indzh,indexh) &
< +p2*ww(ixp,jy ,indzh,indexh) &
< +p3*ww(ix ,jyp,indzh,indexh) &
< +p4*ww(ixp,jyp,indzh,indexh)
< end do
<
<
< !**********************************
< ! 2.) Linear vertical interpolation
< !**********************************
<
< uh(m)=dz2*u1(1)+dz1*u1(2)
< vh(m)=dz2*v1(1)+dz1*v1(2)
< wh(m)=dz2*w1(1)+dz1*w1(2)
< end do
<
<
<
< !************************************
< ! 3.) Temporal interpolation (linear)
< !************************************
<
< u=(uh(1)*dt2+uh(2)*dt1)*dtt
< v=(vh(1)*dt2+vh(2)*dt1)*dtt
< w=(wh(1)*dt2+wh(2)*dt1)*dtt
<
< end subroutine interpol_wind_short
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_wind_short(itime,xt,yt,zt)
> ! i i i i
> !*****************************************************************************
> ! *
> ! This subroutine interpolates the wind data to current trajectory position.*
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 December 1997 *
> ! *
> ! Revision March 2005 by AST : all output variables in common block *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! u,v,w wind components *
> ! itime [s] current temporal position *
> ! memtime(3) [s] times of the wind fields in memory *
> ! xt,yt,zt coordinates position for which wind data shall be *
> ! calculated *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
>
> implicit none
>
> integer :: itime
> real :: xt,yt,zt
>
> ! Auxiliary variables needed for interpolation
> real :: dz1,dz2,dz
> real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
> integer :: i,m,n,indexh,indzh
>
>
> !********************************************
> ! Multilinear interpolation in time and space
> !********************************************
>
> 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)
>
> ! Determine the level below the current position for u,v
> !*******************************************************
>
> do i=2,nz
> if (height(i).gt.zt) then
> indz=i-1
> goto 6
> endif
> end do
> 6 continue
>
>
> ! Vertical distance to the level below and above current position
> !****************************************************************
>
> dz=1./(height(indz+1)-height(indz))
> dz1=(zt-height(indz))*dz
> dz2=(height(indz+1)-zt)*dz
>
>
> !**********************************************************************
> ! 1.) Bilinear horizontal interpolation
> ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
> !**********************************************************************
>
> ! Loop over 2 time steps and 2 levels
> !************************************
>
> do m=1,2
> indexh=memind(m)
> do n=1,2
> indzh=indz+n-1
>
> if (ngrid.lt.0) then
> u1(n)=p1*uupol(ix ,jy ,indzh,indexh) &
> +p2*uupol(ixp,jy ,indzh,indexh) &
> +p3*uupol(ix ,jyp,indzh,indexh) &
> +p4*uupol(ixp,jyp,indzh,indexh)
> v1(n)=p1*vvpol(ix ,jy ,indzh,indexh) &
> +p2*vvpol(ixp,jy ,indzh,indexh) &
> +p3*vvpol(ix ,jyp,indzh,indexh) &
> +p4*vvpol(ixp,jyp,indzh,indexh)
> else
> u1(n)=p1*uu(ix ,jy ,indzh,indexh) &
> +p2*uu(ixp,jy ,indzh,indexh) &
> +p3*uu(ix ,jyp,indzh,indexh) &
> +p4*uu(ixp,jyp,indzh,indexh)
> v1(n)=p1*vv(ix ,jy ,indzh,indexh) &
> +p2*vv(ixp,jy ,indzh,indexh) &
> +p3*vv(ix ,jyp,indzh,indexh) &
> +p4*vv(ixp,jyp,indzh,indexh)
> endif
> w1(n)=p1*ww(ix ,jy ,indzh,indexh) &
> +p2*ww(ixp,jy ,indzh,indexh) &
> +p3*ww(ix ,jyp,indzh,indexh) &
> +p4*ww(ixp,jyp,indzh,indexh)
> end do
>
>
> !**********************************
> ! 2.) Linear vertical interpolation
> !**********************************
>
> uh(m)=dz2*u1(1)+dz1*u1(2)
> vh(m)=dz2*v1(1)+dz1*v1(2)
> wh(m)=dz2*w1(1)+dz1*w1(2)
> end do
>
>
>
> !************************************
> ! 3.) Temporal interpolation (linear)
> !************************************
>
> u=(uh(1)*dt2+uh(2)*dt1)*dtt
> v=(vh(1)*dt2+vh(2)*dt1)*dtt
> w=(wh(1)*dt2+wh(2)*dt1)*dtt
>
> end subroutine interpol_wind_short
interpol_wind_short_nests.f90
----------------------------------------------
1,149c1,149
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine interpol_wind_short_nests(itime,xt,yt,zt)
< ! i i i i
< !*****************************************************************************
< ! *
< ! This subroutine interpolates the wind data to current trajectory position.*
< ! *
< ! Author: A. Stohl *
< ! *
< ! 16 December 1997 *
< ! *
< ! Revision March 2005 by AST : all output variables in common block *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! u,v,w wind components *
< ! itime [s] current temporal position *
< ! memtime(3) [s] times of the wind fields in memory *
< ! xt,yt,zt coordinates position for which wind data shall be *
< ! calculated *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use interpol_mod
<
< implicit none
<
< integer :: itime
< real :: xt,yt,zt
<
< ! Auxiliary variables needed for interpolation
< real :: dz1,dz2,dz
< real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
< integer :: i,m,n,indexh,indzh
<
<
< !********************************************
< ! Multilinear interpolation in time and space
< !********************************************
<
< 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)
<
< ! Determine the level below the current position for u,v
< !*******************************************************
<
< do i=2,nz
< if (height(i).gt.zt) then
< indz=i-1
< goto 6
< endif
< end do
< 6 continue
<
<
< ! Vertical distance to the level below and above current position
< !****************************************************************
<
< dz=1./(height(indz+1)-height(indz))
< dz1=(zt-height(indz))*dz
< dz2=(height(indz+1)-zt)*dz
<
<
< !**********************************************************************
< ! 1.) Bilinear horizontal interpolation
< ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
< !**********************************************************************
<
< ! Loop over 2 time steps and 2 levels
< !************************************
<
< do m=1,2
< indexh=memind(m)
< do n=1,2
< indzh=indz+n-1
<
< u1(n)=p1*uun(ix ,jy ,indzh,indexh,ngrid) &
< +p2*uun(ixp,jy ,indzh,indexh,ngrid) &
< +p3*uun(ix ,jyp,indzh,indexh,ngrid) &
< +p4*uun(ixp,jyp,indzh,indexh,ngrid)
< v1(n)=p1*vvn(ix ,jy ,indzh,indexh,ngrid) &
< +p2*vvn(ixp,jy ,indzh,indexh,ngrid) &
< +p3*vvn(ix ,jyp,indzh,indexh,ngrid) &
< +p4*vvn(ixp,jyp,indzh,indexh,ngrid)
< w1(n)=p1*wwn(ix ,jy ,indzh,indexh,ngrid) &
< +p2*wwn(ixp,jy ,indzh,indexh,ngrid) &
< +p3*wwn(ix ,jyp,indzh,indexh,ngrid) &
< +p4*wwn(ixp,jyp,indzh,indexh,ngrid)
<
< end do
<
<
< !**********************************
< ! 2.) Linear vertical interpolation
< !**********************************
<
< uh(m)=dz2*u1(1)+dz1*u1(2)
< vh(m)=dz2*v1(1)+dz1*v1(2)
< wh(m)=dz2*w1(1)+dz1*w1(2)
< end do
<
<
< !************************************
< ! 3.) Temporal interpolation (linear)
< !************************************
<
< u=(uh(1)*dt2+uh(2)*dt1)*dtt
< v=(vh(1)*dt2+vh(2)*dt1)*dtt
< w=(wh(1)*dt2+wh(2)*dt1)*dtt
<
< end subroutine interpol_wind_short_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine interpol_wind_short_nests(itime,xt,yt,zt)
> ! i i i i
> !*****************************************************************************
> ! *
> ! This subroutine interpolates the wind data to current trajectory position.*
> ! *
> ! Author: A. Stohl *
> ! *
> ! 16 December 1997 *
> ! *
> ! Revision March 2005 by AST : all output variables in common block *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! u,v,w wind components *
> ! itime [s] current temporal position *
> ! memtime(3) [s] times of the wind fields in memory *
> ! xt,yt,zt coordinates position for which wind data shall be *
> ! calculated *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use interpol_mod
>
> implicit none
>
> integer :: itime
> real :: xt,yt,zt
>
> ! Auxiliary variables needed for interpolation
> real :: dz1,dz2,dz
> real :: u1(2),v1(2),w1(2),uh(2),vh(2),wh(2)
> integer :: i,m,n,indexh,indzh
>
>
> !********************************************
> ! Multilinear interpolation in time and space
> !********************************************
>
> 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)
>
> ! Determine the level below the current position for u,v
> !*******************************************************
>
> do i=2,nz
> if (height(i).gt.zt) then
> indz=i-1
> goto 6
> endif
> end do
> 6 continue
>
>
> ! Vertical distance to the level below and above current position
> !****************************************************************
>
> dz=1./(height(indz+1)-height(indz))
> dz1=(zt-height(indz))*dz
> dz2=(height(indz+1)-zt)*dz
>
>
> !**********************************************************************
> ! 1.) Bilinear horizontal interpolation
> ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3))
> !**********************************************************************
>
> ! Loop over 2 time steps and 2 levels
> !************************************
>
> do m=1,2
> indexh=memind(m)
> do n=1,2
> indzh=indz+n-1
>
> u1(n)=p1*uun(ix ,jy ,indzh,indexh,ngrid) &
> +p2*uun(ixp,jy ,indzh,indexh,ngrid) &
> +p3*uun(ix ,jyp,indzh,indexh,ngrid) &
> +p4*uun(ixp,jyp,indzh,indexh,ngrid)
> v1(n)=p1*vvn(ix ,jy ,indzh,indexh,ngrid) &
> +p2*vvn(ixp,jy ,indzh,indexh,ngrid) &
> +p3*vvn(ix ,jyp,indzh,indexh,ngrid) &
> +p4*vvn(ixp,jyp,indzh,indexh,ngrid)
> w1(n)=p1*wwn(ix ,jy ,indzh,indexh,ngrid) &
> +p2*wwn(ixp,jy ,indzh,indexh,ngrid) &
> +p3*wwn(ix ,jyp,indzh,indexh,ngrid) &
> +p4*wwn(ixp,jyp,indzh,indexh,ngrid)
>
> end do
>
>
> !**********************************
> ! 2.) Linear vertical interpolation
> !**********************************
>
> uh(m)=dz2*u1(1)+dz1*u1(2)
> vh(m)=dz2*v1(1)+dz1*v1(2)
> wh(m)=dz2*w1(1)+dz1*w1(2)
> end do
>
>
> !************************************
> ! 3.) Temporal interpolation (linear)
> !************************************
>
> u=(uh(1)*dt2+uh(2)*dt1)*dtt
> v=(vh(1)*dt2+vh(2)*dt1)*dtt
> w=(wh(1)*dt2+wh(2)*dt1)*dtt
>
> end subroutine interpol_wind_short_nests
juldate.f90
----------------------------------------------
1,85c1,85
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< function juldate(yyyymmdd,hhmiss)
<
< !*****************************************************************************
< ! *
< ! Calculates the Julian date *
< ! *
< ! AUTHOR: Andreas Stohl (15 October 1993) *
< ! *
< ! Variables: *
< ! dd Day *
< ! hh Hour *
< ! hhmiss Hour, minute + second *
< ! ja,jm,jy help variables *
< ! juldate Julian Date *
< ! julday help variable *
< ! mi Minute *
< ! mm Month *
< ! ss Second *
< ! yyyy Year *
< ! yyyymmddhh Date and Time *
< ! *
< ! Constants: *
< ! igreg help constant *
< ! *
< !*****************************************************************************
<
< use par_mod, only: dp
<
< implicit none
<
< integer :: yyyymmdd,yyyy,mm,dd,hh,mi,ss,hhmiss
< integer :: julday,jy,jm,ja
< integer,parameter :: igreg=15+31*(10+12*1582)
< real(kind=dp) :: juldate
<
< yyyy=yyyymmdd/10000
< mm=(yyyymmdd-10000*yyyy)/100
< dd=yyyymmdd-10000*yyyy-100*mm
< hh=hhmiss/10000
< mi=(hhmiss-10000*hh)/100
< ss=hhmiss-10000*hh-100*mi
<
< if (yyyy.eq.0) then
< print*, 'there is no year zero.'
< stop
< end if
< if (yyyy.lt.0) yyyy=yyyy+1
< if (mm.gt.2) then
< jy=yyyy
< jm=mm+1
< else
< jy=yyyy-1
< jm=mm+13
< endif
< julday=int(365.25*jy)+int(30.6001*jm)+dd+1720995
< if (dd+31*(mm+12*yyyy).ge.igreg) then
< ja=int(0.01*jy)
< julday=julday+2-ja+int(0.25*ja)
< endif
<
< juldate=real(julday,kind=dp) + real(hh,kind=dp)/24._dp + &
< real(mi,kind=dp)/1440._dp + real(ss,kind=dp)/86400._dp
<
< end function juldate
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> function juldate(yyyymmdd,hhmiss)
>
> !*****************************************************************************
> ! *
> ! Calculates the Julian date *
> ! *
> ! AUTHOR: Andreas Stohl (15 October 1993) *
> ! *
> ! Variables: *
> ! dd Day *
> ! hh Hour *
> ! hhmiss Hour, minute + second *
> ! ja,jm,jy help variables *
> ! juldate Julian Date *
> ! julday help variable *
> ! mi Minute *
> ! mm Month *
> ! ss Second *
> ! yyyy Year *
> ! yyyymmddhh Date and Time *
> ! *
> ! Constants: *
> ! igreg help constant *
> ! *
> !*****************************************************************************
>
> use par_mod, only: dp
>
> implicit none
>
> integer :: yyyymmdd,yyyy,mm,dd,hh,mi,ss,hhmiss
> integer :: julday,jy,jm,ja
> integer,parameter :: igreg=15+31*(10+12*1582)
> real(kind=dp) :: juldate
>
> yyyy=yyyymmdd/10000
> mm=(yyyymmdd-10000*yyyy)/100
> dd=yyyymmdd-10000*yyyy-100*mm
> hh=hhmiss/10000
> mi=(hhmiss-10000*hh)/100
> ss=hhmiss-10000*hh-100*mi
>
> if (yyyy.eq.0) then
> print*, 'there is no year zero.'
> stop
> end if
> if (yyyy.lt.0) yyyy=yyyy+1
> if (mm.gt.2) then
> jy=yyyy
> jm=mm+1
> else
> jy=yyyy-1
> jm=mm+13
> endif
> julday=int(365.25*jy)+int(30.6001*jm)+dd+1720995
> if (dd+31*(mm+12*yyyy).ge.igreg) then
> ja=int(0.01*jy)
> julday=julday+2-ja+int(0.25*ja)
> endif
>
> juldate=real(julday,kind=dp) + real(hh,kind=dp)/24._dp + &
> real(mi,kind=dp)/1440._dp + real(ss,kind=dp)/86400._dp
>
> end function juldate
mean.f90
----------------------------------------------
1,66c1,66
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine mean(x,xm,xs,number)
<
< !*****************************************************************************
< ! *
< ! This subroutine calculates mean and standard deviation of a given element.*
< ! *
< ! AUTHOR: Andreas Stohl, 25 January 1994 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! x(number) field of input data *
< ! xm mean *
< ! xs standard deviation *
< ! number number of elements of field x *
< ! *
< ! Constants: *
< ! eps tiny number *
< ! *
< !*****************************************************************************
<
< implicit none
<
< integer :: number,i
< real :: x(number),xm,xs,xl,xq,xaux
< real,parameter :: eps=1.0e-30
<
< xl=0.
< xq=0.
< do i=1,number
< xl=xl+x(i)
< xq=xq+x(i)*x(i)
< end do
<
< xm=xl/real(number)
<
< xaux=xq-xl*xl/real(number)
<
< if (xaux.lt.eps) then
< xs=0.
< else
< xs=sqrt(xaux/real(number-1))
< endif
<
< end subroutine mean
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine mean(x,xm,xs,number)
>
> !*****************************************************************************
> ! *
> ! This subroutine calculates mean and standard deviation of a given element.*
> ! *
> ! AUTHOR: Andreas Stohl, 25 January 1994 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! x(number) field of input data *
> ! xm mean *
> ! xs standard deviation *
> ! number number of elements of field x *
> ! *
> ! Constants: *
> ! eps tiny number *
> ! *
> !*****************************************************************************
>
> implicit none
>
> integer :: number,i
> real :: x(number),xm,xs,xl,xq,xaux
> real,parameter :: eps=1.0e-30
>
> xl=0.
> xq=0.
> do i=1,number
> xl=xl+x(i)
> xq=xq+x(i)*x(i)
> end do
>
> xm=xl/real(number)
>
> xaux=xq-xl*xl/real(number)
>
> if (xaux.lt.eps) then
> xs=0.
> else
> xs=sqrt(xaux/real(number-1))
> endif
>
> end subroutine mean
obukhov.f90
----------------------------------------------
1,78c1,78
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,akm,bkm)
<
< !********************************************************************
< ! *
< ! Author: G. WOTAWA *
< ! Date: 1994-06-27 *
< ! *
< ! Update: A. Stohl, 2000-09-25, avoid division by zero by *
< ! setting ustar to minimum value *
< ! *
< !********************************************************************
< ! *
< ! This program calculates Obukhov scale height from surface *
< ! meteorological data and sensible heat flux. *
< ! *
< !********************************************************************
< ! *
< ! INPUT: *
< ! *
< ! ps surface pressure [Pa] *
< ! tsurf surface temperature [K] *
< ! tdsurf surface dew point [K] *
< ! tlev temperature first model level [K] *
< ! ustar scale velocity [m/s] *
< ! hf surface sensible heat flux [W/m2] *
< ! akm ECMWF vertical discretization parameter *
< ! bkm ECMWF vertical discretization parameter *
< ! *
< !********************************************************************
<
< use par_mod
<
< implicit none
<
< real :: akm(nwzmax),bkm(nwzmax)
< real :: ps,tsurf,tdsurf,tlev,ustar,hf,e,ew,tv,rhoa,plev
< real :: ak1,bk1,theta,thetastar
<
<
< e=ew(tdsurf) ! vapor pressure
< tv=tsurf*(1.+0.378*e/ps) ! virtual temperature
< rhoa=ps/(r_air*tv) ! air density
< ak1=(akm(1)+akm(2))/2.
< bk1=(bkm(1)+bkm(2))/2.
< plev=ak1+bk1*ps ! Pressure level 1
< theta=tlev*(100000./plev)**(r_air/cpa) ! potential temperature
< if (ustar.le.0.) ustar=1.e-8
< thetastar=hf/(rhoa*cpa*ustar) ! scale temperature
< if(abs(thetastar).gt.1.e-10) then
< obukhov=theta*ustar**2/(karman*ga*thetastar)
< else
< obukhov=9999 ! zero heat flux
< endif
< if (obukhov.gt. 9999.) obukhov= 9999.
< if (obukhov.lt.-9999.) obukhov=-9999.
<
< end function obukhov
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,akm,bkm)
>
> !********************************************************************
> ! *
> ! Author: G. WOTAWA *
> ! Date: 1994-06-27 *
> ! *
> ! Update: A. Stohl, 2000-09-25, avoid division by zero by *
> ! setting ustar to minimum value *
> ! *
> !********************************************************************
> ! *
> ! This program calculates Obukhov scale height from surface *
> ! meteorological data and sensible heat flux. *
> ! *
> !********************************************************************
> ! *
> ! INPUT: *
> ! *
> ! ps surface pressure [Pa] *
> ! tsurf surface temperature [K] *
> ! tdsurf surface dew point [K] *
> ! tlev temperature first model level [K] *
> ! ustar scale velocity [m/s] *
> ! hf surface sensible heat flux [W/m2] *
> ! akm ECMWF vertical discretization parameter *
> ! bkm ECMWF vertical discretization parameter *
> ! *
> !********************************************************************
>
> use par_mod
>
> implicit none
>
> real :: akm(nwzmax),bkm(nwzmax)
> real :: ps,tsurf,tdsurf,tlev,ustar,hf,e,ew,tv,rhoa,plev
> real :: ak1,bk1,theta,thetastar
>
>
> e=ew(tdsurf) ! vapor pressure
> tv=tsurf*(1.+0.378*e/ps) ! virtual temperature
> rhoa=ps/(r_air*tv) ! air density
> ak1=(akm(1)+akm(2))/2.
> bk1=(bkm(1)+bkm(2))/2.
> plev=ak1+bk1*ps ! Pressure level 1
> theta=tlev*(100000./plev)**(r_air/cpa) ! potential temperature
> if (ustar.le.0.) ustar=1.e-8
> thetastar=hf/(rhoa*cpa*ustar) ! scale temperature
> if(abs(thetastar).gt.1.e-10) then
> obukhov=theta*ustar**2/(karman*ga*thetastar)
> else
> obukhov=9999 ! zero heat flux
> endif
> if (obukhov.gt. 9999.) obukhov= 9999.
> if (obukhov.lt.-9999.) obukhov=-9999.
>
> end function obukhov
obukhov_gfs.f90
----------------------------------------------
1,76c1,76
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,plev)
<
< !********************************************************************
< ! *
< ! Author: G. WOTAWA *
< ! Date: 1994-06-27 *
< ! *
< ! Update: A. Stohl, 2000-09-25, avoid division by zero by *
< ! setting ustar to minimum value *
< ! *
< ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version *
< ! *
< !********************************************************************
< ! *
< ! This program calculates Obukhov scale height from surface *
< ! meteorological data and sensible heat flux. *
< ! *
< !********************************************************************
< ! *
< ! INPUT: *
< ! *
< ! ps surface pressure [Pa] *
< ! tsurf surface temperature [K] *
< ! tdsurf surface dew point [K] *
< ! tlev temperature first model level [K] *
< ! ustar scale velocity [m/s] *
< ! hf surface sensible heat flux [W/m2] *
< ! akm ECMWF vertical discretization parameter *
< ! bkm ECMWF vertical discretization parameter *
< ! *
< !********************************************************************
<
< use par_mod
<
< implicit none
<
< real :: ps,tsurf,tdsurf,tlev,ustar,hf,e,ew,tv,rhoa,plev
< real :: theta,thetastar
<
<
< e=ew(tdsurf) ! vapor pressure
< tv=tsurf*(1.+0.378*e/ps) ! virtual temperature
< rhoa=ps/(r_air*tv) ! air density
< theta=tlev*(100000./plev)**(r_air/cpa) ! potential temperature
< if (ustar.le.0.) ustar=1.e-8
< thetastar=hf/(rhoa*cpa*ustar) ! scale temperature
< if(abs(thetastar).gt.1.e-10) then
< obukhov=theta*ustar**2/(karman*ga*thetastar)
< else
< obukhov=9999 ! zero heat flux
< endif
< if (obukhov.gt. 9999.) obukhov= 9999.
< if (obukhov.lt.-9999.) obukhov=-9999.
<
< end function obukhov
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,plev)
>
> !********************************************************************
> ! *
> ! Author: G. WOTAWA *
> ! Date: 1994-06-27 *
> ! *
> ! Update: A. Stohl, 2000-09-25, avoid division by zero by *
> ! setting ustar to minimum value *
> ! *
> ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version *
> ! *
> !********************************************************************
> ! *
> ! This program calculates Obukhov scale height from surface *
> ! meteorological data and sensible heat flux. *
> ! *
> !********************************************************************
> ! *
> ! INPUT: *
> ! *
> ! ps surface pressure [Pa] *
> ! tsurf surface temperature [K] *
> ! tdsurf surface dew point [K] *
> ! tlev temperature first model level [K] *
> ! ustar scale velocity [m/s] *
> ! hf surface sensible heat flux [W/m2] *
> ! akm ECMWF vertical discretization parameter *
> ! bkm ECMWF vertical discretization parameter *
> ! *
> !********************************************************************
>
> use par_mod
>
> implicit none
>
> real :: ps,tsurf,tdsurf,tlev,ustar,hf,e,ew,tv,rhoa,plev
> real :: theta,thetastar
>
>
> e=ew(tdsurf) ! vapor pressure
> tv=tsurf*(1.+0.378*e/ps) ! virtual temperature
> rhoa=ps/(r_air*tv) ! air density
> theta=tlev*(100000./plev)**(r_air/cpa) ! potential temperature
> if (ustar.le.0.) ustar=1.e-8
> thetastar=hf/(rhoa*cpa*ustar) ! scale temperature
> if(abs(thetastar).gt.1.e-10) then
> obukhov=theta*ustar**2/(karman*ga*thetastar)
> else
> obukhov=9999 ! zero heat flux
> endif
> if (obukhov.gt. 9999.) obukhov= 9999.
> if (obukhov.lt.-9999.) obukhov=-9999.
>
> end function obukhov
oh_mod.f90
----------------------------------------------
1,32c1,32
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< module oh_mod
<
< !includes OH concentration field as well as the height information
< !for this field
<
< implicit none
<
< real,allocatable, dimension (:,:,:,:) :: OH_field
< real,allocatable, dimension (:) :: OH_field_height
<
< end module oh_mod
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> module oh_mod
>
> !includes OH concentration field as well as the height information
> !for this field
>
> implicit none
>
> real,allocatable, dimension (:,:,:,:) :: OH_field
> real,allocatable, dimension (:) :: OH_field_height
>
> end module oh_mod
ohreaction.f90
----------------------------------------------
1,213c1,213
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine ohreaction(itime,ltsample,loutnext)
< ! i i i
< !*****************************************************************************
< ! *
< ! *
< ! Author: S. Eckhardt *
< ! *
< ! June 2007 *
< ! *
< ! *
< !*****************************************************************************
< ! Variables: *
< ! ix,jy indices of output grid cell for each particle *
< ! itime [s] actual simulation time [s] *
< ! jpart particle index *
< ! ldeltat [s] interval since radioactive decay was computed *
< ! loutnext [s] time for which gridded deposition is next output *
< ! loutstep [s] interval at which gridded deposition is output *
< ! oh_average [mol/m^3] OH Concentration *
< ! ltsample [s] interval over which mass is deposited *
< ! *
< !*****************************************************************************
<
< use oh_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: jpart,itime,ltsample,loutnext,ldeltat,j,k,ix,jy
< integer :: ngrid,il,interp_time,n,mm,indz,i
< integer :: jjjjmmdd,ihmmss,OHx,OHy,dOHx,dOHy,OHz
< real :: xtn,ytn,oh_average
< !real oh_diurn_var,sum_ang
< !real zenithangle, ang
< real :: restmass,ohreacted,OHinc
< real :: xlon, ylat, gas_const, act_energy
< real :: ohreact_temp_corr, act_temp
< real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
< real(kind=dp) :: jul
<
< ! Compute interval since radioactive decay of deposited mass was computed
< !************************************************************************
<
< gas_const=8.314 ! define gas constant
< act_energy=10000 ! activation energy
<
< !write(*,*) 'OH reaction n:',n,ohreact(1)
< if (itime.le.loutnext) then
< ldeltat=itime-(loutnext-loutstep)
< else ! first half of next interval
< ldeltat=itime-loutnext
< endif
<
<
< dOHx=360/(maxxOH-1)
< dOHy=180/(maxyOH-1)
<
< jul=bdate+real(itime,kind=dp)/86400._dp
< call caldate(jul,jjjjmmdd,ihmmss)
< mm=int((jjjjmmdd-(jjjjmmdd/10000)*10000)/100)
<
< do jpart=1,numpart
<
< ! Determine which nesting level to be used
< !*****************************************
<
< ngrid=0
< do j=numbnests,1,-1
< if ((xtra1(jpart).gt.xln(j)).and.(xtra1(jpart).lt.xrn(j)).and. &
< (ytra1(jpart).gt.yln(j)).and.(ytra1(jpart).lt.yrn(j))) then
< ngrid=j
< goto 23
< endif
< end do
< 23 continue
<
<
< ! Determine nested grid coordinates
< !**********************************
<
< if (ngrid.gt.0) then
< xtn=(xtra1(jpart)-xln(ngrid))*xresoln(ngrid)
< ytn=(ytra1(jpart)-yln(ngrid))*yresoln(ngrid)
< ix=int(xtn)
< jy=int(ytn)
< else
< ix=int(xtra1(jpart))
< jy=int(ytra1(jpart))
< endif
<
< n=2
< if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) &
< n=1
<
< do i=2,nz
< if (height(i).gt.ztra1(jpart)) then
< indz=i-1
< goto 6
< endif
< end do
< 6 continue
<
< ! The concentration from the nearest available gridcell is taken
< ! get OH concentration for the specific month and solar angle
<
< ! write(*,*) OH_field(1,1,1,1),OH_field(10,1,1,10)
< ! write(*,*) OH_field(1,maxxOH-1,maxyOH-1,1)
< ! write(*,*) OH_field(10,maxxOH-1,maxyOH-1,10)
< ! write(*,*) OH_field_height(1,10,4,1),OH_field_height(10,4,10,10)
< ! write(*,*) OH_field_height(1,maxxOH-1,maxyOH-1,1)
< ! write(*,*) OH_field_height(10,maxxOH-1,maxyOH-1,10)
< interp_time=nint(itime-0.5*ltsample)
<
< ! World coordinates
< xlon=xtra1(jpart)*dx+xlon0
< if (xlon.gt.180) then
< xlon=xlon-360
< endif
< ylat=ytra1(jpart)*dy+ylat0
< ! get position in the OH field - assume that the OH field is global
< OHx=(180+xlon-1)/dOHx
< OHy=(90+ylat-1)/dOHy
< ! sum_ang=0
< ! get the level of the OH height field were the actual particle is in
< ! ztra1 is the z-coordinate of the trajectory above model orography in m
< ! OH_field_height is the heigth of the OH field above orography
< OHz=maxzOH
< ! assume equally distrib. OH field, OH_field_height gives the middle of
< ! the z coordinate
< OHinc=(OH_field_height(3)-OH_field_height(2))/2
< do il=2,maxzOH+1
< if ((OH_field_height(il-1)+OHinc).gt.ztra1(jpart)) goto 26
< end do
< 26 continue
<
< OHz=il-1
< ! loop was not interrupted il would be 8 (9-1)
< if (OHz.gt.maxzOH) OHz=7
< ! write (*,*) 'OH height: '
< ! + ,ztra1(jpart),jpart,OHz,OH_field_height(OHz),OHinc,
< ! + OH_field_height
<
< oh_average=OH_field(mm,OHx,OHy,OHz)
< if (oh_average.gt.smallnum) then
< !**********************************************************
< ! if there is noOH concentration no reaction
< ! for performance reason take average concentration and
< ! ignore diurnal variation
< ! do 28 il=1,24
< ! ang=70-zenithangle(ylat,xlon,jul+(24-il)/24.)
< ! if (ang.lt.0) then
< ! ang=0
< ! endif
< ! sum_ang=sum_ang+ang
< !28 enddo
< ! oh_diurn_var=(ang/sum_ang)*(oh_average*24)
< ! oh_average=oh_diurn_var
< !**********************************************************
<
<
< ! Computation of the OH reaction
< !**********************************************************
< act_temp=tt(ix,jy,indz,n)
<
< do k=1,nspec ! loop over species
< if (ohreact(k).gt.0.) then
< ohreact_temp_corr=ohreact(k)*oh_average* &
< exp((act_energy/gas_const)*(1/298.15-1/act_temp))
< ohreacted=xmass1(jpart,k)* &
< (1.-exp(-1*ohreact_temp_corr*abs(ltsample)))
< ! new particle mass:
< restmass = xmass1(jpart,k)-ohreacted
< if (restmass .gt. smallnum) then
< xmass1(jpart,k)=restmass
< ! write (104) xlon,ylat,ztra1(jpart),k,oh_diurn_var,jjjjmmdd,
< ! + ihmmss,restmass,ohreacted
< else
< xmass1(jpart,k)=0.
< endif
< ! write (*,*) 'restmass: ',restmass
< else
< ohreacted=0.
< endif
< end do
<
< endif
< !endif OH concentration gt 0
< end do
< !continue loop over all particles
<
< end subroutine ohreaction
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine ohreaction(itime,ltsample,loutnext)
> ! i i i
> !*****************************************************************************
> ! *
> ! *
> ! Author: S. Eckhardt *
> ! *
> ! June 2007 *
> ! *
> ! *
> !*****************************************************************************
> ! Variables: *
> ! ix,jy indices of output grid cell for each particle *
> ! itime [s] actual simulation time [s] *
> ! jpart particle index *
> ! ldeltat [s] interval since radioactive decay was computed *
> ! loutnext [s] time for which gridded deposition is next output *
> ! loutstep [s] interval at which gridded deposition is output *
> ! oh_average [mol/m^3] OH Concentration *
> ! ltsample [s] interval over which mass is deposited *
> ! *
> !*****************************************************************************
>
> use oh_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: jpart,itime,ltsample,loutnext,ldeltat,j,k,ix,jy
> integer :: ngrid,il,interp_time,n,mm,indz,i
> integer :: jjjjmmdd,ihmmss,OHx,OHy,dOHx,dOHy,OHz
> real :: xtn,ytn,oh_average
> !real oh_diurn_var,sum_ang
> !real zenithangle, ang
> real :: restmass,ohreacted,OHinc
> real :: xlon, ylat, gas_const, act_energy
> real :: ohreact_temp_corr, act_temp
> real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
> real(kind=dp) :: jul
>
> ! Compute interval since radioactive decay of deposited mass was computed
> !************************************************************************
>
> gas_const=8.314 ! define gas constant
> act_energy=10000 ! activation energy
>
> !write(*,*) 'OH reaction n:',n,ohreact(1)
> if (itime.le.loutnext) then
> ldeltat=itime-(loutnext-loutstep)
> else ! first half of next interval
> ldeltat=itime-loutnext
> endif
>
>
> dOHx=360/(maxxOH-1)
> dOHy=180/(maxyOH-1)
>
> jul=bdate+real(itime,kind=dp)/86400._dp
> call caldate(jul,jjjjmmdd,ihmmss)
> mm=int((jjjjmmdd-(jjjjmmdd/10000)*10000)/100)
>
> do jpart=1,numpart
>
> ! Determine which nesting level to be used
> !*****************************************
>
> ngrid=0
> do j=numbnests,1,-1
> if ((xtra1(jpart).gt.xln(j)).and.(xtra1(jpart).lt.xrn(j)).and. &
> (ytra1(jpart).gt.yln(j)).and.(ytra1(jpart).lt.yrn(j))) then
> ngrid=j
> goto 23
> endif
> end do
> 23 continue
>
>
> ! Determine nested grid coordinates
> !**********************************
>
> if (ngrid.gt.0) then
> xtn=(xtra1(jpart)-xln(ngrid))*xresoln(ngrid)
> ytn=(ytra1(jpart)-yln(ngrid))*yresoln(ngrid)
> ix=int(xtn)
> jy=int(ytn)
> else
> ix=int(xtra1(jpart))
> jy=int(ytra1(jpart))
> endif
>
> n=2
> if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) &
> n=1
>
> do i=2,nz
> if (height(i).gt.ztra1(jpart)) then
> indz=i-1
> goto 6
> endif
> end do
> 6 continue
>
> ! The concentration from the nearest available gridcell is taken
> ! get OH concentration for the specific month and solar angle
>
> ! write(*,*) OH_field(1,1,1,1),OH_field(10,1,1,10)
> ! write(*,*) OH_field(1,maxxOH-1,maxyOH-1,1)
> ! write(*,*) OH_field(10,maxxOH-1,maxyOH-1,10)
> ! write(*,*) OH_field_height(1,10,4,1),OH_field_height(10,4,10,10)
> ! write(*,*) OH_field_height(1,maxxOH-1,maxyOH-1,1)
> ! write(*,*) OH_field_height(10,maxxOH-1,maxyOH-1,10)
> interp_time=nint(itime-0.5*ltsample)
>
> ! World coordinates
> xlon=xtra1(jpart)*dx+xlon0
> if (xlon.gt.180) then
> xlon=xlon-360
> endif
> ylat=ytra1(jpart)*dy+ylat0
> ! get position in the OH field - assume that the OH field is global
> OHx=(180+xlon-1)/dOHx
> OHy=(90+ylat-1)/dOHy
> ! sum_ang=0
> ! get the level of the OH height field were the actual particle is in
> ! ztra1 is the z-coordinate of the trajectory above model orography in m
> ! OH_field_height is the heigth of the OH field above orography
> OHz=maxzOH
> ! assume equally distrib. OH field, OH_field_height gives the middle of
> ! the z coordinate
> OHinc=(OH_field_height(3)-OH_field_height(2))/2
> do il=2,maxzOH+1
> if ((OH_field_height(il-1)+OHinc).gt.ztra1(jpart)) goto 26
> end do
> 26 continue
>
> OHz=il-1
> ! loop was not interrupted il would be 8 (9-1)
> if (OHz.gt.maxzOH) OHz=7
> ! write (*,*) 'OH height: '
> ! + ,ztra1(jpart),jpart,OHz,OH_field_height(OHz),OHinc,
> ! + OH_field_height
>
> oh_average=OH_field(mm,OHx,OHy,OHz)
> if (oh_average.gt.smallnum) then
> !**********************************************************
> ! if there is noOH concentration no reaction
> ! for performance reason take average concentration and
> ! ignore diurnal variation
> ! do 28 il=1,24
> ! ang=70-zenithangle(ylat,xlon,jul+(24-il)/24.)
> ! if (ang.lt.0) then
> ! ang=0
> ! endif
> ! sum_ang=sum_ang+ang
> !28 enddo
> ! oh_diurn_var=(ang/sum_ang)*(oh_average*24)
> ! oh_average=oh_diurn_var
> !**********************************************************
>
>
> ! Computation of the OH reaction
> !**********************************************************
> act_temp=tt(ix,jy,indz,n)
>
> do k=1,nspec ! loop over species
> if (ohreact(k).gt.0.) then
> ohreact_temp_corr=ohreact(k)*oh_average* &
> exp((act_energy/gas_const)*(1/298.15-1/act_temp))
> ohreacted=xmass1(jpart,k)* &
> (1.-exp(-1*ohreact_temp_corr*abs(ltsample)))
> ! new particle mass:
> restmass = xmass1(jpart,k)-ohreacted
> if (restmass .gt. smallnum) then
> xmass1(jpart,k)=restmass
> ! write (104) xlon,ylat,ztra1(jpart),k,oh_diurn_var,jjjjmmdd,
> ! + ihmmss,restmass,ohreacted
> else
> xmass1(jpart,k)=0.
> endif
> ! write (*,*) 'restmass: ',restmass
> else
> ohreacted=0.
> endif
> end do
>
> endif
> !endif OH concentration gt 0
> end do
> !continue loop over all particles
>
> end subroutine ohreaction
openouttraj.f90
----------------------------------------------
1,85c1,85
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine openouttraj
<
< !*****************************************************************************
< ! *
< ! This routine opens the output file for the plume trajectory output *
< ! produced by the cluster analysis. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 27 January 2001 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< !*****************************************************************************
<
< use point_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: i
< real :: xp1,yp1,xp2,yp2
<
<
< ! Open output file for trajectory output
< !***************************************
<
< open(unitouttraj,file=path(2)(1:length(2))//'trajectories.txt', &
< form='formatted',err=998)
<
< if (ldirect.eq.1) then
< write(unitouttraj,'(i8,1x,i6,1x,a)') ibdate,ibtime,'FLEXPART V8.2'
< else
< write(unitouttraj,'(i8,1x,i6,1x,a)') iedate,ietime,'FLEXPART V8.2'
< endif
< write(unitouttraj,*) method,lsubgrid,lconvection
< write(unitouttraj,*) numpoint
< do i=1,numpoint
< xp1=xpoint1(i)*dx+xlon0
< yp1=ypoint1(i)*dy+ylat0
< xp2=xpoint2(i)*dx+xlon0
< yp2=ypoint2(i)*dy+ylat0
< write(unitouttraj,*) ireleasestart(i),ireleaseend(i), &
< xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i),kindz(i),npart(i)
< if (numpoint.le.1000) then
< write(unitouttraj,'(a)') compoint(i)(1:40)
< else
< write(unitouttraj,'(a)') compoint(1001)(1:40)
< endif
< end do
<
< return
<
< 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
< write(*,*) ' #### trajectories.txt #### '
< write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
< write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
< write(*,*) ' #### THE PROGRAM AGAIN. #### '
< stop
<
< end subroutine openouttraj
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine openouttraj
>
> !*****************************************************************************
> ! *
> ! This routine opens the output file for the plume trajectory output *
> ! produced by the cluster analysis. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 27 January 2001 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> !*****************************************************************************
>
> use point_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: i
> real :: xp1,yp1,xp2,yp2
>
>
> ! Open output file for trajectory output
> !***************************************
>
> open(unitouttraj,file=path(2)(1:length(2))//'trajectories.txt', &
> form='formatted',err=998)
>
> if (ldirect.eq.1) then
> write(unitouttraj,'(i8,1x,i6,1x,a)') ibdate,ibtime,'FLEXPART V8.2'
> else
> write(unitouttraj,'(i8,1x,i6,1x,a)') iedate,ietime,'FLEXPART V8.2'
> endif
> write(unitouttraj,*) method,lsubgrid,lconvection
> write(unitouttraj,*) numpoint
> do i=1,numpoint
> xp1=xpoint1(i)*dx+xlon0
> yp1=ypoint1(i)*dy+ylat0
> xp2=xpoint2(i)*dx+xlon0
> yp2=ypoint2(i)*dy+ylat0
> write(unitouttraj,*) ireleasestart(i),ireleaseend(i), &
> xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i),kindz(i),npart(i)
> if (numpoint.le.1000) then
> write(unitouttraj,'(a)') compoint(i)(1:40)
> else
> write(unitouttraj,'(a)') compoint(1001)(1:40)
> endif
> end do
>
> return
>
> 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
> write(*,*) ' #### trajectories.txt #### '
> write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
> write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
> write(*,*) ' #### THE PROGRAM AGAIN. #### '
> stop
>
> end subroutine openouttraj
openreceptors.f90
----------------------------------------------
1,93c1,93
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine openreceptors
<
< !*****************************************************************************
< ! *
< ! This routine opens the receptor output files and writes out the receptor *
< ! names and the receptor locations. The receptor output files are not *
< ! closed, but kept open throughout the simulation. Concentrations are *
< ! continuously dumped to these files. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 7 August 2002 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! numreceptor actual number of receptor points specified *
< ! receptornames names of the receptor points *
< ! xreceptor,yreceptor coordinates of the receptor points *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: j
<
< ! Open output file for receptor points and write out a short header
< ! containing receptor names and locations
< !******************************************************************
<
< if (numreceptor.ge.1) then ! do it only if receptors are specified
<
< ! Concentration output
< !*********************
<
< if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
< open(unitoutrecept,file=path(2)(1:length(2))//'receptor_conc', &
< form='unformatted',err=997)
< write(unitoutrecept) (receptorname(j),j=1,numreceptor)
< write(unitoutrecept) (xreceptor(j)*dx+xlon0, &
< yreceptor(j)*dy+ylat0,j=1,numreceptor)
< endif
<
< ! Mixing ratio output
< !********************
<
< if ((iout.eq.2).or.(iout.eq.3)) then
< open(unitoutreceptppt,file=path(2)(1:length(2))//'receptor_pptv', &
< form='unformatted',err=998)
< write(unitoutreceptppt) (receptorname(j),j=1,numreceptor)
< write(unitoutreceptppt) (xreceptor(j)*dx+xlon0, &
< yreceptor(j)*dy+ylat0,j=1,numreceptor)
< endif
< endif
<
< return
<
<
< 997 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
< write(*,*) ' #### receptor_conc #### '
< write(*,*) ' #### CANNOT BE OPENED. #### '
< stop
<
< 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
< write(*,*) ' #### receptor_pptv #### '
< write(*,*) ' #### CANNOT BE OPENED. #### '
< stop
<
< end subroutine openreceptors
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine openreceptors
>
> !*****************************************************************************
> ! *
> ! This routine opens the receptor output files and writes out the receptor *
> ! names and the receptor locations. The receptor output files are not *
> ! closed, but kept open throughout the simulation. Concentrations are *
> ! continuously dumped to these files. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 7 August 2002 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! numreceptor actual number of receptor points specified *
> ! receptornames names of the receptor points *
> ! xreceptor,yreceptor coordinates of the receptor points *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: j
>
> ! Open output file for receptor points and write out a short header
> ! containing receptor names and locations
> !******************************************************************
>
> if (numreceptor.ge.1) then ! do it only if receptors are specified
>
> ! Concentration output
> !*********************
>
> if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then
> open(unitoutrecept,file=path(2)(1:length(2))//'receptor_conc', &
> form='unformatted',err=997)
> write(unitoutrecept) (receptorname(j),j=1,numreceptor)
> write(unitoutrecept) (xreceptor(j)*dx+xlon0, &
> yreceptor(j)*dy+ylat0,j=1,numreceptor)
> endif
>
> ! Mixing ratio output
> !********************
>
> if ((iout.eq.2).or.(iout.eq.3)) then
> open(unitoutreceptppt,file=path(2)(1:length(2))//'receptor_pptv', &
> form='unformatted',err=998)
> write(unitoutreceptppt) (receptorname(j),j=1,numreceptor)
> write(unitoutreceptppt) (xreceptor(j)*dx+xlon0, &
> yreceptor(j)*dy+ylat0,j=1,numreceptor)
> endif
> endif
>
> return
>
>
> 997 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
> write(*,*) ' #### receptor_conc #### '
> write(*,*) ' #### CANNOT BE OPENED. #### '
> stop
>
> 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
> write(*,*) ' #### receptor_pptv #### '
> write(*,*) ' #### CANNOT BE OPENED. #### '
> stop
>
> end subroutine openreceptors
outg_mod.f90
----------------------------------------------
1,47c1,47
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< module outg_mod
<
< implicit none
<
< real,allocatable, dimension (:) :: outheight
< real,allocatable, dimension (:) :: outheighthalf
< real,allocatable, dimension (:,:) :: oroout
< real,allocatable, dimension (:,:) :: orooutn
< real,allocatable, dimension (:,:) :: area
< real,allocatable, dimension (:,:) :: arean
< real,allocatable, dimension (:,:,:) :: volume
< real,allocatable, dimension (:,:,:) :: volumen
< real,allocatable, dimension (:,:,:) :: areaeast
< real,allocatable, dimension (:,:,:) :: areanorth
< real,allocatable, dimension (:,:,:) :: densityoutgrid
< real,allocatable, dimension (:,:,:) :: factor3d
< real,allocatable, dimension (:,:,:) :: grid
< real,allocatable, dimension (:,:) :: wetgrid
< real,allocatable, dimension (:,:) :: drygrid
< real,allocatable, dimension (:,:,:) :: gridsigma
< real,allocatable, dimension (:,:) :: drygridsigma
< real,allocatable, dimension (:,:) :: wetgridsigma
< real,allocatable, dimension (:) :: sparse_dump_r
< integer,allocatable, dimension (:) :: sparse_dump_i
<
< end module outg_mod
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> module outg_mod
>
> implicit none
>
> real,allocatable, dimension (:) :: outheight
> real,allocatable, dimension (:) :: outheighthalf
> real,allocatable, dimension (:,:) :: oroout
> real,allocatable, dimension (:,:) :: orooutn
> real,allocatable, dimension (:,:) :: area
> real,allocatable, dimension (:,:) :: arean
> real,allocatable, dimension (:,:,:) :: volume
> real,allocatable, dimension (:,:,:) :: volumen
> real,allocatable, dimension (:,:,:) :: areaeast
> real,allocatable, dimension (:,:,:) :: areanorth
> real,allocatable, dimension (:,:,:) :: densityoutgrid
> real,allocatable, dimension (:,:,:) :: factor3d
> real,allocatable, dimension (:,:,:) :: grid
> real,allocatable, dimension (:,:) :: wetgrid
> real,allocatable, dimension (:,:) :: drygrid
> real,allocatable, dimension (:,:,:) :: gridsigma
> real,allocatable, dimension (:,:) :: drygridsigma
> real,allocatable, dimension (:,:) :: wetgridsigma
> real,allocatable, dimension (:) :: sparse_dump_r
> integer,allocatable, dimension (:) :: sparse_dump_i
>
> end module outg_mod
outgrid_init.f90
----------------------------------------------
1,318c1,318
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine outgrid_init
< !
< !*****************************************************************************
< ! *
< ! This routine initializes the output grids *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 7 August 2002 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! area surface area of all output grid cells *
< ! areaeast eastward facing wall area of all output grid cells *
< ! areanorth northward facing wall area of all output grid cells *
< ! volume volumes of all output grid cells *
< ! *
< !*****************************************************************************
<
< use flux_mod
< use oh_mod
< use unc_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: ix,jy,kz,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid
< integer :: ks,kp,stat
< real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp
< real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh
< real,parameter :: eps=nxmax/3.e5
<
<
< ! Compute surface area and volume of each grid cell: area, volume;
< ! and the areas of the northward and eastward facing walls: areaeast, areanorth
< !***********************************************************************
< do jy=0,numygrid-1
< ylat=outlat0+(real(jy)+0.5)*dyout
< ylatp=ylat+0.5*dyout
< ylatm=ylat-0.5*dyout
< if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
< hzone=dyout*r_earth*pi180
< else
<
< ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
< ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
< !************************************************************
<
< cosfactp=cos(ylatp*pi180)
< cosfactm=cos(ylatm*pi180)
< if (cosfactp.lt.cosfactm) then
< hzone=sqrt(1-cosfactp**2)- &
< sqrt(1-cosfactm**2)
< hzone=hzone*r_earth
< else
< hzone=sqrt(1-cosfactm**2)- &
< sqrt(1-cosfactp**2)
< hzone=hzone*r_earth
< endif
< endif
<
< ! Surface are of a grid cell at a latitude ylat
< !**********************************************
<
< gridarea=2.*pi*r_earth*hzone*dxout/360.
<
< do ix=0,numxgrid-1
< area(ix,jy)=gridarea
<
< ! Volume = area x box height
< !***************************
<
< volume(ix,jy,1)=area(ix,jy)*outheight(1)
< areaeast(ix,jy,1)=dyout*r_earth*pi180*outheight(1)
< areanorth(ix,jy,1)=cos(ylat*pi180)*dxout*r_earth*pi180* &
< outheight(1)
< do kz=2,numzgrid
< areaeast(ix,jy,kz)=dyout*r_earth*pi180* &
< (outheight(kz)-outheight(kz-1))
< areanorth(ix,jy,kz)=cos(ylat*pi180)*dxout*r_earth*pi180* &
< (outheight(kz)-outheight(kz-1))
< volume(ix,jy,kz)=area(ix,jy)*(outheight(kz)-outheight(kz-1))
< end do
< end do
< end do
<
<
<
<
< !******************************************************************
< ! Determine average height of model topography in output grid cells
< !******************************************************************
<
< ! Loop over all output grid cells
< !********************************
<
< do jjy=0,numygrid-1
< do iix=0,numxgrid-1
< oroh=0.
<
< ! Take 100 samples of the topography in every grid cell
< !******************************************************
<
< do j1=1,10
< ylat=outlat0+(real(jjy)+real(j1)/10.-0.05)*dyout
< yl=(ylat-ylat0)/dy
< do i1=1,10
< xlon=outlon0+(real(iix)+real(i1)/10.-0.05)*dxout
< xl=(xlon-xlon0)/dx
<
< ! Determine the nest we are in
< !*****************************
<
< ngrid=0
< do j=numbnests,1,-1
< if ((xl.gt.xln(j)+eps).and.(xl.lt.xrn(j)-eps).and. &
< (yl.gt.yln(j)+eps).and.(yl.lt.yrn(j)-eps)) then
< ngrid=j
< goto 43
< endif
< end do
< 43 continue
<
< ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
< !*****************************************************************************
<
< if (ngrid.gt.0) then
< xtn=(xl-xln(ngrid))*xresoln(ngrid)
< ytn=(yl-yln(ngrid))*yresoln(ngrid)
< ix=int(xtn)
< jy=int(ytn)
< ddy=ytn-real(jy)
< ddx=xtn-real(ix)
< else
< ix=int(xl)
< jy=int(yl)
< ddy=yl-real(jy)
< ddx=xl-real(ix)
< endif
< ixp=ix+1
< jyp=jy+1
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
<
< if (ngrid.gt.0) then
< oroh=oroh+p1*oron(ix ,jy ,ngrid) &
< + p2*oron(ixp,jy ,ngrid) &
< + p3*oron(ix ,jyp,ngrid) &
< + p4*oron(ixp,jyp,ngrid)
< else
< oroh=oroh+p1*oro(ix ,jy) &
< + p2*oro(ixp,jy) &
< + p3*oro(ix ,jyp) &
< + p4*oro(ixp,jyp)
< endif
< end do
< end do
<
< ! Divide by the number of samples taken
< !**************************************
<
< oroout(iix,jjy)=oroh/100.
< end do
< end do
<
< ! if necessary allocate flux fields
< if (iflux.eq.1) then
< allocate(flux(6,0:numxgrid-1,0:numygrid-1,numzgrid, &
< 1:nspec,1:maxpointspec_act,1:nageclass),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate flux array '
< endif
<
< !write (*,*) 'allocating: in a sec',OHREA
< if (OHREA.eqv..TRUE.) then
< ! write (*,*) 'allocating: ',maxxOH,maxyOH,maxzOH
< allocate(OH_field(12,0:maxxOH-1,0:maxyOH-1,maxzOH) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate OH array '
< allocate(OH_field_height(7) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate OH array '
< endif
< ! gridunc,griduncn uncertainty of outputted concentrations
< allocate(gridunc(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
< maxpointspec_act,nclassunc,maxageclass),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< if (ldirect.gt.0) then
< allocate(wetgridunc(0:numxgrid-1,0:numygrid-1,maxspec, &
< maxpointspec_act,nclassunc,maxageclass),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< allocate(drygridunc(0:numxgrid-1,0:numygrid-1,maxspec, &
< maxpointspec_act,nclassunc,maxageclass),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< endif
< !write (*,*) 'Dimensions for fields', numxgrid,numygrid, &
< ! maxspec,maxpointspec_act,nclassunc,maxageclass
<
< write (*,*) ' Allocating fields for nested and global output (x,y): ', &
< max(numxgrid,numxgridn),max(numygrid,numygridn)
<
< ! allocate fields for concoutput with maximum dimension of outgrid
< ! and outgrid_nest
<
< allocate(gridsigma(0:max(numxgrid,numxgridn)-1, &
< 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< allocate(grid(0:max(numxgrid,numxgridn)-1, &
< 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< allocate(densityoutgrid(0:max(numxgrid,numxgridn)-1, &
< 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
<
< allocate(factor3d(0:max(numxgrid,numxgridn)-1, &
< 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< allocate(sparse_dump_r(max(numxgrid,numxgridn)* &
< max(numygrid,numygridn)*numzgrid),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< allocate(sparse_dump_i(max(numxgrid,numxgridn)* &
< max(numygrid,numygridn)*numzgrid),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
<
< ! deposition fields are only allocated for forward runs
< if (ldirect.gt.0) then
< allocate(wetgridsigma(0:max(numxgrid,numxgridn)-1, &
< 0:max(numygrid,numygridn)-1),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< allocate(drygridsigma(0:max(numxgrid,numxgridn)-1, &
< 0:max(numygrid,numygridn)-1),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< allocate(wetgrid(0:max(numxgrid,numxgridn)-1, &
< 0:max(numygrid,numygridn)-1),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< allocate(drygrid(0:max(numxgrid,numxgridn)-1, &
< 0:max(numygrid,numygridn)-1),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
< endif
<
< ! Initial condition field
<
< if (linit_cond.gt.0) then
< allocate(init_cond(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
< maxpointspec_act),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate init_cond'
< endif
<
< !************************
< ! Initialize output grids
< !************************
<
< do ks=1,nspec
< do kp=1,maxpointspec_act
< do i=1,numreceptor
< ! Receptor points
< creceptor(i,ks)=0.
< end do
< do nage=1,nageclass
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< do l=1,nclassunc
< ! Deposition fields
< if (ldirect.gt.0) then
< wetgridunc(ix,jy,ks,kp,l,nage)=0.
< drygridunc(ix,jy,ks,kp,l,nage)=0.
< endif
< do kz=1,numzgrid
< if (iflux.eq.1) then
< ! Flux fields
< do i=1,5
< flux(i,ix,jy,kz,ks,kp,nage)=0.
< end do
< endif
< ! Initial condition field
< if ((l.eq.1).and.(nage.eq.1).and.(linit_cond.gt.0)) &
< init_cond(ix,jy,kz,ks,kp)=0.
< ! Concentration fields
< gridunc(ix,jy,kz,ks,kp,l,nage)=0.
< end do
< end do
< end do
< end do
< end do
< end do
< end do
<
<
<
< end subroutine outgrid_init
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine outgrid_init
> !
> !*****************************************************************************
> ! *
> ! This routine initializes the output grids *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 7 August 2002 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! area surface area of all output grid cells *
> ! areaeast eastward facing wall area of all output grid cells *
> ! areanorth northward facing wall area of all output grid cells *
> ! volume volumes of all output grid cells *
> ! *
> !*****************************************************************************
>
> use flux_mod
> use oh_mod
> use unc_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: ix,jy,kz,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid
> integer :: ks,kp,stat
> real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp
> real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh
> real,parameter :: eps=nxmax/3.e5
>
>
> ! Compute surface area and volume of each grid cell: area, volume;
> ! and the areas of the northward and eastward facing walls: areaeast, areanorth
> !***********************************************************************
> do jy=0,numygrid-1
> ylat=outlat0+(real(jy)+0.5)*dyout
> ylatp=ylat+0.5*dyout
> ylatm=ylat-0.5*dyout
> if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
> hzone=dyout*r_earth*pi180
> else
>
> ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
> ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
> !************************************************************
>
> cosfactp=cos(ylatp*pi180)
> cosfactm=cos(ylatm*pi180)
> if (cosfactp.lt.cosfactm) then
> hzone=sqrt(1-cosfactp**2)- &
> sqrt(1-cosfactm**2)
> hzone=hzone*r_earth
> else
> hzone=sqrt(1-cosfactm**2)- &
> sqrt(1-cosfactp**2)
> hzone=hzone*r_earth
> endif
> endif
>
> ! Surface are of a grid cell at a latitude ylat
> !**********************************************
>
> gridarea=2.*pi*r_earth*hzone*dxout/360.
>
> do ix=0,numxgrid-1
> area(ix,jy)=gridarea
>
> ! Volume = area x box height
> !***************************
>
> volume(ix,jy,1)=area(ix,jy)*outheight(1)
> areaeast(ix,jy,1)=dyout*r_earth*pi180*outheight(1)
> areanorth(ix,jy,1)=cos(ylat*pi180)*dxout*r_earth*pi180* &
> outheight(1)
> do kz=2,numzgrid
> areaeast(ix,jy,kz)=dyout*r_earth*pi180* &
> (outheight(kz)-outheight(kz-1))
> areanorth(ix,jy,kz)=cos(ylat*pi180)*dxout*r_earth*pi180* &
> (outheight(kz)-outheight(kz-1))
> volume(ix,jy,kz)=area(ix,jy)*(outheight(kz)-outheight(kz-1))
> end do
> end do
> end do
>
>
>
>
> !******************************************************************
> ! Determine average height of model topography in output grid cells
> !******************************************************************
>
> ! Loop over all output grid cells
> !********************************
>
> do jjy=0,numygrid-1
> do iix=0,numxgrid-1
> oroh=0.
>
> ! Take 100 samples of the topography in every grid cell
> !******************************************************
>
> do j1=1,10
> ylat=outlat0+(real(jjy)+real(j1)/10.-0.05)*dyout
> yl=(ylat-ylat0)/dy
> do i1=1,10
> xlon=outlon0+(real(iix)+real(i1)/10.-0.05)*dxout
> xl=(xlon-xlon0)/dx
>
> ! Determine the nest we are in
> !*****************************
>
> ngrid=0
> do j=numbnests,1,-1
> if ((xl.gt.xln(j)+eps).and.(xl.lt.xrn(j)-eps).and. &
> (yl.gt.yln(j)+eps).and.(yl.lt.yrn(j)-eps)) then
> ngrid=j
> goto 43
> endif
> end do
> 43 continue
>
> ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
> !*****************************************************************************
>
> if (ngrid.gt.0) then
> xtn=(xl-xln(ngrid))*xresoln(ngrid)
> ytn=(yl-yln(ngrid))*yresoln(ngrid)
> ix=int(xtn)
> jy=int(ytn)
> ddy=ytn-real(jy)
> ddx=xtn-real(ix)
> else
> ix=int(xl)
> jy=int(yl)
> ddy=yl-real(jy)
> ddx=xl-real(ix)
> endif
> ixp=ix+1
> jyp=jy+1
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
>
> if (ngrid.gt.0) then
> oroh=oroh+p1*oron(ix ,jy ,ngrid) &
> + p2*oron(ixp,jy ,ngrid) &
> + p3*oron(ix ,jyp,ngrid) &
> + p4*oron(ixp,jyp,ngrid)
> else
> oroh=oroh+p1*oro(ix ,jy) &
> + p2*oro(ixp,jy) &
> + p3*oro(ix ,jyp) &
> + p4*oro(ixp,jyp)
> endif
> end do
> end do
>
> ! Divide by the number of samples taken
> !**************************************
>
> oroout(iix,jjy)=oroh/100.
> end do
> end do
>
> ! if necessary allocate flux fields
> if (iflux.eq.1) then
> allocate(flux(6,0:numxgrid-1,0:numygrid-1,numzgrid, &
> 1:nspec,1:maxpointspec_act,1:nageclass),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate flux array '
> endif
>
> !write (*,*) 'allocating: in a sec',OHREA
> if (OHREA.eqv..TRUE.) then
> ! write (*,*) 'allocating: ',maxxOH,maxyOH,maxzOH
> allocate(OH_field(12,0:maxxOH-1,0:maxyOH-1,maxzOH) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate OH array '
> allocate(OH_field_height(7) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate OH array '
> endif
> ! gridunc,griduncn uncertainty of outputted concentrations
> allocate(gridunc(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
> maxpointspec_act,nclassunc,maxageclass),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> if (ldirect.gt.0) then
> allocate(wetgridunc(0:numxgrid-1,0:numygrid-1,maxspec, &
> maxpointspec_act,nclassunc,maxageclass),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> allocate(drygridunc(0:numxgrid-1,0:numygrid-1,maxspec, &
> maxpointspec_act,nclassunc,maxageclass),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> endif
> !write (*,*) 'Dimensions for fields', numxgrid,numygrid, &
> ! maxspec,maxpointspec_act,nclassunc,maxageclass
>
> write (*,*) ' Allocating fields for nested and global output (x,y): ', &
> max(numxgrid,numxgridn),max(numygrid,numygridn)
>
> ! allocate fields for concoutput with maximum dimension of outgrid
> ! and outgrid_nest
>
> allocate(gridsigma(0:max(numxgrid,numxgridn)-1, &
> 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> allocate(grid(0:max(numxgrid,numxgridn)-1, &
> 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> allocate(densityoutgrid(0:max(numxgrid,numxgridn)-1, &
> 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
>
> allocate(factor3d(0:max(numxgrid,numxgridn)-1, &
> 0:max(numygrid,numygridn)-1,numzgrid),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> allocate(sparse_dump_r(max(numxgrid,numxgridn)* &
> max(numygrid,numygridn)*numzgrid),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> allocate(sparse_dump_i(max(numxgrid,numxgridn)* &
> max(numygrid,numygridn)*numzgrid),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
>
> ! deposition fields are only allocated for forward runs
> if (ldirect.gt.0) then
> allocate(wetgridsigma(0:max(numxgrid,numxgridn)-1, &
> 0:max(numygrid,numygridn)-1),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> allocate(drygridsigma(0:max(numxgrid,numxgridn)-1, &
> 0:max(numygrid,numygridn)-1),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> allocate(wetgrid(0:max(numxgrid,numxgridn)-1, &
> 0:max(numygrid,numygridn)-1),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> allocate(drygrid(0:max(numxgrid,numxgridn)-1, &
> 0:max(numygrid,numygridn)-1),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc'
> endif
>
> ! Initial condition field
>
> if (linit_cond.gt.0) then
> allocate(init_cond(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, &
> maxpointspec_act),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate init_cond'
> endif
>
> !************************
> ! Initialize output grids
> !************************
>
> do ks=1,nspec
> do kp=1,maxpointspec_act
> do i=1,numreceptor
> ! Receptor points
> creceptor(i,ks)=0.
> end do
> do nage=1,nageclass
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> do l=1,nclassunc
> ! Deposition fields
> if (ldirect.gt.0) then
> wetgridunc(ix,jy,ks,kp,l,nage)=0.
> drygridunc(ix,jy,ks,kp,l,nage)=0.
> endif
> do kz=1,numzgrid
> if (iflux.eq.1) then
> ! Flux fields
> do i=1,5
> flux(i,ix,jy,kz,ks,kp,nage)=0.
> end do
> endif
> ! Initial condition field
> if ((l.eq.1).and.(nage.eq.1).and.(linit_cond.gt.0)) &
> init_cond(ix,jy,kz,ks,kp)=0.
> ! Concentration fields
> gridunc(ix,jy,kz,ks,kp,l,nage)=0.
> end do
> end do
> end do
> end do
> end do
> end do
> end do
>
>
>
> end subroutine outgrid_init
outgrid_init_nest.f90
----------------------------------------------
1,230c1,230
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine outgrid_init_nest
<
< !*****************************************************************************
< ! *
< ! This routine calculates, for each grid cell of the output nest, the *
< ! volume and the surface area. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 30 August 2004 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! arean surface area of all output nest cells *
< ! volumen volumes of all output nest cells *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: ix,jy,kz,ks,kp,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid
< integer :: stat
< real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp
< real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh
< real,parameter :: eps=nxmax/3.e5
<
<
<
< ! gridunc,griduncn uncertainty of outputted concentrations
< allocate(griduncn(0:numxgridn-1,0:numygridn-1,numzgrid,maxspec, &
< maxpointspec_act,nclassunc,maxageclass),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
<
< if (ldirect.gt.0) then
< allocate(wetgriduncn(0:numxgridn-1,0:numygridn-1,maxspec, &
< maxpointspec_act,nclassunc,maxageclass),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
< allocate(drygriduncn(0:numxgridn-1,0:numygridn-1,maxspec, &
< maxpointspec_act,nclassunc,maxageclass),stat=stat)
< if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
< endif
<
< ! Compute surface area and volume of each grid cell: area, volume;
< ! and the areas of the northward and eastward facing walls: areaeast, areanorth
< !***********************************************************************
<
< do jy=0,numygridn-1
< ylat=outlat0n+(real(jy)+0.5)*dyoutn
< ylatp=ylat+0.5*dyoutn
< ylatm=ylat-0.5*dyoutn
< if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
< hzone=dyoutn*r_earth*pi180
< else
<
< ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
< ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
< !************************************************************
<
< cosfactp=cos(ylatp*pi180)
< cosfactm=cos(ylatm*pi180)
< if (cosfactp.lt.cosfactm) then
< hzone=sqrt(1-cosfactp**2)- &
< sqrt(1-cosfactm**2)
< hzone=hzone*r_earth
< else
< hzone=sqrt(1-cosfactm**2)- &
< sqrt(1-cosfactp**2)
< hzone=hzone*r_earth
< endif
< endif
<
<
<
< ! Surface are of a grid cell at a latitude ylat
< !**********************************************
<
< gridarea=2.*pi*r_earth*hzone*dxoutn/360.
<
< do ix=0,numxgridn-1
< arean(ix,jy)=gridarea
<
< ! Volume = area x box height
< !***************************
<
< volumen(ix,jy,1)=arean(ix,jy)*outheight(1)
< do kz=2,numzgrid
< volumen(ix,jy,kz)=arean(ix,jy)*(outheight(kz)-outheight(kz-1))
< end do
< end do
< end do
<
<
< !**************************************************************************
< ! Determine average height of model topography in nesteed output grid cells
< !**************************************************************************
<
< ! Loop over all output grid cells
< !********************************
<
< do jjy=0,numygridn-1
< do iix=0,numxgridn-1
< oroh=0.
<
< ! Take 100 samples of the topography in every grid cell
< !******************************************************
<
< do j1=1,10
< ylat=outlat0n+(real(jjy)+real(j1)/10.-0.05)*dyoutn
< yl=(ylat-ylat0)/dy
< do i1=1,10
< xlon=outlon0n+(real(iix)+real(i1)/10.-0.05)*dxoutn
< xl=(xlon-xlon0)/dx
<
< ! Determine the nest we are in
< !*****************************
<
< ngrid=0
< do j=numbnests,1,-1
< if ((xl.gt.xln(j)+eps).and.(xl.lt.xrn(j)-eps).and. &
< (yl.gt.yln(j)+eps).and.(yl.lt.yrn(j)-eps)) then
< ngrid=j
< goto 43
< endif
< end do
< 43 continue
<
< ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
< !*****************************************************************************
<
< if (ngrid.gt.0) then
< xtn=(xl-xln(ngrid))*xresoln(ngrid)
< ytn=(yl-yln(ngrid))*yresoln(ngrid)
< ix=int(xtn)
< jy=int(ytn)
< ddy=ytn-real(jy)
< ddx=xtn-real(ix)
< else
< ix=int(xl)
< jy=int(yl)
< ddy=yl-real(jy)
< ddx=xl-real(ix)
< endif
< ixp=ix+1
< jyp=jy+1
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
<
< if (ngrid.gt.0) then
< oroh=oroh+p1*oron(ix ,jy ,ngrid) &
< + p2*oron(ixp,jy ,ngrid) &
< + p3*oron(ix ,jyp,ngrid) &
< + p4*oron(ixp,jyp,ngrid)
< else
< oroh=oroh+p1*oro(ix ,jy) &
< + p2*oro(ixp,jy) &
< + p3*oro(ix ,jyp) &
< + p4*oro(ixp,jyp)
< endif
< end do
< end do
<
< ! Divide by the number of samples taken
< !**************************************
<
< orooutn(iix,jjy)=oroh/100.
< end do
< end do
<
<
<
< !*******************************
< ! Initialization of output grids
< !*******************************
<
< do kp=1,maxpointspec_act
< do ks=1,nspec
< do nage=1,nageclass
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< do l=1,nclassunc
< ! Deposition fields
< if (ldirect.gt.0) then
< wetgriduncn(ix,jy,ks,kp,l,nage)=0.
< drygriduncn(ix,jy,ks,kp,l,nage)=0.
< endif
< ! Concentration fields
< do kz=1,numzgrid
< griduncn(ix,jy,kz,ks,kp,l,nage)=0.
< end do
< end do
< end do
< end do
< end do
< end do
< end do
<
<
< end subroutine outgrid_init_nest
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine outgrid_init_nest
>
> !*****************************************************************************
> ! *
> ! This routine calculates, for each grid cell of the output nest, the *
> ! volume and the surface area. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 30 August 2004 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! arean surface area of all output nest cells *
> ! volumen volumes of all output nest cells *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: ix,jy,kz,ks,kp,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid
> integer :: stat
> real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp
> real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh
> real,parameter :: eps=nxmax/3.e5
>
>
>
> ! gridunc,griduncn uncertainty of outputted concentrations
> allocate(griduncn(0:numxgridn-1,0:numygridn-1,numzgrid,maxspec, &
> maxpointspec_act,nclassunc,maxageclass),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
>
> if (ldirect.gt.0) then
> allocate(wetgriduncn(0:numxgridn-1,0:numygridn-1,maxspec, &
> maxpointspec_act,nclassunc,maxageclass),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
> allocate(drygriduncn(0:numxgridn-1,0:numygridn-1,maxspec, &
> maxpointspec_act,nclassunc,maxageclass),stat=stat)
> if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc'
> endif
>
> ! Compute surface area and volume of each grid cell: area, volume;
> ! and the areas of the northward and eastward facing walls: areaeast, areanorth
> !***********************************************************************
>
> do jy=0,numygridn-1
> ylat=outlat0n+(real(jy)+0.5)*dyoutn
> ylatp=ylat+0.5*dyoutn
> ylatm=ylat-0.5*dyoutn
> if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
> hzone=dyoutn*r_earth*pi180
> else
>
> ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
> ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
> !************************************************************
>
> cosfactp=cos(ylatp*pi180)
> cosfactm=cos(ylatm*pi180)
> if (cosfactp.lt.cosfactm) then
> hzone=sqrt(1-cosfactp**2)- &
> sqrt(1-cosfactm**2)
> hzone=hzone*r_earth
> else
> hzone=sqrt(1-cosfactm**2)- &
> sqrt(1-cosfactp**2)
> hzone=hzone*r_earth
> endif
> endif
>
>
>
> ! Surface are of a grid cell at a latitude ylat
> !**********************************************
>
> gridarea=2.*pi*r_earth*hzone*dxoutn/360.
>
> do ix=0,numxgridn-1
> arean(ix,jy)=gridarea
>
> ! Volume = area x box height
> !***************************
>
> volumen(ix,jy,1)=arean(ix,jy)*outheight(1)
> do kz=2,numzgrid
> volumen(ix,jy,kz)=arean(ix,jy)*(outheight(kz)-outheight(kz-1))
> end do
> end do
> end do
>
>
> !**************************************************************************
> ! Determine average height of model topography in nesteed output grid cells
> !**************************************************************************
>
> ! Loop over all output grid cells
> !********************************
>
> do jjy=0,numygridn-1
> do iix=0,numxgridn-1
> oroh=0.
>
> ! Take 100 samples of the topography in every grid cell
> !******************************************************
>
> do j1=1,10
> ylat=outlat0n+(real(jjy)+real(j1)/10.-0.05)*dyoutn
> yl=(ylat-ylat0)/dy
> do i1=1,10
> xlon=outlon0n+(real(iix)+real(i1)/10.-0.05)*dxoutn
> xl=(xlon-xlon0)/dx
>
> ! Determine the nest we are in
> !*****************************
>
> ngrid=0
> do j=numbnests,1,-1
> if ((xl.gt.xln(j)+eps).and.(xl.lt.xrn(j)-eps).and. &
> (yl.gt.yln(j)+eps).and.(yl.lt.yrn(j)-eps)) then
> ngrid=j
> goto 43
> endif
> end do
> 43 continue
>
> ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
> !*****************************************************************************
>
> if (ngrid.gt.0) then
> xtn=(xl-xln(ngrid))*xresoln(ngrid)
> ytn=(yl-yln(ngrid))*yresoln(ngrid)
> ix=int(xtn)
> jy=int(ytn)
> ddy=ytn-real(jy)
> ddx=xtn-real(ix)
> else
> ix=int(xl)
> jy=int(yl)
> ddy=yl-real(jy)
> ddx=xl-real(ix)
> endif
> ixp=ix+1
> jyp=jy+1
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
>
> if (ngrid.gt.0) then
> oroh=oroh+p1*oron(ix ,jy ,ngrid) &
> + p2*oron(ixp,jy ,ngrid) &
> + p3*oron(ix ,jyp,ngrid) &
> + p4*oron(ixp,jyp,ngrid)
> else
> oroh=oroh+p1*oro(ix ,jy) &
> + p2*oro(ixp,jy) &
> + p3*oro(ix ,jyp) &
> + p4*oro(ixp,jyp)
> endif
> end do
> end do
>
> ! Divide by the number of samples taken
> !**************************************
>
> orooutn(iix,jjy)=oroh/100.
> end do
> end do
>
>
>
> !*******************************
> ! Initialization of output grids
> !*******************************
>
> do kp=1,maxpointspec_act
> do ks=1,nspec
> do nage=1,nageclass
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> do l=1,nclassunc
> ! Deposition fields
> if (ldirect.gt.0) then
> wetgriduncn(ix,jy,ks,kp,l,nage)=0.
> drygriduncn(ix,jy,ks,kp,l,nage)=0.
> endif
> ! Concentration fields
> do kz=1,numzgrid
> griduncn(ix,jy,kz,ks,kp,l,nage)=0.
> end do
> end do
> end do
> end do
> end do
> end do
> end do
>
>
> end subroutine outgrid_init_nest
par_mod.f90
----------------------------------------------
1,261c1,266
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< !*******************************************************************************
< ! Include file for calculation of particle trajectories (Program FLEXPART) *
< ! This file contains the parameter statements used in FLEXPART *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 1997 *
< ! *
< ! Last update 10 August 2000 *
< ! *
< !*******************************************************************************
<
< module par_mod
<
< implicit none
<
< !****************************************************************
< ! Parameter defining KIND parameter for "double precision"
< !****************************************************************
<
< integer,parameter :: dp=selected_real_kind(P=15)
<
<
< !***********************************************************
< ! Number of directories/files used for FLEXPART input/output
< !***********************************************************
<
< integer,parameter :: numpath=4
<
< ! numpath Number of different pathnames for input/output files
<
<
< !*****************************
< ! Physical and other constants
< !*****************************
<
< real,parameter :: pi=3.14159265, r_earth=6.371e6, r_air=287.05, ga=9.81
< real,parameter :: cpa=1004.6, kappa=0.286, pi180=pi/180., vonkarman=0.4
<
< ! pi number "pi"
< ! pi180 pi/180.
< ! r_earth radius of earth [m]
< ! r_air individual gas constant for dry air [J/kg/K]
< ! ga gravity acceleration of earth [m/s**2]
< ! cpa specific heat for dry air
< ! kappa exponent of formula for potential temperature
< ! vonkarman von Karman constant
<
< real,parameter :: karman=0.40, href=15., convke=2.0
< real,parameter :: hmixmin=100., hmixmax=4500., turbmesoscale=0.16
< real,parameter :: d_trop=50., d_strat=0.1
<
< ! karman Karman's constant
< ! href [m] Reference height for dry deposition
< ! konvke Relative share of kinetic energy used for parcel lifting
< ! hmixmin,hmixmax Minimum and maximum allowed PBL height
< ! turbmesoscale the factor by which standard deviations of winds at grid
< ! points surrounding the particle positions are scaled to
< ! yield the scales for the mesoscale wind velocity fluctuations
< ! d_trop [m2/s] Turbulent diffusivity for horizontal components in the troposphere
< ! d_strat [m2/s] Turbulent diffusivity for vertical component in the stratosphere
<
< real,parameter :: xmwml=18.016/28.960
<
< ! xmwml ratio of molar weights of water vapor and dry air
< !****************************************************
< ! Constants related to the stratospheric ozone tracer
< !****************************************************
<
< real,parameter :: ozonescale=60., pvcrit=2.0
<
< ! ozonescale ppbv O3 per PV unit
< ! pvcrit PV level of the tropopause
<
<
<
< !********************
< ! Some time constants
< !********************
<
< integer,parameter :: idiffnorm=10800, idiffmax=2*idiffnorm, minstep=1
<
< ! idiffnorm [s] normal time interval between two wind fields
< ! idiffmax [s] maximum time interval between two wind fields
< ! minstep [s] minimum time step to be used within FLEXPART
<
<
< !*****************************************************************
< ! Parameters for polar stereographic projection close to the poles
< !*****************************************************************
<
< real,parameter :: switchnorth=75., switchsouth=-75.
<
< ! switchnorth use polar stereographic grid north of switchnorth
< ! switchsouth use polar stereographic grid south of switchsouth
<
<
< !*********************************************
< ! Maximum dimensions of the input mother grids
< !*********************************************
<
< integer,parameter :: nxmax=361,nymax=181,nuvzmax=92,nwzmax=92,nzmax=92
< !integer,parameter :: nxmax=361,nymax=181,nuvzmax=26,nwzmax=26,nzmax=26
< !integer,parameter :: nxmax=721,nymax=361,nuvzmax=64,nwzmax=64,nzmax=64
< !integer,parameter :: nxmax=1201,nymax=235,nuvzmax=58,nwzmax=58,nzmax=58
< integer,parameter :: nxshift=359 ! for ECMWF
< !integer,parameter :: nxshift=0 ! for GFS
<
< integer,parameter :: nconvlevmax = nuvzmax-1
< integer,parameter :: na = nconvlevmax+1
<
<
< ! nxmax,nymax maximum dimension of wind fields in x and y
< ! direction, respectively
< ! nuvzmax,nwzmax maximum dimension of (u,v) and (w) wind fields in z
< ! direction (for fields on eta levels)
< ! nzmax maximum dimension of wind fields in z direction
< ! for the transformed Cartesian coordinates
< ! nxshift for global grids (in x), the grid can be shifted by
< ! nxshift grid points, in order to accomodate nested
< ! grids, and output grids overlapping the domain "boundary"
< ! nxshift must not be negative; "normal" setting would be 0
< ! ntracermax maximum number of tracer species in convection
< ! nconvlevmax maximum number of levels for convection
< ! na parameter used in Emanuel's convect subroutine
<
<
< !*********************************************
< ! Maximum dimensions of the nested input grids
< !*********************************************
<
< integer,parameter :: maxnests=0, nxmaxn=0, nymaxn=0
< !integer,parameter :: maxnests=1,nxmaxn=251,nymaxn=151
<
< ! maxnests maximum number of nested grids
< ! nxmaxn,nymaxn maximum dimension of nested wind fields in
< ! x and y direction, respectively
<
<
< !*********************************
< ! Parmaters for GRIB file decoding
< !*********************************
<
< integer,parameter :: jpack=4*nxmax*nymax, jpunp=4*jpack
<
< ! jpack,jpunp maximum dimensions needed for GRIB file decoding
<
<
< !**************************************
< ! Maximum dimensions of the output grid
< !**************************************
<
< !integer,parameter :: maxageclass=1,maxzgrid=10,nclassunc=1
< integer,parameter :: maxageclass=1,nclassunc=1
<
< ! nclassunc number of classes used to calculate the uncertainty
< ! of the output
< ! maxageclass maximum number of age classes used for output
<
< ! Sabine Eckhardt, June, 2008
< ! the dimensions of the OUTGRID are now set dynamically during runtime
< ! maxxgrid,maxygrid,maxzgrid maximum dimensions in x,y,z direction
< ! maxxgridn,maxygridn maximum dimension of the nested grid
< !integer maxxgrid,maxygrid,maxzgrid,maxxgridn,maxygridn
< !integer,parameter :: maxxgrid=361,maxygrid=181,maxxgridn=0,maxygridn=0)
<
< integer,parameter :: maxreceptor=200
<
< ! maxreceptor maximum number of receptor points
<
<
< !**************************************************
< ! Maximum number of particles, species, and similar
< !**************************************************
<
< integer,parameter :: maxpart=150000
< integer,parameter :: maxspec=1
<
<
< ! maxpart Maximum number of particles
< ! maxspec Maximum number of chemical species per release
<
< ! maxpoint is also set dynamically during runtime
< ! maxpoint Maximum number of release locations
<
< ! ---------
< ! Sabine Eckhardt: change of landuse inventary numclass=13
< ! ---------
< integer,parameter :: maxwf=50000, maxtable=1000, numclass=13, ni=11
<
< ! maxwf maximum number of wind fields to be used for simulation
< ! maxtable Maximum number of chemical species that can be
< ! tabulated for FLEXPART
< ! numclass Number of landuse classes available to FLEXPART
< ! ni Number of diameter classes of particles
<
< !**************************************************************************
< ! dimension of the OH field
< !**************************************************************************
< integer,parameter :: maxxOH=72, maxyOH=46, maxzOH=7
<
< !**************************************************************************
< ! Maximum number of particles to be released in a single atmospheric column
< ! for the domain-filling trajectories option
< !**************************************************************************
<
< integer,parameter :: maxcolumn=3000
<
<
< !*********************************
< ! Dimension of random number field
< !*********************************
<
< integer,parameter :: maxrand=2000000
<
< ! maxrand number of random numbers used
<
<
< !*****************************************************
< ! Number of clusters to be used for plume trajectories
< !*****************************************************
<
< integer,parameter :: ncluster=5
<
< !************************************
< ! Unit numbers for input/output files
< !************************************
<
< integer,parameter :: unitpath=1, unitcommand=1, unitageclasses=1, unitgrid=1
< integer,parameter :: unitavailab=1, unitreleases=88, unitpartout=93
< integer,parameter :: unitpartin=93, unitflux=98, unitouttraj=96
< integer,parameter :: unitvert=1, unitoro=1, unitpoin=1, unitreceptor=1
< integer,parameter :: unitoutgrid=97, unitoutgridppt=99, unitoutinfo=1
< integer,parameter :: unitspecies=1, unitoutrecept=91, unitoutreceptppt=92
< integer,parameter :: unitlsm=1, unitsurfdata=1, unitland=1, unitwesely=1
< integer,parameter :: unitOH=1
< integer,parameter :: unitdates=94, unitheader=90, unitshortpart=95
< integer,parameter :: unitboundcond=89
<
< end module par_mod
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> !*******************************************************************************
> ! Include file for calculation of particle trajectories (Program FLEXPART) *
> ! This file contains the parameter statements used in FLEXPART *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 1997 *
> ! *
> ! Last update 10 August 2000 *
> ! *
> !*******************************************************************************
>
> module par_mod
>
> implicit none
>
> !****************************************************************
> ! Parameter defining KIND parameter for "double precision"
> !****************************************************************
>
> integer,parameter :: dp=selected_real_kind(P=15)
>
>
> !***********************************************************
> ! Number of directories/files used for FLEXPART input/output
> !***********************************************************
>
> integer,parameter :: numpath=4
>
> ! numpath Number of different pathnames for input/output files
>
>
> !*****************************
> ! Physical and other constants
> !*****************************
>
> real,parameter :: pi=3.14159265, r_earth=6.371e6, r_air=287.05, ga=9.81
> real,parameter :: cpa=1004.6, kappa=0.286, pi180=pi/180., vonkarman=0.4
>
> ! pi number "pi"
> ! pi180 pi/180.
> ! r_earth radius of earth [m]
> ! r_air individual gas constant for dry air [J/kg/K]
> ! ga gravity acceleration of earth [m/s**2]
> ! cpa specific heat for dry air
> ! kappa exponent of formula for potential temperature
> ! vonkarman von Karman constant
>
> real,parameter :: karman=0.40, href=15., convke=2.0
> real,parameter :: hmixmin=100., hmixmax=4500., turbmesoscale=0. !0.16
> real,parameter :: d_trop=50., d_strat=0.1
>
> ! karman Karman's constant
> ! href [m] Reference height for dry deposition
> ! konvke Relative share of kinetic energy used for parcel lifting
> ! hmixmin,hmixmax Minimum and maximum allowed PBL height
> ! turbmesoscale the factor by which standard deviations of winds at grid
> ! points surrounding the particle positions are scaled to
> ! yield the scales for the mesoscale wind velocity fluctuations
> ! d_trop [m2/s] Turbulent diffusivity for horizontal components in the troposphere
> ! d_strat [m2/s] Turbulent diffusivity for vertical component in the stratosphere
>
> real,parameter :: xmwml=18.016/28.960
>
> ! xmwml ratio of molar weights of water vapor and dry air
> !****************************************************
> ! Constants related to the stratospheric ozone tracer
> !****************************************************
>
> real,parameter :: ozonescale=60., pvcrit=2.0
>
> ! ozonescale ppbv O3 per PV unit
> ! pvcrit PV level of the tropopause
>
>
>
> !********************
> ! Some time constants
> !********************
>
> integer,parameter :: idiffnorm=10800, idiffmax=2*idiffnorm, minstep=1
>
> ! idiffnorm [s] normal time interval between two wind fields
> ! idiffmax [s] maximum time interval between two wind fields
> ! minstep [s] minimum time step to be used within FLEXPART
>
>
> !*****************************************************************
> ! Parameters for polar stereographic projection close to the poles
> !*****************************************************************
>
> real,parameter :: switchnorth=75., switchsouth=-75.
>
> ! switchnorth use polar stereographic grid north of switchnorth
> ! switchsouth use polar stereographic grid south of switchsouth
>
>
> !*********************************************
> ! Maximum dimensions of the input mother grids
> !*********************************************
>
> integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138
> !integer,parameter :: nxmax=361,nymax=181,nuvzmax=61,nwzmax=61,nzmax=61
> !integer,parameter :: nxmax=721,nymax=361,nuvzmax=64,nwzmax=64,nzmax=64
> ! integer,parameter :: nxshift=359 ! for ECMWF
> integer,parameter :: nxshift=0 ! for GFS
>
> integer,parameter :: nconvlevmax = nuvzmax-1
> integer,parameter :: na = nconvlevmax+1
>
>
> ! nxmax,nymax maximum dimension of wind fields in x and y
> ! direction, respectively
> ! nuvzmax,nwzmax maximum dimension of (u,v) and (w) wind fields in z
> ! direction (for fields on eta levels)
> ! nzmax maximum dimension of wind fields in z direction
> ! for the transformed Cartesian coordinates
> ! nxshift for global grids (in x), the grid can be shifted by
> ! nxshift grid points, in order to accomodate nested
> ! grids, and output grids overlapping the domain "boundary"
> ! nxshift must not be negative; "normal" setting would be 0
> ! ntracermax maximum number of tracer species in convection
> ! nconvlevmax maximum number of levels for convection
> ! na parameter used in Emanuel's convect subroutine
>
>
> !*********************************************
> ! Maximum dimensions of the nested input grids
> !*********************************************
>
> integer,parameter :: maxnests=1, nxmaxn=151, nymaxn=151
> !integer,parameter :: maxnests=1,nxmaxn=251,nymaxn=151
>
> ! maxnests maximum number of nested grids
> ! nxmaxn,nymaxn maximum dimension of nested wind fields in
> ! x and y direction, respectively
>
>
> !*********************************
> ! Parmaters for GRIB file decoding
> !*********************************
>
> integer,parameter :: jpack=4*nxmax*nymax, jpunp=4*jpack
>
> ! jpack,jpunp maximum dimensions needed for GRIB file decoding
>
>
> !**************************************
> ! Maximum dimensions of the output grid
> !**************************************
>
> !integer,parameter :: maxageclass=1,maxzgrid=10,nclassunc=1
> integer,parameter :: maxageclass=1
>
> #if (defined _OPENMP)
> integer :: nclassunc=1
> #else
> integer,parameter :: nclassunc=1
> #endif
>
> ! nclassunc number of classes used to calculate the uncertainty
> ! of the output
> ! maxageclass maximum number of age classes used for output
>
> ! Sabine Eckhardt, June, 2008
> ! the dimensions of the OUTGRID are now set dynamically during runtime
> ! maxxgrid,maxygrid,maxzgrid maximum dimensions in x,y,z direction
> ! maxxgridn,maxygridn maximum dimension of the nested grid
> !integer maxxgrid,maxygrid,maxzgrid,maxxgridn,maxygridn
> !integer,parameter :: maxxgrid=361,maxygrid=181,maxxgridn=0,maxygridn=0)
>
> integer,parameter :: maxreceptor=200
>
> ! maxreceptor maximum number of receptor points
>
>
> !**************************************************
> ! Maximum number of particles, species, and similar
> !**************************************************
>
> integer,parameter :: maxpart=3000000
> integer,parameter :: maxspec=2
>
>
> ! maxpart Maximum number of particles
> ! maxspec Maximum number of chemical species per release
>
> ! maxpoint is also set dynamically during runtime
> ! maxpoint Maximum number of release locations
>
> ! ---------
> ! Sabine Eckhardt: change of landuse inventary numclass=13
> ! ---------
> integer,parameter :: maxwf=50000, maxtable=1000, numclass=13, ni=11
>
> ! maxwf maximum number of wind fields to be used for simulation
> ! maxtable Maximum number of chemical species that can be
> ! tabulated for FLEXPART
> ! numclass Number of landuse classes available to FLEXPART
> ! ni Number of diameter classes of particles
>
> !**************************************************************************
> ! dimension of the OH field
> !**************************************************************************
> integer,parameter :: maxxOH=72, maxyOH=46, maxzOH=7
>
> !**************************************************************************
> ! Maximum number of particles to be released in a single atmospheric column
> ! for the domain-filling trajectories option
> !**************************************************************************
>
> integer,parameter :: maxcolumn=3000
>
>
> !*********************************
> ! Dimension of random number field
> !*********************************
>
> integer,parameter :: maxrand=2000000
>
> ! maxrand number of random numbers used
>
>
> !*****************************************************
> ! Number of clusters to be used for plume trajectories
> !*****************************************************
>
> integer,parameter :: ncluster=5
>
> !************************************
> ! Unit numbers for input/output files
> !************************************
>
> integer,parameter :: unitpath=1, unitcommand=1, unitageclasses=1, unitgrid=1
> integer,parameter :: unitavailab=1, unitreleases=88, unitpartout=93
> integer,parameter :: unitpartin=93, unitflux=98, unitouttraj=96
> integer,parameter :: unitvert=1, unitoro=1, unitpoin=1, unitreceptor=1
> integer,parameter :: unitoutgrid=97, unitoutgridppt=99, unitoutinfo=1
> integer,parameter :: unitspecies=1, unitoutrecept=91, unitoutreceptppt=92
> integer,parameter :: unitlsm=1, unitsurfdata=1, unitland=1, unitwesely=1
> integer,parameter :: unitOH=1
> integer,parameter :: unitdates=94, unitheader=90, unitshortpart=95
> integer,parameter :: unitboundcond=89
>
> end module par_mod
part0.f90
----------------------------------------------
1,136c1,136
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine part0(dquer,dsigma,density,fract,schmi,cun,vsh)
< ! i i i o o o o
< !*****************************************************************************
< ! *
< ! Calculation of time independent factors of the dry deposition of *
< ! particles: *
< ! Log-Normal-distribution of mass [dM/dlog(dp)], unimodal *
< ! *
< ! AUTHOR: Matthias Langer, adapted by Andreas Stohl, 13 November 1993 *
< ! *
< ! Literature: *
< ! [1] Scire/Yamartino/Carmichael/Chang (1989), *
< ! CALGRID: A Mesoscale Photochemical Grid Model. *
< ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! alpha help variable *
< ! cun 'slip-flow' correction after Cunningham *
< ! d01 [um] upper diameter *
< ! d02 [um] lower diameter *
< ! dc [m2/s] coefficient of Brownian diffusion *
< ! delta distance given in standard deviation units *
< ! density [kg/m3] density of the particle *
< ! dmean geometric mean diameter of interval *
< ! dquer [um] geometric mass mean particle diameter *
< ! dsigma e.g. dsigma=10 or dsigma=0.1 means that 68% of the mass *
< ! are between 0.1*dquer and 10*dquer *
< ! fract(ni) mass fraction of each diameter interval *
< ! kn Knudsen number *
< ! ni number of diameter intervals, for which deposition *
< ! is calculated *
< ! schmidt Schmidt number *
< ! schmi schmidt**2/3 *
< ! vsh [m/s] gravitational settling velocity of the particle *
< ! x01 normalized upper diameter *
< ! x02 normalized lower diameter *
< ! *
< ! Constants: *
< ! g [m/s2] Acceleration of gravity *
< ! kb [J/K] Stefan-Boltzmann constant *
< ! lam [m] mean free path of air molecules *
< ! myl [kg/m/s] dynamical viscosity of air *
< ! nyl [m2/s] kinematic viscosity of air *
< ! tr reference temperature *
< ! *
< ! Function: *
< ! erf calculates the integral of the Gauss function *
< ! *
< !*****************************************************************************
<
< use par_mod
<
< implicit none
<
< real,parameter :: tr=293.15
<
< integer :: i
< real :: dquer,dsigma,density,xdummy,d01,d02,delta,x01,x02,fract(ni)
< real :: dmean,alpha,cun,dc,schmidt,schmi(ni),vsh(ni),kn,erf
< real,parameter :: myl=1.81e-5,nyl=0.15e-4
< real,parameter :: lam=6.53e-8,kb=1.38e-23,eps=1.2e-38
<
<
< ! xdummy constant for all intervals
< !**********************************
<
< xdummy=sqrt(2.)*alog(dsigma)
<
<
< ! particles diameters are split up to ni intervals between
< ! dquer-3*dsigma and dquer+3*dsigma
< !*********************************************************
<
< delta=6./real(ni)
<
< d01=dquer*dsigma**(-3)
< do i=1,ni
< d02=d01
< d01=dquer*dsigma**(-3.+delta*real(i))
< x01=alog(d01/dquer)/xdummy
< x02=alog(d02/dquer)/xdummy
<
<
< ! Area under Gauss-function is calculated and gives mass fraction of interval
< !****************************************************************************
<
< fract(i)=0.5*(erf(x01)-erf(x02))
<
<
< ! Geometric mean diameter of interval in [m]
< !*******************************************
<
< dmean=1.E-6*exp(0.5*alog(d01*d02))
<
<
< ! Calculation of time independent parameters of each interval
< !************************************************************
<
< kn=2.*lam/dmean
< if ((-1.1/kn).le.log10(eps)*log(10.)) then
< alpha=1.257
< else
< alpha=1.257+0.4*exp(-1.1/kn)
< endif
< cun=1.+alpha*kn
< dc=kb*tr*cun/(3.*pi*myl*dmean)
< schmidt=nyl/dc
< schmi(i)=schmidt**(-2./3.)
< vsh(i)=ga*density*dmean*dmean*cun/(18.*myl)
<
< end do
<
< end subroutine part0
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine part0(dquer,dsigma,density,fract,schmi,cun,vsh)
> ! i i i o o o o
> !*****************************************************************************
> ! *
> ! Calculation of time independent factors of the dry deposition of *
> ! particles: *
> ! Log-Normal-distribution of mass [dM/dlog(dp)], unimodal *
> ! *
> ! AUTHOR: Matthias Langer, adapted by Andreas Stohl, 13 November 1993 *
> ! *
> ! Literature: *
> ! [1] Scire/Yamartino/Carmichael/Chang (1989), *
> ! CALGRID: A Mesoscale Photochemical Grid Model. *
> ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! alpha help variable *
> ! cun 'slip-flow' correction after Cunningham *
> ! d01 [um] upper diameter *
> ! d02 [um] lower diameter *
> ! dc [m2/s] coefficient of Brownian diffusion *
> ! delta distance given in standard deviation units *
> ! density [kg/m3] density of the particle *
> ! dmean geometric mean diameter of interval *
> ! dquer [um] geometric mass mean particle diameter *
> ! dsigma e.g. dsigma=10 or dsigma=0.1 means that 68% of the mass *
> ! are between 0.1*dquer and 10*dquer *
> ! fract(ni) mass fraction of each diameter interval *
> ! kn Knudsen number *
> ! ni number of diameter intervals, for which deposition *
> ! is calculated *
> ! schmidt Schmidt number *
> ! schmi schmidt**2/3 *
> ! vsh [m/s] gravitational settling velocity of the particle *
> ! x01 normalized upper diameter *
> ! x02 normalized lower diameter *
> ! *
> ! Constants: *
> ! g [m/s2] Acceleration of gravity *
> ! kb [J/K] Stefan-Boltzmann constant *
> ! lam [m] mean free path of air molecules *
> ! myl [kg/m/s] dynamical viscosity of air *
> ! nyl [m2/s] kinematic viscosity of air *
> ! tr reference temperature *
> ! *
> ! Function: *
> ! erf calculates the integral of the Gauss function *
> ! *
> !*****************************************************************************
>
> use par_mod
>
> implicit none
>
> real,parameter :: tr=293.15
>
> integer :: i
> real :: dquer,dsigma,density,xdummy,d01,d02,delta,x01,x02,fract(ni)
> real :: dmean,alpha,cun,dc,schmidt,schmi(ni),vsh(ni),kn,erf
> real,parameter :: myl=1.81e-5,nyl=0.15e-4
> real,parameter :: lam=6.53e-8,kb=1.38e-23,eps=1.2e-38
>
>
> ! xdummy constant for all intervals
> !**********************************
>
> xdummy=sqrt(2.)*alog(dsigma)
>
>
> ! particles diameters are split up to ni intervals between
> ! dquer-3*dsigma and dquer+3*dsigma
> !*********************************************************
>
> delta=6./real(ni)
>
> d01=dquer*dsigma**(-3)
> do i=1,ni
> d02=d01
> d01=dquer*dsigma**(-3.+delta*real(i))
> x01=alog(d01/dquer)/xdummy
> x02=alog(d02/dquer)/xdummy
>
>
> ! Area under Gauss-function is calculated and gives mass fraction of interval
> !****************************************************************************
>
> fract(i)=0.5*(erf(x01)-erf(x02))
>
>
> ! Geometric mean diameter of interval in [m]
> !*******************************************
>
> dmean=1.E-6*exp(0.5*alog(d01*d02))
>
>
> ! Calculation of time independent parameters of each interval
> !************************************************************
>
> kn=2.*lam/dmean
> if ((-1.1/kn).le.log10(eps)*log(10.)) then
> alpha=1.257
> else
> alpha=1.257+0.4*exp(-1.1/kn)
> endif
> cun=1.+alpha*kn
> dc=kb*tr*cun/(3.*pi*myl*dmean)
> schmidt=nyl/dc
> schmi(i)=schmidt**(-2./3.)
> vsh(i)=ga*density*dmean*dmean*cun/(18.*myl)
>
> end do
>
> end subroutine part0
partdep.f90
----------------------------------------------
1,116c1,116
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine partdep(nc,density,fract,schmi,vset,ra,ustar,nyl,vdep)
< ! i i i i i i i i i/o
< !*****************************************************************************
< ! *
< ! Calculation of the dry deposition velocities of particles. *
< ! This routine is based on Stokes' law for considering settling and *
< ! assumes constant dynamic viscosity of the air. *
< ! *
< ! AUTHOR: Andreas Stohl, 12 November 1993 *
< ! Update: 20 December 1996 *
< ! *
< ! Literature: *
< ! [1] Hicks/Baldocchi/Meyers/Hosker/Matt (1987), A Preliminary *
< ! Multiple Resistance Routine for Deriving Dry Deposition *
< ! Velocities from Measured Quantities. *
< ! Water, Air and Soil Pollution 36 (1987), pp.311-330. *
< ! [2] Slinn (1982), Predictions for Particle Deposition to *
< ! Vegetative Canopies. Atm.Env.16-7 (1982), pp.1785-1794. *
< ! [3] Slinn/Slinn (1980), Predictions for Particle Deposition on *
< ! Natural Waters. Atm.Env.14 (1980), pp.1013-1016. *
< ! [4] Scire/Yamartino/Carmichael/Chang (1989), *
< ! CALGRID: A Mesoscale Photochemical Grid Model. *
< ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
< ! [5] Langer M. (1992): Ein einfaches Modell zur Abschaetzung der *
< ! Depositionsgeschwindigkeit von Teilchen und Gasen. *
< ! Internal report. *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! alpha help variable *
< ! fract(nc,ni) mass fraction of each diameter interval *
< ! lpdep(nc) 1 for particle deposition, 0 else *
< ! nc actual number of chemical components *
< ! ni number of diameter intervals, for which vdepj is calc.*
< ! rdp [s/m] deposition layer resistance *
< ! ra [s/m] aerodynamical resistance *
< ! schmi(nc,ni) Schmidt number**2/3 of each diameter interval *
< ! stokes Stokes number *
< ! ustar [m/s] friction velocity *
< ! vdep(nc) [m/s] deposition velocities of all components *
< ! vdepj [m/s] help, deposition velocity of 1 interval *
< ! vset(nc,ni) gravitational settling velocity of each interval *
< ! *
< ! Constants: *
< ! nc number of chemical species *
< ! ni number of diameter intervals, for which deposition *
< ! is calculated *
< ! *
< !*****************************************************************************
<
< use par_mod
<
< implicit none
<
< real :: density(maxspec),schmi(maxspec,ni),fract(maxspec,ni)
< real :: vset(maxspec,ni)
< real :: vdep(maxspec),stokes,vdepj,rdp,ustar,alpha,ra,nyl
< real,parameter :: eps=1.e-5
< integer :: ic,j,nc
<
<
< do ic=1,nc ! loop over all species
< if (density(ic).gt.0.) then
< do j=1,ni ! loop over all diameter intervals
< if (ustar.gt.eps) then
<
< ! Stokes number for each diameter interval
< !*****************************************
<
< stokes=vset(ic,j)/ga*ustar*ustar/nyl
< alpha=-3./stokes
<
< ! Deposition layer resistance
< !****************************
<
< if (alpha.le.log10(eps)) then
< rdp=1./(schmi(ic,j)*ustar)
< else
< rdp=1./((schmi(ic,j)+10.**alpha)*ustar)
< endif
< vdepj=vset(ic,j)+1./(ra+rdp+ra*rdp*vset(ic,j))
< else
< vdepj=vset(ic,j)
< endif
<
< ! deposition velocities of each interval are weighted with mass fraction
< !***********************************************************************
<
< vdep(ic)=vdep(ic)+vdepj*fract(ic,j)
< end do
< endif
< end do
<
< end subroutine partdep
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine partdep(nc,density,fract,schmi,vset,ra,ustar,nyl,vdep)
> ! i i i i i i i i i/o
> !*****************************************************************************
> ! *
> ! Calculation of the dry deposition velocities of particles. *
> ! This routine is based on Stokes' law for considering settling and *
> ! assumes constant dynamic viscosity of the air. *
> ! *
> ! AUTHOR: Andreas Stohl, 12 November 1993 *
> ! Update: 20 December 1996 *
> ! *
> ! Literature: *
> ! [1] Hicks/Baldocchi/Meyers/Hosker/Matt (1987), A Preliminary *
> ! Multiple Resistance Routine for Deriving Dry Deposition *
> ! Velocities from Measured Quantities. *
> ! Water, Air and Soil Pollution 36 (1987), pp.311-330. *
> ! [2] Slinn (1982), Predictions for Particle Deposition to *
> ! Vegetative Canopies. Atm.Env.16-7 (1982), pp.1785-1794. *
> ! [3] Slinn/Slinn (1980), Predictions for Particle Deposition on *
> ! Natural Waters. Atm.Env.14 (1980), pp.1013-1016. *
> ! [4] Scire/Yamartino/Carmichael/Chang (1989), *
> ! CALGRID: A Mesoscale Photochemical Grid Model. *
> ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
> ! [5] Langer M. (1992): Ein einfaches Modell zur Abschaetzung der *
> ! Depositionsgeschwindigkeit von Teilchen und Gasen. *
> ! Internal report. *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! alpha help variable *
> ! fract(nc,ni) mass fraction of each diameter interval *
> ! lpdep(nc) 1 for particle deposition, 0 else *
> ! nc actual number of chemical components *
> ! ni number of diameter intervals, for which vdepj is calc.*
> ! rdp [s/m] deposition layer resistance *
> ! ra [s/m] aerodynamical resistance *
> ! schmi(nc,ni) Schmidt number**2/3 of each diameter interval *
> ! stokes Stokes number *
> ! ustar [m/s] friction velocity *
> ! vdep(nc) [m/s] deposition velocities of all components *
> ! vdepj [m/s] help, deposition velocity of 1 interval *
> ! vset(nc,ni) gravitational settling velocity of each interval *
> ! *
> ! Constants: *
> ! nc number of chemical species *
> ! ni number of diameter intervals, for which deposition *
> ! is calculated *
> ! *
> !*****************************************************************************
>
> use par_mod
>
> implicit none
>
> real :: density(maxspec),schmi(maxspec,ni),fract(maxspec,ni)
> real :: vset(maxspec,ni)
> real :: vdep(maxspec),stokes,vdepj,rdp,ustar,alpha,ra,nyl
> real,parameter :: eps=1.e-5
> integer :: ic,j,nc
>
>
> do ic=1,nc ! loop over all species
> if (density(ic).gt.0.) then
> do j=1,ni ! loop over all diameter intervals
> if (ustar.gt.eps) then
>
> ! Stokes number for each diameter interval
> !*****************************************
>
> stokes=vset(ic,j)/ga*ustar*ustar/nyl
> alpha=-3./stokes
>
> ! Deposition layer resistance
> !****************************
>
> if (alpha.le.log10(eps)) then
> rdp=1./(schmi(ic,j)*ustar)
> else
> rdp=1./((schmi(ic,j)+10.**alpha)*ustar)
> endif
> vdepj=vset(ic,j)+1./(ra+rdp+ra*rdp*vset(ic,j))
> else
> vdepj=vset(ic,j)
> endif
>
> ! deposition velocities of each interval are weighted with mass fraction
> !***********************************************************************
>
> vdep(ic)=vdep(ic)+vdepj*fract(ic,j)
> end do
> endif
> end do
>
> end subroutine partdep
partoutput.f90
----------------------------------------------
1,209c1,209
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine partoutput(itime)
< ! i
< !*****************************************************************************
< ! *
< ! Dump all particle positions *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 12 March 1999 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< real(kind=dp) :: jul
< integer :: itime,i,j,jjjjmmdd,ihmmss
< integer :: ix,jy,ixp,jyp,indexh,m,il,ind,indz,indzp
< real :: xlon,ylat
< real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
< real :: topo,hm(2),hmixi,pv1(2),pvprof(2),pvi,qv1(2),qvprof(2),qvi
< real :: tt1(2),ttprof(2),tti,rho1(2),rhoprof(2),rhoi
< real :: tr(2),tri
< character :: adate*8,atime*6
<
<
< ! Determine current calendar date, needed for the file name
< !**********************************************************
<
< jul=bdate+real(itime,kind=dp)/86400._dp
< call caldate(jul,jjjjmmdd,ihmmss)
< write(adate,'(i8.8)') jjjjmmdd
< write(atime,'(i6.6)') ihmmss
<
<
< ! Some variables needed for temporal interpolation
< !*************************************************
<
< dt1=real(itime-memtime(1))
< dt2=real(memtime(2)-itime)
< dtt=1./(dt1+dt2)
<
< ! Open output file and write the output
< !**************************************
<
< if (ipout.eq.1) then
< open(unitpartout,file=path(2)(1:length(2))//'partposit_'//adate// &
< atime,form='unformatted')
< else
< open(unitpartout,file=path(2)(1:length(2))//'partposit_end', &
< form='unformatted')
< endif
<
< ! Write current time to file
< !***************************
<
< write(unitpartout) itime
< do i=1,numpart
<
< ! Take only valid particles
< !**************************
<
< if (itra1(i).eq.itime) then
< xlon=xlon0+xtra1(i)*dx
< ylat=ylat0+ytra1(i)*dy
<
< !*****************************************************************************
< ! Interpolate several variables (PV, specific humidity, etc.) to particle position
< !*****************************************************************************
<
< ix=xtra1(i)
< jy=ytra1(i)
< ixp=ix+1
< jyp=jy+1
< ddx=xtra1(i)-real(ix)
< ddy=ytra1(i)-real(jy)
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
<
< ! Topography
< !***********
<
< topo=p1*oro(ix ,jy) &
< + p2*oro(ixp,jy) &
< + p3*oro(ix ,jyp) &
< + p4*oro(ixp,jyp)
<
< ! Potential vorticity, specific humidity, temperature, and density
< !*****************************************************************
<
< do il=2,nz
< if (height(il).gt.ztra1(i)) then
< indz=il-1
< indzp=il
< goto 6
< endif
< end do
< 6 continue
<
< dz1=ztra1(i)-height(indz)
< dz2=height(indzp)-ztra1(i)
< dz=1./(dz1+dz2)
<
<
< do ind=indz,indzp
< do m=1,2
< indexh=memind(m)
<
< ! Potential vorticity
< pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
< +p2*pv(ixp,jy ,ind,indexh) &
< +p3*pv(ix ,jyp,ind,indexh) &
< +p4*pv(ixp,jyp,ind,indexh)
< ! Specific humidity
< qv1(m)=p1*qv(ix ,jy ,ind,indexh) &
< +p2*qv(ixp,jy ,ind,indexh) &
< +p3*qv(ix ,jyp,ind,indexh) &
< +p4*qv(ixp,jyp,ind,indexh)
< ! Temperature
< tt1(m)=p1*tt(ix ,jy ,ind,indexh) &
< +p2*tt(ixp,jy ,ind,indexh) &
< +p3*tt(ix ,jyp,ind,indexh) &
< +p4*tt(ixp,jyp,ind,indexh)
< ! Density
< rho1(m)=p1*rho(ix ,jy ,ind,indexh) &
< +p2*rho(ixp,jy ,ind,indexh) &
< +p3*rho(ix ,jyp,ind,indexh) &
< +p4*rho(ixp,jyp,ind,indexh)
< end do
< pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
< qvprof(ind-indz+1)=(qv1(1)*dt2+qv1(2)*dt1)*dtt
< ttprof(ind-indz+1)=(tt1(1)*dt2+tt1(2)*dt1)*dtt
< rhoprof(ind-indz+1)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
< end do
< pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
< qvi=(dz1*qvprof(2)+dz2*qvprof(1))*dz
< tti=(dz1*ttprof(2)+dz2*ttprof(1))*dz
< rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
<
< ! Tropopause and PBL height
< !**************************
<
< do m=1,2
< indexh=memind(m)
<
< ! Tropopause
< tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
< + p2*tropopause(ixp,jy ,1,indexh) &
< + p3*tropopause(ix ,jyp,1,indexh) &
< + p4*tropopause(ixp,jyp,1,indexh)
<
< ! PBL height
< hm(m)=p1*hmix(ix ,jy ,1,indexh) &
< + p2*hmix(ixp,jy ,1,indexh) &
< + p3*hmix(ix ,jyp,1,indexh) &
< + p4*hmix(ixp,jyp,1,indexh)
< end do
<
< hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
< tri=(tr(1)*dt2+tr(2)*dt1)*dtt
<
<
< ! Write the output
< !*****************
<
< write(unitpartout) npoint(i),xlon,ylat,ztra1(i), &
< itramem(i),topo,pvi,qvi,rhoi,hmixi,tri,tti, &
< (xmass1(i,j),j=1,nspec)
< endif
< end do
< write(unitpartout) -99999,-9999.9,-9999.9,-9999.9,-99999, &
< -9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9, &
< (-9999.9,j=1,nspec)
<
<
< close(unitpartout)
<
< end subroutine partoutput
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine partoutput(itime)
> ! i
> !*****************************************************************************
> ! *
> ! Dump all particle positions *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 12 March 1999 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> real(kind=dp) :: jul
> integer :: itime,i,j,jjjjmmdd,ihmmss
> integer :: ix,jy,ixp,jyp,indexh,m,il,ind,indz,indzp
> real :: xlon,ylat
> real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
> real :: topo,hm(2),hmixi,pv1(2),pvprof(2),pvi,qv1(2),qvprof(2),qvi
> real :: tt1(2),ttprof(2),tti,rho1(2),rhoprof(2),rhoi
> real :: tr(2),tri
> character :: adate*8,atime*6
>
>
> ! Determine current calendar date, needed for the file name
> !**********************************************************
>
> jul=bdate+real(itime,kind=dp)/86400._dp
> call caldate(jul,jjjjmmdd,ihmmss)
> write(adate,'(i8.8)') jjjjmmdd
> write(atime,'(i6.6)') ihmmss
>
>
> ! Some variables needed for temporal interpolation
> !*************************************************
>
> dt1=real(itime-memtime(1))
> dt2=real(memtime(2)-itime)
> dtt=1./(dt1+dt2)
>
> ! Open output file and write the output
> !**************************************
>
> if (ipout.eq.1) then
> open(unitpartout,file=path(2)(1:length(2))//'partposit_'//adate// &
> atime,form='unformatted')
> else
> open(unitpartout,file=path(2)(1:length(2))//'partposit_end', &
> form='unformatted')
> endif
>
> ! Write current time to file
> !***************************
>
> write(unitpartout) itime
> do i=1,numpart
>
> ! Take only valid particles
> !**************************
>
> if (itra1(i).eq.itime) then
> xlon=xlon0+xtra1(i)*dx
> ylat=ylat0+ytra1(i)*dy
>
> !*****************************************************************************
> ! Interpolate several variables (PV, specific humidity, etc.) to particle position
> !*****************************************************************************
>
> ix=xtra1(i)
> jy=ytra1(i)
> ixp=ix+1
> jyp=jy+1
> ddx=xtra1(i)-real(ix)
> ddy=ytra1(i)-real(jy)
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
>
> ! Topography
> !***********
>
> topo=p1*oro(ix ,jy) &
> + p2*oro(ixp,jy) &
> + p3*oro(ix ,jyp) &
> + p4*oro(ixp,jyp)
>
> ! Potential vorticity, specific humidity, temperature, and density
> !*****************************************************************
>
> do il=2,nz
> if (height(il).gt.ztra1(i)) then
> indz=il-1
> indzp=il
> goto 6
> endif
> end do
> 6 continue
>
> dz1=ztra1(i)-height(indz)
> dz2=height(indzp)-ztra1(i)
> dz=1./(dz1+dz2)
>
>
> do ind=indz,indzp
> do m=1,2
> indexh=memind(m)
>
> ! Potential vorticity
> pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
> +p2*pv(ixp,jy ,ind,indexh) &
> +p3*pv(ix ,jyp,ind,indexh) &
> +p4*pv(ixp,jyp,ind,indexh)
> ! Specific humidity
> qv1(m)=p1*qv(ix ,jy ,ind,indexh) &
> +p2*qv(ixp,jy ,ind,indexh) &
> +p3*qv(ix ,jyp,ind,indexh) &
> +p4*qv(ixp,jyp,ind,indexh)
> ! Temperature
> tt1(m)=p1*tt(ix ,jy ,ind,indexh) &
> +p2*tt(ixp,jy ,ind,indexh) &
> +p3*tt(ix ,jyp,ind,indexh) &
> +p4*tt(ixp,jyp,ind,indexh)
> ! Density
> rho1(m)=p1*rho(ix ,jy ,ind,indexh) &
> +p2*rho(ixp,jy ,ind,indexh) &
> +p3*rho(ix ,jyp,ind,indexh) &
> +p4*rho(ixp,jyp,ind,indexh)
> end do
> pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
> qvprof(ind-indz+1)=(qv1(1)*dt2+qv1(2)*dt1)*dtt
> ttprof(ind-indz+1)=(tt1(1)*dt2+tt1(2)*dt1)*dtt
> rhoprof(ind-indz+1)=(rho1(1)*dt2+rho1(2)*dt1)*dtt
> end do
> pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
> qvi=(dz1*qvprof(2)+dz2*qvprof(1))*dz
> tti=(dz1*ttprof(2)+dz2*ttprof(1))*dz
> rhoi=(dz1*rhoprof(2)+dz2*rhoprof(1))*dz
>
> ! Tropopause and PBL height
> !**************************
>
> do m=1,2
> indexh=memind(m)
>
> ! Tropopause
> tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
> + p2*tropopause(ixp,jy ,1,indexh) &
> + p3*tropopause(ix ,jyp,1,indexh) &
> + p4*tropopause(ixp,jyp,1,indexh)
>
> ! PBL height
> hm(m)=p1*hmix(ix ,jy ,1,indexh) &
> + p2*hmix(ixp,jy ,1,indexh) &
> + p3*hmix(ix ,jyp,1,indexh) &
> + p4*hmix(ixp,jyp,1,indexh)
> end do
>
> hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
> tri=(tr(1)*dt2+tr(2)*dt1)*dtt
>
>
> ! Write the output
> !*****************
>
> write(unitpartout) npoint(i),xlon,ylat,ztra1(i), &
> itramem(i),topo,pvi,qvi,rhoi,hmixi,tri,tti, &
> (xmass1(i,j),j=1,nspec)
> endif
> end do
> write(unitpartout) -99999,-9999.9,-9999.9,-9999.9,-99999, &
> -9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9, &
> (-9999.9,j=1,nspec)
>
>
> close(unitpartout)
>
> end subroutine partoutput
partoutput_short.f90
----------------------------------------------
1,152c1,152
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine partoutput_short(itime)
< ! i
< !*****************************************************************************
< ! *
< ! Dump all particle positions *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 12 March 1999 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< real(kind=dp) :: jul
< integer :: itime,i,j,jjjjmmdd,ihmmss,numshortout,numshortall
< integer :: ix,jy,ixp,jyp
< real :: xlon,ylat,zlim,dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,topo
< character :: adate*8,atime*6
<
< integer(kind=2) :: idump(3,maxpart)
< integer :: i4dump(maxpart)
<
<
< ! Determine current calendar date, needed for the file name
< !**********************************************************
<
< jul=bdate+real(itime,kind=dp)/86400._dp
< call caldate(jul,jjjjmmdd,ihmmss)
< write(adate,'(i8.8)') jjjjmmdd
< write(atime,'(i6.6)') ihmmss
<
<
< ! Some variables needed for temporal interpolation
< !*************************************************
<
< dt1=real(itime-memtime(1))
< dt2=real(memtime(2)-itime)
< dtt=1./(dt1+dt2)
<
<
< ! Loop about all particles
< !*************************
<
< numshortout=0
< numshortall=0
< do i=1,numpart
<
< ! Take only valid particles
< !**************************
<
< if (itra1(i).eq.itime) then
< xlon=xlon0+xtra1(i)*dx
< ylat=ylat0+ytra1(i)*dy
<
< !*****************************************************************************
< ! Interpolate several variables (PV, specific humidity, etc.) to particle position
< !*****************************************************************************
<
< ix=xtra1(i)
< jy=ytra1(i)
< ixp=ix+1
< jyp=jy+1
< ddx=xtra1(i)-real(ix)
< ddy=ytra1(i)-real(jy)
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
<
< ! Topography
< !***********
<
< topo=p1*oro(ix ,jy) &
< + p2*oro(ixp,jy) &
< + p3*oro(ix ,jyp) &
< + p4*oro(ixp,jyp)
<
<
< ! Convert positions to integer*2 variables (from -32768 to 32767)
< ! Do this only for region of main interest, i.e. extended North Atlantic region,
< ! and for the tracer of interest, i.e. the North American one
< !*****************************************************************************
<
< if (xlon.gt.180.) xlon=xlon-360.
< if (xlon.lt.-180.) xlon=xlon+360.
<
< numshortall=numshortall+1
< if ((xlon.gt.-140).and.(xlon.lt.60).and.(ylat.gt.10).and. &
< (xmass1(i,1).gt.0.)) then
< numshortout=numshortout+1
< idump(1,numshortout)=nint(xlon*180.)
< idump(2,numshortout)=nint(ylat*360.)
< zlim=min(ztra1(i)+topo,32766.)
< idump(3,numshortout)=nint(zlim)
< i4dump(numshortout)=npoint(i)
< endif
<
< endif
< end do
<
<
< ! Open output file and write the output
< !**************************************
<
< open(unitshortpart,file=path(2)(1:length(2))//'shortposit_'//adate// &
< atime,form='unformatted')
<
< ! Write current time to file
< !***************************
<
< write(unitshortpart) itime
< write(unitshortpart) numshortout
< write(unitshortpart) &
< (i4dump(i),(idump(j,i),j=1,3),i=1,numshortout)
<
<
< write(*,*) numshortout,numshortall
<
< close(unitshortpart)
<
< end subroutine partoutput_short
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine partoutput_short(itime)
> ! i
> !*****************************************************************************
> ! *
> ! Dump all particle positions *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 12 March 1999 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> real(kind=dp) :: jul
> integer :: itime,i,j,jjjjmmdd,ihmmss,numshortout,numshortall
> integer :: ix,jy,ixp,jyp
> real :: xlon,ylat,zlim,dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,topo
> character :: adate*8,atime*6
>
> integer(kind=2) :: idump(3,maxpart)
> integer :: i4dump(maxpart)
>
>
> ! Determine current calendar date, needed for the file name
> !**********************************************************
>
> jul=bdate+real(itime,kind=dp)/86400._dp
> call caldate(jul,jjjjmmdd,ihmmss)
> write(adate,'(i8.8)') jjjjmmdd
> write(atime,'(i6.6)') ihmmss
>
>
> ! Some variables needed for temporal interpolation
> !*************************************************
>
> dt1=real(itime-memtime(1))
> dt2=real(memtime(2)-itime)
> dtt=1./(dt1+dt2)
>
>
> ! Loop about all particles
> !*************************
>
> numshortout=0
> numshortall=0
> do i=1,numpart
>
> ! Take only valid particles
> !**************************
>
> if (itra1(i).eq.itime) then
> xlon=xlon0+xtra1(i)*dx
> ylat=ylat0+ytra1(i)*dy
>
> !*****************************************************************************
> ! Interpolate several variables (PV, specific humidity, etc.) to particle position
> !*****************************************************************************
>
> ix=xtra1(i)
> jy=ytra1(i)
> ixp=ix+1
> jyp=jy+1
> ddx=xtra1(i)-real(ix)
> ddy=ytra1(i)-real(jy)
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
>
> ! Topography
> !***********
>
> topo=p1*oro(ix ,jy) &
> + p2*oro(ixp,jy) &
> + p3*oro(ix ,jyp) &
> + p4*oro(ixp,jyp)
>
>
> ! Convert positions to integer*2 variables (from -32768 to 32767)
> ! Do this only for region of main interest, i.e. extended North Atlantic region,
> ! and for the tracer of interest, i.e. the North American one
> !*****************************************************************************
>
> if (xlon.gt.180.) xlon=xlon-360.
> if (xlon.lt.-180.) xlon=xlon+360.
>
> numshortall=numshortall+1
> if ((xlon.gt.-140).and.(xlon.lt.60).and.(ylat.gt.10).and. &
> (xmass1(i,1).gt.0.)) then
> numshortout=numshortout+1
> idump(1,numshortout)=nint(xlon*180.)
> idump(2,numshortout)=nint(ylat*360.)
> zlim=min(ztra1(i)+topo,32766.)
> idump(3,numshortout)=nint(zlim)
> i4dump(numshortout)=npoint(i)
> endif
>
> endif
> end do
>
>
> ! Open output file and write the output
> !**************************************
>
> open(unitshortpart,file=path(2)(1:length(2))//'shortposit_'//adate// &
> atime,form='unformatted')
>
> ! Write current time to file
> !***************************
>
> write(unitshortpart) itime
> write(unitshortpart) numshortout
> write(unitshortpart) &
> (i4dump(i),(idump(j,i),j=1,3),i=1,numshortout)
>
>
> write(*,*) numshortout,numshortall
>
> close(unitshortpart)
>
> end subroutine partoutput_short
pbl_profile.f90
----------------------------------------------
1,132c1,132
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine pbl_profile(ps,td2m,zml1,t2m,tml1,u10m,uml1,stress,hf)
<
< !********************************************************************
< ! *
< ! G. WOTAWA, 1995-07-07 *
< ! *
< !********************************************************************
< ! *
< ! DESCRIPTION: CALCULATION OF FRICTION VELOCITY AND SURFACE SENS- *
< ! IBLE HEAT FLUX USING THE PROFILE METHOD (BERKOVICZ *
< ! AND PRAHM, 1982) *
< ! *
< ! Output now is surface stress instead of ustar *
< ! *
< ! *
< !********************************************************************
< ! *
< ! INPUT: *
< ! *
< ! *
< ! ps surface pressure(Pa) *
< ! td2m two metre dew point(K) *
< ! zml1 heigth of first model level (m) *
< ! t2m two metre temperature (K) *
< ! tml1 temperature first model level (K) *
< ! u10m ten metre wind speed (ms-1) *
< ! uml1 wind speed first model level (ms-1) *
< ! *
< !********************************************************************
< ! *
< ! OUTPUT: *
< ! *
< ! stress surface stress (i.e., friction velocity (ms-1) squared *
< ! multiplied with air density) *
< ! hf surface sensible heat flux (Wm-2) *
< ! *
< !********************************************************************
< ! ustar friction velocity (ms-1) *
< ! maxiter maximum number of iterations *
< !********************************************************************
<
< use par_mod
<
< implicit none
<
< integer :: iter
< real :: ps,td2m,rhoa,zml1,t2m,tml1,u10m,uml1,ustar,hf
< real :: al,alold,aldiff,tmean,crit
< real :: deltau,deltat,thetastar,psim,psih,e,ew,tv,stress
< integer,parameter :: maxiter=10
< real,parameter :: r1=0.74
<
< e=ew(td2m) ! vapor pressure
< tv=t2m*(1.+0.378*e/ps) ! virtual temperature
< rhoa=ps/(r_air*tv) ! air density
<
< deltau=uml1-u10m !! Wind Speed difference between
< !! Model level 1 and 10 m
<
< if(deltau.le.0.001) then !! Monin-Obukhov Theory not
< al=9999. !! applicable --> Set dummy values
< ustar=0.01
< stress=ustar*ustar*rhoa
< hf=0.0
< return
< endif
< deltat=tml1-t2m+0.0098*(zml1-2.) !! Potential temperature difference
< !! between model level 1 and 10 m
<
< if(abs(deltat).le.0.03) then !! Neutral conditions
< hf=0.0
< al=9999.
< ustar=(vonkarman*deltau)/ &
< (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
< stress=ustar*ustar*rhoa
< return
< endif
<
< tmean=0.5*(t2m+tml1)
< crit=(0.0219*tmean*(zml1-2.0)*deltau**2)/ &
< (deltat*(zml1-10.0)**2)
< if((deltat.gt.0).and.(crit.le.1.)) then
< !! Successive approximation will
< al=50. !! not converge
< ustar=(vonkarman*deltau)/ &
< (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
< thetastar=(vonkarman*deltat/r1)/ &
< (log(zml1/2.)-psih(zml1,al)+psih(2.,al))
< hf=rhoa*cpa*ustar*thetastar
< stress=ustar*ustar*rhoa
< return
< endif
<
< al=9999. ! Start iteration assuming neutral conditions
< do iter=1,maxiter
< alold=al
< ustar=(vonkarman*deltau)/ &
< (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
< thetastar=(vonkarman*deltat/r1)/ &
< (log(zml1/2.)-psih(zml1,al)+psih(2.,al))
< al=(tmean*ustar**2)/(ga*vonkarman*thetastar)
< aldiff=abs((al-alold)/alold)
< if(aldiff.lt.0.01) goto 30 !! Successive approximation successful
< end do
< 30 hf=rhoa*cpa*ustar*thetastar
< if(al.gt.9999.) al=9999.
< if(al.lt.-9999.) al=-9999.
<
< stress=ustar*ustar*rhoa
<
< end subroutine pbl_profile
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine pbl_profile(ps,td2m,zml1,t2m,tml1,u10m,uml1,stress,hf)
>
> !********************************************************************
> ! *
> ! G. WOTAWA, 1995-07-07 *
> ! *
> !********************************************************************
> ! *
> ! DESCRIPTION: CALCULATION OF FRICTION VELOCITY AND SURFACE SENS- *
> ! IBLE HEAT FLUX USING THE PROFILE METHOD (BERKOVICZ *
> ! AND PRAHM, 1982) *
> ! *
> ! Output now is surface stress instead of ustar *
> ! *
> ! *
> !********************************************************************
> ! *
> ! INPUT: *
> ! *
> ! *
> ! ps surface pressure(Pa) *
> ! td2m two metre dew point(K) *
> ! zml1 heigth of first model level (m) *
> ! t2m two metre temperature (K) *
> ! tml1 temperature first model level (K) *
> ! u10m ten metre wind speed (ms-1) *
> ! uml1 wind speed first model level (ms-1) *
> ! *
> !********************************************************************
> ! *
> ! OUTPUT: *
> ! *
> ! stress surface stress (i.e., friction velocity (ms-1) squared *
> ! multiplied with air density) *
> ! hf surface sensible heat flux (Wm-2) *
> ! *
> !********************************************************************
> ! ustar friction velocity (ms-1) *
> ! maxiter maximum number of iterations *
> !********************************************************************
>
> use par_mod
>
> implicit none
>
> integer :: iter
> real :: ps,td2m,rhoa,zml1,t2m,tml1,u10m,uml1,ustar,hf
> real :: al,alold,aldiff,tmean,crit
> real :: deltau,deltat,thetastar,psim,psih,e,ew,tv,stress
> integer,parameter :: maxiter=10
> real,parameter :: r1=0.74
>
> e=ew(td2m) ! vapor pressure
> tv=t2m*(1.+0.378*e/ps) ! virtual temperature
> rhoa=ps/(r_air*tv) ! air density
>
> deltau=uml1-u10m !! Wind Speed difference between
> !! Model level 1 and 10 m
>
> if(deltau.le.0.001) then !! Monin-Obukhov Theory not
> al=9999. !! applicable --> Set dummy values
> ustar=0.01
> stress=ustar*ustar*rhoa
> hf=0.0
> return
> endif
> deltat=tml1-t2m+0.0098*(zml1-2.) !! Potential temperature difference
> !! between model level 1 and 10 m
>
> if(abs(deltat).le.0.03) then !! Neutral conditions
> hf=0.0
> al=9999.
> ustar=(vonkarman*deltau)/ &
> (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
> stress=ustar*ustar*rhoa
> return
> endif
>
> tmean=0.5*(t2m+tml1)
> crit=(0.0219*tmean*(zml1-2.0)*deltau**2)/ &
> (deltat*(zml1-10.0)**2)
> if((deltat.gt.0).and.(crit.le.1.)) then
> !! Successive approximation will
> al=50. !! not converge
> ustar=(vonkarman*deltau)/ &
> (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
> thetastar=(vonkarman*deltat/r1)/ &
> (log(zml1/2.)-psih(zml1,al)+psih(2.,al))
> hf=rhoa*cpa*ustar*thetastar
> stress=ustar*ustar*rhoa
> return
> endif
>
> al=9999. ! Start iteration assuming neutral conditions
> do iter=1,maxiter
> alold=al
> ustar=(vonkarman*deltau)/ &
> (log(zml1/10.)-psim(zml1,al)+psim(10.,al))
> thetastar=(vonkarman*deltat/r1)/ &
> (log(zml1/2.)-psih(zml1,al)+psih(2.,al))
> al=(tmean*ustar**2)/(ga*vonkarman*thetastar)
> aldiff=abs((al-alold)/alold)
> if(aldiff.lt.0.01) goto 30 !! Successive approximation successful
> end do
> 30 hf=rhoa*cpa*ustar*thetastar
> if(al.gt.9999.) al=9999.
> if(al.lt.-9999.) al=-9999.
>
> stress=ustar*ustar*rhoa
>
> end subroutine pbl_profile
plumetraj.f90
----------------------------------------------
1,250c1,250
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine plumetraj(itime)
< ! i
< !*****************************************************************************
< ! *
< ! Determines a plume centroid trajectory for each release site, and manages *
< ! clustering of particle locations. Certain parameters (average PV, *
< ! tropopause height, etc., are provided along the plume trajectories. *
< ! At the end, output is written to file 'trajectories.txt'. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 24 January 2002 *
< ! *
< ! Variables: *
< ! fclust fraction of particles belonging to each cluster *
< ! hmixcenter mean mixing height for all particles *
< ! ncluster number of clusters to be used *
< ! pvcenter mean PV for all particles *
< ! pvfract fraction of particles with PV<2pvu *
< ! rms total horizontal rms distance after clustering *
< ! rmsdist total horizontal rms distance before clustering *
< ! rmsclust horizontal rms distance for each individual cluster *
< ! topocenter mean topography underlying all particles *
< ! tropocenter mean tropopause height at the positions of particles *
< ! tropofract fraction of particles within the troposphere *
< ! zrms total vertical rms distance after clustering *
< ! zrmsdist total vertical rms distance before clustering *
< ! xclust,yclust, Cluster centroid positions *
< ! zclust *
< ! *
< !*****************************************************************************
<
< use point_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: itime,ix,jy,ixp,jyp,indexh,i,j,k,m,n,il,ind,indz,indzp
< real :: xl(maxpart),yl(maxpart),zl(maxpart)
< real :: xcenter,ycenter,zcenter,dist,distance,rmsdist,zrmsdist
<
< real :: xclust(ncluster),yclust(ncluster),zclust(ncluster)
< real :: fclust(ncluster),rms,rmsclust(ncluster),zrms
<
< real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
< real :: topo,topocenter,hm(2),hmixi,hmixfract,hmixcenter
< real :: pv1(2),pvprof(2),pvi,pvcenter,pvfract,tr(2),tri,tropofract
< real :: tropocenter
<
<
< dt1=real(itime-memtime(1))
< dt2=real(memtime(2)-itime)
< dtt=1./(dt1+dt2)
<
<
< ! Loop about all release points
< !******************************
<
< do j=1,numpoint
< if (abs(ireleasestart(j)-itime).gt.lage(nageclass)) goto 10
< topocenter=0.
< hmixcenter=0.
< hmixfract=0.
< tropocenter=0.
< tropofract=0.
< pvfract=0.
< pvcenter=0.
< rmsdist=0.
< zrmsdist=0.
<
< n=0
< do i=1,numpart
< if (itra1(i).ne.itime) goto 20
< if (npoint(i).ne.j) goto 20
< n=n+1
< xl(n)=xlon0+xtra1(i)*dx
< yl(n)=ylat0+ytra1(i)*dy
< zl(n)=ztra1(i)
<
<
< ! Interpolate PBL height, PV, and tropopause height to each
< ! particle position in order to determine fraction of particles
< ! within the PBL, above tropopause height, and average PV.
< ! Interpolate topography, too, and convert to altitude asl
< !**************************************************************
<
< ix=int(xtra1(i))
< jy=int(ytra1(i))
< ixp=ix+1
< jyp=jy+1
< ddx=xtra1(i)-real(ix)
< ddy=ytra1(i)-real(jy)
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
<
< ! Topography
< !***********
<
< topo=p1*oro(ix ,jy) &
< + p2*oro(ixp,jy) &
< + p3*oro(ix ,jyp) &
< + p4*oro(ixp,jyp)
< topocenter=topocenter+topo
<
< ! Potential vorticity
< !********************
<
< do il=2,nz
< if (height(il).gt.zl(n)) then
< indz=il-1
< indzp=il
< goto 6
< endif
< end do
< 6 continue
<
< dz1=zl(n)-height(indz)
< dz2=height(indzp)-zl(n)
< dz=1./(dz1+dz2)
<
<
< do ind=indz,indzp
< do m=1,2
< indexh=memind(m)
< pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
< +p2*pv(ixp,jy ,ind,indexh) &
< +p3*pv(ix ,jyp,ind,indexh) &
< +p4*pv(ixp,jyp,ind,indexh)
< end do
< pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
< end do
< pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
< pvcenter=pvcenter+pvi
< if (yl(n).gt.0.) then
< if (pvi.lt.2.) pvfract=pvfract+1.
< else
< if (pvi.gt.-2.) pvfract=pvfract+1.
< endif
<
<
< ! Tropopause and PBL height
< !**************************
<
< do m=1,2
< indexh=memind(m)
<
< tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
< + p2*tropopause(ixp,jy ,1,indexh) &
< + p3*tropopause(ix ,jyp,1,indexh) &
< + p4*tropopause(ixp,jyp,1,indexh)
<
< hm(m)=p1*hmix(ix ,jy ,1,indexh) &
< + p2*hmix(ixp,jy ,1,indexh) &
< + p3*hmix(ix ,jyp,1,indexh) &
< + p4*hmix(ixp,jyp,1,indexh)
< end do
<
< hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
< tri=(tr(1)*dt2+tr(2)*dt1)*dtt
< if (zl(n).lt.tri) tropofract=tropofract+1.
< tropocenter=tropocenter+tri+topo
< if (zl(n).lt.hmixi) hmixfract=hmixfract+1.
< zl(n)=zl(n)+topo ! convert to height asl
< hmixcenter=hmixcenter+hmixi
<
<
< 20 continue
< end do
<
<
< ! Make statistics for all plumes with n>0 particles
< !**************************************************
<
< if (n.gt.0) then
< topocenter=topocenter/real(n)
< hmixcenter=hmixcenter/real(n)
< pvcenter=pvcenter/real(n)
< tropocenter=tropocenter/real(n)
< hmixfract=100.*hmixfract/real(n)
< pvfract=100.*pvfract/real(n)
< tropofract=100.*tropofract/real(n)
<
< ! Cluster the particle positions
< !*******************************
<
< call clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
< rmsclust,zrms)
<
<
< ! Determine center of mass position on earth and average height
< !**************************************************************
<
< call centerofmass(xl,yl,n,xcenter,ycenter)
< call mean(zl,zcenter,zrmsdist,n)
<
< ! Root mean square distance from center of mass
< !**********************************************
<
< do k=1,n
< dist=distance(yl(k),xl(k),ycenter,xcenter)
< rmsdist=rmsdist+dist*dist
< end do
< if (rmsdist.gt.0.) rmsdist=sqrt(rmsdist/real(n))
< rmsdist=max(rmsdist,0.)
<
< ! Write out results in trajectory data file
< !******************************************
<
< write(unitouttraj,'(i5,i8,2f9.4,4f8.1,f8.2,4f8.1,3f6.1,&
< &5(2f8.3,f7.0,f6.1,f8.1))')&
< &j,itime-(ireleasestart(j)+ireleaseend(j))/2, &
< xcenter,ycenter,zcenter,topocenter,hmixcenter,tropocenter, &
< pvcenter,rmsdist,rms,zrmsdist,zrms,hmixfract,pvfract, &
< tropofract, &
< (xclust(k),yclust(k),zclust(k),fclust(k),rmsclust(k), &
< k=1,ncluster)
< endif
<
<
< 10 continue
< end do
<
<
< end subroutine plumetraj
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine plumetraj(itime)
> ! i
> !*****************************************************************************
> ! *
> ! Determines a plume centroid trajectory for each release site, and manages *
> ! clustering of particle locations. Certain parameters (average PV, *
> ! tropopause height, etc., are provided along the plume trajectories. *
> ! At the end, output is written to file 'trajectories.txt'. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 24 January 2002 *
> ! *
> ! Variables: *
> ! fclust fraction of particles belonging to each cluster *
> ! hmixcenter mean mixing height for all particles *
> ! ncluster number of clusters to be used *
> ! pvcenter mean PV for all particles *
> ! pvfract fraction of particles with PV<2pvu *
> ! rms total horizontal rms distance after clustering *
> ! rmsdist total horizontal rms distance before clustering *
> ! rmsclust horizontal rms distance for each individual cluster *
> ! topocenter mean topography underlying all particles *
> ! tropocenter mean tropopause height at the positions of particles *
> ! tropofract fraction of particles within the troposphere *
> ! zrms total vertical rms distance after clustering *
> ! zrmsdist total vertical rms distance before clustering *
> ! xclust,yclust, Cluster centroid positions *
> ! zclust *
> ! *
> !*****************************************************************************
>
> use point_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: itime,ix,jy,ixp,jyp,indexh,i,j,k,m,n,il,ind,indz,indzp
> real :: xl(maxpart),yl(maxpart),zl(maxpart)
> real :: xcenter,ycenter,zcenter,dist,distance,rmsdist,zrmsdist
>
> real :: xclust(ncluster),yclust(ncluster),zclust(ncluster)
> real :: fclust(ncluster),rms,rmsclust(ncluster),zrms
>
> real :: dt1,dt2,dtt,ddx,ddy,rddx,rddy,p1,p2,p3,p4,dz1,dz2,dz
> real :: topo,topocenter,hm(2),hmixi,hmixfract,hmixcenter
> real :: pv1(2),pvprof(2),pvi,pvcenter,pvfract,tr(2),tri,tropofract
> real :: tropocenter
>
>
> dt1=real(itime-memtime(1))
> dt2=real(memtime(2)-itime)
> dtt=1./(dt1+dt2)
>
>
> ! Loop about all release points
> !******************************
>
> do j=1,numpoint
> if (abs(ireleasestart(j)-itime).gt.lage(nageclass)) goto 10
> topocenter=0.
> hmixcenter=0.
> hmixfract=0.
> tropocenter=0.
> tropofract=0.
> pvfract=0.
> pvcenter=0.
> rmsdist=0.
> zrmsdist=0.
>
> n=0
> do i=1,numpart
> if (itra1(i).ne.itime) goto 20
> if (npoint(i).ne.j) goto 20
> n=n+1
> xl(n)=xlon0+xtra1(i)*dx
> yl(n)=ylat0+ytra1(i)*dy
> zl(n)=ztra1(i)
>
>
> ! Interpolate PBL height, PV, and tropopause height to each
> ! particle position in order to determine fraction of particles
> ! within the PBL, above tropopause height, and average PV.
> ! Interpolate topography, too, and convert to altitude asl
> !**************************************************************
>
> ix=int(xtra1(i))
> jy=int(ytra1(i))
> ixp=ix+1
> jyp=jy+1
> ddx=xtra1(i)-real(ix)
> ddy=ytra1(i)-real(jy)
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
>
> ! Topography
> !***********
>
> topo=p1*oro(ix ,jy) &
> + p2*oro(ixp,jy) &
> + p3*oro(ix ,jyp) &
> + p4*oro(ixp,jyp)
> topocenter=topocenter+topo
>
> ! Potential vorticity
> !********************
>
> do il=2,nz
> if (height(il).gt.zl(n)) then
> indz=il-1
> indzp=il
> goto 6
> endif
> end do
> 6 continue
>
> dz1=zl(n)-height(indz)
> dz2=height(indzp)-zl(n)
> dz=1./(dz1+dz2)
>
>
> do ind=indz,indzp
> do m=1,2
> indexh=memind(m)
> pv1(m)=p1*pv(ix ,jy ,ind,indexh) &
> +p2*pv(ixp,jy ,ind,indexh) &
> +p3*pv(ix ,jyp,ind,indexh) &
> +p4*pv(ixp,jyp,ind,indexh)
> end do
> pvprof(ind-indz+1)=(pv1(1)*dt2+pv1(2)*dt1)*dtt
> end do
> pvi=(dz1*pvprof(2)+dz2*pvprof(1))*dz
> pvcenter=pvcenter+pvi
> if (yl(n).gt.0.) then
> if (pvi.lt.2.) pvfract=pvfract+1.
> else
> if (pvi.gt.-2.) pvfract=pvfract+1.
> endif
>
>
> ! Tropopause and PBL height
> !**************************
>
> do m=1,2
> indexh=memind(m)
>
> tr(m)=p1*tropopause(ix ,jy ,1,indexh) &
> + p2*tropopause(ixp,jy ,1,indexh) &
> + p3*tropopause(ix ,jyp,1,indexh) &
> + p4*tropopause(ixp,jyp,1,indexh)
>
> hm(m)=p1*hmix(ix ,jy ,1,indexh) &
> + p2*hmix(ixp,jy ,1,indexh) &
> + p3*hmix(ix ,jyp,1,indexh) &
> + p4*hmix(ixp,jyp,1,indexh)
> end do
>
> hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt
> tri=(tr(1)*dt2+tr(2)*dt1)*dtt
> if (zl(n).lt.tri) tropofract=tropofract+1.
> tropocenter=tropocenter+tri+topo
> if (zl(n).lt.hmixi) hmixfract=hmixfract+1.
> zl(n)=zl(n)+topo ! convert to height asl
> hmixcenter=hmixcenter+hmixi
>
>
> 20 continue
> end do
>
>
> ! Make statistics for all plumes with n>0 particles
> !**************************************************
>
> if (n.gt.0) then
> topocenter=topocenter/real(n)
> hmixcenter=hmixcenter/real(n)
> pvcenter=pvcenter/real(n)
> tropocenter=tropocenter/real(n)
> hmixfract=100.*hmixfract/real(n)
> pvfract=100.*pvfract/real(n)
> tropofract=100.*tropofract/real(n)
>
> ! Cluster the particle positions
> !*******************************
>
> call clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, &
> rmsclust,zrms)
>
>
> ! Determine center of mass position on earth and average height
> !**************************************************************
>
> call centerofmass(xl,yl,n,xcenter,ycenter)
> call mean(zl,zcenter,zrmsdist,n)
>
> ! Root mean square distance from center of mass
> !**********************************************
>
> do k=1,n
> dist=distance(yl(k),xl(k),ycenter,xcenter)
> rmsdist=rmsdist+dist*dist
> end do
> if (rmsdist.gt.0.) rmsdist=sqrt(rmsdist/real(n))
> rmsdist=max(rmsdist,0.)
>
> ! Write out results in trajectory data file
> !******************************************
>
> write(unitouttraj,'(i5,i8,2f9.4,4f8.1,f8.2,4f8.1,3f6.1,&
> &5(2f8.3,f7.0,f6.1,f8.1))')&
> &j,itime-(ireleasestart(j)+ireleaseend(j))/2, &
> xcenter,ycenter,zcenter,topocenter,hmixcenter,tropocenter, &
> pvcenter,rmsdist,rms,zrmsdist,zrms,hmixfract,pvfract, &
> tropofract, &
> (xclust(k),yclust(k),zclust(k),fclust(k),rmsclust(k), &
> k=1,ncluster)
> endif
>
>
> 10 continue
> end do
>
>
> end subroutine plumetraj
point_mod.f90
----------------------------------------------
1,41c1,41
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< module point_mod
<
< implicit none
<
< integer, allocatable, dimension (:) :: ireleasestart
< integer, allocatable, dimension (:) :: ireleaseend
< integer, allocatable, dimension (:) :: npart
< integer*2, allocatable, dimension (:) :: kindz
<
< real,allocatable, dimension (:) :: xpoint1
< real,allocatable, dimension (:) :: xpoint2
< real,allocatable, dimension (:) :: ypoint1
< real,allocatable, dimension (:) :: ypoint2
< real,allocatable, dimension (:) :: zpoint1
< real,allocatable, dimension (:) :: zpoint2
<
< real,allocatable, dimension (:,:) :: xmass
< real,allocatable, dimension (:) :: rho_rel
<
< end module point_mod
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> module point_mod
>
> implicit none
>
> integer, allocatable, dimension (:) :: ireleasestart
> integer, allocatable, dimension (:) :: ireleaseend
> integer, allocatable, dimension (:) :: npart
> integer*2, allocatable, dimension (:) :: kindz
>
> real,allocatable, dimension (:) :: xpoint1
> real,allocatable, dimension (:) :: xpoint2
> real,allocatable, dimension (:) :: ypoint1
> real,allocatable, dimension (:) :: ypoint2
> real,allocatable, dimension (:) :: zpoint1
> real,allocatable, dimension (:) :: zpoint2
>
> real,allocatable, dimension (:,:) :: xmass
> real,allocatable, dimension (:) :: rho_rel
>
> end module point_mod
psih.f90
----------------------------------------------
1,76c1,76
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< function psih (z,l)
<
< !*****************************************************************************
< ! *
< ! Calculation of the stability correction term *
< ! *
< ! AUTHOR: Matthias Langer, adapted by Andreas Stohl (6 August 1993) *
< ! Update: G. Wotawa, 11 October 1994 *
< ! *
< ! Literature: *
< ! [1] C.A.Paulson (1970), A Mathematical Representation of Wind Speed *
< ! and Temperature Profiles in the Unstable Atmospheric Surface *
< ! Layer. J.Appl.Met.,Vol.9.(1970), pp.857-861. *
< ! *
< ! [2] A.C.M. Beljaars, A.A.M. Holtslag (1991), Flux Parameterization over*
< ! Land Surfaces for Atmospheric Models. J.Appl.Met. Vol. 30,pp 327-*
< ! 341 *
< ! *
< ! Variables: *
< ! L = Monin-Obukhov-length [m] *
< ! z = height [m] *
< ! zeta = auxiliary variable *
< ! *
< ! Constants: *
< ! eps = 1.2E-38, SUN-underflow: to avoid division by zero errors *
< ! *
< !*****************************************************************************
<
< use par_mod
<
< implicit none
<
< real :: psih,x,z,zeta,l
< real,parameter :: a=1.,b=0.667,c=5.,d=0.35,eps=1.e-20
<
< if ((l.ge.0).and.(l.lt.eps)) then
< l=eps
< else if ((l.lt.0).and.(l.gt.(-1.*eps))) then
< l=-1.*eps
< endif
<
< if ((log10(z)-log10(abs(l))).lt.log10(eps)) then
< psih=0.
< else
< zeta=z/l
< if (zeta.gt.0.) then
< psih = - (1.+0.667*a*zeta)**(1.5) - b*(zeta-c/d)*exp(-d*zeta) &
< - b*c/d + 1.
< else
< x=(1.-16.*zeta)**(.25)
< psih=2.*log((1.+x*x)/2.)
< end if
< end if
<
< end function psih
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> function psih (z,l)
>
> !*****************************************************************************
> ! *
> ! Calculation of the stability correction term *
> ! *
> ! AUTHOR: Matthias Langer, adapted by Andreas Stohl (6 August 1993) *
> ! Update: G. Wotawa, 11 October 1994 *
> ! *
> ! Literature: *
> ! [1] C.A.Paulson (1970), A Mathematical Representation of Wind Speed *
> ! and Temperature Profiles in the Unstable Atmospheric Surface *
> ! Layer. J.Appl.Met.,Vol.9.(1970), pp.857-861. *
> ! *
> ! [2] A.C.M. Beljaars, A.A.M. Holtslag (1991), Flux Parameterization over*
> ! Land Surfaces for Atmospheric Models. J.Appl.Met. Vol. 30,pp 327-*
> ! 341 *
> ! *
> ! Variables: *
> ! L = Monin-Obukhov-length [m] *
> ! z = height [m] *
> ! zeta = auxiliary variable *
> ! *
> ! Constants: *
> ! eps = 1.2E-38, SUN-underflow: to avoid division by zero errors *
> ! *
> !*****************************************************************************
>
> use par_mod
>
> implicit none
>
> real :: psih,x,z,zeta,l
> real,parameter :: a=1.,b=0.667,c=5.,d=0.35,eps=1.e-20
>
> if ((l.ge.0).and.(l.lt.eps)) then
> l=eps
> else if ((l.lt.0).and.(l.gt.(-1.*eps))) then
> l=-1.*eps
> endif
>
> if ((log10(z)-log10(abs(l))).lt.log10(eps)) then
> psih=0.
> else
> zeta=z/l
> if (zeta.gt.0.) then
> psih = - (1.+0.667*a*zeta)**(1.5) - b*(zeta-c/d)*exp(-d*zeta) &
> - b*c/d + 1.
> else
> x=(1.-16.*zeta)**(.25)
> psih=2.*log((1.+x*x)/2.)
> end if
> end if
>
> end function psih
psim.f90
----------------------------------------------
1,50c1,50
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< real function psim(z,al)
<
< !**********************************************************************
< ! *
< ! DESCRIPTION: CALCULATION OF THE STABILITY CORRECTION FUNCTION FOR *
< ! MOMENTUM AS FUNCTION OF HEIGHT Z AND OBUKHOV SCALE *
< ! HEIGHT L *
< ! *
< !**********************************************************************
<
< use par_mod
<
< implicit none
<
< real :: z,al,zeta,x,a1,a2
<
< zeta=z/al
< if(zeta.le.0.) then
< ! UNSTABLE CASE
< x=(1.-15.*zeta)**0.25
< a1=((1.+x)/2.)**2
< a2=(1.+x**2)/2.
< psim=log(a1*a2)-2.*atan(x)+pi/2.
< else
< ! STABLE CASE
< psim=-4.7*zeta
< endif
<
< end function psim
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> real function psim(z,al)
>
> !**********************************************************************
> ! *
> ! DESCRIPTION: CALCULATION OF THE STABILITY CORRECTION FUNCTION FOR *
> ! MOMENTUM AS FUNCTION OF HEIGHT Z AND OBUKHOV SCALE *
> ! HEIGHT L *
> ! *
> !**********************************************************************
>
> use par_mod
>
> implicit none
>
> real :: z,al,zeta,x,a1,a2
>
> zeta=z/al
> if(zeta.le.0.) then
> ! UNSTABLE CASE
> x=(1.-15.*zeta)**0.25
> a1=((1.+x)/2.)**2
> a2=(1.+x**2)/2.
> psim=log(a1*a2)-2.*atan(x)+pi/2.
> else
> ! STABLE CASE
> psim=-4.7*zeta
> endif
>
> end function psim
qvsat.f90
----------------------------------------------
1,157c1,157
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< !##################################################################
< !##################################################################
< !###### ######
< !###### Developed by ######
< !###### Center for Analysis and Prediction of Storms ######
< !###### University of Oklahoma ######
< !###### ######
< !##################################################################
< !##################################################################
<
< function f_qvsat( p, t )
<
< !PURPOSE:
< !
< !Calculate the saturation specific humidity using enhanced Teten's
< !formula.
< !
< !AUTHOR: Yuhe Liu
< !01/08/1998
< !
< !MODIFICATION HISTORY:
< !
< !INPUT :
< ! p Pressure (Pascal)
< ! t Temperature (K)
< !OUTPUT:
< ! f_qvsat Saturation water vapor specific humidity (kg/kg).
< !
< !Variable Declarations.
< !
<
< implicit none
<
< real :: p ! Pressure (Pascal)
< real :: t ! Temperature (K)
< real :: f_qvsat ! Saturation water vapor specific humidity (kg/kg)
< real :: f_esl,f_esi,fespt
<
< real,parameter :: rd = 287.0 ! Gas constant for dry air (m**2/(s**2*K))
< real,parameter :: rv = 461.0 ! Gas constant for water vapor (m**2/(s**2*K)).
< real,parameter :: rddrv = rd/rv
<
<
< ! Change by A. Stohl to save computation time:
< ! IF ( t.ge.273.15 ) THEN ! for water
< if ( t.ge.253.15 ) then ! modification Petra Seibert
< ! (supercooled water may be present)
< fespt=f_esl(p,t)
< else
< fespt=f_esi(p,t)
< endif
<
< !!$ f_qvsat = rddrv * fespt / (p-(1.0-rddrv)*fespt) !old
< if (p-(1.0-rddrv)*fespt == 0.) then !bugfix
< f_qvsat = 1.
< else
< f_qvsat = rddrv * fespt / (p-(1.0-rddrv)*fespt)
< end if
<
< return
< end function f_qvsat
<
<
< function f_esl( p, t )
<
< implicit none
<
< real :: p ! Pressure (Pascal)
< real :: t ! Temperature (K)
< real :: f_esl ! Saturation water vapor pressure over liquid water
<
< real :: f
<
< !#######################################################################
< !
< !Saturation specific humidity parameters used in enhanced Teten's
< !formula. (See A. Buck, JAM 1981)
< !
< !#######################################################################
<
< real,parameter :: satfwa = 1.0007
< real,parameter :: satfwb = 3.46e-8 ! for p in Pa
<
< real,parameter :: satewa = 611.21 ! es in Pa
< real,parameter :: satewb = 17.502
< real,parameter :: satewc = 32.18
<
< real,parameter :: satfia = 1.0003
< real,parameter :: satfib = 4.18e-8 ! for p in Pa
<
< real,parameter :: sateia = 611.15 ! es in Pa
< real,parameter :: sateib = 22.452
< real,parameter :: sateic = 0.6
<
< f = satfwa + satfwb * p
< f_esl = f * satewa * exp( satewb*(t-273.15)/(t-satewc) )
<
< return
< end function f_esl
<
< function f_esi( p, t )
<
< implicit none
<
< real :: p ! Pressure (Pascal)
< real :: t ! Temperature (K)
< real :: f_esi ! Saturation water vapor pressure over ice (Pa)
<
< real :: f
<
< !#######################################################################
< !
< !Saturation specific humidity parameters used in enhanced Teten's
< !formula. (See A. Buck, JAM 1981)
< !
< !#######################################################################
< !
< real,parameter :: satfwa = 1.0007
< real,parameter :: satfwb = 3.46e-8 ! for p in Pa
<
< real,parameter :: satewa = 611.21 ! es in Pa
< real,parameter :: satewb = 17.502
< real,parameter :: satewc = 32.18
<
< real,parameter :: satfia = 1.0003
< real,parameter :: satfib = 4.18e-8 ! for p in Pa
<
< real,parameter :: sateia = 611.15 ! es in Pa
< real,parameter :: sateib = 22.452
< real,parameter :: sateic = 0.6
<
< f = satfia + satfib * p
< f_esi = f * sateia * exp( sateib*(t-273.15)/(t-sateic) )
<
< return
< end function f_esi
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> !##################################################################
> !##################################################################
> !###### ######
> !###### Developed by ######
> !###### Center for Analysis and Prediction of Storms ######
> !###### University of Oklahoma ######
> !###### ######
> !##################################################################
> !##################################################################
>
> function f_qvsat( p, t )
>
> !PURPOSE:
> !
> !Calculate the saturation specific humidity using enhanced Teten's
> !formula.
> !
> !AUTHOR: Yuhe Liu
> !01/08/1998
> !
> !MODIFICATION HISTORY:
> !
> !INPUT :
> ! p Pressure (Pascal)
> ! t Temperature (K)
> !OUTPUT:
> ! f_qvsat Saturation water vapor specific humidity (kg/kg).
> !
> !Variable Declarations.
> !
>
> implicit none
>
> real :: p ! Pressure (Pascal)
> real :: t ! Temperature (K)
> real :: f_qvsat ! Saturation water vapor specific humidity (kg/kg)
> real :: f_esl,f_esi,fespt
>
> real,parameter :: rd = 287.0 ! Gas constant for dry air (m**2/(s**2*K))
> real,parameter :: rv = 461.0 ! Gas constant for water vapor (m**2/(s**2*K)).
> real,parameter :: rddrv = rd/rv
>
>
> ! Change by A. Stohl to save computation time:
> ! IF ( t.ge.273.15 ) THEN ! for water
> if ( t.ge.253.15 ) then ! modification Petra Seibert
> ! (supercooled water may be present)
> fespt=f_esl(p,t)
> else
> fespt=f_esi(p,t)
> endif
>
> !!$ f_qvsat = rddrv * fespt / (p-(1.0-rddrv)*fespt) !old
> if (p-(1.0-rddrv)*fespt == 0.) then !bugfix
> f_qvsat = 1.
> else
> f_qvsat = rddrv * fespt / (p-(1.0-rddrv)*fespt)
> end if
>
> return
> end function f_qvsat
>
>
> function f_esl( p, t )
>
> implicit none
>
> real :: p ! Pressure (Pascal)
> real :: t ! Temperature (K)
> real :: f_esl ! Saturation water vapor pressure over liquid water
>
> real :: f
>
> !#######################################################################
> !
> !Saturation specific humidity parameters used in enhanced Teten's
> !formula. (See A. Buck, JAM 1981)
> !
> !#######################################################################
>
> real,parameter :: satfwa = 1.0007
> real,parameter :: satfwb = 3.46e-8 ! for p in Pa
>
> real,parameter :: satewa = 611.21 ! es in Pa
> real,parameter :: satewb = 17.502
> real,parameter :: satewc = 32.18
>
> real,parameter :: satfia = 1.0003
> real,parameter :: satfib = 4.18e-8 ! for p in Pa
>
> real,parameter :: sateia = 611.15 ! es in Pa
> real,parameter :: sateib = 22.452
> real,parameter :: sateic = 0.6
>
> f = satfwa + satfwb * p
> f_esl = f * satewa * exp( satewb*(t-273.15)/(t-satewc) )
>
> return
> end function f_esl
>
> function f_esi( p, t )
>
> implicit none
>
> real :: p ! Pressure (Pascal)
> real :: t ! Temperature (K)
> real :: f_esi ! Saturation water vapor pressure over ice (Pa)
>
> real :: f
>
> !#######################################################################
> !
> !Saturation specific humidity parameters used in enhanced Teten's
> !formula. (See A. Buck, JAM 1981)
> !
> !#######################################################################
> !
> real,parameter :: satfwa = 1.0007
> real,parameter :: satfwb = 3.46e-8 ! for p in Pa
>
> real,parameter :: satewa = 611.21 ! es in Pa
> real,parameter :: satewb = 17.502
> real,parameter :: satewc = 32.18
>
> real,parameter :: satfia = 1.0003
> real,parameter :: satfib = 4.18e-8 ! for p in Pa
>
> real,parameter :: sateia = 611.15 ! es in Pa
> real,parameter :: sateib = 22.452
> real,parameter :: sateic = 0.6
>
> f = satfia + satfib * p
> f_esi = f * sateia * exp( sateib*(t-273.15)/(t-sateic) )
>
> return
> end function f_esi
raerod.f90
----------------------------------------------
1,63c1,63
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< function raerod (l,ust,z0)
<
< !*****************************************************************************
< ! *
< ! Calculation of the aerodynamical resistance ra from ground up to href *
< ! *
< ! AUTHOR: Matthias Langer, modified by Andreas Stohl (6 August 1993) *
< ! *
< ! Literature: *
< ! [1] Hicks/Baldocchi/Meyers/Hosker/Matt (1987), A Preliminary *
< ! Multiple Resistance Routine for Deriving Dry Deposition *
< ! Velocities from Measured Quantities. *
< ! Water, Air and Soil Pollution 36 (1987), pp.311-330. *
< ! [2] Scire/Yamartino/Carmichael/Chang (1989), *
< ! CALGRID: A Mesoscale Photochemical Grid Model. *
< ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
< ! *
< ! Variable list: *
< ! L = Monin-Obukhov-length [m] *
< ! ust = friction velocity [m/sec] *
< ! z0 = surface roughness length [m] *
< ! href = reference height [m], for which deposition velocity is *
< ! calculated *
< ! *
< ! Constants: *
< ! karman = von Karman-constant (~0.4) *
< ! ramin = minimum resistence of ra (1 s/m) *
< ! *
< ! Subprograms and functions: *
< ! function psih (z/L) *
< ! *
< !*****************************************************************************
<
< use par_mod
<
< implicit none
<
< real :: l,psih,raerod,ust,z0
<
< raerod=(alog(href/z0)-psih(href,l)+psih(z0,l))/(karman*ust)
<
< end function raerod
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> function raerod (l,ust,z0)
>
> !*****************************************************************************
> ! *
> ! Calculation of the aerodynamical resistance ra from ground up to href *
> ! *
> ! AUTHOR: Matthias Langer, modified by Andreas Stohl (6 August 1993) *
> ! *
> ! Literature: *
> ! [1] Hicks/Baldocchi/Meyers/Hosker/Matt (1987), A Preliminary *
> ! Multiple Resistance Routine for Deriving Dry Deposition *
> ! Velocities from Measured Quantities. *
> ! Water, Air and Soil Pollution 36 (1987), pp.311-330. *
> ! [2] Scire/Yamartino/Carmichael/Chang (1989), *
> ! CALGRID: A Mesoscale Photochemical Grid Model. *
> ! Vol II: User's Guide. (Report No.A049-1, June, 1989) *
> ! *
> ! Variable list: *
> ! L = Monin-Obukhov-length [m] *
> ! ust = friction velocity [m/sec] *
> ! z0 = surface roughness length [m] *
> ! href = reference height [m], for which deposition velocity is *
> ! calculated *
> ! *
> ! Constants: *
> ! karman = von Karman-constant (~0.4) *
> ! ramin = minimum resistence of ra (1 s/m) *
> ! *
> ! Subprograms and functions: *
> ! function psih (z/L) *
> ! *
> !*****************************************************************************
>
> use par_mod
>
> implicit none
>
> real :: l,psih,raerod,ust,z0
>
> raerod=(alog(href/z0)-psih(href,l)+psih(z0,l))/(karman*ust)
>
> end function raerod
random.f90
----------------------------------------------
1,154c1,154
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< ! Taken from Press et al., Numerical Recipes
<
< function ran1(idum)
<
< implicit none
<
< integer :: idum
< real :: ran1
< integer,parameter :: ia=16807, im=2147483647, iq=127773, ir=2836
< integer,parameter :: ntab=32, ndiv=1+(im-1)/ntab
< real,parameter :: am=1./im, eps=1.2e-7, rnmx=1.-eps
< integer :: j, k
< integer :: iv(ntab) = (/ (0,j=1,ntab) /)
< integer :: iy=0
<
< if (idum.le.0.or.iy.eq.0) then
< idum=max(-idum,1)
< do j=ntab+8,1,-1
< k=idum/iq
< idum=ia*(idum-k*iq)-ir*k
< if (idum.lt.0) idum=idum+im
< if (j.le.ntab) iv(j)=idum
< enddo
< iy=iv(1)
< endif
< k=idum/iq
< idum=ia*(idum-k*iq)-ir*k
< if (idum.lt.0) idum=idum+im
< j=1+iy/ndiv
< iy=iv(j)
< iv(j)=idum
< ran1=min(am*iy,rnmx)
< end function ran1
<
<
< function gasdev(idum)
<
< implicit none
<
< integer :: idum
< real :: gasdev, fac, r, v1, v2
< integer :: iset = 0
< real :: gset = 0.
< real, external :: ran3
<
< if (iset.eq.0) then
< 1 v1=2.*ran3(idum)-1.
< v2=2.*ran3(idum)-1.
< r=v1**2+v2**2
< if(r.ge.1.0 .or. r.eq.0.0) go to 1
< fac=sqrt(-2.*log(r)/r)
< gset=v1*fac
< gasdev=v2*fac
< iset=1
< else
< gasdev=gset
< iset=0
< endif
< end function gasdev
<
<
< subroutine gasdev1(idum,random1,random2)
<
< implicit none
<
< integer :: idum
< real :: random1, random2, fac, v1, v2, r
< real, external :: ran3
<
< 1 v1=2.*ran3(idum)-1.
< v2=2.*ran3(idum)-1.
< r=v1**2+v2**2
< if(r.ge.1.0 .or. r.eq.0.0) go to 1
< fac=sqrt(-2.*log(r)/r)
< random1=v1*fac
< random2=v2*fac
< ! Limit the random numbers to lie within the interval -3 and +3
< !**************************************************************
< if (random1.lt.-3.) random1=-3.
< if (random2.lt.-3.) random2=-3.
< if (random1.gt.3.) random1=3.
< if (random2.gt.3.) random2=3.
< end subroutine gasdev1
<
<
< function ran3(idum)
<
< implicit none
<
< integer :: idum
< real :: ran3
<
< integer,parameter :: mbig=1000000000, mseed=161803398, mz=0
< real,parameter :: fac=1./mbig
< integer :: i,ii,inext,inextp,k
< integer :: mj,mk,ma(55)
<
< save inext,inextp,ma
< integer :: iff = 0
<
< if(idum.lt.0.or.iff.eq.0)then
< iff=1
< mj=mseed-iabs(idum)
< mj=mod(mj,mbig)
< ma(55)=mj
< mk=1
< do i=1,54
< ii=mod(21*i,55)
< ma(ii)=mk
< mk=mj-mk
< if(mk.lt.mz)mk=mk+mbig
< mj=ma(ii)
< end do
< do k=1,4
< do i=1,55
< ma(i)=ma(i)-ma(1+mod(i+30,55))
< if(ma(i).lt.mz)ma(i)=ma(i)+mbig
< end do
< end do
< inext=0
< inextp=31
< idum=1
< endif
< inext=inext+1
< if(inext.eq.56)inext=1
< inextp=inextp+1
< if(inextp.eq.56)inextp=1
< mj=ma(inext)-ma(inextp)
< if(mj.lt.mz)mj=mj+mbig
< ma(inext)=mj
< ran3=mj*fac
< end function ran3
< ! (C) Copr. 1986-92 Numerical Recipes Software US.
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> ! Taken from Press et al., Numerical Recipes
>
> function ran1(idum)
>
> implicit none
>
> integer :: idum
> real :: ran1
> integer,parameter :: ia=16807, im=2147483647, iq=127773, ir=2836
> integer,parameter :: ntab=32, ndiv=1+(im-1)/ntab
> real,parameter :: am=1./im, eps=1.2e-7, rnmx=1.-eps
> integer :: j, k
> integer :: iv(ntab) = (/ (0,j=1,ntab) /)
> integer :: iy=0
>
> if (idum.le.0.or.iy.eq.0) then
> idum=max(-idum,1)
> do j=ntab+8,1,-1
> k=idum/iq
> idum=ia*(idum-k*iq)-ir*k
> if (idum.lt.0) idum=idum+im
> if (j.le.ntab) iv(j)=idum
> enddo
> iy=iv(1)
> endif
> k=idum/iq
> idum=ia*(idum-k*iq)-ir*k
> if (idum.lt.0) idum=idum+im
> j=1+iy/ndiv
> iy=iv(j)
> iv(j)=idum
> ran1=min(am*iy,rnmx)
> end function ran1
>
>
> function gasdev(idum)
>
> implicit none
>
> integer :: idum
> real :: gasdev, fac, r, v1, v2
> integer :: iset = 0
> real :: gset = 0.
> real, external :: ran3
>
> if (iset.eq.0) then
> 1 v1=2.*ran3(idum)-1.
> v2=2.*ran3(idum)-1.
> r=v1**2+v2**2
> if(r.ge.1.0 .or. r.eq.0.0) go to 1
> fac=sqrt(-2.*log(r)/r)
> gset=v1*fac
> gasdev=v2*fac
> iset=1
> else
> gasdev=gset
> iset=0
> endif
> end function gasdev
>
>
> subroutine gasdev1(idum,random1,random2)
>
> implicit none
>
> integer :: idum
> real :: random1, random2, fac, v1, v2, r
> real, external :: ran3
>
> 1 v1=2.*ran3(idum)-1.
> v2=2.*ran3(idum)-1.
> r=v1**2+v2**2
> if(r.ge.1.0 .or. r.eq.0.0) go to 1
> fac=sqrt(-2.*log(r)/r)
> random1=v1*fac
> random2=v2*fac
> ! Limit the random numbers to lie within the interval -3 and +3
> !**************************************************************
> if (random1.lt.-3.) random1=-3.
> if (random2.lt.-3.) random2=-3.
> if (random1.gt.3.) random1=3.
> if (random2.gt.3.) random2=3.
> end subroutine gasdev1
>
>
> function ran3(idum)
>
> implicit none
>
> integer :: idum
> real :: ran3
>
> integer,parameter :: mbig=1000000000, mseed=161803398, mz=0
> real,parameter :: fac=1./mbig
> integer :: i,ii,inext,inextp,k
> integer :: mj,mk,ma(55)
>
> save inext,inextp,ma
> integer :: iff = 0
>
> if(idum.lt.0.or.iff.eq.0)then
> iff=1
> mj=mseed-iabs(idum)
> mj=mod(mj,mbig)
> ma(55)=mj
> mk=1
> do i=1,54
> ii=mod(21*i,55)
> ma(ii)=mk
> mk=mj-mk
> if(mk.lt.mz)mk=mk+mbig
> mj=ma(ii)
> end do
> do k=1,4
> do i=1,55
> ma(i)=ma(i)-ma(1+mod(i+30,55))
> if(ma(i).lt.mz)ma(i)=ma(i)+mbig
> end do
> end do
> inext=0
> inextp=31
> idum=1
> endif
> inext=inext+1
> if(inext.eq.56)inext=1
> inextp=inextp+1
> if(inextp.eq.56)inextp=1
> mj=ma(inext)-ma(inextp)
> if(mj.lt.mz)mj=mj+mbig
> ma(inext)=mj
> ran3=mj*fac
> end function ran3
> ! (C) Copr. 1986-92 Numerical Recipes Software US.
readageclasses.f90
----------------------------------------------
1,107c1,107
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readageclasses
<
< !*****************************************************************************
< ! *
< ! This routine reads the age classes to be used for the current model *
< ! run. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 20 March 2000 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: i
<
<
< ! If age spectra calculation is switched off, set number of age classes
< ! to 1 and maximum age to a large number
< !**********************************************************************
<
< if (lagespectra.ne.1) then
< nageclass=1
< lage(nageclass)=999999999
< return
< endif
<
<
< ! If age spectra claculation is switched on,
< ! open the AGECLASSSES file and read user options
< !************************************************
<
< open(unitageclasses,file=path(1)(1:length(1))//'AGECLASSES', &
< status='old',err=999)
<
< do i=1,13
< read(unitageclasses,*)
< end do
< read(unitageclasses,*) nageclass
<
<
< if (nageclass.gt.maxageclass) then
< write(*,*) ' #### FLEXPART MODEL ERROR! NUMBER OF AGE #### '
< write(*,*) ' #### CLASSES GREATER THAN MAXIMUM ALLOWED. #### '
< write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES OR #### '
< write(*,*) ' #### RECOMPILE WITH LARGER MAXAGECLASS IN #### '
< write(*,*) ' #### FILE PAR_MOD. #### '
< stop
< endif
<
< read(unitageclasses,*) lage(1)
< if (lage(1).le.0) then
< write(*,*) ' #### FLEXPART MODEL ERROR! AGE OF FIRST #### '
< write(*,*) ' #### CLASS MUST BE GREATER THAN ZERO. CHANGE #### '
< write(*,*) ' #### SETTINGS IN FILE AGECLASSES. #### '
< stop
< endif
<
< do i=2,nageclass
< read(unitageclasses,*) lage(i)
< if (lage(i).le.lage(i-1)) then
< write(*,*) ' #### FLEXPART MODEL ERROR! AGE CLASSES #### '
< write(*,*) ' #### MUST BE GIVEN IN TEMPORAL ORDER. #### '
< write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES. #### '
< stop
< endif
< end do
<
< return
<
< 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "AGECLASSES" #### '
< write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
< write(*,'(a)') path(1)(1:length(1))
< stop
<
< end subroutine readageclasses
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readageclasses
>
> !*****************************************************************************
> ! *
> ! This routine reads the age classes to be used for the current model *
> ! run. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 20 March 2000 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: i
>
>
> ! If age spectra calculation is switched off, set number of age classes
> ! to 1 and maximum age to a large number
> !**********************************************************************
>
> if (lagespectra.ne.1) then
> nageclass=1
> lage(nageclass)=999999999
> return
> endif
>
>
> ! If age spectra claculation is switched on,
> ! open the AGECLASSSES file and read user options
> !************************************************
>
> open(unitageclasses,file=path(1)(1:length(1))//'AGECLASSES', &
> status='old',err=999)
>
> do i=1,13
> read(unitageclasses,*)
> end do
> read(unitageclasses,*) nageclass
>
>
> if (nageclass.gt.maxageclass) then
> write(*,*) ' #### FLEXPART MODEL ERROR! NUMBER OF AGE #### '
> write(*,*) ' #### CLASSES GREATER THAN MAXIMUM ALLOWED. #### '
> write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES OR #### '
> write(*,*) ' #### RECOMPILE WITH LARGER MAXAGECLASS IN #### '
> write(*,*) ' #### FILE PAR_MOD. #### '
> stop
> endif
>
> read(unitageclasses,*) lage(1)
> if (lage(1).le.0) then
> write(*,*) ' #### FLEXPART MODEL ERROR! AGE OF FIRST #### '
> write(*,*) ' #### CLASS MUST BE GREATER THAN ZERO. CHANGE #### '
> write(*,*) ' #### SETTINGS IN FILE AGECLASSES. #### '
> stop
> endif
>
> do i=2,nageclass
> read(unitageclasses,*) lage(i)
> if (lage(i).le.lage(i-1)) then
> write(*,*) ' #### FLEXPART MODEL ERROR! AGE CLASSES #### '
> write(*,*) ' #### MUST BE GIVEN IN TEMPORAL ORDER. #### '
> write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES. #### '
> stop
> endif
> end do
>
> return
>
> 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "AGECLASSES" #### '
> write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
> write(*,'(a)') path(1)(1:length(1))
> stop
>
> end subroutine readageclasses
readavailable.f90
----------------------------------------------
1,290c1,288
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readavailable
<
< !*****************************************************************************
< ! *
< ! This routine reads the dates and times for which windfields are *
< ! available. *
< ! *
< ! Authors: A. Stohl *
< ! *
< ! 6 February 1994 *
< ! 8 February 1999, Use of nested fields, A. Stohl *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! bdate beginning date as Julian date *
< ! beg beginning date for windfields *
< ! end ending date for windfields *
< ! fname filename of wind field, help variable *
< ! ideltas [s] duration of modelling period *
< ! idiff time difference between 2 wind fields *
< ! idiffnorm normal time difference between 2 wind fields *
< ! idiffmax [s] maximum allowable time between 2 wind fields *
< ! jul julian date, help variable *
< ! numbwf actual number of wind fields *
< ! wfname(maxwf) file names of needed wind fields *
< ! wfspec(maxwf) file specifications of wind fields (e.g., if on disc) *
< ! wftime(maxwf) [s]times of wind fields relative to beginning time *
< ! wfname1,wfspec1,wftime1 = same as above, but only local (help variables) *
< ! *
< ! Constants: *
< ! maxwf maximum number of wind fields *
< ! unitavailab unit connected to file AVAILABLE *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: i,idiff,ldat,ltim,wftime1(maxwf),numbwfn(maxnests),k
< integer :: wftime1n(maxnests,maxwf),wftimen(maxnests,maxwf)
< real(kind=dp) :: juldate,jul,beg,end
< character(len=255) :: fname,spec,wfname1(maxwf),wfspec1(maxwf)
< character(len=255) :: wfname1n(maxnests,maxwf)
< character(len=40) :: wfspec1n(maxnests,maxwf)
<
<
< ! Windfields are only used, if they are within the modelling period.
< ! However, 1 additional day at the beginning and at the end is used for
< ! interpolation. -> Compute beginning and ending date for the windfields.
< !************************************************************************
<
< if (ideltas.gt.0) then ! forward trajectories
< beg=bdate-1._dp
< end=bdate+real(ideltas,kind=dp)/86400._dp+real(idiffmax,kind=dp)/ &
< 86400._dp
< else ! backward trajectories
< beg=bdate+real(ideltas,kind=dp)/86400._dp-real(idiffmax,kind=dp)/ &
< 86400._dp
< end=bdate+1._dp
< endif
<
< ! Open the wind field availability file and read available wind fields
< ! within the modelling period.
< !*********************************************************************
<
< open(unitavailab,file=path(4)(1:length(4)),status='old', &
< err=999)
<
< do i=1,3
< read(unitavailab,*)
< end do
<
< numbwf=0
< 100 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=99) &
< ldat,ltim,fname,spec
< jul=juldate(ldat,ltim)
< if ((jul.ge.beg).and.(jul.le.end)) then
< numbwf=numbwf+1
< if (numbwf.gt.maxwf) then ! check exceedance of dimension
< write(*,*) 'Number of wind fields needed is too great.'
< write(*,*) 'Reduce modelling period (file "COMMAND") or'
< write(*,*) 'reduce number of wind fields (file "AVAILABLE").'
< stop
< endif
<
< wfname1(numbwf)=fname(1:index(fname,' '))
< wfspec1(numbwf)=spec
< wftime1(numbwf)=nint((jul-bdate)*86400._dp)
< endif
< goto 100 ! next wind field
<
< 99 continue
<
< close(unitavailab)
<
< ! Open the wind field availability file and read available wind fields
< ! within the modelling period (nested grids)
< !*********************************************************************
<
< do k=1,numbnests
< print*,length(numpath+2*(k-1)+1),length(numpath+2*(k-1)+2),length(4),length(3)
< print*,path(numpath+2*(k-1)+2)(1:length(numpath+2*(k-1)+2))
< open(unitavailab,file=path(numpath+2*(k-1)+2) &
< (1:length(numpath+2*(k-1)+2)),status='old',err=998)
<
< do i=1,3
< read(unitavailab,*)
< end do
<
< numbwfn(k)=0
< 700 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=699) ldat, &
< ltim,fname,spec
< jul=juldate(ldat,ltim)
< if ((jul.ge.beg).and.(jul.le.end)) then
< numbwfn(k)=numbwfn(k)+1
< if (numbwfn(k).gt.maxwf) then ! check exceedance of dimension
< write(*,*) 'Number of nested wind fields is too great.'
< write(*,*) 'Reduce modelling period (file "COMMAND") or'
< write(*,*) 'reduce number of wind fields (file "AVAILABLE").'
< stop
< endif
<
< wfname1n(k,numbwfn(k))=fname
< wfspec1n(k,numbwfn(k))=spec
< wftime1n(k,numbwfn(k))=nint((jul-bdate)*86400._dp)
< endif
< goto 700 ! next wind field
<
< 699 continue
<
< close(unitavailab)
< end do
<
<
< ! Check wind field times of file AVAILABLE (expected to be in temporal order)
< !****************************************************************************
<
< if (numbwf.eq.0) then
< write(*,*) ' #### FLEXPART MODEL ERROR! NO WIND FIELDS #### '
< write(*,*) ' #### AVAILABLE FOR SELECTED TIME PERIOD. #### '
< stop
< endif
<
< do i=2,numbwf
< if (wftime1(i).le.wftime1(i-1)) then
< write(*,*) 'FLEXPART ERROR: FILE AVAILABLE IS CORRUPT.'
< write(*,*) 'THE WIND FIELDS ARE NOT IN TEMPORAL ORDER.'
< write(*,*) 'PLEASE CHECK FIELD ',wfname1(i)
< stop
< endif
< end do
<
< ! Check wind field times of file AVAILABLE for the nested fields
< ! (expected to be in temporal order)
< !***************************************************************
<
< do k=1,numbnests
< if (numbwfn(k).eq.0) then
< write(*,*) '#### FLEXPART MODEL ERROR! NO WIND FIELDS ####'
< write(*,*) '#### AVAILABLE FOR SELECTED TIME PERIOD. ####'
< stop
< endif
<
< do i=2,numbwfn(k)
< if (wftime1n(k,i).le.wftime1n(k,i-1)) then
< write(*,*) 'FLEXPART ERROR: FILE AVAILABLE IS CORRUPT. '
< write(*,*) 'THE NESTED WIND FIELDS ARE NOT IN TEMPORAL ORDER.'
< write(*,*) 'PLEASE CHECK FIELD ',wfname1n(k,i)
< write(*,*) 'AT NESTING LEVEL ',k
< stop
< endif
< end do
<
< end do
<
<
< ! For backward trajectories, reverse the order of the windfields
< !***************************************************************
<
< if (ideltas.ge.0) then
< do i=1,numbwf
< wfname(i)=wfname1(i)
< wfspec(i)=wfspec1(i)
< wftime(i)=wftime1(i)
< end do
< do k=1,numbnests
< do i=1,numbwfn(k)
< wfnamen(k,i)=wfname1n(k,i)
< wfspecn(k,i)=wfspec1n(k,i)
< wftimen(k,i)=wftime1n(k,i)
< end do
< end do
< else
< do i=1,numbwf
< wfname(numbwf-i+1)=wfname1(i)
< wfspec(numbwf-i+1)=wfspec1(i)
< wftime(numbwf-i+1)=wftime1(i)
< end do
< do k=1,numbnests
< do i=1,numbwfn(k)
< wfnamen(k,numbwfn(k)-i+1)=wfname1n(k,i)
< wfspecn(k,numbwfn(k)-i+1)=wfspec1n(k,i)
< wftimen(k,numbwfn(k)-i+1)=wftime1n(k,i)
< end do
< end do
< endif
<
< ! Check the time difference between the wind fields. If it is big,
< ! write a warning message. If it is too big, terminate the trajectory.
< !*********************************************************************
<
< do i=2,numbwf
< idiff=abs(wftime(i)-wftime(i-1))
< if (idiff.gt.idiffmax) then
< write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO'
< write(*,*) 'WIND FIELDS IS TOO BIG FOR TRANSPORT CALCULATION.&
< &'
< write(*,*) 'THEREFORE, TRAJECTORIES HAVE TO BE SKIPPED.'
< else if (idiff.gt.idiffnorm) then
< write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO'
< write(*,*) 'WIND FIELDS IS BIG. THIS MAY CAUSE A DEGRADATION'
< write(*,*) 'OF SIMULATION QUALITY.'
< endif
< end do
<
< do k=1,numbnests
< if (numbwfn(k).ne.numbwf) then
< write(*,*) 'FLEXPART ERROR: THE AVAILABLE FILES FOR THE'
< write(*,*) 'NESTED WIND FIELDS ARE NOT CONSISTENT WITH'
< write(*,*) 'THE AVAILABLE FILE OF THE MOTHER DOMAIN. '
< write(*,*) 'ERROR AT NEST LEVEL: ',k
< stop
< endif
< do i=1,numbwf
< if (wftimen(k,i).ne.wftime(i)) then
< write(*,*) 'FLEXPART ERROR: THE AVAILABLE FILES FOR THE'
< write(*,*) 'NESTED WIND FIELDS ARE NOT CONSISTENT WITH'
< write(*,*) 'THE AVAILABLE FILE OF THE MOTHER DOMAIN. '
< write(*,*) 'ERROR AT NEST LEVEL: ',k
< stop
< endif
< end do
< end do
<
< ! Reset the times of the wind fields that are kept in memory to no time
< !**********************************************************************
<
< do i=1,2
< memind(i)=i
< memtime(i)=999999999
< end do
<
< return
<
< 998 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE FILE #### '
< write(*,'(a)') ' '//path(numpath+2*(k-1)+2) &
< (1:length(numpath+2*(k-1)+2))
< write(*,*) ' #### CANNOT BE OPENED #### '
< stop
<
< 999 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE IILE #### '
< write(*,'(a)') ' '//path(4)(1:length(4))
< write(*,*) ' #### CANNOT BE OPENED #### '
< stop
<
< end subroutine readavailable
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readavailable
>
> !*****************************************************************************
> ! *
> ! This routine reads the dates and times for which windfields are *
> ! available. *
> ! *
> ! Authors: A. Stohl *
> ! *
> ! 6 February 1994 *
> ! 8 February 1999, Use of nested fields, A. Stohl *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! bdate beginning date as Julian date *
> ! beg beginning date for windfields *
> ! end ending date for windfields *
> ! fname filename of wind field, help variable *
> ! ideltas [s] duration of modelling period *
> ! idiff time difference between 2 wind fields *
> ! idiffnorm normal time difference between 2 wind fields *
> ! idiffmax [s] maximum allowable time between 2 wind fields *
> ! jul julian date, help variable *
> ! numbwf actual number of wind fields *
> ! wfname(maxwf) file names of needed wind fields *
> ! wfspec(maxwf) file specifications of wind fields (e.g., if on disc) *
> ! wftime(maxwf) [s]times of wind fields relative to beginning time *
> ! wfname1,wfspec1,wftime1 = same as above, but only local (help variables) *
> ! *
> ! Constants: *
> ! maxwf maximum number of wind fields *
> ! unitavailab unit connected to file AVAILABLE *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: i,idiff,ldat,ltim,wftime1(maxwf),numbwfn(maxnests),k
> integer :: wftime1n(maxnests,maxwf),wftimen(maxnests,maxwf)
> real(kind=dp) :: juldate,jul,beg,end
> character(len=255) :: fname,spec,wfname1(maxwf),wfspec1(maxwf)
> character(len=255) :: wfname1n(maxnests,maxwf)
> character(len=40) :: wfspec1n(maxnests,maxwf)
>
>
> ! Windfields are only used, if they are within the modelling period.
> ! However, 1 additional day at the beginning and at the end is used for
> ! interpolation. -> Compute beginning and ending date for the windfields.
> !************************************************************************
>
> if (ideltas.gt.0) then ! forward trajectories
> beg=bdate-1._dp
> end=bdate+real(ideltas,kind=dp)/86400._dp+real(idiffmax,kind=dp)/ &
> 86400._dp
> else ! backward trajectories
> beg=bdate+real(ideltas,kind=dp)/86400._dp-real(idiffmax,kind=dp)/ &
> 86400._dp
> end=bdate+1._dp
> endif
>
> ! Open the wind field availability file and read available wind fields
> ! within the modelling period.
> !*********************************************************************
>
> open(unitavailab,file=path(4)(1:length(4)),status='old', &
> err=999)
>
> do i=1,3
> read(unitavailab,*)
> end do
>
> numbwf=0
> 100 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=99) &
> ldat,ltim,fname,spec
> jul=juldate(ldat,ltim)
> if ((jul.ge.beg).and.(jul.le.end)) then
> numbwf=numbwf+1
> if (numbwf.gt.maxwf) then ! check exceedance of dimension
> write(*,*) 'Number of wind fields needed is too great.'
> write(*,*) 'Reduce modelling period (file "COMMAND") or'
> write(*,*) 'reduce number of wind fields (file "AVAILABLE").'
> stop
> endif
>
> wfname1(numbwf)=fname(1:index(fname,' '))
> wfspec1(numbwf)=spec
> wftime1(numbwf)=nint((jul-bdate)*86400._dp)
> endif
> goto 100 ! next wind field
>
> 99 continue
>
> close(unitavailab)
>
> ! Open the wind field availability file and read available wind fields
> ! within the modelling period (nested grids)
> !*********************************************************************
>
> do k=1,numbnests
> open(unitavailab,file=path(numpath+2*(k-1)+2) &
> (1:length(numpath+2*(k-1)+2)),status='old',err=998)
>
> do i=1,3
> read(unitavailab,*)
> end do
>
> numbwfn(k)=0
> 700 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=699) ldat, &
> ltim,fname,spec
> jul=juldate(ldat,ltim)
> if ((jul.ge.beg).and.(jul.le.end)) then
> numbwfn(k)=numbwfn(k)+1
> if (numbwfn(k).gt.maxwf) then ! check exceedance of dimension
> write(*,*) 'Number of nested wind fields is too great.'
> write(*,*) 'Reduce modelling period (file "COMMAND") or'
> write(*,*) 'reduce number of wind fields (file "AVAILABLE").'
> stop
> endif
>
> wfname1n(k,numbwfn(k))=fname
> wfspec1n(k,numbwfn(k))=spec
> wftime1n(k,numbwfn(k))=nint((jul-bdate)*86400._dp)
> endif
> goto 700 ! next wind field
>
> 699 continue
>
> close(unitavailab)
> end do
>
>
> ! Check wind field times of file AVAILABLE (expected to be in temporal order)
> !****************************************************************************
>
> if (numbwf.eq.0) then
> write(*,*) ' #### FLEXPART MODEL ERROR! NO WIND FIELDS #### '
> write(*,*) ' #### AVAILABLE FOR SELECTED TIME PERIOD. #### '
> stop
> endif
>
> do i=2,numbwf
> if (wftime1(i).le.wftime1(i-1)) then
> write(*,*) 'FLEXPART ERROR: FILE AVAILABLE IS CORRUPT.'
> write(*,*) 'THE WIND FIELDS ARE NOT IN TEMPORAL ORDER.'
> write(*,*) 'PLEASE CHECK FIELD ',wfname1(i)
> stop
> endif
> end do
>
> ! Check wind field times of file AVAILABLE for the nested fields
> ! (expected to be in temporal order)
> !***************************************************************
>
> do k=1,numbnests
> if (numbwfn(k).eq.0) then
> write(*,*) '#### FLEXPART MODEL ERROR! NO WIND FIELDS ####'
> write(*,*) '#### AVAILABLE FOR SELECTED TIME PERIOD. ####'
> stop
> endif
>
> do i=2,numbwfn(k)
> if (wftime1n(k,i).le.wftime1n(k,i-1)) then
> write(*,*) 'FLEXPART ERROR: FILE AVAILABLE IS CORRUPT. '
> write(*,*) 'THE NESTED WIND FIELDS ARE NOT IN TEMPORAL ORDER.'
> write(*,*) 'PLEASE CHECK FIELD ',wfname1n(k,i)
> write(*,*) 'AT NESTING LEVEL ',k
> stop
> endif
> end do
>
> end do
>
>
> ! For backward trajectories, reverse the order of the windfields
> !***************************************************************
>
> if (ideltas.ge.0) then
> do i=1,numbwf
> wfname(i)=wfname1(i)
> wfspec(i)=wfspec1(i)
> wftime(i)=wftime1(i)
> end do
> do k=1,numbnests
> do i=1,numbwfn(k)
> wfnamen(k,i)=wfname1n(k,i)
> wfspecn(k,i)=wfspec1n(k,i)
> wftimen(k,i)=wftime1n(k,i)
> end do
> end do
> else
> do i=1,numbwf
> wfname(numbwf-i+1)=wfname1(i)
> wfspec(numbwf-i+1)=wfspec1(i)
> wftime(numbwf-i+1)=wftime1(i)
> end do
> do k=1,numbnests
> do i=1,numbwfn(k)
> wfnamen(k,numbwfn(k)-i+1)=wfname1n(k,i)
> wfspecn(k,numbwfn(k)-i+1)=wfspec1n(k,i)
> wftimen(k,numbwfn(k)-i+1)=wftime1n(k,i)
> end do
> end do
> endif
>
> ! Check the time difference between the wind fields. If it is big,
> ! write a warning message. If it is too big, terminate the trajectory.
> !*********************************************************************
>
> do i=2,numbwf
> idiff=abs(wftime(i)-wftime(i-1))
> if (idiff.gt.idiffmax) then
> write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO'
> write(*,*) 'WIND FIELDS IS TOO BIG FOR TRANSPORT CALCULATION.&
> &'
> write(*,*) 'THEREFORE, TRAJECTORIES HAVE TO BE SKIPPED.'
> else if (idiff.gt.idiffnorm) then
> write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO'
> write(*,*) 'WIND FIELDS IS BIG. THIS MAY CAUSE A DEGRADATION'
> write(*,*) 'OF SIMULATION QUALITY.'
> endif
> end do
>
> do k=1,numbnests
> if (numbwfn(k).ne.numbwf) then
> write(*,*) 'FLEXPART ERROR: THE AVAILABLE FILES FOR THE'
> write(*,*) 'NESTED WIND FIELDS ARE NOT CONSISTENT WITH'
> write(*,*) 'THE AVAILABLE FILE OF THE MOTHER DOMAIN. '
> write(*,*) 'ERROR AT NEST LEVEL: ',k
> stop
> endif
> do i=1,numbwf
> if (wftimen(k,i).ne.wftime(i)) then
> write(*,*) 'FLEXPART ERROR: THE AVAILABLE FILES FOR THE'
> write(*,*) 'NESTED WIND FIELDS ARE NOT CONSISTENT WITH'
> write(*,*) 'THE AVAILABLE FILE OF THE MOTHER DOMAIN. '
> write(*,*) 'ERROR AT NEST LEVEL: ',k
> stop
> endif
> end do
> end do
>
> ! Reset the times of the wind fields that are kept in memory to no time
> !**********************************************************************
>
> do i=1,2
> memind(i)=i
> memtime(i)=999999999
> end do
>
> return
>
> 998 write(*,*) ' #### FLEXPART MODEL ERROR! FILE #### '
> write(*,'(a)') ' '//path(numpath+2*(k-1)+2) &
> (1:length(numpath+2*(k-1)+2))
> write(*,*) ' #### CANNOT BE OPENED #### '
> stop
>
> 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE #### '
> write(*,'(a)') ' '//path(4)(1:length(4))
> write(*,*) ' #### CANNOT BE OPENED #### '
> stop
>
> end subroutine readavailable
readcommand.f90
----------------------------------------------
1,585c1,507
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readcommand
<
< !*****************************************************************************
< ! *
< ! This routine reads the user specifications for the current model run. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 18 May 1996 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! bdate beginning date as Julian date *
< ! ctl factor by which time step must be smaller than *
< ! Lagrangian time scale *
< ! ibdate,ibtime beginnning date and time (YYYYMMDD, HHMISS) *
< ! ideltas [s] modelling period *
< ! iedate,ietime ending date and time (YYYYMMDD, HHMISS) *
< ! ifine reduction factor for vertical wind time step *
< ! outputforeachrel for forward runs it is possible either to create *
< ! one outputfield or several for each releasepoint *
< ! iflux switch to turn on (1)/off (0) flux calculations *
< ! iout 1 for conc. (residence time for backward runs) output,*
< ! 2 for mixing ratio output, 3 both, 4 for plume *
< ! trajectory output, 5 = options 1 and 4 *
< ! ipin 1 continue simulation with dumped particle data, 0 no *
< ! ipout 0 no particle dump, 1 every output time, 3 only at end*
< ! itsplit [s] time constant for particle splitting *
< ! loutaver [s] concentration output is an average over loutaver *
< ! seconds *
< ! loutsample [s] average is computed from samples taken every [s] *
< ! seconds *
< ! loutstep [s] time interval of concentration output *
< ! lsynctime [s] synchronisation time interval for all particles *
< ! lagespectra switch to turn on (1)/off (0) calculation of age *
< ! spectra *
< ! lconvection value of either 0 and 1 indicating mixing by *
< ! convection *
< ! = 0 .. no convection *
< ! + 1 .. parameterisation of mixing by subgrid-scale *
< ! convection = on *
< ! lsubgrid switch to turn on (1)/off (0) subgrid topography *
< ! parameterization *
< ! method method used to compute the particle pseudovelocities *
< ! mdomainfill 1 use domain-filling option, 0 not, 2 use strat. O3 *
< ! *
< ! Constants: *
< ! unitcommand unit connected to file COMMAND *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< real(kind=dp) :: juldate
< character(len=50) :: line
< logical :: old
< logical :: nmlout=.false.
< integer :: readerror
<
< namelist /command/ &
< ldirect, &
< ibdate,ibtime, &
< iedate,ietime, &
< loutstep, &
< loutaver, &
< loutsample, &
< itsplit, &
< lsynctime, &
< ctl, &
< ifine, &
< iout, &
< ipout, &
< lsubgrid, &
< lconvection, &
< lagespectra, &
< ipin, &
< ioutputforeachrelease, &
< iflux, &
< mdomainfill, &
< ind_source, &
< ind_receptor, &
< mquasilag, &
< nested_output, &
< linit_cond
<
< ! Presetting namelist command
< ldirect=1
< ibdate=20000101
< ibtime=0
< iedate=20000102
< ietime=0
< loutstep=10800
< loutaver=10800
< loutsample=900
< itsplit=999999999
< lsynctime=900
< ctl=-5.0
< ifine=4
< iout=3
< ipout=0
< lsubgrid=1
< lconvection=1
< lagespectra=0
< ipin=1
< ioutputforeachrelease=0
< iflux=1
< mdomainfill=0
< ind_source=1
< ind_receptor=1
< mquasilag=0
< nested_output=0
< linit_cond=0
<
< ! Open the command file and read user options
< ! Namelist input first: try to read as namelist file
< !**************************************************************************
< open(unitcommand,file=path(1)(1:length(1))//'COMMAND',status='old', &
< form='formatted',iostat=readerror)
< ! If fail, check if file does not exist
< if (readerror.ne.0) then
<
< print*,'***ERROR: file COMMAND not found. Check your pathnames file.'
< stop
<
< endif
<
< read(unitcommand,command,iostat=readerror)
< close(unitcommand)
<
< ! If error in namelist format, try to open with old input code
< if (readerror.ne.0) then
<
< open(unitcommand,file=path(1)(1:length(1))//'COMMAND',status='old', &
< err=999)
<
< ! Check the format of the COMMAND file (either in free format,
< ! or using formatted mask)
< ! Use of formatted mask is assumed if line 10 contains the word 'DIRECTION'
< !**************************************************************************
<
< call skplin(9,unitcommand)
< read (unitcommand,901) line
< 901 format (a)
< if (index(line,'LDIRECT') .eq. 0) then
< old = .false.
< else
< old = .true.
< endif
< rewind(unitcommand)
<
< ! Read parameters
< !****************
<
< call skplin(7,unitcommand)
< if (old) call skplin(1,unitcommand)
<
< read(unitcommand,*) ldirect
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) ibdate,ibtime
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) iedate,ietime
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) loutstep
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) loutaver
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) loutsample
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) itsplit
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) lsynctime
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) ctl
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) ifine
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) iout
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) ipout
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) lsubgrid
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) lconvection
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) lagespectra
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) ipin
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) ioutputforeachrelease
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) iflux
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) mdomainfill
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) ind_source
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) ind_receptor
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) mquasilag
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) nested_output
< if (old) call skplin(3,unitcommand)
< read(unitcommand,*) linit_cond
< close(unitcommand)
<
< endif ! input format
<
< ! write command file in namelist format to output directory if requested
< if (nmlout.eqv..true.) then
< open(unitcommand,file=path(2)(1:length(2))//'COMMAND.namelist',status='new',err=999)
< write(unitcommand,nml=command)
< close(unitcommand)
< endif
<
< ifine=max(ifine,1)
<
< ! Determine how Markov chain is formulated (for w or for w/sigw)
< !***************************************************************
<
< if (ctl.ge.0.1) then
< turbswitch=.true.
< else
< turbswitch=.false.
< ifine=1
< endif
< fine=1./real(ifine)
< ctl=1./ctl
<
< ! Set the switches required for the various options for input/output units
< !*************************************************************************
< !AF Set the switches IND_REL and IND_SAMP for the release and sampling
< !Af switches for the releasefile:
< !Af IND_REL = 1 : xmass * rho
< !Af IND_REL = 0 : xmass * 1
<
< !Af switches for the conccalcfile:
< !AF IND_SAMP = 0 : xmass * 1
< !Af IND_SAMP = -1 : xmass / rho
<
< !AF IND_SOURCE switches between different units for concentrations at the source
< !Af NOTE that in backward simulations the release of computational particles
< !Af takes place at the "receptor" and the sampling of p[articles at the "source".
< !Af 1 = mass units
< !Af 2 = mass mixing ratio units
< !Af IND_RECEPTOR switches between different units for concentrations at the receptor
< !Af 1 = mass units
< !Af 2 = mass mixing ratio units
<
< if ( ldirect .eq. 1 ) then ! FWD-Run
< !Af set release-switch
< if (ind_source .eq. 1 ) then !mass
< ind_rel = 0
< else ! mass mix
< ind_rel = 1
< endif
< !Af set sampling switch
< if (ind_receptor .eq. 1) then !mass
< ind_samp = 0
< else ! mass mix
< ind_samp = -1
< endif
< elseif (ldirect .eq. -1 ) then !BWD-Run
< !Af set sampling switch
< if (ind_source .eq. 1 ) then !mass
< ind_samp = -1
< else ! mass mix
< ind_samp = 0
< endif
< !Af set release-switch
< if (ind_receptor .eq. 1) then !mass
< ind_rel = 1
< else ! mass mix
< ind_rel = 0
< endif
< endif
<
< !*************************************************************
< ! Check whether valid options have been chosen in file COMMAND
< !*************************************************************
<
< ! Check options for initial condition output: Switch off for forward runs
< !************************************************************************
<
< if (ldirect.eq.1) linit_cond=0
< if ((linit_cond.lt.0).or.(linit_cond.gt.2)) then
< write(*,*) ' #### FLEXPART MODEL ERROR! INVALID OPTION #### '
< write(*,*) ' #### FOR LINIT_COND IN FILE "COMMAND". #### '
< stop
< endif
<
< ! Check input dates
< !******************
<
< if (iedate.lt.ibdate) then
< write(*,*) ' #### FLEXPART MODEL ERROR! BEGINNING DATE #### '
< write(*,*) ' #### IS LARGER THAN ENDING DATE. CHANGE #### '
< write(*,*) ' #### EITHER POINT 2 OR POINT 3 IN FILE #### '
< write(*,*) ' #### "COMMAND". #### '
< stop
< else if (iedate.eq.ibdate) then
< if (ietime.lt.ibtime) then
< write(*,*) ' #### FLEXPART MODEL ERROR! BEGINNING TIME #### '
< write(*,*) ' #### IS LARGER THAN ENDING TIME. CHANGE #### '
< write(*,*) ' #### EITHER POINT 2 OR POINT 3 IN FILE #### '
< write(*,*) ' #### "COMMAND". #### '
< stop
< endif
< endif
<
<
< ! Determine kind of dispersion method
< !************************************
<
< if (ctl.gt.0.) then
< method=1
< mintime=minstep
< else
< method=0
< mintime=lsynctime
< endif
<
< ! Check whether a valid option for gridded model output has been chosen
< !**********************************************************************
<
< if ((iout.lt.1).or.(iout.gt.5)) then
< write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
< write(*,*) ' #### IOUT MUST BE 1, 2, 3, 4, OR 5! #### '
< stop
< endif
<
< !AF check consistency between units and volume mixing ratio
< if ( ((iout.eq.2).or.(iout.eq.3)).and. &
< (ind_source.gt.1 .or.ind_receptor.gt.1) ) then
< write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
< write(*,*) ' #### VOLUME MIXING RATIO ONLY SUPPORTED #### '
< write(*,*) ' #### FOR MASS UNITS (at the moment) #### '
< stop
< endif
<
<
<
< ! For quasilag output for each release is forbidden
< !*****************************************************************************
<
< if ((ioutputforeachrelease.eq.1).and.(mquasilag.eq.1)) then
< write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
< write(*,*) '#### OUTPUTFOREACHRELEASE AND QUASILAGRANGIAN####'
< write(*,*) '#### MODE IS NOT POSSIBLE ! ####'
< stop
< endif
<
<
< ! For quasilag backward is forbidden
< !*****************************************************************************
<
< if ((ldirect.lt.0).and.(mquasilag.eq.1)) then
< write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
< write(*,*) '#### FOR BACKWARD RUNS, QUASILAGRANGIAN MODE ####'
< write(*,*) '#### IS NOT POSSIBLE ! ####'
< stop
< endif
<
<
< ! For backward runs one releasefield for all releases makes no sense,
< ! For quasilag and domainfill ioutputforechrelease is forbidden
< !*****************************************************************************
<
< if ((ldirect.lt.0).and.(ioutputforeachrelease.eq.0)) then
< write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
< write(*,*) '#### FOR BACKWARD RUNS, IOUTPUTFOREACHRLEASE ####'
< write(*,*) '#### MUST BE SET TO ONE! ####'
< stop
< endif
<
<
< ! For backward runs one releasefield for all releases makes no sense,
< ! and is "forbidden"
< !*****************************************************************************
<
< if ((mdomainfill.eq.1).and.(ioutputforeachrelease.eq.1)) then
< write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
< write(*,*) '#### FOR DOMAIN FILLING RUNS OUTPUT FOR ####'
< write(*,*) '#### EACH RELEASE IS FORBIDDEN ! ####'
< stop
< endif
<
<
< ! For domain-filling trajectories, a plume centroid trajectory makes no sense,
< ! For backward runs, only residence time output (iout=1) or plume trajectories (iout=4),
< ! or both (iout=5) makes sense; other output options are "forbidden"
< !*****************************************************************************
<
< if (ldirect.lt.0) then
< if ((iout.eq.2).or.(iout.eq.3)) then
< write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
< write(*,*) '#### FOR BACKWARD RUNS, IOUT MUST BE 1,4,OR 5####'
< stop
< endif
< endif
<
<
< ! For domain-filling trajectories, a plume centroid trajectory makes no sense,
< ! and is "forbidden"
< !*****************************************************************************
<
< if (mdomainfill.ge.1) then
< if ((iout.eq.4).or.(iout.eq.5)) then
< write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
< write(*,*) '#### FOR DOMAIN-FILLING TRAJECTORY OPTION, ####'
< write(*,*) '#### IOUT MUST NOT BE SET TO 4 OR 5. ####'
< stop
< endif
< endif
<
<
<
< ! Check whether a valid options for particle dump has been chosen
< !****************************************************************
<
< if ((ipout.ne.0).and.(ipout.ne.1).and.(ipout.ne.2)) then
< write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
< write(*,*) ' #### IPOUT MUST BE 1, 2 OR 3! #### '
< stop
< endif
<
< if(lsubgrid.ne.1) then
< write(*,*) ' ---------------- '
< write(*,*) ' INFORMATION: SUBGRIDSCALE TERRAIN EFFECT IS'
< write(*,*) ' NOT PARAMETERIZED DURING THIS SIMULATION. '
< write(*,*) ' ---------------- '
< endif
<
<
< ! Check whether convection scheme is either turned on or off
< !***********************************************************
<
< if ((lconvection.ne.0).and.(lconvection.ne.1)) then
< write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
< write(*,*) ' #### LCONVECTION MUST BE SET TO EITHER 1 OR 0#### '
< stop
< endif
<
<
< ! Check whether synchronisation interval is sufficiently short
< !*************************************************************
<
< if (lsynctime.gt.(idiffnorm/2)) then
< write(*,*) ' #### FLEXPART MODEL ERROR! SYNCHRONISATION #### '
< write(*,*) ' #### TIME IS TOO LONG. MAKE IT SHORTER. #### '
< write(*,*) ' #### MINIMUM HAS TO BE: ', idiffnorm/2
< stop
< endif
<
<
< ! Check consistency of the intervals, sampling periods, etc., for model output
< !*****************************************************************************
<
< if (loutaver.eq.0) then
< write(*,*) ' #### FLEXPART MODEL ERROR! TIME AVERAGE OF #### '
< write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
< write(*,*) ' #### ZERO. #### '
< write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
< stop
< endif
<
< if (loutaver.gt.loutstep) then
< write(*,*) ' #### FLEXPART MODEL ERROR! TIME AVERAGE OF #### '
< write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
< write(*,*) ' #### GREATER THAN INTERVAL OF OUTPUT. #### '
< write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
< stop
< endif
<
< if (loutsample.gt.loutaver) then
< write(*,*) ' #### FLEXPART MODEL ERROR! SAMPLING TIME OF #### '
< write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
< write(*,*) ' #### GREATER THAN TIME AVERAGE OF OUTPUT. #### '
< write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
< stop
< endif
<
< if (mod(loutaver,lsynctime).ne.0) then
< write(*,*) ' #### FLEXPART MODEL ERROR! AVERAGING TIME OF #### '
< write(*,*) ' #### CONCENTRATION FIELD MUST BE A MULTIPLE #### '
< write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
< stop
< endif
<
< if ((loutaver/lsynctime).lt.2) then
< write(*,*) ' #### FLEXPART MODEL ERROR! AVERAGING TIME OF #### '
< write(*,*) ' #### CONCENTRATION FIELD MUST BE AT LEAST #### '
< write(*,*) ' #### TWICE THE SYNCHRONISATION INTERVAL #### '
< stop
< endif
<
< if (mod(loutstep,lsynctime).ne.0) then
< write(*,*) ' #### FLEXPART MODEL ERROR! INTERVAL BETWEEN #### '
< write(*,*) ' #### CONCENTRATION FIELDS MUST BE A MULTIPLE #### '
< write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
< stop
< endif
<
< if ((loutstep/lsynctime).lt.2) then
< write(*,*) ' #### FLEXPART MODEL ERROR! INTERVAL BETWEEN #### '
< write(*,*) ' #### CONCENTRATION FIELDS MUST BE AT LEAST #### '
< write(*,*) ' #### TWICE THE SYNCHRONISATION INTERVAL #### '
< stop
< endif
<
< if (mod(loutsample,lsynctime).ne.0) then
< write(*,*) ' #### FLEXPART MODEL ERROR! SAMPLING TIME OF #### '
< write(*,*) ' #### CONCENTRATION FIELD MUST BE A MULTIPLE #### '
< write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
< stop
< endif
<
< if (itsplit.lt.loutaver) then
< write(*,*) ' #### FLEXPART MODEL ERROR! SPLITTING TIME FOR#### '
< write(*,*) ' #### PARTICLES IS TOO SHORT. PLEASE INCREASE #### '
< write(*,*) ' #### SPLITTING TIME CONSTANT. #### '
< stop
< endif
<
< if ((mquasilag.eq.1).and.(iout.ge.4)) then
< write(*,*) ' #### FLEXPART MODEL ERROR! CONFLICTING #### '
< write(*,*) ' #### OPTIONS: IF MQUASILAG=1, PLUME #### '
< write(*,*) ' #### TRAJECTORY OUTPUT IS IMPOSSIBLE. #### '
< stop
< endif
<
< ! Compute modeling time in seconds and beginning date in Julian date
< !*******************************************************************
<
< outstep=real(abs(loutstep))
< if (ldirect.eq.1) then
< bdate=juldate(ibdate,ibtime)
< edate=juldate(iedate,ietime)
< ideltas=nint((edate-bdate)*86400.)
< else if (ldirect.eq.-1) then
< loutaver=-1*loutaver
< loutstep=-1*loutstep
< loutsample=-1*loutsample
< lsynctime=-1*lsynctime
< bdate=juldate(iedate,ietime)
< edate=juldate(ibdate,ibtime)
< ideltas=nint((edate-bdate)*86400.)
< else
< write(*,*) ' #### FLEXPART MODEL ERROR! DIRECTION IN #### '
< write(*,*) ' #### FILE "COMMAND" MUST BE EITHER -1 OR 1. #### '
< stop
< endif
<
< return
<
< 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### '
< write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
< write(*,'(a)') path(1)(1:length(1))
< stop
<
< end subroutine readcommand
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readcommand
>
> !*****************************************************************************
> ! *
> ! This routine reads the user specifications for the current model run. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 18 May 1996 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! bdate beginning date as Julian date *
> ! ctl factor by which time step must be smaller than *
> ! Lagrangian time scale *
> ! ibdate,ibtime beginnning date and time (YYYYMMDD, HHMISS) *
> ! ideltas [s] modelling period *
> ! iedate,ietime ending date and time (YYYYMMDD, HHMISS) *
> ! ifine reduction factor for vertical wind time step *
> ! outputforeachrel for forward runs it is possible either to create *
> ! one outputfield or several for each releasepoint *
> ! iflux switch to turn on (1)/off (0) flux calculations *
> ! iout 1 for conc. (residence time for backward runs) output,*
> ! 2 for mixing ratio output, 3 both, 4 for plume *
> ! trajectory output, 5 = options 1 and 4 *
> ! ipin 1 continue simulation with dumped particle data, 0 no *
> ! ipout 0 no particle dump, 1 every output time, 3 only at end*
> ! itsplit [s] time constant for particle splitting *
> ! loutaver [s] concentration output is an average over loutaver *
> ! seconds *
> ! loutsample [s] average is computed from samples taken every [s] *
> ! seconds *
> ! loutstep [s] time interval of concentration output *
> ! lsynctime [s] synchronisation time interval for all particles *
> ! lagespectra switch to turn on (1)/off (0) calculation of age *
> ! spectra *
> ! lconvection value of either 0 and 1 indicating mixing by *
> ! convection *
> ! = 0 .. no convection *
> ! + 1 .. parameterisation of mixing by subgrid-scale *
> ! convection = on *
> ! lsubgrid switch to turn on (1)/off (0) subgrid topography *
> ! parameterization *
> ! method method used to compute the particle pseudovelocities *
> ! mdomainfill 1 use domain-filling option, 0 not, 2 use strat. O3 *
> ! *
> ! Constants: *
> ! unitcommand unit connected to file COMMAND *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> real(kind=dp) :: juldate
> character(len=50) :: line
> logical :: old
>
>
> ! Open the command file and read user options
> !********************************************
>
>
> open(unitcommand,file=path(1)(1:length(1))//'COMMAND',status='old', &
> err=999)
>
> ! Check the format of the COMMAND file (either in free format,
> ! or using formatted mask)
> ! Use of formatted mask is assumed if line 10 contains the word 'DIRECTION'
> !**************************************************************************
>
> call skplin(9,unitcommand)
> read (unitcommand,901) line
> 901 format (a)
> if (index(line,'LDIRECT') .eq. 0) then
> old = .false.
> else
> old = .true.
> endif
> rewind(unitcommand)
>
> ! Read parameters
> !****************
>
> call skplin(7,unitcommand)
> if (old) call skplin(1,unitcommand)
>
> read(unitcommand,*) ldirect
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) ibdate,ibtime
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) iedate,ietime
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) loutstep
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) loutaver
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) loutsample
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) itsplit
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) lsynctime
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) ctl
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) ifine
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) iout
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) ipout
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) lsubgrid
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) lconvection
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) lagespectra
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) ipin
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) ioutputforeachrelease
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) iflux
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) mdomainfill
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) ind_source
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) ind_receptor
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) mquasilag
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) nested_output
> if (old) call skplin(3,unitcommand)
> read(unitcommand,*) linit_cond
> close(unitcommand)
>
> ifine=max(ifine,1)
>
>
> ! Determine how Markov chain is formulated (for w or for w/sigw)
> !***************************************************************
>
> if (ctl.ge.0.1) then
> turbswitch=.true.
> else
> turbswitch=.false.
> ifine=1
> endif
> fine=1./real(ifine)
> ctl=1./ctl
>
> ! Set the switches required for the various options for input/output units
> !*************************************************************************
> !AF Set the switches IND_REL and IND_SAMP for the release and sampling
> !Af switches for the releasefile:
> !Af IND_REL = 1 : xmass * rho
> !Af IND_REL = 0 : xmass * 1
>
> !Af switches for the conccalcfile:
> !AF IND_SAMP = 0 : xmass * 1
> !Af IND_SAMP = -1 : xmass / rho
>
> !AF IND_SOURCE switches between different units for concentrations at the source
> !Af NOTE that in backward simulations the release of computational particles
> !Af takes place at the "receptor" and the sampling of p[articles at the "source".
> !Af 1 = mass units
> !Af 2 = mass mixing ratio units
> !Af IND_RECEPTOR switches between different units for concentrations at the receptor
> !Af 1 = mass units
> !Af 2 = mass mixing ratio units
>
> if ( ldirect .eq. 1 ) then ! FWD-Run
> !Af set release-switch
> if (ind_source .eq. 1 ) then !mass
> ind_rel = 0
> else ! mass mix
> ind_rel = 1
> endif
> !Af set sampling switch
> if (ind_receptor .eq. 1) then !mass
> ind_samp = 0
> else ! mass mix
> ind_samp = -1
> endif
> elseif (ldirect .eq. -1 ) then !BWD-Run
> !Af set sampling switch
> if (ind_source .eq. 1 ) then !mass
> ind_samp = -1
> else ! mass mix
> ind_samp = 0
> endif
> !Af set release-switch
> if (ind_receptor .eq. 1) then !mass
> ind_rel = 1
> else ! mass mix
> ind_rel = 0
> endif
> endif
>
> !*************************************************************
> ! Check whether valid options have been chosen in file COMMAND
> !*************************************************************
>
> ! Check options for initial condition output: Switch off for forward runs
> !************************************************************************
>
> if (ldirect.eq.1) linit_cond=0
> if ((linit_cond.lt.0).or.(linit_cond.gt.2)) then
> write(*,*) ' #### FLEXPART MODEL ERROR! INVALID OPTION #### '
> write(*,*) ' #### FOR LINIT_COND IN FILE "COMMAND". #### '
> stop
> endif
>
> ! Check input dates
> !******************
>
> if (iedate.lt.ibdate) then
> write(*,*) ' #### FLEXPART MODEL ERROR! BEGINNING DATE #### '
> write(*,*) ' #### IS LARGER THAN ENDING DATE. CHANGE #### '
> write(*,*) ' #### EITHER POINT 2 OR POINT 3 IN FILE #### '
> write(*,*) ' #### "COMMAND". #### '
> stop
> else if (iedate.eq.ibdate) then
> if (ietime.lt.ibtime) then
> write(*,*) ' #### FLEXPART MODEL ERROR! BEGINNING TIME #### '
> write(*,*) ' #### IS LARGER THAN ENDING TIME. CHANGE #### '
> write(*,*) ' #### EITHER POINT 2 OR POINT 3 IN FILE #### '
> write(*,*) ' #### "COMMAND". #### '
> stop
> endif
> endif
>
>
> ! Determine kind of dispersion method
> !************************************
>
> if (ctl.gt.0.) then
> method=1
> mintime=minstep
> else
> method=0
> mintime=lsynctime
> endif
>
> ! Check whether a valid option for gridded model output has been chosen
> !**********************************************************************
>
> if ((iout.lt.1).or.(iout.gt.5)) then
> write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
> write(*,*) ' #### IOUT MUST BE 1, 2, 3, 4, OR 5! #### '
> stop
> endif
>
> !AF check consistency between units and volume mixing ratio
> if ( ((iout.eq.2).or.(iout.eq.3)).and. &
> (ind_source.gt.1 .or.ind_receptor.gt.1) ) then
> write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
> write(*,*) ' #### VOLUME MIXING RATIO ONLY SUPPORTED #### '
> write(*,*) ' #### FOR MASS UNITS (at the moment) #### '
> stop
> endif
>
>
>
> ! For quasilag output for each release is forbidden
> !*****************************************************************************
>
> if ((ioutputforeachrelease.eq.1).and.(mquasilag.eq.1)) then
> write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
> write(*,*) '#### OUTPUTFOREACHRELEASE AND QUASILAGRANGIAN####'
> write(*,*) '#### MODE IS NOT POSSIBLE ! ####'
> stop
> endif
>
>
> ! For quasilag backward is forbidden
> !*****************************************************************************
>
> if ((ldirect.lt.0).and.(mquasilag.eq.1)) then
> write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
> write(*,*) '#### FOR BACKWARD RUNS, QUASILAGRANGIAN MODE ####'
> write(*,*) '#### IS NOT POSSIBLE ! ####'
> stop
> endif
>
>
> ! For backward runs one releasefield for all releases makes no sense,
> ! For quasilag and domainfill ioutputforechrelease is forbidden
> !*****************************************************************************
>
> if ((ldirect.lt.0).and.(ioutputforeachrelease.eq.0)) then
> write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
> write(*,*) '#### FOR BACKWARD RUNS, IOUTPUTFOREACHRLEASE ####'
> write(*,*) '#### MUST BE SET TO ONE! ####'
> stop
> endif
>
>
> ! For backward runs one releasefield for all releases makes no sense,
> ! and is "forbidden"
> !*****************************************************************************
>
> if ((mdomainfill.eq.1).and.(ioutputforeachrelease.eq.1)) then
> write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
> write(*,*) '#### FOR DOMAIN FILLING RUNS OUTPUT FOR ####'
> write(*,*) '#### EACH RELEASE IS FORBIDDEN ! ####'
> stop
> endif
>
>
> ! For domain-filling trajectories, a plume centroid trajectory makes no sense,
> ! For backward runs, only residence time output (iout=1) or plume trajectories (iout=4),
> ! or both (iout=5) makes sense; other output options are "forbidden"
> !*****************************************************************************
>
> if (ldirect.lt.0) then
> if ((iout.eq.2).or.(iout.eq.3)) then
> write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
> write(*,*) '#### FOR BACKWARD RUNS, IOUT MUST BE 1,4,OR 5####'
> stop
> endif
> endif
>
>
> ! For domain-filling trajectories, a plume centroid trajectory makes no sense,
> ! and is "forbidden"
> !*****************************************************************************
>
> if (mdomainfill.ge.1) then
> if ((iout.eq.4).or.(iout.eq.5)) then
> write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####'
> write(*,*) '#### FOR DOMAIN-FILLING TRAJECTORY OPTION, ####'
> write(*,*) '#### IOUT MUST NOT BE SET TO 4 OR 5. ####'
> stop
> endif
> endif
>
>
>
> ! Check whether a valid options for particle dump has been chosen
> !****************************************************************
>
> if ((ipout.ne.0).and.(ipout.ne.1).and.(ipout.ne.2)) then
> write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
> write(*,*) ' #### IPOUT MUST BE 1, 2 OR 3! #### '
> stop
> endif
>
> if(lsubgrid.ne.1) then
> write(*,*) ' ---------------- '
> write(*,*) ' INFORMATION: SUBGRIDSCALE TERRAIN EFFECT IS'
> write(*,*) ' NOT PARAMETERIZED DURING THIS SIMULATION. '
> write(*,*) ' ---------------- '
> endif
>
>
> ! Check whether convection scheme is either turned on or off
> !***********************************************************
>
> if ((lconvection.ne.0).and.(lconvection.ne.1)) then
> write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### '
> write(*,*) ' #### LCONVECTION MUST BE SET TO EITHER 1 OR 0#### '
> stop
> endif
>
>
> ! Check whether synchronisation interval is sufficiently short
> !*************************************************************
>
> if (lsynctime.gt.(idiffnorm/2)) then
> write(*,*) ' #### FLEXPART MODEL ERROR! SYNCHRONISATION #### '
> write(*,*) ' #### TIME IS TOO LONG. MAKE IT SHORTER. #### '
> write(*,*) ' #### MINIMUM HAS TO BE: ', idiffnorm/2
> stop
> endif
>
>
> ! Check consistency of the intervals, sampling periods, etc., for model output
> !*****************************************************************************
>
> if (loutaver.eq.0) then
> write(*,*) ' #### FLEXPART MODEL ERROR! TIME AVERAGE OF #### '
> write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
> write(*,*) ' #### ZERO. #### '
> write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
> stop
> endif
>
> if (loutaver.gt.loutstep) then
> write(*,*) ' #### FLEXPART MODEL ERROR! TIME AVERAGE OF #### '
> write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
> write(*,*) ' #### GREATER THAN INTERVAL OF OUTPUT. #### '
> write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
> stop
> endif
>
> if (loutsample.gt.loutaver) then
> write(*,*) ' #### FLEXPART MODEL ERROR! SAMPLING TIME OF #### '
> write(*,*) ' #### CONCENTRATION FIELD OUTPUT MUST NOT BE #### '
> write(*,*) ' #### GREATER THAN TIME AVERAGE OF OUTPUT. #### '
> write(*,*) ' #### CHANGE INPUT IN FILE COMMAND. #### '
> stop
> endif
>
> if (mod(loutaver,lsynctime).ne.0) then
> write(*,*) ' #### FLEXPART MODEL ERROR! AVERAGING TIME OF #### '
> write(*,*) ' #### CONCENTRATION FIELD MUST BE A MULTIPLE #### '
> write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
> stop
> endif
>
> if ((loutaver/lsynctime).lt.2) then
> write(*,*) ' #### FLEXPART MODEL ERROR! AVERAGING TIME OF #### '
> write(*,*) ' #### CONCENTRATION FIELD MUST BE AT LEAST #### '
> write(*,*) ' #### TWICE THE SYNCHRONISATION INTERVAL #### '
> stop
> endif
>
> if (mod(loutstep,lsynctime).ne.0) then
> write(*,*) ' #### FLEXPART MODEL ERROR! INTERVAL BETWEEN #### '
> write(*,*) ' #### CONCENTRATION FIELDS MUST BE A MULTIPLE #### '
> write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
> stop
> endif
>
> if ((loutstep/lsynctime).lt.2) then
> write(*,*) ' #### FLEXPART MODEL ERROR! INTERVAL BETWEEN #### '
> write(*,*) ' #### CONCENTRATION FIELDS MUST BE AT LEAST #### '
> write(*,*) ' #### TWICE THE SYNCHRONISATION INTERVAL #### '
> stop
> endif
>
> if (mod(loutsample,lsynctime).ne.0) then
> write(*,*) ' #### FLEXPART MODEL ERROR! SAMPLING TIME OF #### '
> write(*,*) ' #### CONCENTRATION FIELD MUST BE A MULTIPLE #### '
> write(*,*) ' #### OF THE SYNCHRONISATION INTERVAL #### '
> stop
> endif
>
> if (itsplit.lt.loutaver) then
> write(*,*) ' #### FLEXPART MODEL ERROR! SPLITTING TIME FOR#### '
> write(*,*) ' #### PARTICLES IS TOO SHORT. PLEASE INCREASE #### '
> write(*,*) ' #### SPLITTING TIME CONSTANT. #### '
> stop
> endif
>
> if ((mquasilag.eq.1).and.(iout.ge.4)) then
> write(*,*) ' #### FLEXPART MODEL ERROR! CONFLICTING #### '
> write(*,*) ' #### OPTIONS: IF MQUASILAG=1, PLUME #### '
> write(*,*) ' #### TRAJECTORY OUTPUT IS IMPOSSIBLE. #### '
> stop
> endif
>
> ! Compute modeling time in seconds and beginning date in Julian date
> !*******************************************************************
>
> outstep=real(abs(loutstep))
> if (ldirect.eq.1) then
> bdate=juldate(ibdate,ibtime)
> edate=juldate(iedate,ietime)
> ideltas=nint((edate-bdate)*86400.)
> else if (ldirect.eq.-1) then
> loutaver=-1*loutaver
> loutstep=-1*loutstep
> loutsample=-1*loutsample
> lsynctime=-1*lsynctime
> bdate=juldate(iedate,ietime)
> edate=juldate(ibdate,ibtime)
> ideltas=nint((edate-bdate)*86400.)
> else
> write(*,*) ' #### FLEXPART MODEL ERROR! DIRECTION IN #### '
> write(*,*) ' #### FILE "COMMAND" MUST BE EITHER -1 OR 1. #### '
> stop
> endif
>
> return
>
> 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### '
> write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
> write(*,'(a)') path(1)(1:length(1))
> stop
>
> end subroutine readcommand
readdepo.f90
----------------------------------------------
1,145c1,145
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readdepo
<
< !*****************************************************************************
< ! *
< ! Reads dry deposition parameters needed by the procedure of Wesely (1989). *
< ! Wesely (1989): Parameterization of surface resistances to gaseous *
< ! dry deposition in regional-scale numerical models. *
< ! Atmos. Environ. 23, 1293-1304. *
< ! *
< ! *
< ! AUTHOR: Andreas Stohl, 19 May 1995 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! rcl(maxspec,5,9) [s/m] Lower canopy resistance *
< ! rgs(maxspec,5,9) [s/m] Ground resistance *
< ! rlu(maxspec,5,9) [s/m] Leaf cuticular resistance *
< ! rm(maxspec) [s/m] Mesophyll resistance, set in readreleases *
< ! ri(maxspec) [s/m] Stomatal resistance *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< ! FOR THIS SUBROUTINE, numclass=9 IS ASSUMED
< !*******************************************
<
< real :: rluh(5,numclass),rgssh(5,numclass),rgsoh(5,numclass)
< real :: rclsh(5,numclass),rcloh(5,numclass)
< integer :: i,j,ic
<
<
< ! Read deposition constants related with landuse and seasonal category
< !*********************************************************************
< open(unitwesely,file=path(1)(1:length(1))//'surfdepo.t', &
< status='old',err=999)
<
< do i=1,16
< read(unitwesely,*)
< end do
< do i=1,5
< read(unitwesely,*)
< read(unitwesely,'(8x,13f8.0)') (ri(i,j),j=1,numclass)
< read(unitwesely,'(8x,13f8.0)') (rluh(i,j),j=1,numclass)
< read(unitwesely,'(8x,13f8.0)') (rac(i,j),j=1,numclass)
< read(unitwesely,'(8x,13f8.0)') (rgssh(i,j),j=1,numclass)
< read(unitwesely,'(8x,13f8.0)') (rgsoh(i,j),j=1,numclass)
< read(unitwesely,'(8x,13f8.0)') (rclsh(i,j),j=1,numclass)
< read(unitwesely,'(8x,13f8.0)') (rcloh(i,j),j=1,numclass)
< end do
<
< ! TEST
< ! do 31 i=1,5
< ! ri(i,13)=ri(i,5)
< ! rluh(i,13)=rluh(i,5)
< ! rac(i,13)=rac(i,5)
< ! rgssh(i,13)=rgssh(i,5)
< ! rgsoh(i,13)=rgsoh(i,5)
< ! rclsh(i,13)=rclsh(i,5)
< ! rcloh(i,13)=rcloh(i,5)
< !31 continue
< ! TEST
< ! Sabine Eckhardt, Dec 06, set resistances of 9999 to 'infinite' (1E25)
< do i=1,5
< do j=1,numclass
< if (ri(i,j).eq.9999.) ri(i,j)=1.E25
< if (rluh(i,j).eq.9999.) rluh(i,j)=1.E25
< if (rac(i,j).eq.9999.) rac(i,j)=1.E25
< if (rgssh(i,j).eq.9999.) rgssh(i,j)=1.E25
< if (rgsoh(i,j).eq.9999.) rgsoh(i,j)=1.E25
< if (rclsh(i,j).eq.9999.) rclsh(i,j)=1.E25
< if (rcloh(i,j).eq.9999.) rcloh(i,j)=1.E25
< end do
< end do
<
<
<
< do i=1,5
< do j=1,numclass
< ri(i,j)=max(ri(i,j),0.001)
< rluh(i,j)=max(rluh(i,j),0.001)
< rac(i,j)=max(rac(i,j),0.001)
< rgssh(i,j)=max(rgssh(i,j),0.001)
< rgsoh(i,j)=max(rgsoh(i,j),0.001)
< rclsh(i,j)=max(rclsh(i,j),0.001)
< rcloh(i,j)=max(rcloh(i,j),0.001)
< end do
< end do
< close(unitwesely)
<
<
< ! Compute additional parameters
< !******************************
<
< do ic=1,nspec
< if (reldiff(ic).gt.0.) then ! gas is dry deposited
< do i=1,5
< do j=1,numclass
< rlu(ic,i,j)=rluh(i,j)/(1.e-5*henry(ic)+f0(ic))
< rgs(ic,i,j)=1./(henry(ic)/(10.e5*rgssh(i,j))+f0(ic)/ &
< rgsoh(i,j))
< rcl(ic,i,j)=1./(henry(ic)/(10.e5*rclsh(i,j))+f0(ic)/ &
< rcloh(i,j))
< end do
< end do
< endif
< end do
<
<
< return
<
<
< 999 write(*,*) '### FLEXPART ERROR! FILE ###'
< write(*,*) '### surfdepo.t DOES NOT EXIST. ###'
< stop
<
< end subroutine readdepo
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readdepo
>
> !*****************************************************************************
> ! *
> ! Reads dry deposition parameters needed by the procedure of Wesely (1989). *
> ! Wesely (1989): Parameterization of surface resistances to gaseous *
> ! dry deposition in regional-scale numerical models. *
> ! Atmos. Environ. 23, 1293-1304. *
> ! *
> ! *
> ! AUTHOR: Andreas Stohl, 19 May 1995 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! rcl(maxspec,5,9) [s/m] Lower canopy resistance *
> ! rgs(maxspec,5,9) [s/m] Ground resistance *
> ! rlu(maxspec,5,9) [s/m] Leaf cuticular resistance *
> ! rm(maxspec) [s/m] Mesophyll resistance, set in readreleases *
> ! ri(maxspec) [s/m] Stomatal resistance *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> ! FOR THIS SUBROUTINE, numclass=9 IS ASSUMED
> !*******************************************
>
> real :: rluh(5,numclass),rgssh(5,numclass),rgsoh(5,numclass)
> real :: rclsh(5,numclass),rcloh(5,numclass)
> integer :: i,j,ic
>
>
> ! Read deposition constants related with landuse and seasonal category
> !*********************************************************************
> open(unitwesely,file=path(1)(1:length(1))//'surfdepo.t', &
> status='old',err=999)
>
> do i=1,16
> read(unitwesely,*)
> end do
> do i=1,5
> read(unitwesely,*)
> read(unitwesely,'(8x,13f8.0)') (ri(i,j),j=1,numclass)
> read(unitwesely,'(8x,13f8.0)') (rluh(i,j),j=1,numclass)
> read(unitwesely,'(8x,13f8.0)') (rac(i,j),j=1,numclass)
> read(unitwesely,'(8x,13f8.0)') (rgssh(i,j),j=1,numclass)
> read(unitwesely,'(8x,13f8.0)') (rgsoh(i,j),j=1,numclass)
> read(unitwesely,'(8x,13f8.0)') (rclsh(i,j),j=1,numclass)
> read(unitwesely,'(8x,13f8.0)') (rcloh(i,j),j=1,numclass)
> end do
>
> ! TEST
> ! do 31 i=1,5
> ! ri(i,13)=ri(i,5)
> ! rluh(i,13)=rluh(i,5)
> ! rac(i,13)=rac(i,5)
> ! rgssh(i,13)=rgssh(i,5)
> ! rgsoh(i,13)=rgsoh(i,5)
> ! rclsh(i,13)=rclsh(i,5)
> ! rcloh(i,13)=rcloh(i,5)
> !31 continue
> ! TEST
> ! Sabine Eckhardt, Dec 06, set resistances of 9999 to 'infinite' (1E25)
> do i=1,5
> do j=1,numclass
> if (ri(i,j).eq.9999.) ri(i,j)=1.E25
> if (rluh(i,j).eq.9999.) rluh(i,j)=1.E25
> if (rac(i,j).eq.9999.) rac(i,j)=1.E25
> if (rgssh(i,j).eq.9999.) rgssh(i,j)=1.E25
> if (rgsoh(i,j).eq.9999.) rgsoh(i,j)=1.E25
> if (rclsh(i,j).eq.9999.) rclsh(i,j)=1.E25
> if (rcloh(i,j).eq.9999.) rcloh(i,j)=1.E25
> end do
> end do
>
>
>
> do i=1,5
> do j=1,numclass
> ri(i,j)=max(ri(i,j),0.001)
> rluh(i,j)=max(rluh(i,j),0.001)
> rac(i,j)=max(rac(i,j),0.001)
> rgssh(i,j)=max(rgssh(i,j),0.001)
> rgsoh(i,j)=max(rgsoh(i,j),0.001)
> rclsh(i,j)=max(rclsh(i,j),0.001)
> rcloh(i,j)=max(rcloh(i,j),0.001)
> end do
> end do
> close(unitwesely)
>
>
> ! Compute additional parameters
> !******************************
>
> do ic=1,nspec
> if (reldiff(ic).gt.0.) then ! gas is dry deposited
> do i=1,5
> do j=1,numclass
> rlu(ic,i,j)=rluh(i,j)/(1.e-5*henry(ic)+f0(ic))
> rgs(ic,i,j)=1./(henry(ic)/(10.e5*rgssh(i,j))+f0(ic)/ &
> rgsoh(i,j))
> rcl(ic,i,j)=1./(henry(ic)/(10.e5*rclsh(i,j))+f0(ic)/ &
> rcloh(i,j))
> end do
> end do
> endif
> end do
>
>
> return
>
>
> 999 write(*,*) '### FLEXPART ERROR! FILE ###'
> write(*,*) '### surfdepo.t DOES NOT EXIST. ###'
> stop
>
> end subroutine readdepo
readlanduse.f90
----------------------------------------------
1,159c1,159
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readlanduse
<
< !*****************************************************************************
< ! *
< ! Reads the landuse inventory into memory and relates it to Leaf Area *
< ! Index and roughness length. *
< ! *
< ! AUTHOR: Andreas Stohl, 10 January 1994 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! i loop indices *
< ! landinvent(1200,600,13) area fractions of 13 landuse categories *
< ! LENGTH(numpath) length of the path names *
< ! PATH(numpath) contains the path names *
< ! unitland unit connected with landuse inventory *
< ! *
< ! ----- *
< ! Sabine Eckhardt, Dec 06 - new landuse inventary *
< ! after *
< ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
< ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
< ! A Project Overview: Photogrammetric Engineering and Remote Sensing, *
< ! v. 65, no. 9, p. 1013-1020 *
< ! *
< ! LANDUSE CATEGORIES: *
< ! *
< ! 1 Urban land *
< ! 2 Agricultural land *
< ! 3 Range land *
< ! 4 Deciduous forest *
< ! 5 Coniferous forest *
< ! 6 Mixed forest including wetland *
< ! 7 water, both salt and fresh *
< ! 8 barren land mostly desert *
< ! 9 nonforested wetland *
< ! 10 mixed agricultural and range land *
< ! 11 rocky open areas with low growing shrubs *
< ! 12 ice *
< ! 13 rainforest *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: ix,jy,i,k,lu_cat,lu_perc
< integer(kind=1) :: ilr
< integer(kind=1) :: ilr_buffer(2160000)
< integer :: il,irecread
< real :: rlr, r2lr
<
<
< ! Read landuse inventory
< !***********************
< ! The landuse information is saved in a compressed format and written
< ! out by records of the length of 1 BYTE. Each grid cell consists of 3
< ! Bytes, which include 3 landuse categories (val 1-13 and 16 percentage
< ! categories) So one half byte is used to store the Landusecat the other
< ! for the percentageclass in 6.25 steps (100/6.25=16)
< ! e.g.
< ! 4 3 percentage 4 = 4*6.25 => 25% landuse class 3
< ! 2 1 percentage 2 = 2*6.25 => 13% landuse class 1
< ! 1 12 percentage 1 = 1*6.26 => 6.25% landuse class 12
<
< open(unitland,file=path(1)(1:length(1)) &
< //'IGBP_int1.dat',status='old', &
< ! +form='UNFORMATTED', err=998)
< form='UNFORMATTED', err=998, convert='little_endian')
< ! print*,unitland
< read (unitland) (ilr_buffer(i),i=1,2160000)
< close(unitland)
<
< irecread=1
< do ix=1,1200
< do jy=1,600
< ! the 3 most abundant landuse categories in the inventory
< ! first half byte contains the landuse class
< ! second half byte contains the respective percentage
< do k=1,3
< ! 1 byte is read
< ilr=ilr_buffer(irecread)
< ! ilr=0
< irecread=irecread+1
< ! as only signed integer values exist an unsigned value is constructed
< if (ilr.lt.0) then
< il=ilr+256
< else
< il=ilr
< endif
< ! dividing by 16 has the effect to get rid of the right half of the byte
< ! so just the left half remains, this corresponds to a shift right of 4
< ! bits
< rlr=real(il)/16.
< lu_cat=int(rlr)
< ! the left half of the byte is substracted from the whole in order to
< ! get only the right half of the byte
< r2lr=rlr-int(rlr)
< ! shift left by 4
< lu_perc=r2lr*16.
< landinvent(ix,jy,k)=lu_cat
< landinvent(ix,jy,k+3)=lu_perc
< ! if ((jy.lt.10).and.(ix.lt.10)) write(*,*) 'reading: ' , ix, jy, lu_cat, lu_perc
< end do
< end do
< end do
<
< ! Read relation landuse,z0
< !*****************************
<
< open(unitsurfdata,file=path(1)(1:length(1))//'surfdata.t', &
< status='old',err=999)
<
< do i=1,4
< read(unitsurfdata,*)
< end do
< do i=1,numclass
< read(unitsurfdata,'(45x,f15.3)') z0(i)
< end do
< close(unitsurfdata)
<
< return
<
< ! Issue error messages
< !*********************
<
< 998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
< write(*,*) ' #### LANDUSE INVENTORY DOES NOT EXIST ####'
< stop
<
< 999 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
< write(*,*) ' #### RELATION LANDUSE,z0 DOES NOT EXIST ####'
< stop
<
< end subroutine readlanduse
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readlanduse
>
> !*****************************************************************************
> ! *
> ! Reads the landuse inventory into memory and relates it to Leaf Area *
> ! Index and roughness length. *
> ! *
> ! AUTHOR: Andreas Stohl, 10 January 1994 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! i loop indices *
> ! landinvent(1200,600,13) area fractions of 13 landuse categories *
> ! LENGTH(numpath) length of the path names *
> ! PATH(numpath) contains the path names *
> ! unitland unit connected with landuse inventory *
> ! *
> ! ----- *
> ! Sabine Eckhardt, Dec 06 - new landuse inventary *
> ! after *
> ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
> ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
> ! A Project Overview: Photogrammetric Engineering and Remote Sensing, *
> ! v. 65, no. 9, p. 1013-1020 *
> ! *
> ! LANDUSE CATEGORIES: *
> ! *
> ! 1 Urban land *
> ! 2 Agricultural land *
> ! 3 Range land *
> ! 4 Deciduous forest *
> ! 5 Coniferous forest *
> ! 6 Mixed forest including wetland *
> ! 7 water, both salt and fresh *
> ! 8 barren land mostly desert *
> ! 9 nonforested wetland *
> ! 10 mixed agricultural and range land *
> ! 11 rocky open areas with low growing shrubs *
> ! 12 ice *
> ! 13 rainforest *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: ix,jy,i,k,lu_cat,lu_perc
> integer(kind=1) :: ilr
> integer(kind=1) :: ilr_buffer(2160000)
> integer :: il,irecread
> real :: rlr, r2lr
>
>
> ! Read landuse inventory
> !***********************
> ! The landuse information is saved in a compressed format and written
> ! out by records of the length of 1 BYTE. Each grid cell consists of 3
> ! Bytes, which include 3 landuse categories (val 1-13 and 16 percentage
> ! categories) So one half byte is used to store the Landusecat the other
> ! for the percentageclass in 6.25 steps (100/6.25=16)
> ! e.g.
> ! 4 3 percentage 4 = 4*6.25 => 25% landuse class 3
> ! 2 1 percentage 2 = 2*6.25 => 13% landuse class 1
> ! 1 12 percentage 1 = 1*6.26 => 6.25% landuse class 12
>
> open(unitland,file=path(1)(1:length(1)) &
> //'IGBP_int1.dat',status='old', &
> ! +form='UNFORMATTED', err=998)
> form='UNFORMATTED', err=998, convert='little_endian')
> ! print*,unitland
> read (unitland) (ilr_buffer(i),i=1,2160000)
> close(unitland)
>
> irecread=1
> do ix=1,1200
> do jy=1,600
> ! the 3 most abundant landuse categories in the inventory
> ! first half byte contains the landuse class
> ! second half byte contains the respective percentage
> do k=1,3
> ! 1 byte is read
> ilr=ilr_buffer(irecread)
> ! ilr=0
> irecread=irecread+1
> ! as only signed integer values exist an unsigned value is constructed
> if (ilr.lt.0) then
> il=ilr+256
> else
> il=ilr
> endif
> ! dividing by 16 has the effect to get rid of the right half of the byte
> ! so just the left half remains, this corresponds to a shift right of 4
> ! bits
> rlr=real(il)/16.
> lu_cat=int(rlr)
> ! the left half of the byte is substracted from the whole in order to
> ! get only the right half of the byte
> r2lr=rlr-int(rlr)
> ! shift left by 4
> lu_perc=r2lr*16.
> landinvent(ix,jy,k)=lu_cat
> landinvent(ix,jy,k+3)=lu_perc
> ! if ((jy.lt.10).and.(ix.lt.10)) write(*,*) 'reading: ' , ix, jy, lu_cat, lu_perc
> end do
> end do
> end do
>
> ! Read relation landuse,z0
> !*****************************
>
> open(unitsurfdata,file=path(1)(1:length(1))//'surfdata.t', &
> status='old',err=999)
>
> do i=1,4
> read(unitsurfdata,*)
> end do
> do i=1,numclass
> read(unitsurfdata,'(45x,f15.3)') z0(i)
> end do
> close(unitsurfdata)
>
> return
>
> ! Issue error messages
> !*********************
>
> 998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
> write(*,*) ' #### LANDUSE INVENTORY DOES NOT EXIST ####'
> stop
>
> 999 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
> write(*,*) ' #### RELATION LANDUSE,z0 DOES NOT EXIST ####'
> stop
>
> end subroutine readlanduse
readlanduse_int1.f90
----------------------------------------------
1,161c1,161
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readlanduse
<
< !*****************************************************************************
< ! *
< ! Reads the landuse inventory into memory and relates it to Leaf Area *
< ! Index and roughness length. *
< ! *
< ! AUTHOR: Andreas Stohl, 10 January 1994 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! i loop indices *
< ! landinvent(1200,600,13) area fractions of 13 landuse categories *
< ! LENGTH(numpath) length of the path names *
< ! PATH(numpath) contains the path names *
< ! unitland unit connected with landuse inventory *
< ! *
< ! ----- *
< ! Sabine Eckhardt, Dec 06 - new landuse inventary *
< ! after *
< ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
< ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
< ! A Project Overview: Photogrammetric Engineering and Remote Sensing, *
< ! v. 65, no. 9, p. 1013-1020 *
< ! *
< ! LANDUSE CATEGORIES: *
< ! *
< ! 1 Urban land *
< ! 2 Agricultural land *
< ! 3 Range land *
< ! 4 Deciduous forest *
< ! 5 Coniferous forest *
< ! 6 Mixed forest including wetland *
< ! 7 water, both salt and fresh *
< ! 8 barren land mostly desert *
< ! 9 nonforested wetland *
< ! 10 mixed agricultural and range land *
< ! 11 rocky open areas with low growing shrubs *
< ! 12 ice *
< ! 13 rainforest *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: ix,jy,i,k,lu_cat,lu_perc
< integer(kind=1) :: ilr
< integer(kind=1) :: ilr_buffer(2160000)
< integer :: il,irecread
< real :: rlr, r2lr
<
<
< ! Read landuse inventory
< !***********************
< ! The landuse information is saved in a compressed format and written
< ! out by records of the length of 1 BYTE. Each grid cell consists of 3
< ! Bytes, which include 3 landuse categories (val 1-13 and 16 percentage
< ! categories) So one half byte is used to store the Landusecat the other
< ! for the percentageclass in 6.25 steps (100/6.25=16)
< ! e.g.
< ! 4 3 percentage 4 = 4*6.25 => 25% landuse class 3
< ! 2 1 percentage 2 = 2*6.25 => 13% landuse class 1
< ! 1 12 percentage 1 = 1*6.26 => 6.25% landuse class 12
<
<
< write (*,*) 'reading: ',path(1)(1:length(1))
< open(unitland,file=path(1)(1:length(1)) &
< //'IGBP_int1.dat',status='old', &
< form='UNFORMATTED', err=998)
< read (unitland) (ilr_buffer(i),i=1,2160000)
< close(unitland)
< write (*,*) 'reading: '
<
< irecread=1
< do ix=1,1200
< do jy=1,600
< ! the 3 most abundant landuse categories in the inventory
< ! first half byte contains the landuse class
< ! second half byte contains the respective percentage
< do k=1,3
< ! 1 byte is read
< ilr=ilr_buffer(irecread)
< irecread=irecread+1
< ! as only signed integer values exist an unsigned value is constructed
< if (ilr.lt.0) then
< il=ilr+256
< else
< il=ilr
< endif
< ! dividing by 16 has the effect to get rid of the right half of the byte
< ! so just the left half remains, this corresponds to a shift right of 4
< ! bits
< rlr=real(il)/16.
< lu_cat=int(rlr)
< ! the left half of the byte is substracted from the whole in order to
< ! get only the right half of the byte
< r2lr=rlr-int(rlr)
< ! shift left by 4
< lu_perc=r2lr*16.
< landinvent(ix,jy,k)=lu_cat
< landinvent(ix,jy,k+3)=lu_perc
< if ((jy.lt.10).and.(ix.lt.10)) then
< write(*,*) 'reading: ', ix, jy, lu_cat, lu_perc
< endif
< end do
< end do
< end do
<
< ! Read relation landuse,z0
< !*****************************
<
< open(unitsurfdata,file=path(1)(1:length(1))//'surfdata.t', &
< status='old',err=999)
<
< do i=1,4
< read(unitsurfdata,*)
< end do
< do i=1,numclass
< read(unitsurfdata,'(45x,f15.3)') z0(i)
< end do
< close(unitsurfdata)
<
< return
<
< ! Issue error messages
< !*********************
<
< 998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
< write(*,*) ' #### LANDUSE INVENTORY DOES NOT EXIST ####'
< stop
<
< 999 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
< write(*,*) ' #### RELATION LANDUSE,z0 DOES NOT EXIST ####'
< stop
<
< end subroutine readlanduse
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readlanduse
>
> !*****************************************************************************
> ! *
> ! Reads the landuse inventory into memory and relates it to Leaf Area *
> ! Index and roughness length. *
> ! *
> ! AUTHOR: Andreas Stohl, 10 January 1994 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! i loop indices *
> ! landinvent(1200,600,13) area fractions of 13 landuse categories *
> ! LENGTH(numpath) length of the path names *
> ! PATH(numpath) contains the path names *
> ! unitland unit connected with landuse inventory *
> ! *
> ! ----- *
> ! Sabine Eckhardt, Dec 06 - new landuse inventary *
> ! after *
> ! Belward, A.S., Estes, J.E., and Kline, K.D., 1999, *
> ! The IGBP-DIS 1-Km Land-Cover Data Set DISCover: *
> ! A Project Overview: Photogrammetric Engineering and Remote Sensing, *
> ! v. 65, no. 9, p. 1013-1020 *
> ! *
> ! LANDUSE CATEGORIES: *
> ! *
> ! 1 Urban land *
> ! 2 Agricultural land *
> ! 3 Range land *
> ! 4 Deciduous forest *
> ! 5 Coniferous forest *
> ! 6 Mixed forest including wetland *
> ! 7 water, both salt and fresh *
> ! 8 barren land mostly desert *
> ! 9 nonforested wetland *
> ! 10 mixed agricultural and range land *
> ! 11 rocky open areas with low growing shrubs *
> ! 12 ice *
> ! 13 rainforest *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: ix,jy,i,k,lu_cat,lu_perc
> integer(kind=1) :: ilr
> integer(kind=1) :: ilr_buffer(2160000)
> integer :: il,irecread
> real :: rlr, r2lr
>
>
> ! Read landuse inventory
> !***********************
> ! The landuse information is saved in a compressed format and written
> ! out by records of the length of 1 BYTE. Each grid cell consists of 3
> ! Bytes, which include 3 landuse categories (val 1-13 and 16 percentage
> ! categories) So one half byte is used to store the Landusecat the other
> ! for the percentageclass in 6.25 steps (100/6.25=16)
> ! e.g.
> ! 4 3 percentage 4 = 4*6.25 => 25% landuse class 3
> ! 2 1 percentage 2 = 2*6.25 => 13% landuse class 1
> ! 1 12 percentage 1 = 1*6.26 => 6.25% landuse class 12
>
>
> write (*,*) 'reading: ',path(1)(1:length(1))
> open(unitland,file=path(1)(1:length(1)) &
> //'IGBP_int1.dat',status='old', &
> form='UNFORMATTED', err=998)
> read (unitland) (ilr_buffer(i),i=1,2160000)
> close(unitland)
> write (*,*) 'reading: '
>
> irecread=1
> do ix=1,1200
> do jy=1,600
> ! the 3 most abundant landuse categories in the inventory
> ! first half byte contains the landuse class
> ! second half byte contains the respective percentage
> do k=1,3
> ! 1 byte is read
> ilr=ilr_buffer(irecread)
> irecread=irecread+1
> ! as only signed integer values exist an unsigned value is constructed
> if (ilr.lt.0) then
> il=ilr+256
> else
> il=ilr
> endif
> ! dividing by 16 has the effect to get rid of the right half of the byte
> ! so just the left half remains, this corresponds to a shift right of 4
> ! bits
> rlr=real(il)/16.
> lu_cat=int(rlr)
> ! the left half of the byte is substracted from the whole in order to
> ! get only the right half of the byte
> r2lr=rlr-int(rlr)
> ! shift left by 4
> lu_perc=r2lr*16.
> landinvent(ix,jy,k)=lu_cat
> landinvent(ix,jy,k+3)=lu_perc
> if ((jy.lt.10).and.(ix.lt.10)) then
> write(*,*) 'reading: ', ix, jy, lu_cat, lu_perc
> endif
> end do
> end do
> end do
>
> ! Read relation landuse,z0
> !*****************************
>
> open(unitsurfdata,file=path(1)(1:length(1))//'surfdata.t', &
> status='old',err=999)
>
> do i=1,4
> read(unitsurfdata,*)
> end do
> do i=1,numclass
> read(unitsurfdata,'(45x,f15.3)') z0(i)
> end do
> close(unitsurfdata)
>
> return
>
> ! Issue error messages
> !*********************
>
> 998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
> write(*,*) ' #### LANDUSE INVENTORY DOES NOT EXIST ####'
> stop
>
> 999 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
> write(*,*) ' #### RELATION LANDUSE,z0 DOES NOT EXIST ####'
> stop
>
> end subroutine readlanduse
readOHfield.f90
----------------------------------------------
1,84c1,84
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readOHfield
<
< !*****************************************************************************
< ! *
< ! Reads the OH field into memory *
< ! *
< ! AUTHOR: Sabine Eckhardt, June 2007 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! i loop indices *
< ! LENGTH(numpath) length of the path names *
< ! PATH(numpath) contains the path names *
< ! unitoh unit connected with OH field *
< ! *
< ! ----- *
< ! *
< !*****************************************************************************
<
< use oh_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: ix,jy,lev,m
<
<
< ! Read OH field and level heights
< !********************************
<
< ! write (*,*) 'reading OH'
< open(unitOH,file=path(1)(1:length(1))//'OH_7lev_agl.dat', &
< status='old',form='UNFORMATTED', err=998)
< do m=1,12
< do lev=1,maxzOH
< do ix=0,maxxOH-1
< ! do 10 jy=0,maxyOH-1
< read(unitOH) (OH_field(m,ix,jy,lev),jy=0,maxyOH-1)
< ! if ((ix.eq.20).and.(lev.eq.1)) then
< ! write(*,*) 'reading: ', m, OH_field(m,ix,20,lev)
< ! endif
< end do
< end do
< end do
< close(unitOH)
<
< do lev=1,7
< OH_field_height(lev)=1000+real(lev-1)*2.*1000.
< end do
<
< ! write (*,*) 'OH read'
< return
<
< ! Issue error messages
< !*********************
<
< 998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
< write(*,*) ' #### OH FIELD DOES NOT EXIST ####'
< stop
<
< end subroutine readohfield
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readOHfield
>
> !*****************************************************************************
> ! *
> ! Reads the OH field into memory *
> ! *
> ! AUTHOR: Sabine Eckhardt, June 2007 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! i loop indices *
> ! LENGTH(numpath) length of the path names *
> ! PATH(numpath) contains the path names *
> ! unitoh unit connected with OH field *
> ! *
> ! ----- *
> ! *
> !*****************************************************************************
>
> use oh_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: ix,jy,lev,m
>
>
> ! Read OH field and level heights
> !********************************
>
> ! write (*,*) 'reading OH'
> open(unitOH,file=path(1)(1:length(1))//'OH_7lev_agl.dat', &
> status='old',form='UNFORMATTED', err=998)
> do m=1,12
> do lev=1,maxzOH
> do ix=0,maxxOH-1
> ! do 10 jy=0,maxyOH-1
> read(unitOH) (OH_field(m,ix,jy,lev),jy=0,maxyOH-1)
> ! if ((ix.eq.20).and.(lev.eq.1)) then
> ! write(*,*) 'reading: ', m, OH_field(m,ix,20,lev)
> ! endif
> end do
> end do
> end do
> close(unitOH)
>
> do lev=1,7
> OH_field_height(lev)=1000+real(lev-1)*2.*1000.
> end do
>
> ! write (*,*) 'OH read'
> return
>
> ! Issue error messages
> !*********************
>
> 998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####'
> write(*,*) ' #### OH FIELD DOES NOT EXIST ####'
> stop
>
> end subroutine readohfield
readoutgrid.f90
----------------------------------------------
1,188c1,188
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readoutgrid
<
< !*****************************************************************************
< ! *
< ! This routine reads the user specifications for the output grid. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 4 June 1996 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! dxout,dyout grid distance *
< ! numxgrid,numygrid,numzgrid grid dimensions *
< ! outlon0,outlat0 lower left corner of grid *
< ! outheight(maxzgrid) height levels of output grid [m] *
< ! *
< ! Constants: *
< ! unitoutgrid unit connected to file OUTGRID *
< ! *
< !*****************************************************************************
<
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: i,j,stat
< real :: outhelp,xr,xr1,yr,yr1
< real,parameter :: eps=1.e-4
<
<
<
< ! Open the OUTGRID file and read output grid specifications
< !**********************************************************
<
< open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID',status='old', &
< err=999)
<
<
< call skplin(5,unitoutgrid)
<
<
< ! 1. Read horizontal grid specifications
< !****************************************
<
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,f11.4)') outlon0
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,f11.4)') outlat0
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,i5)') numxgrid
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,i5)') numygrid
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,f12.5)') dxout
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,f12.5)') dyout
<
<
< ! Check validity of output grid (shall be within model domain)
< !*************************************************************
<
< xr=outlon0+real(numxgrid)*dxout
< yr=outlat0+real(numygrid)*dyout
< xr1=xlon0+real(nxmin1)*dx
< yr1=ylat0+real(nymin1)*dy
< if ((outlon0+eps.lt.xlon0).or.(outlat0+eps.lt.ylat0) &
< .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then
< write(*,*) outlon0,outlat0
< write(*,*) xr1,yr1,xlon0,ylat0,xr,yr,dxout,dyout
< write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####'
< write(*,*) ' #### GRID IS OUTSIDE MODEL DOMAIN. CHANGE ####'
< write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####'
< write(*,'(a)') path(1)(1:length(1))
< stop
< endif
<
< ! 2. Count Vertical levels of output grid
< !****************************************
< j=0
< 100 j=j+1
< do i=1,3
< read(unitoutgrid,*,end=99)
< end do
< read(unitoutgrid,'(4x,f7.1)',end=99) outhelp
< if (outhelp.eq.0.) goto 99
< goto 100
< 99 numzgrid=j-1
<
< allocate(outheight(numzgrid) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
< allocate(outheighthalf(numzgrid) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
<
<
< rewind(unitoutgrid)
< call skplin(29,unitoutgrid)
<
< ! 2. Vertical levels of output grid
< !**********************************
<
< j=0
< 1000 j=j+1
< do i=1,3
< read(unitoutgrid,*,end=990)
< end do
< read(unitoutgrid,'(4x,f7.1)',end=990) outhelp
< if (outhelp.eq.0.) goto 99
< outheight(j)=outhelp
< goto 1000
< 990 numzgrid=j-1
<
<
< ! Check whether vertical levels are specified in ascending order
< !***************************************************************
<
< do j=2,numzgrid
< if (outheight(j).le.outheight(j-1)) then
< write(*,*) ' #### FLEXPART MODEL ERROR! YOUR SPECIFICATION#### '
< write(*,*) ' #### OF OUTPUT LEVELS IS CORRUPT AT LEVEL #### '
< write(*,*) ' #### ',j,' #### '
< write(*,*) ' #### PLEASE MAKE CHANGES IN FILE OUTGRID. #### '
< endif
< end do
<
< ! Determine the half levels, i.e. middle levels of the output grid
< !*****************************************************************
<
< outheighthalf(1)=outheight(1)/2.
< do j=2,numzgrid
< outheighthalf(j)=(outheight(j-1)+outheight(j))/2.
< end do
<
<
< xoutshift=xlon0-outlon0
< youtshift=ylat0-outlat0
< close(unitoutgrid)
<
< allocate(oroout(0:numxgrid-1,0:numygrid-1) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
< allocate(area(0:numxgrid-1,0:numygrid-1) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
< allocate(volume(0:numxgrid-1,0:numygrid-1,numzgrid) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
< allocate(areaeast(0:numxgrid-1,0:numygrid-1,numzgrid) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
< allocate(areanorth(0:numxgrid-1,0:numygrid-1,numzgrid) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
< return
<
<
< 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### '
< write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
< write(*,*) ' #### xxx/flexpart/options #### '
< stop
<
< end subroutine readoutgrid
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readoutgrid
>
> !*****************************************************************************
> ! *
> ! This routine reads the user specifications for the output grid. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 4 June 1996 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! dxout,dyout grid distance *
> ! numxgrid,numygrid,numzgrid grid dimensions *
> ! outlon0,outlat0 lower left corner of grid *
> ! outheight(maxzgrid) height levels of output grid [m] *
> ! *
> ! Constants: *
> ! unitoutgrid unit connected to file OUTGRID *
> ! *
> !*****************************************************************************
>
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: i,j,stat
> real :: outhelp,xr,xr1,yr,yr1
> real,parameter :: eps=1.e-4
>
>
>
> ! Open the OUTGRID file and read output grid specifications
> !**********************************************************
>
> open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID',status='old', &
> err=999)
>
>
> call skplin(5,unitoutgrid)
>
>
> ! 1. Read horizontal grid specifications
> !****************************************
>
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,f11.4)') outlon0
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,f11.4)') outlat0
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,i5)') numxgrid
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,i5)') numygrid
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,f12.5)') dxout
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,f12.5)') dyout
>
>
> ! Check validity of output grid (shall be within model domain)
> !*************************************************************
>
> xr=outlon0+real(numxgrid)*dxout
> yr=outlat0+real(numygrid)*dyout
> xr1=xlon0+real(nxmin1)*dx
> yr1=ylat0+real(nymin1)*dy
> if ((outlon0+eps.lt.xlon0).or.(outlat0+eps.lt.ylat0) &
> .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then
> write(*,*) outlon0,outlat0
> write(*,*) xr1,yr1,xlon0,ylat0,xr,yr,dxout,dyout
> write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####'
> write(*,*) ' #### GRID IS OUTSIDE MODEL DOMAIN. CHANGE ####'
> write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####'
> write(*,'(a)') path(1)(1:length(1))
> stop
> endif
>
> ! 2. Count Vertical levels of output grid
> !****************************************
> j=0
> 100 j=j+1
> do i=1,3
> read(unitoutgrid,*,end=99)
> end do
> read(unitoutgrid,'(4x,f7.1)',end=99) outhelp
> if (outhelp.eq.0.) goto 99
> goto 100
> 99 numzgrid=j-1
>
> allocate(outheight(numzgrid) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
> allocate(outheighthalf(numzgrid) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
>
>
> rewind(unitoutgrid)
> call skplin(29,unitoutgrid)
>
> ! 2. Vertical levels of output grid
> !**********************************
>
> j=0
> 1000 j=j+1
> do i=1,3
> read(unitoutgrid,*,end=990)
> end do
> read(unitoutgrid,'(4x,f7.1)',end=990) outhelp
> if (outhelp.eq.0.) goto 99
> outheight(j)=outhelp
> goto 1000
> 990 numzgrid=j-1
>
>
> ! Check whether vertical levels are specified in ascending order
> !***************************************************************
>
> do j=2,numzgrid
> if (outheight(j).le.outheight(j-1)) then
> write(*,*) ' #### FLEXPART MODEL ERROR! YOUR SPECIFICATION#### '
> write(*,*) ' #### OF OUTPUT LEVELS IS CORRUPT AT LEVEL #### '
> write(*,*) ' #### ',j,' #### '
> write(*,*) ' #### PLEASE MAKE CHANGES IN FILE OUTGRID. #### '
> endif
> end do
>
> ! Determine the half levels, i.e. middle levels of the output grid
> !*****************************************************************
>
> outheighthalf(1)=outheight(1)/2.
> do j=2,numzgrid
> outheighthalf(j)=(outheight(j-1)+outheight(j))/2.
> end do
>
>
> xoutshift=xlon0-outlon0
> youtshift=ylat0-outlat0
> close(unitoutgrid)
>
> allocate(oroout(0:numxgrid-1,0:numygrid-1) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
> allocate(area(0:numxgrid-1,0:numygrid-1) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
> allocate(volume(0:numxgrid-1,0:numygrid-1,numzgrid) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
> allocate(areaeast(0:numxgrid-1,0:numygrid-1,numzgrid) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
> allocate(areanorth(0:numxgrid-1,0:numygrid-1,numzgrid) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
> return
>
>
> 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### '
> write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
> write(*,*) ' #### xxx/flexpart/options #### '
> stop
>
> end subroutine readoutgrid
readoutgrid_nest.f90
----------------------------------------------
1,121c1,121
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readoutgrid_nest
<
< !*****************************************************************************
< ! *
< ! This routine reads the user specifications for the output nest. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 4 June 1996 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! dxoutn,dyoutn grid distances of output nest *
< ! numxgridn,numygridn,numzgrid nest dimensions *
< ! outlon0n,outlat0n lower left corner of nest *
< ! outheight(maxzgrid) height levels of output grid [m] *
< ! *
< ! Constants: *
< ! unitoutgrid unit connected to file OUTGRID *
< ! *
< !*****************************************************************************
<
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: stat
< real :: xr,xr1,yr,yr1
< real,parameter :: eps=1.e-4
<
<
<
< ! Open the OUTGRID file and read output grid specifications
< !**********************************************************
<
< open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID_NEST', &
< status='old',err=999)
<
<
< call skplin(5,unitoutgrid)
<
<
< ! 1. Read horizontal grid specifications
< !****************************************
<
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,f11.4)') outlon0n
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,f11.4)') outlat0n
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,i5)') numxgridn
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,i5)') numygridn
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,f12.5)') dxoutn
< call skplin(3,unitoutgrid)
< read(unitoutgrid,'(4x,f12.5)') dyoutn
<
<
< allocate(orooutn(0:numxgridn-1,0:numygridn-1) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
< allocate(arean(0:numxgridn-1,0:numygridn-1) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
< allocate(volumen(0:numxgridn-1,0:numygridn-1,numzgrid) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
<
< ! Check validity of output grid (shall be within model domain)
< !*************************************************************
<
< xr=outlon0n+real(numxgridn)*dxoutn
< yr=outlat0n+real(numygridn)*dyoutn
< xr1=xlon0+real(nxmin1)*dx
< yr1=ylat0+real(nymin1)*dy
< if ((outlon0n+eps.lt.xlon0).or.(outlat0n+eps.lt.ylat0) &
< .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then
< write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####'
< write(*,*) ' #### NEST IS OUTSIDE MODEL DOMAIN. CHANGE ####'
< write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####'
< write(*,'(a)') path(1)(1:length(1))
< stop
< endif
<
< xoutshiftn=xlon0-outlon0n
< youtshiftn=ylat0-outlat0n
< close(unitoutgrid)
< return
<
<
< 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE OUTGRID_NEST #### '
< write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
< write(*,*) ' #### xxx/flexpart/options #### '
< stop
<
< end subroutine readoutgrid_nest
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readoutgrid_nest
>
> !*****************************************************************************
> ! *
> ! This routine reads the user specifications for the output nest. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 4 June 1996 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! dxoutn,dyoutn grid distances of output nest *
> ! numxgridn,numygridn,numzgrid nest dimensions *
> ! outlon0n,outlat0n lower left corner of nest *
> ! outheight(maxzgrid) height levels of output grid [m] *
> ! *
> ! Constants: *
> ! unitoutgrid unit connected to file OUTGRID *
> ! *
> !*****************************************************************************
>
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: stat
> real :: xr,xr1,yr,yr1
> real,parameter :: eps=1.e-4
>
>
>
> ! Open the OUTGRID file and read output grid specifications
> !**********************************************************
>
> open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID_NEST', &
> status='old',err=999)
>
>
> call skplin(5,unitoutgrid)
>
>
> ! 1. Read horizontal grid specifications
> !****************************************
>
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,f11.4)') outlon0n
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,f11.4)') outlat0n
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,i5)') numxgridn
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,i5)') numygridn
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,f12.5)') dxoutn
> call skplin(3,unitoutgrid)
> read(unitoutgrid,'(4x,f12.5)') dyoutn
>
>
> allocate(orooutn(0:numxgridn-1,0:numygridn-1) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
> allocate(arean(0:numxgridn-1,0:numygridn-1) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
> allocate(volumen(0:numxgridn-1,0:numygridn-1,numzgrid) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate outh'
>
> ! Check validity of output grid (shall be within model domain)
> !*************************************************************
>
> xr=outlon0n+real(numxgridn)*dxoutn
> yr=outlat0n+real(numygridn)*dyoutn
> xr1=xlon0+real(nxmin1)*dx
> yr1=ylat0+real(nymin1)*dy
> if ((outlon0n+eps.lt.xlon0).or.(outlat0n+eps.lt.ylat0) &
> .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then
> write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####'
> write(*,*) ' #### NEST IS OUTSIDE MODEL DOMAIN. CHANGE ####'
> write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####'
> write(*,'(a)') path(1)(1:length(1))
> stop
> endif
>
> xoutshiftn=xlon0-outlon0n
> youtshiftn=ylat0-outlat0n
> close(unitoutgrid)
> return
>
>
> 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE OUTGRID_NEST #### '
> write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
> write(*,*) ' #### xxx/flexpart/options #### '
> stop
>
> end subroutine readoutgrid_nest
readpartpositions.f90
----------------------------------------------
1,170c1,261
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readpartpositions
<
< !*****************************************************************************
< ! *
< ! This routine opens the particle dump file and reads all the particle *
< ! positions from a previous run to initialize the current run. *
< ! *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 24 March 2000 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: ibdatein,ibtimein,nspecin,itimein,numpointin,i,j,ix
< integer :: id1,id2,it1,it2
< real :: xlonin,ylatin,ran1,topo,hmixi,pvi,qvi,rhoi,tri,tti
< character :: specin*7
< real(kind=dp) :: julin,julpartin,juldate
<
< integer :: idummy = -8
<
< numparticlecount=0
<
< ! Open header file of dumped particle data
< !*****************************************
<
< open(unitpartin,file=path(2)(1:length(2))//'header', &
< form='unformatted',err=998)
<
< read(unitpartin) ibdatein,ibtimein
< read(unitpartin)
< read(unitpartin)
<
< read(unitpartin)
< read(unitpartin)
< read(unitpartin) nspecin
< nspecin=nspecin/3
< if ((ldirect.eq.1).and.(nspec.ne.nspecin)) goto 997
<
< do i=1,nspecin
< read(unitpartin)
< read(unitpartin)
< read(unitpartin) j,specin
< if ((ldirect.eq.1).and.(species(i)(1:7).ne.specin)) goto 996
< end do
<
< read(unitpartin) numpointin
< if (numpointin.ne.numpoint) goto 995
< do i=1,numpointin
< read(unitpartin)
< read(unitpartin)
< read(unitpartin)
< read(unitpartin)
< do j=1,nspec
< read(unitpartin)
< read(unitpartin)
< read(unitpartin)
< end do
< end do
< read(unitpartin)
< read(unitpartin)
<
< do ix=0,numxgrid-1
< read(unitpartin)
< end do
<
<
< ! Open data file of dumped particle data
< !***************************************
<
< close(unitpartin)
< open(unitpartin,file=path(2)(1:length(2))//'partposit_end', &
< form='unformatted',err=998)
<
<
< 100 read(unitpartin,end=99) itimein
< i=0
< 200 i=i+1
< read(unitpartin) npoint(i),xlonin,ylatin,ztra1(i),itramem(i), &
< topo,pvi,qvi,rhoi,hmixi,tri,tti,(xmass1(i,j),j=1,nspec)
<
< if (xlonin.eq.-9999.9) goto 100
< xtra1(i)=(xlonin-xlon0)/dx
< ytra1(i)=(ylatin-ylat0)/dy
< numparticlecount=max(numparticlecount,npoint(i))
< goto 200
<
< 99 numpart=i-1
<
< close(unitpartin)
<
< julin=juldate(ibdatein,ibtimein)+real(itimein,kind=dp)/86400._dp
< if (abs(julin-bdate).gt.1.e-5) goto 994
< do i=1,numpart
< julpartin=juldate(ibdatein,ibtimein)+ &
< real(itramem(i),kind=dp)/86400._dp
< nclass(i)=min(int(ran1(idummy)*real(nclassunc))+1, &
< nclassunc)
< idt(i)=mintime
< itra1(i)=0
< itramem(i)=nint((julpartin-bdate)*86400.)
< itrasplit(i)=ldirect*itsplit
< end do
<
< return
<
<
< 994 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
< write(*,*) ' #### ENDING TIME OF PREVIOUS MODEL RUN DOES #### '
< write(*,*) ' #### NOT AGREE WITH STARTING TIME OF THIS RUN.#### '
< call caldate(julin,id1,it1)
< call caldate(bdate,id2,it2)
< write(*,*) 'julin: ',julin,id1,it1
< write(*,*) 'bdate: ',bdate,id2,it2
< stop
<
< 995 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
< write(*,*) ' #### NUMBER OF RELEASE LOCATIONS DOES NOT #### '
< write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
< stop
<
< 996 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
< write(*,*) ' #### SPECIES NAMES TO BE READ IN DO NOT #### '
< write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
< stop
<
< 997 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
< write(*,*) ' #### THE NUMBER OF SPECIES TO BE READ IN DOES #### '
< write(*,*) ' #### NOT AGREE WITH CURRENT SETTINGS! #### '
< stop
<
< 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
< write(*,*) ' #### '//path(2)(1:length(2))//'grid'//' #### '
< write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
< write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
< write(*,*) ' #### THE PROGRAM AGAIN. #### '
< stop
<
< end subroutine readpartpositions
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readpartpositions
>
> !*****************************************************************************
> ! *
> ! This routine opens the particle dump file and reads all the particle *
> ! positions from a previous run to initialize the current run. *
> ! *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 24 March 2000 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use point_mod, only: ireleasestart, ireleaseend, npart
> use random_mod, only: ran1
>
> implicit none
>
> integer :: ibdatein,ibtimein,nspecin,itimein,numpointin,i,j,ix, ixp, jy, jyp
> integer :: id1,id2,it1,it2
> real :: xlonin,ylatin,topo,hmixi,pvi,qvi,rhoi,tri,tti
> character :: specin*7
> character :: version*13
> real(kind=dp) :: julin,julpartin,juldate
> real :: p1, p2, p3, p4, ddx, ddy, rddx, rddy, topo_cur, xlon, ylat, xtn, ytn
> integer :: ngrid
>
> integer :: npartcount(numpoint)
> integer :: idummy = -8
> real,parameter :: eps=nxmax/3.e5
>
> numparticlecount=0
> npartcount(:) = 0
> ! Open header file of dumped particle data
> !*****************************************
>
> open(unitpartin,file=path(2)(1:length(2))//'header_previous', &
> form='unformatted',err=998)
>
> read(unitpartin) ibdatein,ibtimein, version
> if (version(12:12).eq.'C') then ! FLEXPART COSMO header
> do i=1,5
> read(unitpartin)
> end do
> else ! standard FLEXPART header
> read(unitpartin)
> read(unitpartin)
> read(unitpartin)
> read(unitpartin)
> end if
>
> read(unitpartin) nspecin
> nspecin=nspecin/3
> if ((ldirect.eq.1).and.(nspec.ne.nspecin)) goto 997
>
> do i=1,nspecin
> read(unitpartin)
> read(unitpartin)
> read(unitpartin) j,specin
> if ((ldirect.eq.1).and.(species(i)(1:7).ne.specin)) goto 996
> if (version(12:12).eq.'C') read(unitpartin)
> end do
>
> read(unitpartin) numpointin
> if (numpointin.ne.numpoint) goto 995
> do i=1,numpointin
> read(unitpartin)
> read(unitpartin)
> read(unitpartin)
> read(unitpartin)
> do j=1,nspec
> read(unitpartin)
> read(unitpartin)
> read(unitpartin)
> end do
> end do
> read(unitpartin)
> read(unitpartin)
>
> ! do ix=0,numxgrid-1
> ! read(unitpartin)
> ! end do
>
> close(unitpartin)
>
> ! Open data file of dumped particle data
> !***************************************
>
> open(unitpartin,file=path(2)(1:length(2))//'partposit_end', &
> form='unformatted',err=998)
>
>
> 100 read(unitpartin,end=99) itimein
> i=0
> 200 i=i+1
> read(unitpartin) npoint(i),xlonin,ylatin,ztra1(i),itramem(i), &
> topo,pvi,qvi,rhoi,hmixi,tri,tti,(xmass1(i,j),j=1,nspec)
>
> if (version(12:12).eq.'C') then ! FLEXPART COSMO header
> itra1(i) = int(pvi/lsynctime) * lsynctime
> endif
>
> if (xlonin.eq.-9999.9) goto 100
> xtra1(i)=(xlonin-xlon0)/dx
> ytra1(i)=(ylatin-ylat0)/dy
> numparticlecount=max(numparticlecount,npoint(i))
> npartcount(npoint(i)) = npartcount(npoint(i)) + 1
>
>
> ! determine topograyph in current model run
>
>
> ngrid = 0
> do j=numbnests,1,-1
> if ( (xtra1(i).gt.xln(j)+eps) .and. (xtra1(i).lt.xrn(j)-eps) .and. &
> (ytra1(i).gt.yln(j)+eps) .and. (ytra1(i).lt.yrn(j)-eps)) then
> ngrid = j
> exit
> end if
> end do
>
> if (ngrid.eq.0) then
> ix=int(xtra1(i))
> jy=int(ytra1(i))
> xtn = xtra1(i)
> ytn = ytra1(i)
> else
> xtn = (xtra1(i)-xln(ngrid))*xresoln(ngrid)
> ytn = (ytra1(i)-yln(ngrid))*yresoln(ngrid)
> ix = int(xtn)
> jy = int(ytn)
> end if
>
> ixp=ix+1
> jyp=jy+1
>
> ddx=xtn-real(ix)
> ddy=ytn-real(jy)
>
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
>
> ! Topography
> !***********
>
> if (ngrid.eq.0) then
> topo_cur =p1*oro(ix ,jy) &
> + p2*oro(ixp,jy) &
> + p3*oro(ix ,jyp) &
> + p4*oro(ixp,jyp)
> else
> topo_cur =p1 * oron(ix , jy , ngrid) &
> + p2 * oron(ixp, jy , ngrid) &
> + p3 * oron(ix , jyp, ngrid) &
> + p4 * oron(ixp, jyp, ngrid)
> end if
>
> ! adjust topography differences, add half the topo difference to particle height
> ! avoid particles below ground
> ztra1(i) = max(0.1, ztra1(i) + (topo-topo_cur)*0.5 )
>
> goto 200
>
> 99 numpart=i-1
>
> close(unitpartin)
>
>
> ! adjust number of particles at release points
> ! set release times before simulation start to avoid double release
> if (version(12:12).eq.'C') then
> do i=1, numpoint
> npart(i) = npartcount(i)
> ireleasestart(i) = lsynctime * ldirect
> ireleaseend(i) = lsynctime * ldirect
> end do
> end if
>
> julin=juldate(ibdatein,ibtimein)+real(itimein,kind=dp)/86400._dp
> if (abs(julin-bdate).gt.1.e-5) goto 994
> do i=1,numpart
> julpartin=juldate(ibdatein,ibtimein)+ &
> real(itramem(i),kind=dp)/86400._dp
> nclass(i)=min(int(ran1(idummy)*real(nclassunc))+1, &
> nclassunc)
> idt(i)=mintime
>
> if (version(12:12).ne.'C') itra1(i)=0
>
> itramem(i)=nint((julpartin-bdate)*86400.)
> itrasplit(i)=ldirect*itsplit
> end do
> write(*,*) maxval(itra1(1:numpart)), minval(itra1(1:numpart))
>
> return
>
>
> 994 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
> write(*,*) ' #### ENDING TIME OF PREVIOUS MODEL RUN DOES #### '
> write(*,*) ' #### NOT AGREE WITH STARTING TIME OF THIS RUN.#### '
> call caldate(julin,id1,it1)
> call caldate(bdate,id2,it2)
> write(*,*) 'julin: ',julin,id1,it1
> write(*,*) 'bdate: ',bdate,id2,it2
> stop
>
> 995 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
> write(*,*) ' #### NUMBER OF RELEASE LOCATIONS DOES NOT #### '
> write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
> stop
>
> 996 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
> write(*,*) ' #### SPECIES NAMES TO BE READ IN DO NOT #### '
> write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### '
> stop
>
> 997 write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### '
> write(*,*) ' #### THE NUMBER OF SPECIES TO BE READ IN DOES #### '
> write(*,*) ' #### NOT AGREE WITH CURRENT SETTINGS! #### '
> stop
>
> 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
> write(*,*) ' #### '//path(2)(1:length(2))//'grid'//' #### '
> write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
> write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
> write(*,*) ' #### THE PROGRAM AGAIN. #### '
> stop
>
> end subroutine readpartpositions
readpaths.f90
----------------------------------------------
1,95c1,91
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readpaths(pathfile)
<
< !*****************************************************************************
< ! *
< ! Reads the pathnames, where input/output files are expected to be. *
< ! The file pathnames must be available in the current working directory. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 1 February 1994 *
< ! last modified *
< ! HS, 7.9.2012 *
< ! option to give pathnames file as command line option *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! length(numpath) lengths of the path names *
< ! path(numpath) pathnames of input/output files *
< ! *
< ! Constants: *
< ! numpath number of pathnames to be read in *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: i
< character(256) :: pathfile
<
< ! Read the pathname information stored in unitpath
< !*************************************************
<
< open(unitpath,file=trim(pathfile),status='old',err=999)
<
< do i=1,numpath
< read(unitpath,'(a)',err=998) path(i)
< length(i)=index(path(i),' ')-1
< end do
<
< ! Check whether any nested subdomains are to be used
< !***************************************************
<
< do i=1,maxnests
< read(unitpath,'(a)') path(numpath+2*(i-1)+1)
< read(unitpath,'(a)') path(numpath+2*(i-1)+2)
< if (path(numpath+2*(i-1)+1)(1:5).eq.'=====') goto 30
< length(numpath+2*(i-1)+1)=index(path(numpath+2*(i-1)+1),' ')-1
< length(numpath+2*(i-1)+2)=index(path(numpath+2*(i-1)+2),' ')-1
< end do
< print*,length(5),length(6)
<
<
< ! Determine number of available nested domains
< !*********************************************
<
< 30 numbnests=i-1
<
< close(unitpath)
< return
<
< 998 write(*,*) ' #### TRAJECTORY MODEL ERROR! ERROR WHILE #### '
< write(*,*) ' #### READING FILE PATHNAMES. #### '
< stop
<
< 999 write(*,*) ' #### TRAJECTORY MODEL ERROR! FILE "pathnames"#### '
< write(*,*) ' #### CANNOT BE OPENED IN THE CURRENT WORKING #### '
< write(*,*) ' #### DIRECTORY. #### '
< stop
<
< end subroutine readpaths
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readpaths
>
> !*****************************************************************************
> ! *
> ! Reads the pathnames, where input/output files are expected to be. *
> ! The file pathnames must be available in the current working directory. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 1 February 1994 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! length(numpath) lengths of the path names *
> ! path(numpath) pathnames of input/output files *
> ! *
> ! Constants: *
> ! numpath number of pathnames to be read in *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: i
>
> ! Read the pathname information stored in unitpath
> !*************************************************
>
>
> open(unitpath,file='pathnames',status='old',err=999)
>
> do i=1,numpath
> read(unitpath,'(a)',err=998) path(i)
> length(i)=index(path(i),' ')-1
> end do
>
> ! Check whether any nested subdomains are to be used
> !***************************************************
>
> do i=1,maxnests
> read(unitpath,'(a)') path(numpath+2*(i-1)+1)
> read(unitpath,'(a)') path(numpath+2*(i-1)+2)
> if (path(numpath+2*(i-1)+1)(1:5).eq.'=====') goto 30
> length(numpath+2*(i-1)+1)=index(path(numpath+2*(i-1)+1),' ')-1
> length(numpath+2*(i-1)+2)=index(path(numpath+2*(i-1)+2),' ')-1
> end do
>
>
> ! Determine number of available nested domains
> !*********************************************
>
> 30 numbnests=i-1
>
> close(unitpath)
> return
>
> 998 write(*,*) ' #### TRAJECTORY MODEL ERROR! ERROR WHILE #### '
> write(*,*) ' #### READING FILE PATHNAMES. #### '
> stop
>
> 999 write(*,*) ' #### TRAJECTORY MODEL ERROR! FILE "pathnames"#### '
> write(*,*) ' #### CANNOT BE OPENED IN THE CURRENT WORKING #### '
> write(*,*) ' #### DIRECTORY. #### '
> stop
>
> end subroutine readpaths
readreceptors.f90
----------------------------------------------
1,114c1,114
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readreceptors
<
< !*****************************************************************************
< ! *
< ! This routine reads the user specifications for the receptor points. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 1 August 1996 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! receptorarea(maxreceptor) area of dx*dy at location of receptor *
< ! receptorname(maxreceptor) names of receptors *
< ! xreceptor,yreceptor coordinates of receptor points *
< ! *
< ! Constants: *
< ! unitreceptor unit connected to file RECEPTORS *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: j
< real :: x,y,xm,ym
< character(len=16) :: receptor
<
<
< ! For backward runs, do not allow receptor output. Thus, set number of receptors to zero
< !*****************************************************************************
<
< if (ldirect.lt.0) then
< numreceptor=0
< return
< endif
<
<
< ! Open the RECEPTORS file and read output grid specifications
< !************************************************************
<
< open(unitreceptor,file=path(1)(1:length(1))//'RECEPTORS', &
< status='old',err=999)
<
< call skplin(5,unitreceptor)
<
<
< ! Read the names and coordinates of the receptors
< !************************************************
<
< j=0
< 100 j=j+1
< read(unitreceptor,*,end=99)
< read(unitreceptor,*,end=99)
< read(unitreceptor,*,end=99)
< read(unitreceptor,'(4x,a16)',end=99) receptor
< call skplin(3,unitreceptor)
< read(unitreceptor,'(4x,f11.4)',end=99) x
< call skplin(3,unitreceptor)
< read(unitreceptor,'(4x,f11.4)',end=99) y
< if ((x.eq.0.).and.(y.eq.0.).and. &
< (receptor.eq.' ')) then
< j=j-1
< goto 100
< endif
< if (j.gt.maxreceptor) then
< write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### '
< write(*,*) ' #### POINTS ARE GIVEN. #### '
< write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### '
< write(*,*) ' #### PLEASE MAKE CHANGES IN FILE RECEPTORS #### '
< endif
< receptorname(j)=receptor
< xreceptor(j)=(x-xlon0)/dx ! transform to grid coordinates
< yreceptor(j)=(y-ylat0)/dy
< xm=r_earth*cos(y*pi/180.)*dx/180.*pi
< ym=r_earth*dy/180.*pi
< receptorarea(j)=xm*ym
< goto 100
<
< 99 numreceptor=j-1
< close(unitreceptor)
< return
<
<
< 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "RECEPTORS" #### '
< write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
< write(*,'(a)') path(1)(1:length(1))
< stop
<
< end subroutine readreceptors
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readreceptors
>
> !*****************************************************************************
> ! *
> ! This routine reads the user specifications for the receptor points. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 1 August 1996 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! receptorarea(maxreceptor) area of dx*dy at location of receptor *
> ! receptorname(maxreceptor) names of receptors *
> ! xreceptor,yreceptor coordinates of receptor points *
> ! *
> ! Constants: *
> ! unitreceptor unit connected to file RECEPTORS *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: j
> real :: x,y,xm,ym
> character(len=16) :: receptor
>
>
> ! For backward runs, do not allow receptor output. Thus, set number of receptors to zero
> !*****************************************************************************
>
> if (ldirect.lt.0) then
> numreceptor=0
> return
> endif
>
>
> ! Open the RECEPTORS file and read output grid specifications
> !************************************************************
>
> open(unitreceptor,file=path(1)(1:length(1))//'RECEPTORS', &
> status='old',err=999)
>
> call skplin(5,unitreceptor)
>
>
> ! Read the names and coordinates of the receptors
> !************************************************
>
> j=0
> 100 j=j+1
> read(unitreceptor,*,end=99)
> read(unitreceptor,*,end=99)
> read(unitreceptor,*,end=99)
> read(unitreceptor,'(4x,a16)',end=99) receptor
> call skplin(3,unitreceptor)
> read(unitreceptor,'(4x,f11.4)',end=99) x
> call skplin(3,unitreceptor)
> read(unitreceptor,'(4x,f11.4)',end=99) y
> if ((x.eq.0.).and.(y.eq.0.).and. &
> (receptor.eq.' ')) then
> j=j-1
> goto 100
> endif
> if (j.gt.maxreceptor) then
> write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### '
> write(*,*) ' #### POINTS ARE GIVEN. #### '
> write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### '
> write(*,*) ' #### PLEASE MAKE CHANGES IN FILE RECEPTORS #### '
> endif
> receptorname(j)=receptor
> xreceptor(j)=(x-xlon0)/dx ! transform to grid coordinates
> yreceptor(j)=(y-ylat0)/dy
> xm=r_earth*cos(y*pi/180.)*dx/180.*pi
> ym=r_earth*dy/180.*pi
> receptorarea(j)=xm*ym
> goto 100
>
> 99 numreceptor=j-1
> close(unitreceptor)
> return
>
>
> 999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "RECEPTORS" #### '
> write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### '
> write(*,'(a)') path(1)(1:length(1))
> stop
>
> end subroutine readreceptors
readreleases.f90
----------------------------------------------
1,494c1,494
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readreleases
<
< !*****************************************************************************
< ! *
< ! This routine reads the release point specifications for the current *
< ! model run. Several release points can be used at the same time. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 18 May 1996 *
< ! *
< ! Update: 29 January 2001 *
< ! Release altitude can be either in magl or masl *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! decay decay constant of species *
< ! dquer [um] mean particle diameters *
< ! dsigma e.g. dsigma=10 or dsigma=0.1 means that 68% of the mass*
< ! are between 0.1*dquer and 10*dquer *
< ! ireleasestart, ireleaseend [s] starting time and ending time of each *
< ! release *
< ! kindz 1: zpoint is in m agl, 2: zpoint is in m asl, 3: zpoint*
< ! is in hPa *
< ! npart number of particles to be released *
< ! nspec number of species to be released *
< ! density [kg/m3] density of the particles *
< ! rm [s/m] Mesophyll resistance *
< ! species name of species *
< ! xmass total mass of each species *
< ! xpoint1,ypoint1 geograf. coordinates of lower left corner of release *
< ! area *
< ! xpoint2,ypoint2 geograf. coordinates of upper right corner of release *
< ! area *
< ! weta, wetb parameters to determine the wet scavenging coefficient *
< ! zpoint1,zpoint2 height range, over which release takes place *
< ! *
< !*****************************************************************************
<
< use point_mod
< use xmass_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: numpartmax,i,j,id1,it1,id2,it2,specnum_rel,idum,stat
< real :: vsh(ni),fracth(ni),schmih(ni),releaserate,xdum,cun
< real(kind=dp) :: jul1,jul2,juldate
< character(len=50) :: line
< logical :: old
<
< !sec, read release to find how many releasepoints should be allocated
<
< open(unitreleases,file=path(1)(1:length(1))//'RELEASES',status='old', &
< err=999)
<
< ! Check the format of the RELEASES file (either in free format,
< ! or using a formatted mask)
< ! Use of formatted mask is assumed if line 10 contains the word 'DIRECTION'
< !**************************************************************************
<
< call skplin(12,unitreleases)
< read (unitreleases,901) line
< 901 format (a)
< if (index(line,'Total') .eq. 0) then
< old = .false.
< else
< old = .true.
< endif
< rewind(unitreleases)
<
<
< ! Skip first 11 lines (file header)
< !**********************************
<
< call skplin(11,unitreleases)
<
<
< read(unitreleases,*,err=998) nspec
< if (old) call skplin(2,unitreleases)
< do i=1,nspec
< read(unitreleases,*,err=998) specnum_rel
< if (old) call skplin(2,unitreleases)
< end do
<
< numpoint=0
< 100 numpoint=numpoint+1
< read(unitreleases,*,end=25)
< read(unitreleases,*,err=998,end=25) idum,idum
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) idum,idum
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) xdum
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) xdum
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) xdum
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) xdum
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) idum
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) xdum
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) xdum
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) idum
< if (old) call skplin(2,unitreleases)
< do i=1,nspec
< read(unitreleases,*,err=998) xdum
< if (old) call skplin(2,unitreleases)
< end do
< !save compoint only for the first 1000 release points
< read(unitreleases,'(a40)',err=998) compoint(1)(1:40)
< if (old) call skplin(1,unitreleases)
<
< goto 100
<
< 25 numpoint=numpoint-1
<
< !allocate memory for numpoint releaspoint
< allocate(ireleasestart(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(ireleaseend(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(xpoint1(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(xpoint2(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(ypoint1(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(ypoint2(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(zpoint1(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(zpoint2(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(kindz(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(xmass(numpoint,maxspec) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(rho_rel(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(npart(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
< allocate(xmasssave(numpoint) &
< ,stat=stat)
< if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
<
< write (*,*) ' Releasepoints allocated: ', numpoint
<
< do i=1,numpoint
< xmasssave(i)=0.
< end do
<
< !now save the information
< DEP=.false.
< DRYDEP=.false.
< WETDEP=.false.
< OHREA=.false.
< do i=1,maxspec
< DRYDEPSPEC(i)=.false.
< end do
<
< rewind(unitreleases)
<
<
< ! Skip first 11 lines (file header)
< !**********************************
<
< call skplin(11,unitreleases)
<
<
< ! Assign species-specific parameters needed for physical processes
< !*************************************************************************
<
< read(unitreleases,*,err=998) nspec
< if (nspec.gt.maxspec) goto 994
< if (old) call skplin(2,unitreleases)
< do i=1,nspec
< read(unitreleases,*,err=998) specnum_rel
< if (old) call skplin(2,unitreleases)
< call readspecies(specnum_rel,i)
<
< ! For backward runs, only 1 species is allowed
< !*********************************************
<
< !if ((ldirect.lt.0).and.(nspec.gt.1)) then
< !write(*,*) '#####################################################'
< !write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
< !write(*,*) '#### FOR BACKWARD RUNS, ONLY 1 SPECIES IS ALLOWED####'
< !write(*,*) '#####################################################'
< ! stop
< !endif
<
< ! Molecular weight
< !*****************
<
< if (((iout.eq.2).or.(iout.eq.3)).and. &
< (weightmolar(i).lt.0.)) then
< write(*,*) 'For mixing ratio output, valid molar weight'
< write(*,*) 'must be specified for all simulated species.'
< write(*,*) 'Check table SPECIES or choose concentration'
< write(*,*) 'output instead if molar weight is not known.'
< stop
< endif
<
<
< ! Radioactive decay
< !******************
<
< decay(i)=0.693147/decay(i) !conversion half life to decay constant
<
<
< ! Dry deposition of gases
< !************************
<
< if (reldiff(i).gt.0.) &
< rm(i)=1./(henry(i)/3000.+100.*f0(i)) ! mesophyll resistance
<
< ! Dry deposition of particles
< !****************************
<
< vsetaver(i)=0.
< cunningham(i)=0.
< dquer(i)=dquer(i)*1000000. ! Conversion m to um
< if (density(i).gt.0.) then ! Additional parameters
< call part0(dquer(i),dsigma(i),density(i),fracth,schmih,cun,vsh)
< do j=1,ni
< fract(i,j)=fracth(j)
< schmi(i,j)=schmih(j)
< vset(i,j)=vsh(j)
< cunningham(i)=cunningham(i)+cun*fract(i,j)
< vsetaver(i)=vsetaver(i)-vset(i,j)*fract(i,j)
< end do
< write(*,*) 'Average setting velocity: ',i,vsetaver(i)
< endif
<
< ! Dry deposition for constant deposition velocity
< !************************************************
<
< dryvel(i)=dryvel(i)*0.01 ! conversion to m/s
<
< ! Check if wet deposition or OH reaction shall be calculated
< !***********************************************************
< if (weta(i).gt.0.) then
< WETDEP=.true.
< write (*,*) 'Wetdeposition switched on: ',weta(i),i
< endif
< if (ohreact(i).gt.0) then
< OHREA=.true.
< write (*,*) 'OHreaction switched on: ',ohreact(i),i
< endif
<
<
< if ((reldiff(i).gt.0.).or.(density(i).gt.0.).or. &
< (dryvel(i).gt.0.)) then
< DRYDEP=.true.
< DRYDEPSPEC(i)=.true.
< endif
<
< end do
<
< if (WETDEP.or.DRYDEP) DEP=.true.
<
< ! Read specifications for each release point
< !*******************************************
<
< numpoint=0
< numpartmax=0
< releaserate=0.
< 1000 numpoint=numpoint+1
< read(unitreleases,*,end=250)
< read(unitreleases,*,err=998,end=250) id1,it1
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) id2,it2
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) xpoint1(numpoint)
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) ypoint1(numpoint)
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) xpoint2(numpoint)
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) ypoint2(numpoint)
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) kindz(numpoint)
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) zpoint1(numpoint)
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) zpoint2(numpoint)
< if (old) call skplin(2,unitreleases)
< read(unitreleases,*,err=998) npart(numpoint)
< if (old) call skplin(2,unitreleases)
< do i=1,nspec
< read(unitreleases,*,err=998) xmass(numpoint,i)
< if (old) call skplin(2,unitreleases)
< end do
< !save compoint only for the first 1000 release points
< if (numpoint.le.1000) then
< read(unitreleases,'(a40)',err=998) compoint(numpoint)(1:40)
< else
< read(unitreleases,'(a40)',err=998) compoint(1001)(1:40)
< endif
< if (old) call skplin(1,unitreleases)
< if (numpoint.le.1000) then
< if((xpoint1(numpoint).eq.0.).and.(ypoint1(numpoint).eq.0.).and. &
< (xpoint2(numpoint).eq.0.).and.(ypoint2(numpoint).eq.0.).and. &
< (compoint(numpoint)(1:8).eq.' ')) goto 250
< else
< if((xpoint1(numpoint).eq.0.).and.(ypoint1(numpoint).eq.0.).and. &
< (xpoint2(numpoint).eq.0.).and.(ypoint2(numpoint).eq.0.)) goto 250
< endif
<
<
< ! If a release point contains no particles, stop and issue error message
< !***********************************************************************
<
< if (npart(numpoint).eq.0) then
< write(*,*) 'FLEXPART MODEL ERROR'
< write(*,*) 'RELEASES file is corrupt.'
< write(*,*) 'At least for one release point, there are zero'
< write(*,*) 'particles released. Make changes to RELEASES.'
< stop
< endif
<
< ! Check whether x coordinates of release point are within model domain
< !*********************************************************************
<
< if (xpoint1(numpoint).lt.xlon0) &
< xpoint1(numpoint)=xpoint1(numpoint)+360.
< if (xpoint1(numpoint).gt.xlon0+(nxmin1)*dx) &
< xpoint1(numpoint)=xpoint1(numpoint)-360.
< if (xpoint2(numpoint).lt.xlon0) &
< xpoint2(numpoint)=xpoint2(numpoint)+360.
< if (xpoint2(numpoint).gt.xlon0+(nxmin1)*dx) &
< xpoint2(numpoint)=xpoint2(numpoint)-360.
<
< ! Determine relative beginning and ending times of particle release
< !******************************************************************
<
< jul1=juldate(id1,it1)
< jul2=juldate(id2,it2)
< if (jul1.gt.jul2) then
< write(*,*) 'FLEXPART MODEL ERROR'
< write(*,*) 'Release stops before it begins.'
< write(*,*) 'Make changes to file RELEASES.'
< stop
< endif
< if (mdomainfill.eq.0) then ! no domain filling
< if (ldirect.eq.1) then
< if ((jul1.lt.bdate).or.(jul2.gt.edate)) then
< write(*,*) 'FLEXPART MODEL ERROR'
< write(*,*) 'Release starts before simulation begins or ends'
< write(*,*) 'after simulation stops.'
< write(*,*) 'Make files COMMAND and RELEASES consistent.'
< stop
< endif
< ireleasestart(numpoint)=int((jul1-bdate)*86400.)
< ireleaseend(numpoint)=int((jul2-bdate)*86400.)
< else if (ldirect.eq.-1) then
< if ((jul1.lt.edate).or.(jul2.gt.bdate)) then
< write(*,*) 'FLEXPART MODEL ERROR'
< write(*,*) 'Release starts before simulation begins or ends'
< write(*,*) 'after simulation stops.'
< write(*,*) 'Make files COMMAND and RELEASES consistent.'
< stop
< endif
< ireleasestart(numpoint)=int((jul1-bdate)*86400.)
< ireleaseend(numpoint)=int((jul2-bdate)*86400.)
< endif
< endif
<
<
< ! Check, whether the total number of particles may exceed totally allowed
< ! number of particles at some time during the simulation
< !************************************************************************
<
< ! Determine the release rate (particles per second) and total number
< ! of particles released during the simulation
< !*******************************************************************
<
< if (ireleasestart(numpoint).ne.ireleaseend(numpoint)) then
< releaserate=releaserate+real(npart(numpoint))/ &
< real(ireleaseend(numpoint)-ireleasestart(numpoint))
< else
< releaserate=99999999
< endif
< numpartmax=numpartmax+npart(numpoint)
< goto 1000
<
<
< 250 close(unitreleases)
<
< write (*,*) ' Particles allocated for this run: ',maxpart, ', released in simulation: ', numpartmax
< numpoint=numpoint-1
<
< if (ioutputforeachrelease.eq.1) then
< maxpointspec_act=numpoint
< else
< maxpointspec_act=1
< endif
<
< if (releaserate.gt. &
< 0.99*real(maxpart)/real(lage(nageclass))) then
< if (numpartmax.gt.maxpart) then
< write(*,*) '#####################################################'
< write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
< write(*,*) '#### ####'
< write(*,*) '####WARNING - TOTAL NUMBER OF PARTICLES SPECIFIED####'
< write(*,*) '#### IN FILE "RELEASES" MAY AT SOME POINT DURING ####'
< write(*,*) '#### THE SIMULATION EXCEED THE MAXIMUM ALLOWED ####'
< write(*,*) '#### NUMBER (MAXPART).IF RELEASES DO NOT OVERLAP,####'
< write(*,*) '#### FLEXPART CAN POSSIBLY COMPLETE SUCCESSFULLY.####'
< write(*,*) '#### HOWEVER, FLEXPART MAY HAVE TO STOP ####'
< write(*,*) '#### AT SOME TIME DURING THE SIMULATION. PLEASE ####'
< write(*,*) '#### MAKE SURE THAT YOUR SETTINGS ARE CORRECT. ####'
< write(*,*) '#####################################################'
< write(*,*) 'Maximum release rate may be: ',releaserate, &
< ' particles per second'
< write(*,*) 'Maximum allowed release rate is: ', &
< real(maxpart)/real(lage(nageclass)),' particles per second'
< write(*,*) &
< 'Total number of particles released during the simulation is: ', &
< numpartmax
< write(*,*) 'Maximum allowed number of particles is: ',maxpart
< endif
< endif
<
< return
<
< 994 write(*,*) '#####################################################'
< write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
< write(*,*) '#### ####'
< write(*,*) '#### ERROR - MAXIMUM NUMBER OF EMITTED SPECIES IS####'
< write(*,*) '#### TOO LARGE. PLEASE REDUCE NUMBER OF SPECIES. ####'
< write(*,*) '#####################################################'
< stop
<
< 998 write(*,*) '#####################################################'
< write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
< write(*,*) '#### ####'
< write(*,*) '#### FATAL ERROR - FILE "RELEASES" IS ####'
< write(*,*) '#### CORRUPT. PLEASE CHECK YOUR INPUTS FOR ####'
< write(*,*) '#### MISTAKES OR GET A NEW "RELEASES"- ####'
< write(*,*) '#### FILE ... ####'
< write(*,*) '#####################################################'
< stop
<
<
< 999 write(*,*) '#####################################################'
< write(*,*) ' FLEXPART MODEL SUBROUTINE READRELEASES: '
< write(*,*)
< write(*,*) 'FATAL ERROR - FILE CONTAINING PARTICLE RELEASE POINTS'
< write(*,*) 'POINTS IS NOT AVAILABLE OR YOU ARE NOT'
< write(*,*) 'PERMITTED FOR ANY ACCESS'
< write(*,*) '#####################################################'
< stop
<
< end subroutine readreleases
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readreleases
>
> !*****************************************************************************
> ! *
> ! This routine reads the release point specifications for the current *
> ! model run. Several release points can be used at the same time. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 18 May 1996 *
> ! *
> ! Update: 29 January 2001 *
> ! Release altitude can be either in magl or masl *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! decay decay constant of species *
> ! dquer [um] mean particle diameters *
> ! dsigma e.g. dsigma=10 or dsigma=0.1 means that 68% of the mass*
> ! are between 0.1*dquer and 10*dquer *
> ! ireleasestart, ireleaseend [s] starting time and ending time of each *
> ! release *
> ! kindz 1: zpoint is in m agl, 2: zpoint is in m asl, 3: zpoint*
> ! is in hPa *
> ! npart number of particles to be released *
> ! nspec number of species to be released *
> ! density [kg/m3] density of the particles *
> ! rm [s/m] Mesophyll resistance *
> ! species name of species *
> ! xmass total mass of each species *
> ! xpoint1,ypoint1 geograf. coordinates of lower left corner of release *
> ! area *
> ! xpoint2,ypoint2 geograf. coordinates of upper right corner of release *
> ! area *
> ! weta, wetb parameters to determine the wet scavenging coefficient *
> ! zpoint1,zpoint2 height range, over which release takes place *
> ! *
> !*****************************************************************************
>
> use point_mod
> use xmass_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: numpartmax,i,j,id1,it1,id2,it2,specnum_rel,idum,stat
> real :: vsh(ni),fracth(ni),schmih(ni),releaserate,xdum,cun
> real(kind=dp) :: jul1,jul2,juldate
> character(len=50) :: line
> logical :: old
>
> !sec, read release to find how many releasepoints should be allocated
>
> open(unitreleases,file=path(1)(1:length(1))//'RELEASES',status='old', &
> err=999)
>
> ! Check the format of the RELEASES file (either in free format,
> ! or using a formatted mask)
> ! Use of formatted mask is assumed if line 10 contains the word 'DIRECTION'
> !**************************************************************************
>
> call skplin(12,unitreleases)
> read (unitreleases,901) line
> 901 format (a)
> if (index(line,'Total') .eq. 0) then
> old = .false.
> else
> old = .true.
> endif
> rewind(unitreleases)
>
>
> ! Skip first 11 lines (file header)
> !**********************************
>
> call skplin(11,unitreleases)
>
>
> read(unitreleases,*,err=998) nspec
> if (old) call skplin(2,unitreleases)
> do i=1,nspec
> read(unitreleases,*,err=998) specnum_rel
> if (old) call skplin(2,unitreleases)
> end do
>
> numpoint=0
> 100 numpoint=numpoint+1
> read(unitreleases,*,end=25)
> read(unitreleases,*,err=998,end=25) idum,idum
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) idum,idum
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) xdum
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) xdum
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) xdum
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) xdum
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) idum
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) xdum
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) xdum
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) idum
> if (old) call skplin(2,unitreleases)
> do i=1,nspec
> read(unitreleases,*,err=998) xdum
> if (old) call skplin(2,unitreleases)
> end do
> !save compoint only for the first 1000 release points
> read(unitreleases,'(a40)',err=998) compoint(1)(1:40)
> if (old) call skplin(1,unitreleases)
>
> goto 100
>
> 25 numpoint=numpoint-1
>
> !allocate memory for numpoint releaspoint
> allocate(ireleasestart(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(ireleaseend(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(xpoint1(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(xpoint2(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(ypoint1(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(ypoint2(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(zpoint1(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(zpoint2(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(kindz(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(xmass(numpoint,maxspec) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(rho_rel(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(npart(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
> allocate(xmasssave(numpoint) &
> ,stat=stat)
> if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT'
>
> write (*,*) ' Releasepoints allocated: ', numpoint
>
> do i=1,numpoint
> xmasssave(i)=0.
> end do
>
> !now save the information
> DEP=.false.
> DRYDEP=.false.
> WETDEP=.false.
> OHREA=.false.
> do i=1,maxspec
> DRYDEPSPEC(i)=.false.
> end do
>
> rewind(unitreleases)
>
>
> ! Skip first 11 lines (file header)
> !**********************************
>
> call skplin(11,unitreleases)
>
>
> ! Assign species-specific parameters needed for physical processes
> !*************************************************************************
>
> read(unitreleases,*,err=998) nspec
> if (nspec.gt.maxspec) goto 994
> if (old) call skplin(2,unitreleases)
> do i=1,nspec
> read(unitreleases,*,err=998) specnum_rel
> if (old) call skplin(2,unitreleases)
> call readspecies(specnum_rel,i)
>
> ! For backward runs, only 1 species is allowed
> !*********************************************
>
> !if ((ldirect.lt.0).and.(nspec.gt.1)) then
> !write(*,*) '#####################################################'
> !write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
> !write(*,*) '#### FOR BACKWARD RUNS, ONLY 1 SPECIES IS ALLOWED####'
> !write(*,*) '#####################################################'
> ! stop
> !endif
>
> ! Molecular weight
> !*****************
>
> if (((iout.eq.2).or.(iout.eq.3)).and. &
> (weightmolar(i).lt.0.)) then
> write(*,*) 'For mixing ratio output, valid molar weight'
> write(*,*) 'must be specified for all simulated species.'
> write(*,*) 'Check table SPECIES or choose concentration'
> write(*,*) 'output instead if molar weight is not known.'
> stop
> endif
>
>
> ! Radioactive decay
> !******************
>
> decay(i)=0.693147/decay(i) !conversion half life to decay constant
>
>
> ! Dry deposition of gases
> !************************
>
> if (reldiff(i).gt.0.) &
> rm(i)=1./(henry(i)/3000.+100.*f0(i)) ! mesophyll resistance
>
> ! Dry deposition of particles
> !****************************
>
> vsetaver(i)=0.
> cunningham(i)=0.
> dquer(i)=dquer(i)*1000000. ! Conversion m to um
> if (density(i).gt.0.) then ! Additional parameters
> call part0(dquer(i),dsigma(i),density(i),fracth,schmih,cun,vsh)
> do j=1,ni
> fract(i,j)=fracth(j)
> schmi(i,j)=schmih(j)
> vset(i,j)=vsh(j)
> cunningham(i)=cunningham(i)+cun*fract(i,j)
> vsetaver(i)=vsetaver(i)-vset(i,j)*fract(i,j)
> end do
> write(*,*) 'Average setting velocity: ',i,vsetaver(i)
> endif
>
> ! Dry deposition for constant deposition velocity
> !************************************************
>
> dryvel(i)=dryvel(i)*0.01 ! conversion to m/s
>
> ! Check if wet deposition or OH reaction shall be calculated
> !***********************************************************
> if (weta(i).gt.0.) then
> WETDEP=.true.
> write (*,*) 'Wetdeposition switched on: ',weta(i),i
> endif
> if (ohreact(i).gt.0) then
> OHREA=.true.
> write (*,*) 'OHreaction switched on: ',ohreact(i),i
> endif
>
>
> if ((reldiff(i).gt.0.).or.(density(i).gt.0.).or. &
> (dryvel(i).gt.0.)) then
> DRYDEP=.true.
> DRYDEPSPEC(i)=.true.
> endif
>
> end do
>
> if (WETDEP.or.DRYDEP) DEP=.true.
>
> ! Read specifications for each release point
> !*******************************************
>
> numpoint=0
> numpartmax=0
> releaserate=0.
> 1000 numpoint=numpoint+1
> read(unitreleases,*,end=250)
> read(unitreleases,*,err=998,end=250) id1,it1
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) id2,it2
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) xpoint1(numpoint)
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) ypoint1(numpoint)
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) xpoint2(numpoint)
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) ypoint2(numpoint)
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) kindz(numpoint)
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) zpoint1(numpoint)
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) zpoint2(numpoint)
> if (old) call skplin(2,unitreleases)
> read(unitreleases,*,err=998) npart(numpoint)
> if (old) call skplin(2,unitreleases)
> do i=1,nspec
> read(unitreleases,*,err=998) xmass(numpoint,i)
> if (old) call skplin(2,unitreleases)
> end do
> !save compoint only for the first 1000 release points
> if (numpoint.le.1000) then
> read(unitreleases,'(a40)',err=998) compoint(numpoint)(1:40)
> else
> read(unitreleases,'(a40)',err=998) compoint(1001)(1:40)
> endif
> if (old) call skplin(1,unitreleases)
> if (numpoint.le.1000) then
> if((xpoint1(numpoint).eq.0.).and.(ypoint1(numpoint).eq.0.).and. &
> (xpoint2(numpoint).eq.0.).and.(ypoint2(numpoint).eq.0.).and. &
> (compoint(numpoint)(1:8).eq.' ')) goto 250
> else
> if((xpoint1(numpoint).eq.0.).and.(ypoint1(numpoint).eq.0.).and. &
> (xpoint2(numpoint).eq.0.).and.(ypoint2(numpoint).eq.0.)) goto 250
> endif
>
>
> ! If a release point contains no particles, stop and issue error message
> !***********************************************************************
>
> if (npart(numpoint).eq.0) then
> write(*,*) 'FLEXPART MODEL ERROR'
> write(*,*) 'RELEASES file is corrupt.'
> write(*,*) 'At least for one release point, there are zero'
> write(*,*) 'particles released. Make changes to RELEASES.'
> stop
> endif
>
> ! Check whether x coordinates of release point are within model domain
> !*********************************************************************
>
> if (xpoint1(numpoint).lt.xlon0) &
> xpoint1(numpoint)=xpoint1(numpoint)+360.
> if (xpoint1(numpoint).gt.xlon0+(nxmin1)*dx) &
> xpoint1(numpoint)=xpoint1(numpoint)-360.
> if (xpoint2(numpoint).lt.xlon0) &
> xpoint2(numpoint)=xpoint2(numpoint)+360.
> if (xpoint2(numpoint).gt.xlon0+(nxmin1)*dx) &
> xpoint2(numpoint)=xpoint2(numpoint)-360.
>
> ! Determine relative beginning and ending times of particle release
> !******************************************************************
>
> jul1=juldate(id1,it1)
> jul2=juldate(id2,it2)
> if (jul1.gt.jul2) then
> write(*,*) 'FLEXPART MODEL ERROR'
> write(*,*) 'Release stops before it begins.'
> write(*,*) 'Make changes to file RELEASES.'
> stop
> endif
> if (mdomainfill.eq.0) then ! no domain filling
> if (ldirect.eq.1) then
> if ((jul1.lt.bdate).or.(jul2.gt.edate)) then
> write(*,*) 'FLEXPART MODEL ERROR'
> write(*,*) 'Release starts before simulation begins or ends'
> write(*,*) 'after simulation stops.'
> write(*,*) 'Make files COMMAND and RELEASES consistent.'
> stop
> endif
> ireleasestart(numpoint)=int((jul1-bdate)*86400.)
> ireleaseend(numpoint)=int((jul2-bdate)*86400.)
> else if (ldirect.eq.-1) then
> if ((jul1.lt.edate).or.(jul2.gt.bdate)) then
> write(*,*) 'FLEXPART MODEL ERROR'
> write(*,*) 'Release starts before simulation begins or ends'
> write(*,*) 'after simulation stops.'
> write(*,*) 'Make files COMMAND and RELEASES consistent.'
> stop
> endif
> ireleasestart(numpoint)=int((jul1-bdate)*86400.)
> ireleaseend(numpoint)=int((jul2-bdate)*86400.)
> endif
> endif
>
>
> ! Check, whether the total number of particles may exceed totally allowed
> ! number of particles at some time during the simulation
> !************************************************************************
>
> ! Determine the release rate (particles per second) and total number
> ! of particles released during the simulation
> !*******************************************************************
>
> if (ireleasestart(numpoint).ne.ireleaseend(numpoint)) then
> releaserate=releaserate+real(npart(numpoint))/ &
> real(ireleaseend(numpoint)-ireleasestart(numpoint))
> else
> releaserate=99999999
> endif
> numpartmax=numpartmax+npart(numpoint)
> goto 1000
>
>
> 250 close(unitreleases)
>
> write (*,*) ' Particles allocated for this run: ',maxpart, ', released in simulation: ', numpartmax
> numpoint=numpoint-1
>
> if (ioutputforeachrelease.eq.1) then
> maxpointspec_act=numpoint
> else
> maxpointspec_act=1
> endif
>
> if (releaserate.gt. &
> 0.99*real(maxpart)/real(lage(nageclass))) then
> if (numpartmax.gt.maxpart) then
> write(*,*) '#####################################################'
> write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
> write(*,*) '#### ####'
> write(*,*) '####WARNING - TOTAL NUMBER OF PARTICLES SPECIFIED####'
> write(*,*) '#### IN FILE "RELEASES" MAY AT SOME POINT DURING ####'
> write(*,*) '#### THE SIMULATION EXCEED THE MAXIMUM ALLOWED ####'
> write(*,*) '#### NUMBER (MAXPART).IF RELEASES DO NOT OVERLAP,####'
> write(*,*) '#### FLEXPART CAN POSSIBLY COMPLETE SUCCESSFULLY.####'
> write(*,*) '#### HOWEVER, FLEXPART MAY HAVE TO STOP ####'
> write(*,*) '#### AT SOME TIME DURING THE SIMULATION. PLEASE ####'
> write(*,*) '#### MAKE SURE THAT YOUR SETTINGS ARE CORRECT. ####'
> write(*,*) '#####################################################'
> write(*,*) 'Maximum release rate may be: ',releaserate, &
> ' particles per second'
> write(*,*) 'Maximum allowed release rate is: ', &
> real(maxpart)/real(lage(nageclass)),' particles per second'
> write(*,*) &
> 'Total number of particles released during the simulation is: ', &
> numpartmax
> write(*,*) 'Maximum allowed number of particles is: ',maxpart
> endif
> endif
>
> return
>
> 994 write(*,*) '#####################################################'
> write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
> write(*,*) '#### ####'
> write(*,*) '#### ERROR - MAXIMUM NUMBER OF EMITTED SPECIES IS####'
> write(*,*) '#### TOO LARGE. PLEASE REDUCE NUMBER OF SPECIES. ####'
> write(*,*) '#####################################################'
> stop
>
> 998 write(*,*) '#####################################################'
> write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####'
> write(*,*) '#### ####'
> write(*,*) '#### FATAL ERROR - FILE "RELEASES" IS ####'
> write(*,*) '#### CORRUPT. PLEASE CHECK YOUR INPUTS FOR ####'
> write(*,*) '#### MISTAKES OR GET A NEW "RELEASES"- ####'
> write(*,*) '#### FILE ... ####'
> write(*,*) '#####################################################'
> stop
>
>
> 999 write(*,*) '#####################################################'
> write(*,*) ' FLEXPART MODEL SUBROUTINE READRELEASES: '
> write(*,*)
> write(*,*) 'FATAL ERROR - FILE CONTAINING PARTICLE RELEASE POINTS'
> write(*,*) 'POINTS IS NOT AVAILABLE OR YOU ARE NOT'
> write(*,*) 'PERMITTED FOR ANY ACCESS'
> write(*,*) '#####################################################'
> stop
>
> end subroutine readreleases
readspecies.f90
----------------------------------------------
1,188c1,188
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readspecies(id_spec,pos_spec)
<
< !*****************************************************************************
< ! *
< ! This routine reads names and physical constants of chemical species/ *
< ! radionuclides given in the parameter pos_spec *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 11 July 1996 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! decaytime(maxtable) half time for radiological decay *
< ! specname(maxtable) names of chemical species, radionuclides *
< ! wetscava, wetscavb Parameters for determining scavenging coefficient *
< ! ohreact OH reaction rate *
< ! id_spec SPECIES number as referenced in RELEASE file *
< ! id_pos position where SPECIES data shall be stored *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: i, pos_spec,j
< integer :: idow,ihour,id_spec
< character(len=3) :: aspecnumb
< logical :: spec_found
<
< ! Open the SPECIES file and read species names and properties
< !************************************************************
< specnum(pos_spec)=id_spec
< write(aspecnumb,'(i3.3)') specnum(pos_spec)
< open(unitspecies,file= &
< path(1)(1:length(1))//'SPECIES/SPECIES_'//aspecnumb,status='old', &
< err=998)
< !write(*,*) 'reading SPECIES',specnum(pos_spec)
<
< ASSSPEC=.FALSE.
<
< do i=1,6
< read(unitspecies,*)
< end do
<
< read(unitspecies,'(a10)',end=22) species(pos_spec)
< ! write(*,*) species(pos_spec)
< read(unitspecies,'(f18.1)',end=22) decay(pos_spec)
< ! write(*,*) decay(pos_spec)
< read(unitspecies,'(e18.1)',end=22) weta(pos_spec)
< ! write(*,*) weta(pos_spec)
< read(unitspecies,'(f18.2)',end=22) wetb(pos_spec)
< ! write(*,*) wetb(pos_spec)
< read(unitspecies,'(f18.1)',end=22) reldiff(pos_spec)
< ! write(*,*) reldiff(pos_spec)
< read(unitspecies,'(e18.1)',end=22) henry(pos_spec)
< ! write(*,*) henry(pos_spec)
< read(unitspecies,'(f18.1)',end=22) f0(pos_spec)
< ! write(*,*) f0(pos_spec)
< read(unitspecies,'(e18.1)',end=22) density(pos_spec)
< ! write(*,*) density(pos_spec)
< read(unitspecies,'(e18.1)',end=22) dquer(pos_spec)
< ! write(*,*) dquer(pos_spec)
< read(unitspecies,'(e18.1)',end=22) dsigma(pos_spec)
< ! write(*,*) dsigma(pos_spec)
< read(unitspecies,'(f18.2)',end=22) dryvel(pos_spec)
< ! write(*,*) dryvel(pos_spec)
< read(unitspecies,'(f18.2)',end=22) weightmolar(pos_spec)
< ! write(*,*) weightmolar(pos_spec)
< read(unitspecies,'(e18.1)',end=22) ohreact(pos_spec)
< ! write(*,*) ohreact(pos_spec)
< read(unitspecies,'(i18)',end=22) spec_ass(pos_spec)
< ! write(*,*) spec_ass(pos_spec)
< read(unitspecies,'(f18.2)',end=22) kao(pos_spec)
< ! write(*,*) kao(pos_spec)
< i=pos_spec
<
< if ((weta(pos_spec).gt.0).and.(henry(pos_spec).le.0)) then
< if (dquer(pos_spec).le.0) goto 996 ! no particle, no henry set
< endif
<
< if (spec_ass(pos_spec).gt.0) then
< spec_found=.FALSE.
< do j=1,pos_spec-1
< if (spec_ass(pos_spec).eq.specnum(j)) then
< spec_ass(pos_spec)=j
< spec_found=.TRUE.
< ASSSPEC=.TRUE.
< endif
< end do
< if (spec_found.eqv..FALSE.) then
< goto 997
< endif
< endif
<
< if (dsigma(i).eq.1.) dsigma(i)=1.0001 ! avoid floating exception
< if (dsigma(i).eq.0.) dsigma(i)=1.0001 ! avoid floating exception
<
< if ((reldiff(i).gt.0.).and.(density(i).gt.0.)) then
< write(*,*) '#### FLEXPART MODEL ERROR! FILE "SPECIES" ####'
< write(*,*) '#### IS CORRUPT. SPECIES CANNOT BE BOTH ####'
< write(*,*) '#### PARTICLE AND GAS. ####'
< write(*,*) '#### SPECIES NUMBER',aspecnumb
< stop
< endif
< 20 continue
<
<
< ! Read in daily and day-of-week variation of emissions, if available
< !*******************************************************************
<
< do j=1,24 ! initialize everything to no variation
< area_hour(i,j)=1.
< point_hour(i,j)=1.
< end do
< do j=1,7
< area_dow(i,j)=1.
< point_dow(i,j)=1.
< end do
<
< read(unitspecies,*,end=22)
< do j=1,24 ! 24 hours, starting with 0-1 local time
< read(unitspecies,*) ihour,area_hour(i,j),point_hour(i,j)
< end do
< read(unitspecies,*)
< do j=1,7 ! 7 days of the week, starting with Monday
< read(unitspecies,*) idow,area_dow(i,j),point_dow(i,j)
< end do
<
< 22 close(unitspecies)
<
< return
<
< 996 write(*,*) '#####################################################'
< write(*,*) '#### FLEXPART MODEL ERROR! #### '
< write(*,*) '#### WET DEPOSITION SWITCHED ON, BUT NO HENRYS #### '
< write(*,*) '#### CONSTANT IS SET ####'
< write(*,*) '#### PLEASE MODIFY SPECIES DESCR. FILE! #### '
< write(*,*) '#####################################################'
< stop
<
<
< 997 write(*,*) '#####################################################'
< write(*,*) '#### FLEXPART MODEL ERROR! #### '
< write(*,*) '#### THE ASSSOCIATED SPECIES HAS TO BE DEFINED #### '
< write(*,*) '#### BEFORE THE ONE WHICH POINTS AT IT #### '
< write(*,*) '#### PLEASE CHANGE ORDER IN RELEASES OR ADD #### '
< write(*,*) '#### THE ASSOCIATED SPECIES IN RELEASES #### '
< write(*,*) '#####################################################'
< stop
<
<
< 998 write(*,*) '#####################################################'
< write(*,*) '#### FLEXPART MODEL ERROR! #### '
< write(*,*) '#### THE SPECIES FILE FOR SPECIES ', id_spec
< write(*,*) '#### CANNOT BE FOUND: CREATE FILE'
< write(*,*) '#### ',path(1)(1:length(1)),'SPECIES/SPECIES_',aspecnumb
< write(*,*) '#####################################################'
< stop
<
<
< end subroutine readspecies
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readspecies(id_spec,pos_spec)
>
> !*****************************************************************************
> ! *
> ! This routine reads names and physical constants of chemical species/ *
> ! radionuclides given in the parameter pos_spec *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 11 July 1996 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! decaytime(maxtable) half time for radiological decay *
> ! specname(maxtable) names of chemical species, radionuclides *
> ! wetscava, wetscavb Parameters for determining scavenging coefficient *
> ! ohreact OH reaction rate *
> ! id_spec SPECIES number as referenced in RELEASE file *
> ! id_pos position where SPECIES data shall be stored *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: i, pos_spec,j
> integer :: idow,ihour,id_spec
> character(len=3) :: aspecnumb
> logical :: spec_found
>
> ! Open the SPECIES file and read species names and properties
> !************************************************************
> specnum(pos_spec)=id_spec
> write(aspecnumb,'(i3.3)') specnum(pos_spec)
> open(unitspecies,file= &
> path(1)(1:length(1))//'SPECIES/SPECIES_'//aspecnumb,status='old', &
> err=998)
> !write(*,*) 'reading SPECIES',specnum(pos_spec)
>
> ASSSPEC=.FALSE.
>
> do i=1,6
> read(unitspecies,*)
> end do
>
> read(unitspecies,'(a10)',end=22) species(pos_spec)
> ! write(*,*) species(pos_spec)
> read(unitspecies,'(f18.1)',end=22) decay(pos_spec)
> ! write(*,*) decay(pos_spec)
> read(unitspecies,'(e18.1)',end=22) weta(pos_spec)
> ! write(*,*) weta(pos_spec)
> read(unitspecies,'(f18.2)',end=22) wetb(pos_spec)
> ! write(*,*) wetb(pos_spec)
> read(unitspecies,'(f18.1)',end=22) reldiff(pos_spec)
> ! write(*,*) reldiff(pos_spec)
> read(unitspecies,'(e18.1)',end=22) henry(pos_spec)
> ! write(*,*) henry(pos_spec)
> read(unitspecies,'(f18.1)',end=22) f0(pos_spec)
> ! write(*,*) f0(pos_spec)
> read(unitspecies,'(e18.1)',end=22) density(pos_spec)
> ! write(*,*) density(pos_spec)
> read(unitspecies,'(e18.1)',end=22) dquer(pos_spec)
> ! write(*,*) dquer(pos_spec)
> read(unitspecies,'(e18.1)',end=22) dsigma(pos_spec)
> ! write(*,*) dsigma(pos_spec)
> read(unitspecies,'(f18.2)',end=22) dryvel(pos_spec)
> ! write(*,*) dryvel(pos_spec)
> read(unitspecies,'(f18.2)',end=22) weightmolar(pos_spec)
> ! write(*,*) weightmolar(pos_spec)
> read(unitspecies,'(e18.1)',end=22) ohreact(pos_spec)
> ! write(*,*) ohreact(pos_spec)
> read(unitspecies,'(i18)',end=22) spec_ass(pos_spec)
> ! write(*,*) spec_ass(pos_spec)
> read(unitspecies,'(f18.2)',end=22) kao(pos_spec)
> ! write(*,*) kao(pos_spec)
> i=pos_spec
>
> if ((weta(pos_spec).gt.0).and.(henry(pos_spec).le.0)) then
> if (dquer(pos_spec).le.0) goto 996 ! no particle, no henry set
> endif
>
> if (spec_ass(pos_spec).gt.0) then
> spec_found=.FALSE.
> do j=1,pos_spec-1
> if (spec_ass(pos_spec).eq.specnum(j)) then
> spec_ass(pos_spec)=j
> spec_found=.TRUE.
> ASSSPEC=.TRUE.
> endif
> end do
> if (spec_found.eqv..FALSE.) then
> goto 997
> endif
> endif
>
> if (dsigma(i).eq.1.) dsigma(i)=1.0001 ! avoid floating exception
> if (dsigma(i).eq.0.) dsigma(i)=1.0001 ! avoid floating exception
>
> if ((reldiff(i).gt.0.).and.(density(i).gt.0.)) then
> write(*,*) '#### FLEXPART MODEL ERROR! FILE "SPECIES" ####'
> write(*,*) '#### IS CORRUPT. SPECIES CANNOT BE BOTH ####'
> write(*,*) '#### PARTICLE AND GAS. ####'
> write(*,*) '#### SPECIES NUMBER',aspecnumb
> stop
> endif
> 20 continue
>
>
> ! Read in daily and day-of-week variation of emissions, if available
> !*******************************************************************
>
> do j=1,24 ! initialize everything to no variation
> area_hour(i,j)=1.
> point_hour(i,j)=1.
> end do
> do j=1,7
> area_dow(i,j)=1.
> point_dow(i,j)=1.
> end do
>
> read(unitspecies,*,end=22)
> do j=1,24 ! 24 hours, starting with 0-1 local time
> read(unitspecies,*) ihour,area_hour(i,j),point_hour(i,j)
> end do
> read(unitspecies,*)
> do j=1,7 ! 7 days of the week, starting with Monday
> read(unitspecies,*) idow,area_dow(i,j),point_dow(i,j)
> end do
>
> 22 close(unitspecies)
>
> return
>
> 996 write(*,*) '#####################################################'
> write(*,*) '#### FLEXPART MODEL ERROR! #### '
> write(*,*) '#### WET DEPOSITION SWITCHED ON, BUT NO HENRYS #### '
> write(*,*) '#### CONSTANT IS SET ####'
> write(*,*) '#### PLEASE MODIFY SPECIES DESCR. FILE! #### '
> write(*,*) '#####################################################'
> stop
>
>
> 997 write(*,*) '#####################################################'
> write(*,*) '#### FLEXPART MODEL ERROR! #### '
> write(*,*) '#### THE ASSSOCIATED SPECIES HAS TO BE DEFINED #### '
> write(*,*) '#### BEFORE THE ONE WHICH POINTS AT IT #### '
> write(*,*) '#### PLEASE CHANGE ORDER IN RELEASES OR ADD #### '
> write(*,*) '#### THE ASSOCIATED SPECIES IN RELEASES #### '
> write(*,*) '#####################################################'
> stop
>
>
> 998 write(*,*) '#####################################################'
> write(*,*) '#### FLEXPART MODEL ERROR! #### '
> write(*,*) '#### THE SPECIES FILE FOR SPECIES ', id_spec
> write(*,*) '#### CANNOT BE FOUND: CREATE FILE'
> write(*,*) '#### ',path(1)(1:length(1)),'SPECIES/SPECIES_',aspecnumb
> write(*,*) '#####################################################'
> stop
>
>
> end subroutine readspecies
readwind.f90
----------------------------------------------
1,480c1,461
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readwind(indj,n,uuh,vvh,wwh)
<
< !**********************************************************************
< ! *
< ! TRAJECTORY MODEL SUBROUTINE READWIND *
< ! *
< !**********************************************************************
< ! *
< ! AUTHOR: G. WOTAWA *
< ! DATE: 1997-08-05 *
< ! LAST UPDATE: 2000-10-17, Andreas Stohl *
< ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
< ! ECMWF grib_api *
< ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
< ! ECMWF grib_api *
< ! *
< !**********************************************************************
< ! Changes, Bernd C. Krueger, Feb. 2001:
< ! Variables tth and qvh (on eta coordinates) in common block
< !**********************************************************************
< ! *
< ! DESCRIPTION: *
< ! *
< ! READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
< ! INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
< ! *
< ! INPUT: *
< ! indj indicates number of the wind field to be read in *
< ! n temporal index for meteorological fields (1 to 3)*
< ! *
< ! IMPORTANT VARIABLES FROM COMMON BLOCK: *
< ! *
< ! wfname File name of data to be read in *
< ! nx,ny,nuvz,nwz expected field dimensions *
< ! nlev_ec number of vertical levels ecmwf model *
< ! uu,vv,ww wind fields *
< ! tt,qv temperature and specific humidity *
< ! ps surface pressure *
< ! *
< !**********************************************************************
<
< use GRIB_API
< use par_mod
< use com_mod
<
< implicit none
<
< !HSO parameters for grib_api
< integer :: ifile
< integer :: iret
< integer :: igrib
< integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
< integer :: gotGrid
< !HSO end
<
< real(kind=4) :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
< real(kind=4) :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real(kind=4) :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
< integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax
<
< ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
<
< ! dimension of isec2 at least (22+n), where n is the number of parallels or
< ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
<
< ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
< ! coordinate parameters
<
< integer :: isec1(56),isec2(22+nxmax+nymax)
< real(kind=4) :: zsec4(jpunp)
< real(kind=4) :: xaux,yaux,xaux0,yaux0
< real(kind=8) :: xauxin,yauxin
< real,parameter :: eps=1.e-4
< real(kind=4) :: nsss(0:nxmax-1,0:nymax-1),ewss(0:nxmax-1,0:nymax-1)
< real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1
<
< logical :: hflswitch,strswitch
<
< !HSO grib api error messages
< character(len=24) :: gribErrorMsg = 'Error reading grib file'
< character(len=20) :: gribFunction = 'readwind'
<
< !HSO conversion of ECMWF etadot to etadot*dp/deta
< logical :: etacon=.false.
< real,parameter :: p00=101325.
< real :: dak,dbk
<
< hflswitch=.false.
< strswitch=.false.
< levdiff2=nlev_ec-nwz+1
< iumax=0
< iwmax=0
<
< !
< ! OPENING OF DATA FILE (GRIB CODE)
< !
< 5 call grib_open_file(ifile,path(3)(1:length(3)) &
< //trim(wfname(indj)),'r',iret)
< if (iret.ne.GRIB_SUCCESS) then
< goto 888 ! ERROR DETECTED
< endif
< !turn on support for multi fields messages */
< !call grib_multi_support_on
<
< gotGrid=0
< ifield=0
< 10 ifield=ifield+1
< !
< ! GET NEXT FIELDS
< !
< call grib_new_from_file(ifile,igrib,iret)
< if (iret.eq.GRIB_END_OF_FILE) then
< goto 50 ! EOF DETECTED
< elseif (iret.ne.GRIB_SUCCESS) then
< goto 888 ! ERROR DETECTED
< endif
<
< !first see if we read GRIB1 or GRIB2
< call grib_get_int(igrib,'editionNumber',gribVer,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< if (gribVer.eq.1) then ! GRIB Edition 1
<
< !print*,'GRiB Edition 1'
< !read the grib2 identifiers
< call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',isec1(8),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !change code for etadot to code for omega
< if (isec1(6).eq.77) then
< isec1(6)=135
< endif
<
< else
<
< !print*,'GRiB Edition 2'
< !read the grib2 identifiers
< call grib_get_int(igrib,'discipline',discipl,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterCategory',parCat,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterNumber',parNum,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',valSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !print*,discipl,parCat,parNum,typSurf,valSurf
<
< !convert to grib1 identifiers
< isec1(6)=-1
< isec1(7)=-1
< isec1(8)=-1
< isec1(8)=valSurf ! level
< if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
< isec1(6)=130 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
< isec1(6)=131 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
< isec1(6)=132 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
< isec1(6)=133 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
< isec1(6)=134 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
< isec1(6)=135 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
< isec1(6)=151 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
< isec1(6)=165 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
< isec1(6)=166 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
< isec1(6)=167 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
< isec1(6)=168 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
< isec1(6)=141 ! indicatorOfParameter
< elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
< isec1(6)=164 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
< isec1(6)=142 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
< isec1(6)=143 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
< isec1(6)=146 ! indicatorOfParameter
< elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
< isec1(6)=176 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
< isec1(6)=180 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
< isec1(6)=181 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
< isec1(6)=129 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
< isec1(6)=160 ! indicatorOfParameter
< elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
< (typSurf.eq.1)) then ! LSM
< isec1(6)=172 ! indicatorOfParameter
< else
< print*,'***ERROR: undefined GRiB2 message found!',discipl, &
< parCat,parNum,typSurf
< endif
<
< endif
<
< !HSO get the size and data of the values array
< if (isec1(6).ne.-1) then
< call grib_get_real4_array(igrib,'values',zsec4,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< endif
<
< !HSO get the required fields from section 2 in a gribex compatible manner
< if (ifield.eq.1) then
< call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
< isec2(2),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
< isec2(3),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
< isec2(12))
< call grib_check(iret,gribFunction,gribErrorMsg)
< ! CHECK GRID SPECIFICATIONS
< if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
< if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
< if(isec2(12)/2-1.ne.nlev_ec) &
< stop 'READWIND: VERTICAL DISCRETIZATION NOT CONSISTENT'
< endif ! ifield
<
< !HSO get the second part of the grid dimensions only from GRiB1 messages
< if ((gribVer.eq.1).and.(gotGrid.eq.0)) then
< call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
< xauxin,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
< yauxin,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< xaux=xauxin+real(nxshift)*dx
< yaux=yauxin
< xaux0=xlon0
< yaux0=ylat0
< if(xaux.lt.0.) xaux=xaux+360.
< if(yaux.lt.0.) yaux=yaux+360.
< if(xaux0.lt.0.) xaux0=xaux0+360.
< if(yaux0.lt.0.) yaux0=yaux0+360.
< if(abs(xaux-xaux0).gt.eps) &
< stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
< if(abs(yaux-yaux0).gt.eps) &
< stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
< gotGrid=1
< endif ! gotGrid
<
< do j=0,nymin1
< do i=0,nxfield-1
< k=isec1(8)
< if(isec1(6).eq.130) tth(i,j,nlev_ec-k+2,n)= &!! TEMPERATURE
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.131) uuh(i,j,nlev_ec-k+2)= &!! U VELOCITY
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.132) vvh(i,j,nlev_ec-k+2)= &!! V VELOCITY
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.133) then !! SPEC. HUMIDITY
< qvh(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
< if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) &
< qvh(i,j,nlev_ec-k+2,n) = 0.
< ! this is necessary because the gridded data may contain
< ! spurious negative values
< endif
< if(isec1(6).eq.134) ps(i,j,1,n)= &!! SURF. PRESS.
< zsec4(nxfield*(ny-j-1)+i+1)
<
< if(isec1(6).eq.135) wwh(i,j,nlev_ec-k+1)= &!! W VELOCITY
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.141) sd(i,j,1,n)= &!! SNOW DEPTH
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.151) msl(i,j,1,n)= &!! SEA LEVEL PRESS.
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.164) tcc(i,j,1,n)= &!! CLOUD COVER
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.165) u10(i,j,1,n)= &!! 10 M U VELOCITY
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.166) v10(i,j,1,n)= &!! 10 M V VELOCITY
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.167) tt2(i,j,1,n)= &!! 2 M TEMPERATURE
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.168) td2(i,j,1,n)= &!! 2 M DEW POINT
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.142) then !! LARGE SCALE PREC.
< lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
< if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0.
< endif
< if(isec1(6).eq.143) then !! CONVECTIVE PREC.
< convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
< if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0.
< endif
< if(isec1(6).eq.146) sshf(i,j,1,n)= &!! SENS. HEAT FLUX
< zsec4(nxfield*(ny-j-1)+i+1)
< if((isec1(6).eq.146).and.(zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) &
< hflswitch=.true. ! Heat flux available
< if(isec1(6).eq.176) then !! SOLAR RADIATION
< ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
< if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0.
< endif
< if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
< zsec4(nxfield*(ny-j-1)+i+1)
< if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
< (zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
< !sec strswitch=.true.
< if(isec1(6).eq.129) oro(i,j)= &!! ECMWF OROGRAPHY
< zsec4(nxfield*(ny-j-1)+i+1)/ga
< if(isec1(6).eq.160) excessoro(i,j)= &!! STANDARD DEVIATION OF OROGRAPHY
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.172) lsm(i,j)= &!! ECMWF LAND SEA MASK
< zsec4(nxfield*(ny-j-1)+i+1)
< if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
< if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
<
< end do
< end do
<
< call grib_release(igrib)
< goto 10 !! READ NEXT LEVEL OR PARAMETER
< !
< ! CLOSING OF INPUT DATA FILE
< !
<
< 50 call grib_close_file(ifile)
<
< !error message if no fields found with correct first longitude in it
< if (gotGrid.eq.0) then
< print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
< 'messages'
< stop
< endif
<
< if(levdiff2.eq.0) then
< iwmax=nlev_ec+1
< do i=0,nxmin1
< do j=0,nymin1
< wwh(i,j,nlev_ec+1)=0.
< end do
< end do
< endif
<
< ! convert from ECMWF etadot to etadot*dp/deta as needed by FLEXPART
< if(etacon.eqv..true.) then
< do k=1,nwzmax
< dak=akm(k+1)-akm(k)
< dbk=bkm(k+1)-bkm(k)
< do i=0,nxmin1
< do j=0,nymin1
< wwh(i,j,k)=2*wwh(i,j,k)*ps(i,j,1,n)*(dak/ps(i,j,1,n)+dbk)/(dak/p00+dbk)
< if (k.gt.1) then
< wwh(i,j,k)=wwh(i,j,k)-wwh(i,j,k-1)
< endif
< end do
< end do
< end do
< endif
<
< ! For global fields, assign the leftmost data column also to the rightmost
< ! data column; if required, shift whole grid by nxshift grid points
< !*************************************************************************
<
< if (xglobal) then
< call shift_field_0(ewss,nxfield,ny)
< call shift_field_0(nsss,nxfield,ny)
< call shift_field_0(oro,nxfield,ny)
< call shift_field_0(excessoro,nxfield,ny)
< call shift_field_0(lsm,nxfield,ny)
< call shift_field(ps,nxfield,ny,1,1,2,n)
< call shift_field(sd,nxfield,ny,1,1,2,n)
< call shift_field(msl,nxfield,ny,1,1,2,n)
< call shift_field(tcc,nxfield,ny,1,1,2,n)
< call shift_field(u10,nxfield,ny,1,1,2,n)
< call shift_field(v10,nxfield,ny,1,1,2,n)
< call shift_field(tt2,nxfield,ny,1,1,2,n)
< call shift_field(td2,nxfield,ny,1,1,2,n)
< call shift_field(lsprec,nxfield,ny,1,1,2,n)
< call shift_field(convprec,nxfield,ny,1,1,2,n)
< call shift_field(sshf,nxfield,ny,1,1,2,n)
< call shift_field(ssr,nxfield,ny,1,1,2,n)
< call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
< call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
< call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
< call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
< call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
< endif
<
< do i=0,nxmin1
< do j=0,nymin1
< surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
< end do
< end do
<
< if ((.not.hflswitch).or.(.not.strswitch)) then
< write(*,*) 'WARNING: No flux data contained in GRIB file ', &
< wfname(indj)
<
< ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
< ! As ECMWF has increased the model resolution, such that now the first model
< ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
< ! (3rd model level in FLEXPART) for the profile method
< !***************************************************************************
<
< do i=0,nxmin1
< do j=0,nymin1
< plev1=akz(3)+bkz(3)*ps(i,j,1,n)
< pmean=0.5*(ps(i,j,1,n)+plev1)
< tv=tth(i,j,3,n)*(1.+0.61*qvh(i,j,3,n))
< fu=-r_air*tv/ga/pmean
< hlev1=fu*(plev1-ps(i,j,1,n)) ! HEIGTH OF FIRST MODEL LAYER
< ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
< fflev1=sqrt(uuh(i,j,3)**2+vvh(i,j,3)**2)
< call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
< tt2(i,j,1,n),tth(i,j,3,n),ff10m,fflev1, &
< surfstr(i,j,1,n),sshf(i,j,1,n))
< if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
< if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
< end do
< end do
< endif
<
<
< ! Assign 10 m wind to model level at eta=1.0 to have one additional model
< ! level at the ground
< ! Specific humidity is taken the same as at one level above
< ! Temperature is taken as 2 m temperature
< !**************************************************************************
<
< do i=0,nxmin1
< do j=0,nymin1
< uuh(i,j,1)=u10(i,j,1,n)
< vvh(i,j,1)=v10(i,j,1,n)
< qvh(i,j,1,n)=qvh(i,j,2,n)
< tth(i,j,1,n)=tt2(i,j,1,n)
< end do
< end do
<
< if(iumax.ne.nuvz-1) stop 'READWIND: NUVZ NOT CONSISTENT'
< if(iwmax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
<
< return
< 888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
< write(*,*) ' #### ',wfname(indj),' #### '
< write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
< stop 'Execution terminated'
< 999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
< write(*,*) ' #### ',wfname(indj),' #### '
< write(*,*) ' #### CANNOT BE OPENED !!! #### '
< stop 'Execution terminated'
<
< end subroutine readwind
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readwind(indj,n,uuh,vvh,wwh)
>
> !**********************************************************************
> ! *
> ! TRAJECTORY MODEL SUBROUTINE READWIND *
> ! *
> !**********************************************************************
> ! *
> ! AUTHOR: G. WOTAWA *
> ! DATE: 1997-08-05 *
> ! LAST UPDATE: 2000-10-17, Andreas Stohl *
> ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with *
> ! ECMWF grib_api *
> ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
> ! ECMWF grib_api *
> ! *
> !**********************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001:
> ! Variables tth and qvh (on eta coordinates) in common block
> !**********************************************************************
> ! *
> ! DESCRIPTION: *
> ! *
> ! READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
> ! INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
> ! *
> ! INPUT: *
> ! indj indicates number of the wind field to be read in *
> ! n temporal index for meteorological fields (1 to 3)*
> ! *
> ! IMPORTANT VARIABLES FROM COMMON BLOCK: *
> ! *
> ! wfname File name of data to be read in *
> ! nx,ny,nuvz,nwz expected field dimensions *
> ! nlev_ec number of vertical levels ecmwf model *
> ! uu,vv,ww wind fields *
> ! tt,qv temperature and specific humidity *
> ! ps surface pressure *
> ! *
> !**********************************************************************
>
> use GRIB_API
> use par_mod
> use com_mod
>
> implicit none
>
> !HSO parameters for grib_api
> integer :: ifile
> integer :: iret
> integer :: igrib
> integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
> integer :: gotGrid
> !HSO end
>
> real(kind=4) :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
> real(kind=4) :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real(kind=4) :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
> integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax
>
> ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
>
> ! dimension of isec2 at least (22+n), where n is the number of parallels or
> ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
>
> ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
> ! coordinate parameters
>
> integer :: isec1(56),isec2(22+nxmax+nymax)
> real(kind=4) :: zsec4(jpunp)
> real(kind=4) :: xaux,yaux,xaux0,yaux0
> real(kind=8) :: xauxin,yauxin
> real,parameter :: eps=1.e-4
> real(kind=4) :: nsss(0:nxmax-1,0:nymax-1),ewss(0:nxmax-1,0:nymax-1)
> real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1
>
> logical :: hflswitch,strswitch
>
> !HSO grib api error messages
> character(len=24) :: gribErrorMsg = 'Error reading grib file'
> character(len=20) :: gribFunction = 'readwind'
>
> hflswitch=.false.
> strswitch=.false.
> levdiff2=nlev_ec-nwz+1
> iumax=0
> iwmax=0
>
> !
> ! OPENING OF DATA FILE (GRIB CODE)
> !
> write(*,*) "Reading:", trim(wfname(indj))
> 5 call grib_open_file(ifile,path(3)(1:length(3)) &
> //trim(wfname(indj)),'r',iret)
> if (iret.ne.GRIB_SUCCESS) then
> goto 888 ! ERROR DETECTED
> endif
> !turn on support for multi fields messages */
> !call grib_multi_support_on
>
> gotGrid=0
> ifield=0
> 10 ifield=ifield+1
> !
> ! GET NEXT FIELDS
> !
> call grib_new_from_file(ifile,igrib,iret)
> if (iret.eq.GRIB_END_OF_FILE) then
> goto 50 ! EOF DETECTED
> elseif (iret.ne.GRIB_SUCCESS) then
> goto 888 ! ERROR DETECTED
> endif
>
> !first see if we read GRIB1 or GRIB2
> call grib_get_int(igrib,'editionNumber',gribVer,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> if (gribVer.eq.1) then ! GRIB Edition 1
>
> !print*,'GRiB Edition 1'
> !read the grib2 identifiers
> call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',isec1(8),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !change code for etadot to code for omega
> if (isec1(6).eq.77) then
> isec1(6)=135
> endif
>
> else
>
> !print*,'GRiB Edition 2'
> !read the grib2 identifiers
> call grib_get_int(igrib,'discipline',discipl,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterCategory',parCat,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterNumber',parNum,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',valSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !print*,discipl,parCat,parNum,typSurf,valSurf
>
> !convert to grib1 identifiers
> isec1(6)=-1
> isec1(7)=-1
> isec1(8)=-1
> isec1(8)=valSurf ! level
> if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
> isec1(6)=130 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
> isec1(6)=131 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
> isec1(6)=132 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
> isec1(6)=133 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
> isec1(6)=134 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
> isec1(6)=135 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
> isec1(6)=151 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
> isec1(6)=165 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
> isec1(6)=166 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
> isec1(6)=167 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
> isec1(6)=168 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
> isec1(6)=141 ! indicatorOfParameter
> elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
> isec1(6)=164 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
> isec1(6)=142 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
> isec1(6)=143 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
> isec1(6)=146 ! indicatorOfParameter
> elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
> isec1(6)=176 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
> isec1(6)=180 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
> isec1(6)=181 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
> isec1(6)=129 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
> isec1(6)=160 ! indicatorOfParameter
> elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
> (typSurf.eq.1)) then ! LSM
> isec1(6)=172 ! indicatorOfParameter
> else
> print*,'***ERROR: undefined GRiB2 message found!',discipl, &
> parCat,parNum,typSurf
> endif
>
> endif
>
> !HSO get the size and data of the values array
> if (isec1(6).ne.-1) then
> call grib_get_real4_array(igrib,'values',zsec4,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> endif
>
> !HSO get the required fields from section 2 in a gribex compatible manner
> if (ifield.eq.1) then
> call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
> isec2(2),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
> isec2(3),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
> isec2(12))
> call grib_check(iret,gribFunction,gribErrorMsg)
> ! CHECK GRID SPECIFICATIONS
> if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
> if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
> if(isec2(12)/2-1.ne.nlev_ec) &
> stop 'READWIND: VERTICAL DISCRETIZATION NOT CONSISTENT'
> endif ! ifield
>
> !HSO get the second part of the grid dimensions only from GRiB1 messages
> if ((gribVer.eq.1).and.(gotGrid.eq.0)) then
> call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
> xauxin,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
> yauxin,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> xaux=xauxin+real(nxshift)*dx
> yaux=yauxin
> xaux0=xlon0
> yaux0=ylat0
> if(xaux.lt.0.) xaux=xaux+360.
> if(yaux.lt.0.) yaux=yaux+360.
> if(xaux0.lt.0.) xaux0=xaux0+360.
> if(yaux0.lt.0.) yaux0=yaux0+360.
> if(abs(xaux-xaux0).gt.eps) &
> stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
> if(abs(yaux-yaux0).gt.eps) &
> stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
> gotGrid=1
> endif ! gotGrid
>
> do j=0,nymin1
> do i=0,nxfield-1
> k=isec1(8)
> if(isec1(6).eq.130) tth(i,j,nlev_ec-k+2,n)= &!! TEMPERATURE
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.131) uuh(i,j,nlev_ec-k+2)= &!! U VELOCITY
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.132) vvh(i,j,nlev_ec-k+2)= &!! V VELOCITY
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.133) then !! SPEC. HUMIDITY
> qvh(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1)
> if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) &
> qvh(i,j,nlev_ec-k+2,n) = 0.
> ! this is necessary because the gridded data may contain
> ! spurious negative values
> endif
> if(isec1(6).eq.134) ps(i,j,1,n)= &!! SURF. PRESS.
> zsec4(nxfield*(ny-j-1)+i+1)
>
> if(isec1(6).eq.135) wwh(i,j,nlev_ec-k+1)= &!! W VELOCITY
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.141) sd(i,j,1,n)= &!! SNOW DEPTH
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.151) msl(i,j,1,n)= &!! SEA LEVEL PRESS.
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.164) tcc(i,j,1,n)= &!! CLOUD COVER
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.165) u10(i,j,1,n)= &!! 10 M U VELOCITY
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.166) v10(i,j,1,n)= &!! 10 M V VELOCITY
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.167) tt2(i,j,1,n)= &!! 2 M TEMPERATURE
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.168) td2(i,j,1,n)= &!! 2 M DEW POINT
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.142) then !! LARGE SCALE PREC.
> lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
> if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0.
> endif
> if(isec1(6).eq.143) then !! CONVECTIVE PREC.
> convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
> if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0.
> endif
> if(isec1(6).eq.146) sshf(i,j,1,n)= &!! SENS. HEAT FLUX
> zsec4(nxfield*(ny-j-1)+i+1)
> if((isec1(6).eq.146).and.(zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) &
> hflswitch=.true. ! Heat flux available
> if(isec1(6).eq.176) then !! SOLAR RADIATION
> ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)
> if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0.
> endif
> if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
> zsec4(nxfield*(ny-j-1)+i+1)
> if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
> (zsec4(nxfield*(ny-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
> !sec strswitch=.true.
> if(isec1(6).eq.129) oro(i,j)= &!! ECMWF OROGRAPHY
> zsec4(nxfield*(ny-j-1)+i+1)/ga
> if(isec1(6).eq.160) excessoro(i,j)= &!! STANDARD DEVIATION OF OROGRAPHY
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.172) lsm(i,j)= &!! ECMWF LAND SEA MASK
> zsec4(nxfield*(ny-j-1)+i+1)
> if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
> if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
>
> end do
> end do
>
> call grib_release(igrib)
> goto 10 !! READ NEXT LEVEL OR PARAMETER
> !
> ! CLOSING OF INPUT DATA FILE
> !
>
> 50 call grib_close_file(ifile)
>
> !error message if no fields found with correct first longitude in it
> if (gotGrid.eq.0) then
> print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
> 'messages'
> stop
> endif
>
> if(levdiff2.eq.0) then
> iwmax=nlev_ec+1
> do i=0,nxmin1
> do j=0,nymin1
> wwh(i,j,nlev_ec+1)=0.
> end do
> end do
> endif
>
> ! For global fields, assign the leftmost data column also to the rightmost
> ! data column; if required, shift whole grid by nxshift grid points
> !*************************************************************************
>
> if (xglobal) then
> call shift_field_0(ewss,nxfield,ny)
> call shift_field_0(nsss,nxfield,ny)
> call shift_field_0(oro,nxfield,ny)
> call shift_field_0(excessoro,nxfield,ny)
> call shift_field_0(lsm,nxfield,ny)
> call shift_field(ps,nxfield,ny,1,1,2,n)
> call shift_field(sd,nxfield,ny,1,1,2,n)
> call shift_field(msl,nxfield,ny,1,1,2,n)
> call shift_field(tcc,nxfield,ny,1,1,2,n)
> call shift_field(u10,nxfield,ny,1,1,2,n)
> call shift_field(v10,nxfield,ny,1,1,2,n)
> call shift_field(tt2,nxfield,ny,1,1,2,n)
> call shift_field(td2,nxfield,ny,1,1,2,n)
> call shift_field(lsprec,nxfield,ny,1,1,2,n)
> call shift_field(convprec,nxfield,ny,1,1,2,n)
> call shift_field(sshf,nxfield,ny,1,1,2,n)
> call shift_field(ssr,nxfield,ny,1,1,2,n)
> call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
> call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
> call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
> call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
> call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
> endif
>
> do i=0,nxmin1
> do j=0,nymin1
> surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
> end do
> end do
>
> if ((.not.hflswitch).or.(.not.strswitch)) then
> write(*,*) 'WARNING: No flux data contained in GRIB file ', &
> wfname(indj)
>
> ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
> ! As ECMWF has increased the model resolution, such that now the first model
> ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
> ! (3rd model level in FLEXPART) for the profile method
> !***************************************************************************
>
> do i=0,nxmin1
> do j=0,nymin1
> plev1=akz(3)+bkz(3)*ps(i,j,1,n)
> pmean=0.5*(ps(i,j,1,n)+plev1)
> tv=tth(i,j,3,n)*(1.+0.61*qvh(i,j,3,n))
> fu=-r_air*tv/ga/pmean
> hlev1=fu*(plev1-ps(i,j,1,n)) ! HEIGTH OF FIRST MODEL LAYER
> ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
> fflev1=sqrt(uuh(i,j,3)**2+vvh(i,j,3)**2)
> call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
> tt2(i,j,1,n),tth(i,j,3,n),ff10m,fflev1, &
> surfstr(i,j,1,n),sshf(i,j,1,n))
> if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
> if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
> end do
> end do
> endif
>
>
> ! Assign 10 m wind to model level at eta=1.0 to have one additional model
> ! level at the ground
> ! Specific humidity is taken the same as at one level above
> ! Temperature is taken as 2 m temperature
> !**************************************************************************
>
> do i=0,nxmin1
> do j=0,nymin1
> uuh(i,j,1)=u10(i,j,1,n)
> vvh(i,j,1)=v10(i,j,1,n)
> qvh(i,j,1,n)=qvh(i,j,2,n)
> tth(i,j,1,n)=tt2(i,j,1,n)
> end do
> end do
>
> if(iumax.ne.nuvz-1) stop 'READWIND: NUVZ NOT CONSISTENT'
> if(iwmax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
>
> write(*,*) "done"
> return
> 888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
> write(*,*) ' #### ',wfname(indj),' #### '
> write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
> stop 'Execution terminated'
> 999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
> write(*,*) ' #### ',wfname(indj),' #### '
> write(*,*) ' #### CANNOT BE OPENED !!! #### '
> stop 'Execution terminated'
>
> end subroutine readwind
readwind_gfs.f90
----------------------------------------------
1,718c1,723
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readwind(indj,n,uuh,vvh,wwh)
<
< !***********************************************************************
< !* *
< !* TRAJECTORY MODEL SUBROUTINE READWIND *
< !* *
< !***********************************************************************
< !* *
< !* AUTHOR: G. WOTAWA *
< !* DATE: 1997-08-05 *
< !* LAST UPDATE: 2000-10-17, Andreas Stohl *
< !* CHANGE: 01/02/2001, Bernd C. Krueger, Variables tth and *
< !* qvh (on eta coordinates) in common block *
< !* CHANGE: 16/11/2005, Caroline Forster, GFS data *
< !* CHANGE: 11/01/2008, Harald Sodemann, Input of GRIB1/2 *
< !* data with the ECMWF grib_api library *
< !* CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
< !* ECMWF grib_api *
< !* *
< !***********************************************************************
< !* *
< !* DESCRIPTION: *
< !* *
< !* READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
< !* INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
< !* *
< !* INPUT: *
< !* indj indicates number of the wind field to be read in *
< !* n temporal index for meteorological fields (1 to 3)*
< !* *
< !* IMPORTANT VARIABLES FROM COMMON BLOCK: *
< !* *
< !* wfname File name of data to be read in *
< !* nx,ny,nuvz,nwz expected field dimensions *
< !* nlev_ec number of vertical levels ecmwf model *
< !* uu,vv,ww wind fields *
< !* tt,qv temperature and specific humidity *
< !* ps surface pressure *
< !* *
< !***********************************************************************
<
< use grib_api
< use par_mod
< use com_mod
<
< implicit none
<
< !HSO new parameters for grib_api
< integer :: ifile
< integer :: iret
< integer :: igrib
< integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
< !HSO end edits
< real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
< integer :: ii,indj,i,j,k,n,levdiff2,ifield,iumax,iwmax
<
< ! NCEP
< integer :: numpt,numpu,numpv,numpw,numprh
< real :: help, temp, ew
< real :: elev
< real :: ulev1(0:nxmax-1,0:nymax-1),vlev1(0:nxmax-1,0:nymax-1)
< real :: tlev1(0:nxmax-1,0:nymax-1)
< real :: qvh2(0:nxmax-1,0:nymax-1)
<
< integer :: i179,i180,i181
<
< ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
< !HSO kept isec1, isec2 and zsec4 for consistency with gribex GRIB input
<
< integer :: isec1(8),isec2(3)
< real(kind=4) :: zsec4(jpunp)
< real(kind=4) :: xaux,yaux,xaux0,yaux0
< real(kind=8) :: xauxin,yauxin
< real,parameter :: eps=1.e-4
< real(kind=4) :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1)
< real :: plev1,hlev1,ff10m,fflev1
<
< logical :: hflswitch,strswitch
<
< !HSO for grib api error messages
< character(len=24) :: gribErrorMsg = 'Error reading grib file'
< character(len=20) :: gribFunction = 'readwind_gfs'
<
<
< hflswitch=.false.
< strswitch=.false.
< levdiff2=nlev_ec-nwz+1
< iumax=0
< iwmax=0
<
<
< ! OPENING OF DATA FILE (GRIB CODE)
<
< !HSO
< 5 call grib_open_file(ifile,path(3)(1:length(3)) &
< //trim(wfname(indj)),'r',iret)
< if (iret.ne.GRIB_SUCCESS) then
< goto 888 ! ERROR DETECTED
< endif
< !turn on support for multi fields messages
< call grib_multi_support_on
<
< numpt=0
< numpu=0
< numpv=0
< numpw=0
< numprh=0
< ifield=0
< 10 ifield=ifield+1
< !
< ! GET NEXT FIELDS
< !
< call grib_new_from_file(ifile,igrib,iret)
< if (iret.eq.GRIB_END_OF_FILE) then
< goto 50 ! EOF DETECTED
< elseif (iret.ne.GRIB_SUCCESS) then
< goto 888 ! ERROR DETECTED
< endif
<
< !first see if we read GRIB1 or GRIB2
< call grib_get_int(igrib,'editionNumber',gribVer,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< if (gribVer.eq.1) then ! GRIB Edition 1
<
< !read the grib1 identifiers
< call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',isec1(8),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< else ! GRIB Edition 2
<
< !read the grib2 identifiers
< call grib_get_int(igrib,'discipline',discipl,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterCategory',parCat,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterNumber',parNum,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', &
< valSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !convert to grib1 identifiers
< isec1(6)=-1
< isec1(7)=-1
< isec1(8)=-1
< if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.100)) then ! T
< isec1(6)=11 ! indicatorOfParameter
< isec1(7)=100 ! indicatorOfTypeOfLevel
< isec1(8)=valSurf/100 ! level, convert to hPa
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.100)) then ! U
< isec1(6)=33 ! indicatorOfParameter
< isec1(7)=100 ! indicatorOfTypeOfLevel
< isec1(8)=valSurf/100 ! level, convert to hPa
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.100)) then ! V
< isec1(6)=34 ! indicatorOfParameter
< isec1(7)=100 ! indicatorOfTypeOfLevel
< isec1(8)=valSurf/100 ! level, convert to hPa
< elseif ((parCat.eq.2).and.(parNum.eq.8).and.(typSurf.eq.100)) then ! W
< isec1(6)=39 ! indicatorOfParameter
< isec1(7)=100 ! indicatorOfTypeOfLevel
< isec1(8)=valSurf/100 ! level, convert to hPa
< elseif ((parCat.eq.1).and.(parNum.eq.1).and.(typSurf.eq.100)) then ! RH
< isec1(6)=52 ! indicatorOfParameter
< isec1(7)=100 ! indicatorOfTypeOfLevel
< isec1(8)=valSurf/100 ! level, convert to hPa
< elseif ((parCat.eq.1).and.(parNum.eq.1).and.(typSurf.eq.103)) then ! RH2
< isec1(6)=52 ! indicatorOfParameter
< isec1(7)=105 ! indicatorOfTypeOfLevel
< isec1(8)=2
< elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! T2
< isec1(6)=11 ! indicatorOfParameter
< isec1(7)=105 ! indicatorOfTypeOfLevel
< isec1(8)=2
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! U10
< isec1(6)=33 ! indicatorOfParameter
< isec1(7)=105 ! indicatorOfTypeOfLevel
< isec1(8)=10
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! V10
< isec1(6)=34 ! indicatorOfParameter
< isec1(7)=105 ! indicatorOfTypeOfLevel
< isec1(8)=10
< elseif ((parCat.eq.3).and.(parNum.eq.1).and.(typSurf.eq.101)) then ! SLP
< isec1(6)=2 ! indicatorOfParameter
< isec1(7)=102 ! indicatorOfTypeOfLevel
< isec1(8)=0
< elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then ! SP
< isec1(6)=1 ! indicatorOfParameter
< isec1(7)=1 ! indicatorOfTypeOfLevel
< isec1(8)=0
< elseif ((parCat.eq.1).and.(parNum.eq.13).and.(typSurf.eq.1)) then ! SNOW
< isec1(6)=66 ! indicatorOfParameter
< isec1(7)=1 ! indicatorOfTypeOfLevel
< isec1(8)=0
< elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.104)) then ! T sigma 0
< isec1(6)=11 ! indicatorOfParameter
< isec1(7)=107 ! indicatorOfTypeOfLevel
< isec1(8)=0.995 ! lowest sigma level
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.104)) then ! U sigma 0
< isec1(6)=33 ! indicatorOfParameter
< isec1(7)=107 ! indicatorOfTypeOfLevel
< isec1(8)=0.995 ! lowest sigma level
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.104)) then ! V sigma 0
< isec1(6)=34 ! indicatorOfParameter
< isec1(7)=107 ! indicatorOfTypeOfLevel
< isec1(8)=0.995 ! lowest sigma level
< elseif ((parCat.eq.3).and.(parNum.eq.5).and.(typSurf.eq.1)) then ! TOPO
< isec1(6)=7 ! indicatorOfParameter
< isec1(7)=1 ! indicatorOfTypeOfLevel
< isec1(8)=0
< elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.1) &
< .and.(discipl.eq.2)) then ! LSM
< isec1(6)=81 ! indicatorOfParameter
< isec1(7)=1 ! indicatorOfTypeOfLevel
< isec1(8)=0
< elseif ((parCat.eq.3).and.(parNum.eq.196).and.(typSurf.eq.1)) then ! BLH
< isec1(6)=221 ! indicatorOfParameter
< isec1(7)=1 ! indicatorOfTypeOfLevel
< isec1(8)=0
< elseif ((parCat.eq.1).and.(parNum.eq.7).and.(typSurf.eq.1)) then ! LSP/TP
< isec1(6)=62 ! indicatorOfParameter
< isec1(7)=1 ! indicatorOfTypeOfLevel
< isec1(8)=0
< elseif ((parCat.eq.1).and.(parNum.eq.196).and.(typSurf.eq.1)) then ! CP
< isec1(6)=63 ! indicatorOfParameter
< isec1(7)=1 ! indicatorOfTypeOfLevel
< isec1(8)=0
< endif
<
< endif ! gribVer
<
< if (isec1(6).ne.-1) then
< ! get the size and data of the values array
< call grib_get_real4_array(igrib,'values',zsec4,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< endif
<
< if(ifield.eq.1) then
<
< !get the required fields from section 2
< !store compatible to gribex input
< call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
< isec2(2),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
< isec2(3),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
< xauxin,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
< yauxin,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< xaux=xauxin+real(nxshift)*dx
< yaux=yauxin
<
< ! CHECK GRID SPECIFICATIONS
<
< if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
< if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
< if(xaux.eq.0.) xaux=-179.0 ! NCEP DATA
< xaux0=xlon0
< yaux0=ylat0
< if(xaux.lt.0.) xaux=xaux+360.
< if(yaux.lt.0.) yaux=yaux+360.
< if(xaux0.lt.0.) xaux0=xaux0+360.
< if(yaux0.lt.0.) yaux0=yaux0+360.
< if(abs(xaux-xaux0).gt.eps) &
< stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
< if(abs(yaux-yaux0).gt.eps) &
< stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
< endif
< !HSO end of edits
<
< i179=nint(179./dx)
< if (dx.lt.0.7) then
< i180=nint(180./dx)+1 ! 0.5 deg data
< else
< i180=nint(179./dx)+1 ! 1 deg data
< endif
< i181=i180+1
<
< if (isec1(6).ne.-1) then
<
< do j=0,nymin1
< do i=0,nxfield-1
< if((isec1(6).eq.011).and.(isec1(7).eq.100)) then
< ! TEMPERATURE
< if((i.eq.0).and.(j.eq.0)) then
< do ii=1,nuvz
< if ((isec1(8)*100.0).eq.akz(ii)) numpt=ii
< end do
< endif
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< tth(i179+i,j,numpt,n)=help
< else
< tth(i-i181,j,numpt,n)=help
< endif
< endif
< if((isec1(6).eq.033).and.(isec1(7).eq.100)) then
< ! U VELOCITY
< if((i.eq.0).and.(j.eq.0)) then
< do ii=1,nuvz
< if ((isec1(8)*100.0).eq.akz(ii)) numpu=ii
< end do
< endif
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< uuh(i179+i,j,numpu)=help
< else
< uuh(i-i181,j,numpu)=help
< endif
< endif
< if((isec1(6).eq.034).and.(isec1(7).eq.100)) then
< ! V VELOCITY
< if((i.eq.0).and.(j.eq.0)) then
< do ii=1,nuvz
< if ((isec1(8)*100.0).eq.akz(ii)) numpv=ii
< end do
< endif
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< vvh(i179+i,j,numpv)=help
< else
< vvh(i-i181,j,numpv)=help
< endif
< endif
< if((isec1(6).eq.052).and.(isec1(7).eq.100)) then
< ! RELATIVE HUMIDITY -> CONVERT TO SPECIFIC HUMIDITY LATER
< if((i.eq.0).and.(j.eq.0)) then
< do ii=1,nuvz
< if ((isec1(8)*100.0).eq.akz(ii)) numprh=ii
< end do
< endif
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< qvh(i179+i,j,numprh,n)=help
< else
< qvh(i-i181,j,numprh,n)=help
< endif
< endif
< if((isec1(6).eq.001).and.(isec1(7).eq.001)) then
< ! SURFACE PRESSURE
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< ps(i179+i,j,1,n)=help
< else
< ps(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.039).and.(isec1(7).eq.100)) then
< ! W VELOCITY
< if((i.eq.0).and.(j.eq.0)) then
< do ii=1,nuvz
< if ((isec1(8)*100.0).eq.akz(ii)) numpw=ii
< end do
< endif
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< wwh(i179+i,j,numpw)=help
< else
< wwh(i-i181,j,numpw)=help
< endif
< endif
< if((isec1(6).eq.066).and.(isec1(7).eq.001)) then
< ! SNOW DEPTH
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< sd(i179+i,j,1,n)=help
< else
< sd(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.002).and.(isec1(7).eq.102)) then
< ! MEAN SEA LEVEL PRESSURE
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< msl(i179+i,j,1,n)=help
< else
< msl(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.071).and.(isec1(7).eq.244)) then
< ! TOTAL CLOUD COVER
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< tcc(i179+i,j,1,n)=help
< else
< tcc(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.033).and.(isec1(7).eq.105).and. &
< (isec1(8).eq.10)) then
< ! 10 M U VELOCITY
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< u10(i179+i,j,1,n)=help
< else
< u10(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.034).and.(isec1(7).eq.105).and. &
< (isec1(8).eq.10)) then
< ! 10 M V VELOCITY
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< v10(i179+i,j,1,n)=help
< else
< v10(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.011).and.(isec1(7).eq.105).and. &
< (isec1(8).eq.02)) then
< ! 2 M TEMPERATURE
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< tt2(i179+i,j,1,n)=help
< else
< tt2(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.017).and.(isec1(7).eq.105).and. &
< (isec1(8).eq.02)) then
< ! 2 M DEW POINT TEMPERATURE
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< td2(i179+i,j,1,n)=help
< else
< td2(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.062).and.(isec1(7).eq.001)) then
< ! LARGE SCALE PREC.
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< lsprec(i179+i,j,1,n)=help
< else
< lsprec(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.063).and.(isec1(7).eq.001)) then
< ! CONVECTIVE PREC.
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< convprec(i179+i,j,1,n)=help
< else
< convprec(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
< ! TOPOGRAPHY
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< oro(i179+i,j)=help
< excessoro(i179+i,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
< else
< oro(i-i181,j)=help
< excessoro(i-i181,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
< endif
< endif
< if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
< ! LAND SEA MASK
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< lsm(i179+i,j)=help
< else
< lsm(i-i181,j)=help
< endif
< endif
< if((isec1(6).eq.221).and.(isec1(7).eq.001)) then
< ! MIXING HEIGHT
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< hmix(i179+i,j,1,n)=help
< else
< hmix(i-i181,j,1,n)=help
< endif
< endif
< if((isec1(6).eq.052).and.(isec1(7).eq.105).and. &
< (isec1(8).eq.02)) then
< ! 2 M RELATIVE HUMIDITY
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< qvh2(i179+i,j)=help
< else
< qvh2(i-i181,j)=help
< endif
< endif
< if((isec1(6).eq.011).and.(isec1(7).eq.107)) then
< ! TEMPERATURE LOWEST SIGMA LEVEL
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< tlev1(i179+i,j)=help
< else
< tlev1(i-i181,j)=help
< endif
< endif
< if((isec1(6).eq.033).and.(isec1(7).eq.107)) then
< ! U VELOCITY LOWEST SIGMA LEVEL
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< ulev1(i179+i,j)=help
< else
< ulev1(i-i181,j)=help
< endif
< endif
< if((isec1(6).eq.034).and.(isec1(7).eq.107)) then
< ! V VELOCITY LOWEST SIGMA LEVEL
< help=zsec4(nxfield*(ny-j-1)+i+1)
< if(i.le.i180) then
< vlev1(i179+i,j)=help
< else
< vlev1(i-i181,j)=help
< endif
< endif
<
< end do
< end do
<
< endif
<
< if((isec1(6).eq.33).and.(isec1(7).eq.100)) then
< ! NCEP ISOBARIC LEVELS
< iumax=iumax+1
< endif
<
< call grib_release(igrib)
< goto 10 !! READ NEXT LEVEL OR PARAMETER
< !
< ! CLOSING OF INPUT DATA FILE
< !
<
< !HSO close grib file
< 50 continue
< call grib_close_file(ifile)
<
< ! SENS. HEAT FLUX
< sshf(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
< hflswitch=.false. ! Heat flux not available
< ! SOLAR RADIATIVE FLUXES
< ssr(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
< ! EW SURFACE STRESS
< ewss=0.0 ! not available from gfs.tccz.pgrbfxx files
< ! NS SURFACE STRESS
< nsss=0.0 ! not available from gfs.tccz.pgrbfxx files
< strswitch=.false. ! stress not available
<
< ! CONVERT TP TO LSP (GRIB2 only)
< if (gribVer.eq.2) then
< do j=0,nymin1
< do i=0,nxfield-1
< if(i.le.i180) then
< if (convprec(i179+i,j,1,n).lt.lsprec(i179+i,j,1,n)) then ! neg precip would occur
< lsprec(i179+i,j,1,n)= &
< lsprec(i179+i,j,1,n)-convprec(i179+i,j,1,n)
< else
< lsprec(i179+i,j,1,n)=0
< endif
< else
< if (convprec(i-i181,j,1,n).lt.lsprec(i-i181,j,1,n)) then
< lsprec(i-i181,j,1,n)= &
< lsprec(i-i181,j,1,n)-convprec(i-i181,j,1,n)
< else
< lsprec(i-i181,j,1,n)=0
< endif
< endif
< enddo
< enddo
< endif
< !HSO end edits
<
<
< ! TRANSFORM RH TO SPECIFIC HUMIDITY
<
< do j=0,ny-1
< do i=0,nxfield-1
< do k=1,nuvz
< help=qvh(i,j,k,n)
< temp=tth(i,j,k,n)
< plev1=akm(k)+bkm(k)*ps(i,j,1,n)
< elev=ew(temp)*help/100.0
< qvh(i,j,k,n)=xmwml*(elev/(plev1-((1.0-xmwml)*elev)))
< end do
< end do
< end do
<
< ! CALCULATE 2 M DEW POINT FROM 2 M RELATIVE HUMIDITY
< ! USING BOLTON'S (1980) FORMULA
< ! BECAUSE td2 IS NOT AVAILABLE FROM NCEP GFS DATA
<
< do j=0,ny-1
< do i=0,nxfield-1
< help=qvh2(i,j)
< temp=tt2(i,j,1,n)
< elev=ew(temp)/100.*help/100. !vapour pressure in hPa
< td2(i,j,1,n)=243.5/(17.67/log(elev/6.112)-1)+273.
< if (help.le.0.) td2(i,j,1,n)=tt2(i,j,1,n)
< end do
< end do
<
< if(levdiff2.eq.0) then
< iwmax=nlev_ec+1
< do i=0,nxmin1
< do j=0,nymin1
< wwh(i,j,nlev_ec+1)=0.
< end do
< end do
< endif
<
<
< ! For global fields, assign the leftmost data column also to the rightmost
< ! data column; if required, shift whole grid by nxshift grid points
< !*************************************************************************
<
< if (xglobal) then
< call shift_field_0(ewss,nxfield,ny)
< call shift_field_0(nsss,nxfield,ny)
< call shift_field_0(oro,nxfield,ny)
< call shift_field_0(excessoro,nxfield,ny)
< call shift_field_0(lsm,nxfield,ny)
< call shift_field_0(ulev1,nxfield,ny)
< call shift_field_0(vlev1,nxfield,ny)
< call shift_field_0(tlev1,nxfield,ny)
< call shift_field_0(qvh2,nxfield,ny)
< call shift_field(ps,nxfield,ny,1,1,2,n)
< call shift_field(sd,nxfield,ny,1,1,2,n)
< call shift_field(msl,nxfield,ny,1,1,2,n)
< call shift_field(tcc,nxfield,ny,1,1,2,n)
< call shift_field(u10,nxfield,ny,1,1,2,n)
< call shift_field(v10,nxfield,ny,1,1,2,n)
< call shift_field(tt2,nxfield,ny,1,1,2,n)
< call shift_field(td2,nxfield,ny,1,1,2,n)
< call shift_field(lsprec,nxfield,ny,1,1,2,n)
< call shift_field(convprec,nxfield,ny,1,1,2,n)
< call shift_field(sshf,nxfield,ny,1,1,2,n)
< call shift_field(ssr,nxfield,ny,1,1,2,n)
< call shift_field(hmix,nxfield,ny,1,1,2,n)
< call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
< call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
< call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
< call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
< call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
< endif
<
< do i=0,nxmin1
< do j=0,nymin1
< ! Convert precip. from mm/s -> mm/hour
< convprec(i,j,1,n)=convprec(i,j,1,n)*3600.
< lsprec(i,j,1,n)=lsprec(i,j,1,n)*3600.
< surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
< end do
< end do
<
< if ((.not.hflswitch).or.(.not.strswitch)) then
< ! write(*,*) 'WARNING: No flux data contained in GRIB file ',
< ! + wfname(indj)
<
< ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
< !***************************************************************************
<
< do i=0,nxmin1
< do j=0,nymin1
< hlev1=30.0 ! HEIGHT OF FIRST MODEL SIGMA LAYER
< ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
< fflev1=sqrt(ulev1(i,j)**2+vlev1(i,j)**2)
< call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
< tt2(i,j,1,n),tlev1(i,j),ff10m,fflev1, &
< surfstr(i,j,1,n),sshf(i,j,1,n))
< if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
< if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
< end do
< end do
< endif
<
< if(iumax.ne.nuvz) stop 'READWIND: NUVZ NOT CONSISTENT'
< if(iumax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
<
< return
< 888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
< write(*,*) ' #### ',wfname(indj),' #### '
< write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
< stop 'Execution terminated'
< 999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
< write(*,*) ' #### ',wfname(indj),' #### '
< write(*,*) ' #### CANNOT BE OPENED !!! #### '
< stop 'Execution terminated'
<
< end subroutine readwind
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readwind(indj,n,uuh,vvh,wwh)
>
> !***********************************************************************
> !* *
> !* TRAJECTORY MODEL SUBROUTINE READWIND *
> !* *
> !***********************************************************************
> !* *
> !* AUTHOR: G. WOTAWA *
> !* DATE: 1997-08-05 *
> !* LAST UPDATE: 2000-10-17, Andreas Stohl *
> !* CHANGE: 01/02/2001, Bernd C. Krueger, Variables tth and *
> !* qvh (on eta coordinates) in common block *
> !* CHANGE: 16/11/2005, Caroline Forster, GFS data *
> !* CHANGE: 11/01/2008, Harald Sodemann, Input of GRIB1/2 *
> !* data with the ECMWF grib_api library *
> !* CHANGE: 03/12/2008, Harald Sodemann, update to f90 with *
> !* ECMWF grib_api *
> !* *
> !***********************************************************************
> !* *
> !* DESCRIPTION: *
> !* *
> !* READING OF ECMWF METEOROLOGICAL FIELDS FROM INPUT DATA FILES. THE *
> !* INPUT DATA FILES ARE EXPECTED TO BE AVAILABLE IN GRIB CODE *
> !* *
> !* INPUT: *
> !* indj indicates number of the wind field to be read in *
> !* n temporal index for meteorological fields (1 to 3)*
> !* *
> !* IMPORTANT VARIABLES FROM COMMON BLOCK: *
> !* *
> !* wfname File name of data to be read in *
> !* nx,ny,nuvz,nwz expected field dimensions *
> !* nlev_ec number of vertical levels ecmwf model *
> !* uu,vv,ww wind fields *
> !* tt,qv temperature and specific humidity *
> !* ps surface pressure *
> !* *
> !***********************************************************************
>
> use grib_api
> use par_mod
> use com_mod
>
> implicit none
>
> !HSO new parameters for grib_api
> integer :: ifile
> integer :: iret
> integer :: igrib
> integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
> !HSO end edits
> real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
> integer :: ii,indj,i,j,k,n,levdiff2,ifield,iumax,iwmax
>
> ! NCEP
> integer :: numpt,numpu,numpv,numpw,numprh
> real :: help, temp, ew
> real :: elev
> real :: ulev1(0:nxmax-1,0:nymax-1),vlev1(0:nxmax-1,0:nymax-1)
> real :: tlev1(0:nxmax-1,0:nymax-1)
> real :: qvh2(0:nxmax-1,0:nymax-1)
>
> integer :: i179,i180,i181
>
> ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
> !HSO kept isec1, isec2 and zsec4 for consistency with gribex GRIB input
>
> integer :: isec1(8),isec2(3)
> real(kind=4) :: zsec4(jpunp)
> real(kind=4) :: xaux,yaux,xaux0,yaux0
> real(kind=8) :: xauxin,yauxin
> real,parameter :: eps=1.e-4
> real(kind=4) :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1)
> real :: plev1,hlev1,ff10m,fflev1
>
> logical :: hflswitch,strswitch
>
> !HSO for grib api error messages
> character(len=24) :: gribErrorMsg = 'Error reading grib file'
> character(len=20) :: gribFunction = 'readwind_gfs'
>
>
> hflswitch=.false.
> strswitch=.false.
> levdiff2=nlev_ec-nwz+1
> iumax=0
> iwmax=0
>
>
> ! OPENING OF DATA FILE (GRIB CODE)
>
> !HSO
> 5 call grib_open_file(ifile,path(3)(1:length(3)) &
> //trim(wfname(indj)),'r',iret)
> if (iret.ne.GRIB_SUCCESS) then
> goto 888 ! ERROR DETECTED
> endif
> !turn on support for multi fields messages
> call grib_multi_support_on
>
> numpt=0
> numpu=0
> numpv=0
> numpw=0
> numprh=0
> ifield=0
> 10 ifield=ifield+1
> !
> ! GET NEXT FIELDS
> !
> call grib_new_from_file(ifile,igrib,iret)
> if (iret.eq.GRIB_END_OF_FILE) then
> goto 50 ! EOF DETECTED
> elseif (iret.ne.GRIB_SUCCESS) then
> goto 888 ! ERROR DETECTED
> endif
>
> !first see if we read GRIB1 or GRIB2
> call grib_get_int(igrib,'editionNumber',gribVer,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> if (gribVer.eq.1) then ! GRIB Edition 1
>
> !read the grib1 identifiers
> call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',isec1(8),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> else ! GRIB Edition 2
>
> !read the grib2 identifiers
> call grib_get_int(igrib,'discipline',discipl,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterCategory',parCat,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterNumber',parNum,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', &
> valSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !convert to grib1 identifiers
> isec1(6)=-1
> isec1(7)=-1
> isec1(8)=-1
> if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.100)) then ! T
> isec1(6)=11 ! indicatorOfParameter
> isec1(7)=100 ! indicatorOfTypeOfLevel
> isec1(8)=valSurf/100 ! level, convert to hPa
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.100)) then ! U
> isec1(6)=33 ! indicatorOfParameter
> isec1(7)=100 ! indicatorOfTypeOfLevel
> isec1(8)=valSurf/100 ! level, convert to hPa
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.100)) then ! V
> isec1(6)=34 ! indicatorOfParameter
> isec1(7)=100 ! indicatorOfTypeOfLevel
> isec1(8)=valSurf/100 ! level, convert to hPa
> elseif ((parCat.eq.2).and.(parNum.eq.8).and.(typSurf.eq.100)) then ! W
> isec1(6)=39 ! indicatorOfParameter
> isec1(7)=100 ! indicatorOfTypeOfLevel
> isec1(8)=valSurf/100 ! level, convert to hPa
> elseif ((parCat.eq.1).and.(parNum.eq.1).and.(typSurf.eq.100)) then ! RH
> isec1(6)=52 ! indicatorOfParameter
> isec1(7)=100 ! indicatorOfTypeOfLevel
> isec1(8)=valSurf/100 ! level, convert to hPa
> elseif ((parCat.eq.1).and.(parNum.eq.1).and.(typSurf.eq.103)) then ! RH2
> isec1(6)=52 ! indicatorOfParameter
> isec1(7)=105 ! indicatorOfTypeOfLevel
> isec1(8)=2
> elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! T2
> isec1(6)=11 ! indicatorOfParameter
> isec1(7)=105 ! indicatorOfTypeOfLevel
> isec1(8)=2
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! U10
> isec1(6)=33 ! indicatorOfParameter
> isec1(7)=105 ! indicatorOfTypeOfLevel
> isec1(8)=10
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! V10
> isec1(6)=34 ! indicatorOfParameter
> isec1(7)=105 ! indicatorOfTypeOfLevel
> isec1(8)=10
> elseif ((parCat.eq.3).and.(parNum.eq.1).and.(typSurf.eq.101)) then ! SLP
> isec1(6)=2 ! indicatorOfParameter
> isec1(7)=102 ! indicatorOfTypeOfLevel
> isec1(8)=0
> elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then ! SP
> isec1(6)=1 ! indicatorOfParameter
> isec1(7)=1 ! indicatorOfTypeOfLevel
> isec1(8)=0
> elseif ((parCat.eq.1).and.(parNum.eq.13).and.(typSurf.eq.1)) then ! SNOW
> isec1(6)=66 ! indicatorOfParameter
> isec1(7)=1 ! indicatorOfTypeOfLevel
> isec1(8)=0
> elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.104)) then ! T sigma 0
> isec1(6)=11 ! indicatorOfParameter
> isec1(7)=107 ! indicatorOfTypeOfLevel
> isec1(8)=0.995 ! lowest sigma level
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.104)) then ! U sigma 0
> isec1(6)=33 ! indicatorOfParameter
> isec1(7)=107 ! indicatorOfTypeOfLevel
> isec1(8)=0.995 ! lowest sigma level
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.104)) then ! V sigma 0
> isec1(6)=34 ! indicatorOfParameter
> isec1(7)=107 ! indicatorOfTypeOfLevel
> isec1(8)=0.995 ! lowest sigma level
> elseif ((parCat.eq.3).and.(parNum.eq.5).and.(typSurf.eq.1)) then ! TOPO
> isec1(6)=7 ! indicatorOfParameter
> isec1(7)=1 ! indicatorOfTypeOfLevel
> isec1(8)=0
> elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.1) &
> .and.(discipl.eq.2)) then ! LSM
> isec1(6)=81 ! indicatorOfParameter
> isec1(7)=1 ! indicatorOfTypeOfLevel
> isec1(8)=0
> elseif ((parCat.eq.3).and.(parNum.eq.196).and.(typSurf.eq.1)) then ! BLH
> isec1(6)=221 ! indicatorOfParameter
> isec1(7)=1 ! indicatorOfTypeOfLevel
> isec1(8)=0
> elseif ((parCat.eq.1).and.(parNum.eq.7).and.(typSurf.eq.1)) then ! LSP/TP
> isec1(6)=62 ! indicatorOfParameter
> isec1(7)=1 ! indicatorOfTypeOfLevel
> isec1(8)=0
> elseif ((parCat.eq.1).and.(parNum.eq.196).and.(typSurf.eq.1)) then ! CP
> isec1(6)=63 ! indicatorOfParameter
> isec1(7)=1 ! indicatorOfTypeOfLevel
> isec1(8)=0
> endif
>
> endif ! gribVer
>
> if (isec1(6).ne.-1) then
> ! get the size and data of the values array
> call grib_get_real4_array(igrib,'values',zsec4,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> endif
>
> if(ifield.eq.1) then
>
> !get the required fields from section 2
> !store compatible to gribex input
> call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
> isec2(2),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
> isec2(3),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
> xauxin,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
> yauxin,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> xaux=xauxin+real(nxshift)*dx
> yaux=yauxin
>
> ! CHECK GRID SPECIFICATIONS
>
> if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT'
> if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT'
> if(xaux.eq.0.) xaux=-179.0 ! NCEP DATA
> xaux0=xlon0
> yaux0=ylat0
> if(xaux.lt.0.) xaux=xaux+360.
> if(yaux.lt.0.) yaux=yaux+360.
> if(xaux0.lt.0.) xaux0=xaux0+360.
> if(yaux0.lt.0.) yaux0=yaux0+360.
> if(abs(xaux-xaux0).gt.eps) &
> stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT'
> if(abs(yaux-yaux0).gt.eps) &
> stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT'
> endif
> !HSO end of edits
>
> i179=nint(179./dx)
> if (dx.lt.0.7) then
> i180=nint(180./dx)+1 ! 0.5 deg data
> else
> i180=nint(179./dx)+1 ! 1 deg data
> endif
> i181=i180+1
>
> if (isec1(6).ne.-1) then
>
> do j=0,nymin1
> do i=0,nxfield-1
> if((isec1(6).eq.011).and.(isec1(7).eq.100)) then
> ! TEMPERATURE
> if((i.eq.0).and.(j.eq.0)) then
> do ii=1,nuvz
> if ((isec1(8)*100.0).eq.akz(ii)) numpt=ii
> end do
> endif
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> tth(i179+i,j,numpt,n)=help
> else
> tth(i-i181,j,numpt,n)=help
> endif
> endif
> if((isec1(6).eq.033).and.(isec1(7).eq.100)) then
> ! U VELOCITY
> if((i.eq.0).and.(j.eq.0)) then
> do ii=1,nuvz
> if ((isec1(8)*100.0).eq.akz(ii)) numpu=ii
> end do
> endif
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> uuh(i179+i,j,numpu)=help
> else
> uuh(i-i181,j,numpu)=help
> endif
> endif
> if((isec1(6).eq.034).and.(isec1(7).eq.100)) then
> ! V VELOCITY
> if((i.eq.0).and.(j.eq.0)) then
> do ii=1,nuvz
> if ((isec1(8)*100.0).eq.akz(ii)) numpv=ii
> end do
> endif
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> vvh(i179+i,j,numpv)=help
> else
> vvh(i-i181,j,numpv)=help
> endif
> endif
> if((isec1(6).eq.052).and.(isec1(7).eq.100)) then
> ! RELATIVE HUMIDITY -> CONVERT TO SPECIFIC HUMIDITY LATER
> if((i.eq.0).and.(j.eq.0)) then
> do ii=1,nuvz
> if ((isec1(8)*100.0).eq.akz(ii)) numprh=ii
> end do
> endif
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> qvh(i179+i,j,numprh,n)=help
> else
> qvh(i-i181,j,numprh,n)=help
> endif
> endif
> if((isec1(6).eq.001).and.(isec1(7).eq.001)) then
> ! SURFACE PRESSURE
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> ps(i179+i,j,1,n)=help
> else
> ps(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.039).and.(isec1(7).eq.100)) then
> ! W VELOCITY
> if((i.eq.0).and.(j.eq.0)) then
> do ii=1,nuvz
> if ((isec1(8)*100.0).eq.akz(ii)) numpw=ii
> end do
> endif
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> wwh(i179+i,j,numpw)=help
> else
> wwh(i-i181,j,numpw)=help
> endif
> endif
> if((isec1(6).eq.066).and.(isec1(7).eq.001)) then
> ! SNOW DEPTH
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> sd(i179+i,j,1,n)=help
> else
> sd(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.002).and.(isec1(7).eq.102)) then
> ! MEAN SEA LEVEL PRESSURE
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> msl(i179+i,j,1,n)=help
> else
> msl(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.071).and.(isec1(7).eq.244)) then
> ! TOTAL CLOUD COVER
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> tcc(i179+i,j,1,n)=help
> else
> tcc(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.033).and.(isec1(7).eq.105).and. &
> (isec1(8).eq.10)) then
> ! 10 M U VELOCITY
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> u10(i179+i,j,1,n)=help
> else
> u10(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.034).and.(isec1(7).eq.105).and. &
> (isec1(8).eq.10)) then
> ! 10 M V VELOCITY
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> v10(i179+i,j,1,n)=help
> else
> v10(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.011).and.(isec1(7).eq.105).and. &
> (isec1(8).eq.02)) then
> ! 2 M TEMPERATURE
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> tt2(i179+i,j,1,n)=help
> else
> tt2(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.017).and.(isec1(7).eq.105).and. &
> (isec1(8).eq.02)) then
> ! 2 M DEW POINT TEMPERATURE
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> td2(i179+i,j,1,n)=help
> else
> td2(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.062).and.(isec1(7).eq.001)) then
> ! LARGE SCALE PREC.
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> lsprec(i179+i,j,1,n)=help
> else
> lsprec(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.063).and.(isec1(7).eq.001)) then
> ! CONVECTIVE PREC.
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> convprec(i179+i,j,1,n)=help
> else
> convprec(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.007).and.(isec1(7).eq.001)) then
> ! TOPOGRAPHY
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> oro(i179+i,j)=help
> excessoro(i179+i,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
> else
> oro(i-i181,j)=help
> excessoro(i-i181,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED
> endif
> endif
> if((isec1(6).eq.081).and.(isec1(7).eq.001)) then
> ! LAND SEA MASK
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> lsm(i179+i,j)=help
> else
> lsm(i-i181,j)=help
> endif
> endif
> if((isec1(6).eq.221).and.(isec1(7).eq.001)) then
> ! MIXING HEIGHT
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> hmix(i179+i,j,1,n)=help
> else
> hmix(i-i181,j,1,n)=help
> endif
> endif
> if((isec1(6).eq.052).and.(isec1(7).eq.105).and. &
> (isec1(8).eq.02)) then
> ! 2 M RELATIVE HUMIDITY
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> qvh2(i179+i,j)=help
> else
> qvh2(i-i181,j)=help
> endif
> endif
> if((isec1(6).eq.011).and.(isec1(7).eq.107)) then
> ! TEMPERATURE LOWEST SIGMA LEVEL
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> tlev1(i179+i,j)=help
> else
> tlev1(i-i181,j)=help
> endif
> endif
> if((isec1(6).eq.033).and.(isec1(7).eq.107)) then
> ! U VELOCITY LOWEST SIGMA LEVEL
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> ulev1(i179+i,j)=help
> else
> ulev1(i-i181,j)=help
> endif
> endif
> if((isec1(6).eq.034).and.(isec1(7).eq.107)) then
> ! V VELOCITY LOWEST SIGMA LEVEL
> help=zsec4(nxfield*(ny-j-1)+i+1)
> if(i.le.i180) then
> vlev1(i179+i,j)=help
> else
> vlev1(i-i181,j)=help
> endif
> endif
>
> end do
> end do
>
> endif
>
> if((isec1(6).eq.33).and.(isec1(7).eq.100)) then
> ! NCEP ISOBARIC LEVELS
> iumax=iumax+1
> endif
>
> call grib_release(igrib)
> goto 10 !! READ NEXT LEVEL OR PARAMETER
> !
> ! CLOSING OF INPUT DATA FILE
> !
>
> !HSO close grib file
> 50 continue
> call grib_close_file(ifile)
>
> ! SENS. HEAT FLUX
> sshf(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
> hflswitch=.false. ! Heat flux not available
> ! SOLAR RADIATIVE FLUXES
> ssr(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files
> ! EW SURFACE STRESS
> ewss=0.0 ! not available from gfs.tccz.pgrbfxx files
> ! NS SURFACE STRESS
> nsss=0.0 ! not available from gfs.tccz.pgrbfxx files
> strswitch=.false. ! stress not available
>
> ! CONVERT TP TO LSP (GRIB2 only)
> if (gribVer.eq.2) then
> do j=0,nymin1
> do i=0,nxfield-1
> if(i.le.i180) then
> if (convprec(i179+i,j,1,n).lt.lsprec(i179+i,j,1,n)) then ! neg precip would occur
> lsprec(i179+i,j,1,n)= &
> lsprec(i179+i,j,1,n)-convprec(i179+i,j,1,n)
> else
> lsprec(i179+i,j,1,n)=0
> endif
> else
> if (convprec(i-i181,j,1,n).lt.lsprec(i-i181,j,1,n)) then
> lsprec(i-i181,j,1,n)= &
> lsprec(i-i181,j,1,n)-convprec(i-i181,j,1,n)
> else
> lsprec(i-i181,j,1,n)=0
> endif
> endif
> enddo
> enddo
> endif
> !HSO end edits
>
>
> ! TRANSFORM RH TO SPECIFIC HUMIDITY
>
> do j=0,ny-1
> do i=0,nxfield-1
> do k=1,nuvz
> help=qvh(i,j,k,n)
> temp=tth(i,j,k,n)
> plev1=akm(k)+bkm(k)*ps(i,j,1,n)
> elev=ew(temp)*help/100.0
> qvh(i,j,k,n)=xmwml*(elev/(plev1-((1.0-xmwml)*elev)))
> end do
> end do
> end do
>
> ! CALCULATE 2 M DEW POINT FROM 2 M RELATIVE HUMIDITY
> ! USING BOLTON'S (1980) FORMULA
> ! BECAUSE td2 IS NOT AVAILABLE FROM NCEP GFS DATA
>
> do j=0,ny-1
> do i=0,nxfield-1
> elev = ew(tt2(i,j,1,n))/100.*qvh2(i,j)/100. !vapour pressure in hPa
> help = 243.5/(17.67/log(elev/6.112)-1)
> if (help.le.0.) then
> td2(i,j,1,n)=tt2(i,j,1,n)
> else
> td2(i,j,1,n)=help+273.15
> endif
> end do
> end do
>
> if(levdiff2.eq.0) then
> iwmax=nlev_ec+1
> do i=0,nxmin1
> do j=0,nymin1
> wwh(i,j,nlev_ec+1)=0.
> end do
> end do
> endif
>
>
> ! For global fields, assign the leftmost data column also to the rightmost
> ! data column; if required, shift whole grid by nxshift grid points
> !*************************************************************************
>
> if (xglobal) then
> call shift_field_0(ewss,nxfield,ny)
> call shift_field_0(nsss,nxfield,ny)
> call shift_field_0(oro,nxfield,ny)
> call shift_field_0(excessoro,nxfield,ny)
> call shift_field_0(lsm,nxfield,ny)
> call shift_field_0(ulev1,nxfield,ny)
> call shift_field_0(vlev1,nxfield,ny)
> call shift_field_0(tlev1,nxfield,ny)
> call shift_field_0(qvh2,nxfield,ny)
> call shift_field(ps,nxfield,ny,1,1,2,n)
> call shift_field(sd,nxfield,ny,1,1,2,n)
> call shift_field(msl,nxfield,ny,1,1,2,n)
> call shift_field(tcc,nxfield,ny,1,1,2,n)
> call shift_field(u10,nxfield,ny,1,1,2,n)
> call shift_field(v10,nxfield,ny,1,1,2,n)
> call shift_field(tt2,nxfield,ny,1,1,2,n)
> call shift_field(td2,nxfield,ny,1,1,2,n)
> call shift_field(lsprec,nxfield,ny,1,1,2,n)
> call shift_field(convprec,nxfield,ny,1,1,2,n)
> call shift_field(sshf,nxfield,ny,1,1,2,n)
> call shift_field(ssr,nxfield,ny,1,1,2,n)
> call shift_field(hmix,nxfield,ny,1,1,2,n)
> call shift_field(tth,nxfield,ny,nuvzmax,nuvz,2,n)
> call shift_field(qvh,nxfield,ny,nuvzmax,nuvz,2,n)
> call shift_field(uuh,nxfield,ny,nuvzmax,nuvz,1,1)
> call shift_field(vvh,nxfield,ny,nuvzmax,nuvz,1,1)
> call shift_field(wwh,nxfield,ny,nwzmax,nwz,1,1)
> endif
>
> do i=0,nxmin1
> do j=0,nymin1
> ! Convert precip. from mm/s -> mm/hour
> convprec(i,j,1,n)=convprec(i,j,1,n)*3600.
> lsprec(i,j,1,n)=lsprec(i,j,1,n)*3600.
> surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
> end do
> end do
>
> if ((.not.hflswitch).or.(.not.strswitch)) then
> ! write(*,*) 'WARNING: No flux data contained in GRIB file ',
> ! + wfname(indj)
>
> ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
> !***************************************************************************
>
> do i=0,nxmin1
> do j=0,nymin1
> hlev1=30.0 ! HEIGHT OF FIRST MODEL SIGMA LAYER
> ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2)
> fflev1=sqrt(ulev1(i,j)**2+vlev1(i,j)**2)
> call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, &
> tt2(i,j,1,n),tlev1(i,j),ff10m,fflev1, &
> surfstr(i,j,1,n),sshf(i,j,1,n))
> if(sshf(i,j,1,n).gt.200.) sshf(i,j,1,n)=200.
> if(sshf(i,j,1,n).lt.-400.) sshf(i,j,1,n)=-400.
> end do
> end do
> endif
>
>
> if(iumax.ne.nuvz) stop 'READWIND: NUVZ NOT CONSISTENT'
> if(iumax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT'
>
>
> return
>
> 888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
> write(*,*) ' #### ',wfname(indj),' #### '
> write(*,*) ' #### IS NOT GRIB FORMAT !!! #### '
> stop 'Execution terminated'
> 999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
> write(*,*) ' #### ',wfname(indj),' #### '
> write(*,*) ' #### CANNOT BE OPENED !!! #### '
> stop 'Execution terminated'
>
> end subroutine readwind
readwind_nests.f90
----------------------------------------------
1,420c1,420
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine readwind_nests(indj,n,uuhn,vvhn,wwhn)
< ! i i o o o
< !*****************************************************************************
< ! *
< ! This routine reads the wind fields for the nested model domains. *
< ! It is similar to subroutine readwind, which reads the mother domain. *
< ! *
< ! Authors: A. Stohl, G. Wotawa *
< ! *
< ! 8 February 1999 *
< ! *
< ! Last update: 17 October 2000, A. Stohl *
< ! *
< !*****************************************************************************
< ! Changes, Bernd C. Krueger, Feb. 2001: *
< ! Variables tthn and qvhn (on eta coordinates) in common block *
< ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api *
< ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with ECMWF grib_api *
< !*****************************************************************************
<
< use grib_api
< use par_mod
< use com_mod
<
< implicit none
<
< !HSO parameters for grib_api
< integer :: ifile
< integer :: iret
< integer :: igrib
< integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
< integer :: gotGrid
< !HSO end
<
< real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
< integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax,l
<
< ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
<
< ! dimension of isec2 at least (22+n), where n is the number of parallels or
< ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
<
< ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
< ! coordinate parameters
<
< integer :: isec1(56),isec2(22+nxmaxn+nymaxn)
< real(kind=4) :: zsec4(jpunp)
< real(kind=8) :: xauxin,yauxin
< real(kind=4) :: xaux,yaux,xaux0,yaux0
< real :: ewss(0:nxmaxn-1,0:nymaxn-1),nsss(0:nxmaxn-1,0:nymaxn-1)
< real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1
<
< logical :: hflswitch,strswitch
<
< !HSO grib api error messages
< character(len=24) :: gribErrorMsg = 'Error reading grib file'
< character(len=20) :: gribFunction = 'readwind_nests'
<
< do l=1,numbnests
< hflswitch=.false.
< strswitch=.false.
< levdiff2=nlev_ec-nwz+1
< iumax=0
< iwmax=0
<
< ifile=0
< igrib=0
< iret=0
<
< !
< ! OPENING OF DATA FILE (GRIB CODE)
< !
<
< 5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) &
< (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,indj)),'r')
< if (iret.ne.GRIB_SUCCESS) then
< goto 888 ! ERROR DETECTED
< endif
< !turn on support for multi fields messages */
< !call grib_multi_support_on
<
< gotGrid=0
< ifield=0
< 10 ifield=ifield+1
< !
< ! GET NEXT FIELDS
< !
< call grib_new_from_file(ifile,igrib,iret)
< if (iret.eq.GRIB_END_OF_FILE) then
< goto 50 ! EOF DETECTED
< elseif (iret.ne.GRIB_SUCCESS) then
< goto 888 ! ERROR DETECTED
< endif
<
< !first see if we read GRIB1 or GRIB2
< call grib_get_int(igrib,'editionNumber',gribVer,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< if (gribVer.eq.1) then ! GRIB Edition 1
<
< !print*,'GRiB Edition 1'
< !read the grib2 identifiers
< call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',isec1(8),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !change code for etadot to code for omega
< if (isec1(6).eq.77) then
< isec1(6)=135
< endif
<
< else
<
< !print*,'GRiB Edition 2'
< !read the grib2 identifiers
< call grib_get_int(igrib,'discipline',discipl,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterCategory',parCat,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'parameterNumber',parNum,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'level',valSurf,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
<
< !print*,discipl,parCat,parNum,typSurf,valSurf
<
< !convert to grib1 identifiers
< isec1(6)=-1
< isec1(7)=-1
< isec1(8)=-1
< isec1(8)=valSurf ! level
< if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
< isec1(6)=130 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
< isec1(6)=131 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
< isec1(6)=132 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
< isec1(6)=133 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
< isec1(6)=134 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
< isec1(6)=135 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
< isec1(6)=151 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
< isec1(6)=165 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
< isec1(6)=166 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
< isec1(6)=167 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
< isec1(6)=168 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
< isec1(6)=141 ! indicatorOfParameter
< elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
< isec1(6)=164 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
< isec1(6)=142 ! indicatorOfParameter
< elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
< isec1(6)=143 ! indicatorOfParameter
< elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
< isec1(6)=146 ! indicatorOfParameter
< elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
< isec1(6)=176 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
< isec1(6)=180 ! indicatorOfParameter
< elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
< isec1(6)=181 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
< isec1(6)=129 ! indicatorOfParameter
< elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
< isec1(6)=160 ! indicatorOfParameter
< elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
< (typSurf.eq.1)) then ! LSM
< isec1(6)=172 ! indicatorOfParameter
< else
< print*,'***ERROR: undefined GRiB2 message found!',discipl, &
< parCat,parNum,typSurf
< endif
<
< endif
<
< !HSO get the size and data of the values array
< if (isec1(6).ne.-1) then
< call grib_get_real4_array(igrib,'values',zsec4,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< endif
<
< !HSO get the required fields from section 2 in a gribex compatible manner
< if(ifield.eq.1) then
< call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
< isec2(2),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
< isec2(3),iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
< isec2(12))
< call grib_check(iret,gribFunction,gribErrorMsg)
< ! CHECK GRID SPECIFICATIONS
< if(isec2(2).ne.nxn(l)) stop &
< 'READWIND: NX NOT CONSISTENT FOR A NESTING LEVEL'
< if(isec2(3).ne.nyn(l)) stop &
< 'READWIND: NY NOT CONSISTENT FOR A NESTING LEVEL'
< if(isec2(12)/2-1.ne.nlev_ec) stop 'READWIND: VERTICAL DISCRET&
< &IZATION NOT CONSISTENT FOR A NESTING LEVEL'
< endif ! ifield
<
< !HSO get the second part of the grid dimensions only from GRiB1 messages
< if ((gribVer.eq.1).and.(gotGrid.eq.0)) then
< call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
< xauxin,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
< yauxin,iret)
< call grib_check(iret,gribFunction,gribErrorMsg)
< xaux=xauxin
< yaux=yauxin
< xaux0=xlon0n(l)
< yaux0=ylat0n(l)
< if(xaux.lt.0.) xaux=xaux+360.
< if(yaux.lt.0.) yaux=yaux+360.
< if(xaux0.lt.0.) xaux0=xaux0+360.
< if(yaux0.lt.0.) yaux0=yaux0+360.
< if(xaux.ne.xaux0) &
< stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT FOR A NES&
< &TING LEVEL'
< if(yaux.ne.yaux0) &
< stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT FOR A NEST&
< &ING LEVEL'
< gotGrid=1
< endif
<
< do j=0,nyn(l)-1
< do i=0,nxn(l)-1
< k=isec1(8)
< if(isec1(6).eq.130) tthn(i,j,nlev_ec-k+2,n,l)= &!! TEMPERATURE
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.131) uuhn(i,j,nlev_ec-k+2,l)= &!! U VELOCITY
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.132) vvhn(i,j,nlev_ec-k+2,l)= &!! V VELOCITY
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.133) then !! SPEC. HUMIDITY
< qvhn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if (qvhn(i,j,nlev_ec-k+2,n,l) .lt. 0.) &
< qvhn(i,j,nlev_ec-k+2,n,l) = 0.
< ! this is necessary because the gridded data may contain
< ! spurious negative values
< endif
< if(isec1(6).eq.134) psn(i,j,1,n,l)= &!! SURF. PRESS.
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.135) wwhn(i,j,nlev_ec-k+1,l)= &!! W VELOCITY
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.141) sdn(i,j,1,n,l)= &!! SNOW DEPTH
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.151) msln(i,j,1,n,l)= &!! SEA LEVEL PRESS.
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.164) tccn(i,j,1,n,l)= &!! CLOUD COVER
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.165) u10n(i,j,1,n,l)= &!! 10 M U VELOCITY
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.166) v10n(i,j,1,n,l)= &!! 10 M V VELOCITY
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.167) tt2n(i,j,1,n,l)= &!! 2 M TEMPERATURE
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.168) td2n(i,j,1,n,l)= &!! 2 M DEW POINT
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.142) then !! LARGE SCALE PREC.
< lsprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if (lsprecn(i,j,1,n,l).lt.0.) lsprecn(i,j,1,n,l)=0.
< endif
< if(isec1(6).eq.143) then !! CONVECTIVE PREC.
< convprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if (convprecn(i,j,1,n,l).lt.0.) convprecn(i,j,1,n,l)=0.
< endif
< if(isec1(6).eq.146) sshfn(i,j,1,n,l)= &!! SENS. HEAT FLUX
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if((isec1(6).eq.146).and. &
< (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) hflswitch=.true. ! Heat flux available
< if(isec1(6).eq.176) then !! SOLAR RADIATION
< ssrn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if (ssrn(i,j,1,n,l).lt.0.) ssrn(i,j,1,n,l)=0.
< endif
< if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
< (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
< if(isec1(6).eq.129) oron(i,j,l)= &!! ECMWF OROGRAPHY
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
< if(isec1(6).eq.160) excessoron(i,j,l)= &!! STANDARD DEVIATION OF OROGRAPHY
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.172) lsmn(i,j,l)= &!! ECMWF LAND SEA MASK
< zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
< if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
< if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
<
< end do
< end do
<
< call grib_release(igrib)
< goto 10 !! READ NEXT LEVEL OR PARAMETER
< !
< ! CLOSING OF INPUT DATA FILE
< !
< 50 call grib_close_file(ifile)
<
< !error message if no fields found with correct first longitude in it
< if (gotGrid.eq.0) then
< print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
< 'messages'
< stop
< endif
<
< if(levdiff2.eq.0) then
< iwmax=nlev_ec+1
< do i=0,nxn(l)-1
< do j=0,nyn(l)-1
< wwhn(i,j,nlev_ec+1,l)=0.
< end do
< end do
< endif
<
< do i=0,nxn(l)-1
< do j=0,nyn(l)-1
< surfstrn(i,j,1,n,l)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
< end do
< end do
<
< if ((.not.hflswitch).or.(.not.strswitch)) then
< write(*,*) 'WARNING: No flux data contained in GRIB file ', &
< wfnamen(l,indj)
<
< ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
< ! As ECMWF has increased the model resolution, such that now the first model
< ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
< ! (3rd model level in FLEXPART) for the profile method
< !***************************************************************************
<
< do i=0,nxn(l)-1
< do j=0,nyn(l)-1
< plev1=akz(3)+bkz(3)*psn(i,j,1,n,l)
< pmean=0.5*(psn(i,j,1,n,l)+plev1)
< tv=tthn(i,j,3,n,l)*(1.+0.61*qvhn(i,j,3,n,l))
< fu=-r_air*tv/ga/pmean
< hlev1=fu*(plev1-psn(i,j,1,n,l)) ! HEIGTH OF FIRST MODEL LAYER
< ff10m= sqrt(u10n(i,j,1,n,l)**2+v10n(i,j,1,n,l)**2)
< fflev1=sqrt(uuhn(i,j,3,l)**2+vvhn(i,j,3,l)**2)
< call pbl_profile(psn(i,j,1,n,l),td2n(i,j,1,n,l),hlev1, &
< tt2n(i,j,1,n,l),tthn(i,j,3,n,l),ff10m,fflev1, &
< surfstrn(i,j,1,n,l),sshfn(i,j,1,n,l))
< if(sshfn(i,j,1,n,l).gt.200.) sshfn(i,j,1,n,l)=200.
< if(sshfn(i,j,1,n,l).lt.-400.) sshfn(i,j,1,n,l)=-400.
< end do
< end do
< endif
<
<
< ! Assign 10 m wind to model level at eta=1.0 to have one additional model
< ! level at the ground
< ! Specific humidity is taken the same as at one level above
< ! Temperature is taken as 2 m temperature
< !**************************************************************************
<
< do i=0,nxn(l)-1
< do j=0,nyn(l)-1
< uuhn(i,j,1,l)=u10n(i,j,1,n,l)
< vvhn(i,j,1,l)=v10n(i,j,1,n,l)
< qvhn(i,j,1,n,l)=qvhn(i,j,2,n,l)
< tthn(i,j,1,n,l)=tt2n(i,j,1,n,l)
< end do
< end do
<
< if(iumax.ne.nuvz-1) stop &
< 'READWIND: NUVZ NOT CONSISTENT FOR A NESTING LEVEL'
< if(iwmax.ne.nwz) stop &
< 'READWIND: NWZ NOT CONSISTENT FOR A NESTING LEVEL'
<
< end do
<
< return
< 888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
< write(*,*) ' #### ',wfnamen(l,indj),' FOR NESTING LEVEL #### '
< write(*,*) ' #### ',l,' IS NOT GRIB FORMAT !!! #### '
< stop 'Execution terminated'
<
<
< 999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
< write(*,*) ' #### ',wfnamen(l,indj),' #### '
< write(*,*) ' #### CANNOT BE OPENED FOR NESTING LEVEL ',l,'####'
<
< end subroutine readwind_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine readwind_nests(indj,n,uuhn,vvhn,wwhn)
> ! i i o o o
> !*****************************************************************************
> ! *
> ! This routine reads the wind fields for the nested model domains. *
> ! It is similar to subroutine readwind, which reads the mother domain. *
> ! *
> ! Authors: A. Stohl, G. Wotawa *
> ! *
> ! 8 February 1999 *
> ! *
> ! Last update: 17 October 2000, A. Stohl *
> ! *
> !*****************************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001: *
> ! Variables tthn and qvhn (on eta coordinates) in common block *
> ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api *
> ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with ECMWF grib_api *
> !*****************************************************************************
>
> use grib_api
> use par_mod
> use com_mod
>
> implicit none
>
> !HSO parameters for grib_api
> integer :: ifile
> integer :: iret
> integer :: igrib
> integer :: gribVer,parCat,parNum,typSurf,valSurf,discipl
> integer :: gotGrid
> !HSO end
>
> real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
> integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax,l
>
> ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING
>
> ! dimension of isec2 at least (22+n), where n is the number of parallels or
> ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid
>
> ! dimension of zsec2 at least (10+nn), where nn is the number of vertical
> ! coordinate parameters
>
> integer :: isec1(56),isec2(22+nxmaxn+nymaxn)
> real(kind=4) :: zsec4(jpunp)
> real(kind=8) :: xauxin,yauxin
> real(kind=4) :: xaux,yaux,xaux0,yaux0
> real :: ewss(0:nxmaxn-1,0:nymaxn-1),nsss(0:nxmaxn-1,0:nymaxn-1)
> real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1
>
> logical :: hflswitch,strswitch
>
> !HSO grib api error messages
> character(len=24) :: gribErrorMsg = 'Error reading grib file'
> character(len=20) :: gribFunction = 'readwind_nests'
>
> do l=1,numbnests
> hflswitch=.false.
> strswitch=.false.
> levdiff2=nlev_ec-nwz+1
> iumax=0
> iwmax=0
>
> ifile=0
> igrib=0
> iret=0
>
> !
> ! OPENING OF DATA FILE (GRIB CODE)
> !
>
> 5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) &
> (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,indj)),'r')
> if (iret.ne.GRIB_SUCCESS) then
> goto 888 ! ERROR DETECTED
> endif
> !turn on support for multi fields messages */
> !call grib_multi_support_on
>
> gotGrid=0
> ifield=0
> 10 ifield=ifield+1
> !
> ! GET NEXT FIELDS
> !
> call grib_new_from_file(ifile,igrib,iret)
> if (iret.eq.GRIB_END_OF_FILE) then
> goto 50 ! EOF DETECTED
> elseif (iret.ne.GRIB_SUCCESS) then
> goto 888 ! ERROR DETECTED
> endif
>
> !first see if we read GRIB1 or GRIB2
> call grib_get_int(igrib,'editionNumber',gribVer,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> if (gribVer.eq.1) then ! GRIB Edition 1
>
> !print*,'GRiB Edition 1'
> !read the grib2 identifiers
> call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',isec1(8),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !change code for etadot to code for omega
> if (isec1(6).eq.77) then
> isec1(6)=135
> endif
>
> else
>
> !print*,'GRiB Edition 2'
> !read the grib2 identifiers
> call grib_get_int(igrib,'discipline',discipl,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterCategory',parCat,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'parameterNumber',parNum,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'typeOfFirstFixedSurface',typSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'level',valSurf,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
>
> !print*,discipl,parCat,parNum,typSurf,valSurf
>
> !convert to grib1 identifiers
> isec1(6)=-1
> isec1(7)=-1
> isec1(8)=-1
> isec1(8)=valSurf ! level
> if ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! T
> isec1(6)=130 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.105)) then ! U
> isec1(6)=131 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.105)) then ! V
> isec1(6)=132 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.0).and.(typSurf.eq.105)) then ! Q
> isec1(6)=133 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.1)) then !SP
> isec1(6)=134 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot
> isec1(6)=135 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.0).and.(typSurf.eq.101)) then !SLP
> isec1(6)=151 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.2).and.(typSurf.eq.103)) then ! 10U
> isec1(6)=165 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.3).and.(typSurf.eq.103)) then ! 10V
> isec1(6)=166 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.0).and.(typSurf.eq.103)) then ! 2T
> isec1(6)=167 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.6).and.(typSurf.eq.103)) then ! 2D
> isec1(6)=168 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SD
> isec1(6)=141 ! indicatorOfParameter
> elseif ((parCat.eq.6).and.(parNum.eq.1)) then ! CC
> isec1(6)=164 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.9)) then ! LSP
> isec1(6)=142 ! indicatorOfParameter
> elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP
> isec1(6)=143 ! indicatorOfParameter
> elseif ((parCat.eq.0).and.(parNum.eq.11).and.(typSurf.eq.1)) then ! SHF
> isec1(6)=146 ! indicatorOfParameter
> elseif ((parCat.eq.4).and.(parNum.eq.9).and.(typSurf.eq.1)) then ! SR
> isec1(6)=176 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.17)) then ! EWSS
> isec1(6)=180 ! indicatorOfParameter
> elseif ((parCat.eq.2).and.(parNum.eq.18)) then ! NSSS
> isec1(6)=181 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO
> isec1(6)=129 ! indicatorOfParameter
> elseif ((parCat.eq.3).and.(parNum.eq.7)) then ! SDO
> isec1(6)=160 ! indicatorOfParameter
> elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. &
> (typSurf.eq.1)) then ! LSM
> isec1(6)=172 ! indicatorOfParameter
> else
> print*,'***ERROR: undefined GRiB2 message found!',discipl, &
> parCat,parNum,typSurf
> endif
>
> endif
>
> !HSO get the size and data of the values array
> if (isec1(6).ne.-1) then
> call grib_get_real4_array(igrib,'values',zsec4,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> endif
>
> !HSO get the required fields from section 2 in a gribex compatible manner
> if(ifield.eq.1) then
> call grib_get_int(igrib,'numberOfPointsAlongAParallel', &
> isec2(2),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfPointsAlongAMeridian', &
> isec2(3),iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_int(igrib,'numberOfVerticalCoordinateValues', &
> isec2(12))
> call grib_check(iret,gribFunction,gribErrorMsg)
> ! CHECK GRID SPECIFICATIONS
> if(isec2(2).ne.nxn(l)) stop &
> 'READWIND: NX NOT CONSISTENT FOR A NESTING LEVEL'
> if(isec2(3).ne.nyn(l)) stop &
> 'READWIND: NY NOT CONSISTENT FOR A NESTING LEVEL'
> if(isec2(12)/2-1.ne.nlev_ec) stop 'READWIND: VERTICAL DISCRET&
> &IZATION NOT CONSISTENT FOR A NESTING LEVEL'
> endif ! ifield
>
> !HSO get the second part of the grid dimensions only from GRiB1 messages
> if ((gribVer.eq.1).and.(gotGrid.eq.0)) then
> call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', &
> xauxin,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', &
> yauxin,iret)
> call grib_check(iret,gribFunction,gribErrorMsg)
> xaux=xauxin
> yaux=yauxin
> xaux0=xlon0n(l)
> yaux0=ylat0n(l)
> if(xaux.lt.0.) xaux=xaux+360.
> if(yaux.lt.0.) yaux=yaux+360.
> if(xaux0.lt.0.) xaux0=xaux0+360.
> if(yaux0.lt.0.) yaux0=yaux0+360.
> if(xaux.ne.xaux0) &
> stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT FOR A NES&
> &TING LEVEL'
> if(yaux.ne.yaux0) &
> stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT FOR A NEST&
> &ING LEVEL'
> gotGrid=1
> endif
>
> do j=0,nyn(l)-1
> do i=0,nxn(l)-1
> k=isec1(8)
> if(isec1(6).eq.130) tthn(i,j,nlev_ec-k+2,n,l)= &!! TEMPERATURE
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.131) uuhn(i,j,nlev_ec-k+2,l)= &!! U VELOCITY
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.132) vvhn(i,j,nlev_ec-k+2,l)= &!! V VELOCITY
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.133) then !! SPEC. HUMIDITY
> qvhn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if (qvhn(i,j,nlev_ec-k+2,n,l) .lt. 0.) &
> qvhn(i,j,nlev_ec-k+2,n,l) = 0.
> ! this is necessary because the gridded data may contain
> ! spurious negative values
> endif
> if(isec1(6).eq.134) psn(i,j,1,n,l)= &!! SURF. PRESS.
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.135) wwhn(i,j,nlev_ec-k+1,l)= &!! W VELOCITY
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.141) sdn(i,j,1,n,l)= &!! SNOW DEPTH
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.151) msln(i,j,1,n,l)= &!! SEA LEVEL PRESS.
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.164) tccn(i,j,1,n,l)= &!! CLOUD COVER
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.165) u10n(i,j,1,n,l)= &!! 10 M U VELOCITY
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.166) v10n(i,j,1,n,l)= &!! 10 M V VELOCITY
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.167) tt2n(i,j,1,n,l)= &!! 2 M TEMPERATURE
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.168) td2n(i,j,1,n,l)= &!! 2 M DEW POINT
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.142) then !! LARGE SCALE PREC.
> lsprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if (lsprecn(i,j,1,n,l).lt.0.) lsprecn(i,j,1,n,l)=0.
> endif
> if(isec1(6).eq.143) then !! CONVECTIVE PREC.
> convprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if (convprecn(i,j,1,n,l).lt.0.) convprecn(i,j,1,n,l)=0.
> endif
> if(isec1(6).eq.146) sshfn(i,j,1,n,l)= &!! SENS. HEAT FLUX
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if((isec1(6).eq.146).and. &
> (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) hflswitch=.true. ! Heat flux available
> if(isec1(6).eq.176) then !! SOLAR RADIATION
> ssrn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if (ssrn(i,j,1,n,l).lt.0.) ssrn(i,j,1,n,l)=0.
> endif
> if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. &
> (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available
> if(isec1(6).eq.129) oron(i,j,l)= &!! ECMWF OROGRAPHY
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga
> if(isec1(6).eq.160) excessoron(i,j,l)= &!! STANDARD DEVIATION OF OROGRAPHY
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.172) lsmn(i,j,l)= &!! ECMWF LAND SEA MASK
> zsec4(nxn(l)*(nyn(l)-j-1)+i+1)
> if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1)
> if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1)
>
> end do
> end do
>
> call grib_release(igrib)
> goto 10 !! READ NEXT LEVEL OR PARAMETER
> !
> ! CLOSING OF INPUT DATA FILE
> !
> 50 call grib_close_file(ifile)
>
> !error message if no fields found with correct first longitude in it
> if (gotGrid.eq.0) then
> print*,'***ERROR: input file needs to contain GRiB1 formatted'// &
> 'messages'
> stop
> endif
>
> if(levdiff2.eq.0) then
> iwmax=nlev_ec+1
> do i=0,nxn(l)-1
> do j=0,nyn(l)-1
> wwhn(i,j,nlev_ec+1,l)=0.
> end do
> end do
> endif
>
> do i=0,nxn(l)-1
> do j=0,nyn(l)-1
> surfstrn(i,j,1,n,l)=sqrt(ewss(i,j)**2+nsss(i,j)**2)
> end do
> end do
>
> if ((.not.hflswitch).or.(.not.strswitch)) then
> write(*,*) 'WARNING: No flux data contained in GRIB file ', &
> wfnamen(l,indj)
>
> ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD
> ! As ECMWF has increased the model resolution, such that now the first model
> ! level is at about 10 m (where 10-m wind is given), use the 2nd ECMWF level
> ! (3rd model level in FLEXPART) for the profile method
> !***************************************************************************
>
> do i=0,nxn(l)-1
> do j=0,nyn(l)-1
> plev1=akz(3)+bkz(3)*psn(i,j,1,n,l)
> pmean=0.5*(psn(i,j,1,n,l)+plev1)
> tv=tthn(i,j,3,n,l)*(1.+0.61*qvhn(i,j,3,n,l))
> fu=-r_air*tv/ga/pmean
> hlev1=fu*(plev1-psn(i,j,1,n,l)) ! HEIGTH OF FIRST MODEL LAYER
> ff10m= sqrt(u10n(i,j,1,n,l)**2+v10n(i,j,1,n,l)**2)
> fflev1=sqrt(uuhn(i,j,3,l)**2+vvhn(i,j,3,l)**2)
> call pbl_profile(psn(i,j,1,n,l),td2n(i,j,1,n,l),hlev1, &
> tt2n(i,j,1,n,l),tthn(i,j,3,n,l),ff10m,fflev1, &
> surfstrn(i,j,1,n,l),sshfn(i,j,1,n,l))
> if(sshfn(i,j,1,n,l).gt.200.) sshfn(i,j,1,n,l)=200.
> if(sshfn(i,j,1,n,l).lt.-400.) sshfn(i,j,1,n,l)=-400.
> end do
> end do
> endif
>
>
> ! Assign 10 m wind to model level at eta=1.0 to have one additional model
> ! level at the ground
> ! Specific humidity is taken the same as at one level above
> ! Temperature is taken as 2 m temperature
> !**************************************************************************
>
> do i=0,nxn(l)-1
> do j=0,nyn(l)-1
> uuhn(i,j,1,l)=u10n(i,j,1,n,l)
> vvhn(i,j,1,l)=v10n(i,j,1,n,l)
> qvhn(i,j,1,n,l)=qvhn(i,j,2,n,l)
> tthn(i,j,1,n,l)=tt2n(i,j,1,n,l)
> end do
> end do
>
> if(iumax.ne.nuvz-1) stop &
> 'READWIND: NUVZ NOT CONSISTENT FOR A NESTING LEVEL'
> if(iwmax.ne.nwz) stop &
> 'READWIND: NWZ NOT CONSISTENT FOR A NESTING LEVEL'
>
> end do
>
> return
> 888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
> write(*,*) ' #### ',wfnamen(l,indj),' FOR NESTING LEVEL #### '
> write(*,*) ' #### ',l,' IS NOT GRIB FORMAT !!! #### '
> stop 'Execution terminated'
>
>
> 999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### '
> write(*,*) ' #### ',wfnamen(l,indj),' #### '
> write(*,*) ' #### CANNOT BE OPENED FOR NESTING LEVEL ',l,'####'
>
> end subroutine readwind_nests
redist.f90
----------------------------------------------
1,253c1,254
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine redist (ipart,ktop,ipconv)
<
< !**************************************************************************
< ! Do the redistribution of particles due to convection
< ! This subroutine is called for each particle which is assigned
< ! a new vertical position randomly, based on the convective redistribution
< ! matrix
< !**************************************************************************
<
< ! Petra Seibert, Feb 2001, Apr 2001, May 2001, Jan 2002, Nov 2002 and
< ! Andreas Frank, Nov 2002
<
< ! Caroline Forster: November 2004 - February 2005
<
< use par_mod
< use com_mod
< use conv_mod
<
< implicit none
<
< real,parameter :: const=r_air/ga
< integer :: ipart, ktop,ipconv
< integer :: k, kz, levnew, levold
< real,save :: uvzlev(nuvzmax)
< real :: wsub(nuvzmax)
< real :: totlevmass, wsubpart
< real :: temp_levold,temp_levold1
< real :: sub_levold,sub_levold1
< real :: pint, pold, rn, tv, tvold, dlevfrac
< real :: ew,ran3, ztold,ffraction
< real :: tv1, tv2, dlogp, dz, dz1, dz2
< integer :: iseed = -88
<
< ! ipart ... number of particle to be treated
<
< ipconv=1
<
< ! determine height of the eta half-levels (uvzlev)
< ! do that only once for each grid column
< ! i.e. when ktop.eq.1
< !**************************************************************
<
< if (ktop .le. 1) then
<
< tvold=tt2conv*(1.+0.378*ew(td2conv)/psconv)
< pold=psconv
< uvzlev(1)=0.
<
< pint = phconv(2)
< ! determine next virtual temperatures
< tv1 = tconv(1)*(1.+0.608*qconv(1))
< tv2 = tconv(2)*(1.+0.608*qconv(2))
< ! interpolate virtual temperature to half-level
< tv = tv1 + (tv2-tv1)*(pconv(1)-phconv(2))/(pconv(1)-pconv(2))
< if (abs(tv-tvold).gt.0.2) then
< uvzlev(2) = uvzlev(1) + &
< const*log(pold/pint)* &
< (tv-tvold)/log(tv/tvold)
< else
< uvzlev(2) = uvzlev(1)+ &
< const*log(pold/pint)*tv
< endif
< tvold=tv
< tv1=tv2
< pold=pint
<
< ! integrate profile (calculation of height agl of eta layers) as required
< do kz = 3, nconvtop+1
< ! note that variables defined in calcmatrix.f (pconv,tconv,qconv)
< ! start at the first real ECMWF model level whereas kz and
< ! thus uvzlev(kz) starts at the surface. uvzlev is defined at the
< ! half-levels (between the tconv, qconv etc. values !)
< ! Thus, uvzlev(kz) is the lower boundary of the tconv(kz) cell.
< pint = phconv(kz)
< ! determine next virtual temperatures
< tv2 = tconv(kz)*(1.+0.608*qconv(kz))
< ! interpolate virtual temperature to half-level
< tv = tv1 + (tv2-tv1)*(pconv(kz-1)-phconv(kz))/ &
< (pconv(kz-1)-pconv(kz))
< if (abs(tv-tvold).gt.0.2) then
< uvzlev(kz) = uvzlev(kz-1) + &
< const*log(pold/pint)* &
< (tv-tvold)/log(tv/tvold)
< else
< uvzlev(kz) = uvzlev(kz-1)+ &
< const*log(pold/pint)*tv
< endif
< tvold=tv
< tv1=tv2
< pold=pint
<
< end do
<
< ktop = 2
<
< endif ! (if ktop .le. 1) then
<
< ! determine vertical grid position of particle in the eta system
< !****************************************************************
<
< ztold = ztra1(abs(ipart))
< ! find old particle grid position
< do kz = 2, nconvtop
< if (uvzlev(kz) .ge. ztold ) then
< levold = kz-1
< goto 30
< endif
< end do
<
< ! Particle is above the potentially convective domain. Skip it.
< goto 90
<
< 30 continue
<
< ! now redistribute particles
< !****************************
<
< ! Choose a random number and find corresponding level of destination
< ! Random numbers to be evenly distributed in [0,1]
<
< rn = ran3(iseed)
<
< ! initialize levnew
<
< levnew = levold
<
< ffraction = 0.
< totlevmass=dpr(levold)/ga
< do k = 1,nconvtop
< ! for backward runs use the transposed matrix
< if (ldirect.eq.1) then
< ffraction=ffraction+fmassfrac(levold,k) &
< /totlevmass
< else
< ffraction=ffraction+fmassfrac(k,levold) &
< /totlevmass
< endif
< if (rn.le.ffraction) then
< levnew=k
< ! avoid division by zero or a too small number
< ! if division by zero or a too small number happens the
< ! particle is assigned to the center of the grid cell
< if (ffraction.gt.1.e-20) then
< if (ldirect.eq.1) then
< dlevfrac = (ffraction-rn) / fmassfrac(levold,k) * totlevmass
< else
< dlevfrac = (ffraction-rn) / fmassfrac(k,levold) * totlevmass
< endif
< else
< dlevfrac = 0.5
< endif
< goto 40
< endif
< end do
<
< 40 continue
<
< ! now assign new position to particle
<
< if (levnew.le.nconvtop) then
< if (levnew.eq.levold) then
< ztra1(abs(ipart)) = ztold
< else
< dlogp = (1.-dlevfrac)* &
< (log(phconv(levnew+1))-log(phconv(levnew)))
< pint = log(phconv(levnew))+dlogp
< dz1 = pint - log(phconv(levnew))
< dz2 = log(phconv(levnew+1)) - pint
< dz = dz1 + dz2
< ztra1(abs(ipart)) = (uvzlev(levnew)*dz2+uvzlev(levnew+1)*dz1)/dz
< if (ztra1(abs(ipart)).lt.0.) &
< ztra1(abs(ipart))=-1.*ztra1(abs(ipart))
< if (ipconv.gt.0) ipconv=-1
< endif
< endif
<
< ! displace particle according to compensating subsidence
< ! this is done to those particles, that were not redistributed
< ! by the matrix
< !**************************************************************
<
< if (levnew.le.nconvtop.and.levnew.eq.levold) then
<
< ztold = ztra1(abs(ipart))
<
< ! determine compensating vertical velocity at the levels
< ! above and below the particel position
< ! increase compensating subsidence by the fraction that
< ! is displaced by convection to this level
<
< if (levold.gt.1) then
< temp_levold = tconv(levold-1) + &
< (tconv(levold)-tconv(levold-1)) &
< *(pconv(levold-1)-phconv(levold))/ &
< (pconv(levold-1)-pconv(levold))
< sub_levold = sub(levold)/(1.-sub(levold)/dpr(levold)*ga)
< wsub(levold)=-1.*sub_levold*r_air*temp_levold/(phconv(levold))
< else
< wsub(levold)=0.
< endif
<
< temp_levold1 = tconv(levold) + &
< (tconv(levold+1)-tconv(levold)) &
< *(pconv(levold)-phconv(levold+1))/ &
< (pconv(levold)-pconv(levold+1))
< sub_levold1 = sub(levold+1)/(1.-sub(levold+1)/dpr(levold+1)*ga)
< wsub(levold+1)=-1.*sub_levold1*r_air*temp_levold1/ &
< (phconv(levold+1))
<
< ! interpolate wsub to the vertical particle position
<
< dz1 = ztold - uvzlev(levold)
< dz2 = uvzlev(levold+1) - ztold
< dz = dz1 + dz2
<
< wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz
< ztra1(abs(ipart)) = ztold+wsubpart*real(lsynctime)
< if (ztra1(abs(ipart)).lt.0.) then
< ztra1(abs(ipart))=-1.*ztra1(abs(ipart))
< endif
<
< endif !(levnew.le.nconvtop.and.levnew.eq.levold)
<
< ! Maximum altitude .5 meter below uppermost model level
< !*******************************************************
<
< 90 continue
<
< if (ztra1(abs(ipart)) .gt. height(nz)-0.5) &
< ztra1(abs(ipart)) = height(nz)-0.5
<
< end subroutine redist
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine redist (ipart,ktop,ipconv)
>
> !**************************************************************************
> ! Do the redistribution of particles due to convection
> ! This subroutine is called for each particle which is assigned
> ! a new vertical position randomly, based on the convective redistribution
> ! matrix
> !**************************************************************************
>
> ! Petra Seibert, Feb 2001, Apr 2001, May 2001, Jan 2002, Nov 2002 and
> ! Andreas Frank, Nov 2002
>
> ! Caroline Forster: November 2004 - February 2005
>
> use par_mod
> use com_mod
> use conv_mod
> use random_mod, only: ran3
>
> implicit none
>
> real,parameter :: const=r_air/ga
> integer :: ipart, ktop,ipconv
> integer :: k, kz, levnew, levold
> real,save :: uvzlev(nuvzmax)
> real :: wsub(nuvzmax)
> real :: totlevmass, wsubpart
> real :: temp_levold,temp_levold1
> real :: sub_levold,sub_levold1
> real :: pint, pold, rn, tv, tvold, dlevfrac
> real :: ew,ztold,ffraction
> real :: tv1, tv2, dlogp, dz, dz1, dz2
> integer :: iseed = -88
>
> ! ipart ... number of particle to be treated
>
> ipconv=1
>
> ! determine height of the eta half-levels (uvzlev)
> ! do that only once for each grid column
> ! i.e. when ktop.eq.1
> !**************************************************************
>
> if (ktop .le. 1) then
>
> tvold=tt2conv*(1.+0.378*ew(td2conv)/psconv)
> pold=psconv
> uvzlev(1)=0.
>
> pint = phconv(2)
> ! determine next virtual temperatures
> tv1 = tconv(1)*(1.+0.608*qconv(1))
> tv2 = tconv(2)*(1.+0.608*qconv(2))
> ! interpolate virtual temperature to half-level
> tv = tv1 + (tv2-tv1)*(pconv(1)-phconv(2))/(pconv(1)-pconv(2))
> if (abs(tv-tvold).gt.0.2) then
> uvzlev(2) = uvzlev(1) + &
> const*log(pold/pint)* &
> (tv-tvold)/log(tv/tvold)
> else
> uvzlev(2) = uvzlev(1)+ &
> const*log(pold/pint)*tv
> endif
> tvold=tv
> tv1=tv2
> pold=pint
>
> ! integrate profile (calculation of height agl of eta layers) as required
> do kz = 3, nconvtop+1
> ! note that variables defined in calcmatrix.f (pconv,tconv,qconv)
> ! start at the first real ECMWF model level whereas kz and
> ! thus uvzlev(kz) starts at the surface. uvzlev is defined at the
> ! half-levels (between the tconv, qconv etc. values !)
> ! Thus, uvzlev(kz) is the lower boundary of the tconv(kz) cell.
> pint = phconv(kz)
> ! determine next virtual temperatures
> tv2 = tconv(kz)*(1.+0.608*qconv(kz))
> ! interpolate virtual temperature to half-level
> tv = tv1 + (tv2-tv1)*(pconv(kz-1)-phconv(kz))/ &
> (pconv(kz-1)-pconv(kz))
> if (abs(tv-tvold).gt.0.2) then
> uvzlev(kz) = uvzlev(kz-1) + &
> const*log(pold/pint)* &
> (tv-tvold)/log(tv/tvold)
> else
> uvzlev(kz) = uvzlev(kz-1)+ &
> const*log(pold/pint)*tv
> endif
> tvold=tv
> tv1=tv2
> pold=pint
>
> end do
>
> ktop = 2
>
> endif ! (if ktop .le. 1) then
>
> ! determine vertical grid position of particle in the eta system
> !****************************************************************
>
> ztold = ztra1(abs(ipart))
> ! find old particle grid position
> do kz = 2, nconvtop
> if (uvzlev(kz) .ge. ztold ) then
> levold = kz-1
> goto 30
> endif
> end do
>
> ! Particle is above the potentially convective domain. Skip it.
> goto 90
>
> 30 continue
>
> ! now redistribute particles
> !****************************
>
> ! Choose a random number and find corresponding level of destination
> ! Random numbers to be evenly distributed in [0,1]
>
> rn = ran3(iseed)
>
> ! initialize levnew
>
> levnew = levold
>
> ffraction = 0.
> totlevmass=dpr(levold)/ga
> do k = 1,nconvtop
> ! for backward runs use the transposed matrix
> if (ldirect.eq.1) then
> ffraction=ffraction+fmassfrac(levold,k) &
> /totlevmass
> else
> ffraction=ffraction+fmassfrac(k,levold) &
> /totlevmass
> endif
> if (rn.le.ffraction) then
> levnew=k
> ! avoid division by zero or a too small number
> ! if division by zero or a too small number happens the
> ! particle is assigned to the center of the grid cell
> if (ffraction.gt.1.e-20) then
> if (ldirect.eq.1) then
> dlevfrac = (ffraction-rn) / fmassfrac(levold,k) * totlevmass
> else
> dlevfrac = (ffraction-rn) / fmassfrac(k,levold) * totlevmass
> endif
> else
> dlevfrac = 0.5
> endif
> goto 40
> endif
> end do
>
> 40 continue
>
> ! now assign new position to particle
>
> if (levnew.le.nconvtop) then
> if (levnew.eq.levold) then
> ztra1(abs(ipart)) = ztold
> else
> dlogp = (1.-dlevfrac)* &
> (log(phconv(levnew+1))-log(phconv(levnew)))
> pint = log(phconv(levnew))+dlogp
> dz1 = pint - log(phconv(levnew))
> dz2 = log(phconv(levnew+1)) - pint
> dz = dz1 + dz2
> ztra1(abs(ipart)) = (uvzlev(levnew)*dz2+uvzlev(levnew+1)*dz1)/dz
> if (ztra1(abs(ipart)).lt.0.) &
> ztra1(abs(ipart))=-1.*ztra1(abs(ipart))
> if (ipconv.gt.0) ipconv=-1
> endif
> endif
>
> ! displace particle according to compensating subsidence
> ! this is done to those particles, that were not redistributed
> ! by the matrix
> !**************************************************************
>
> if (levnew.le.nconvtop.and.levnew.eq.levold) then
>
> ztold = ztra1(abs(ipart))
>
> ! determine compensating vertical velocity at the levels
> ! above and below the particel position
> ! increase compensating subsidence by the fraction that
> ! is displaced by convection to this level
>
> if (levold.gt.1) then
> temp_levold = tconv(levold-1) + &
> (tconv(levold)-tconv(levold-1)) &
> *(pconv(levold-1)-phconv(levold))/ &
> (pconv(levold-1)-pconv(levold))
> sub_levold = sub(levold)/(1.-sub(levold)/dpr(levold)*ga)
> wsub(levold)=-1.*sub_levold*r_air*temp_levold/(phconv(levold))
> else
> wsub(levold)=0.
> endif
>
> temp_levold1 = tconv(levold) + &
> (tconv(levold+1)-tconv(levold)) &
> *(pconv(levold)-phconv(levold+1))/ &
> (pconv(levold)-pconv(levold+1))
> sub_levold1 = sub(levold+1)/(1.-sub(levold+1)/dpr(levold+1)*ga)
> wsub(levold+1)=-1.*sub_levold1*r_air*temp_levold1/ &
> (phconv(levold+1))
>
> ! interpolate wsub to the vertical particle position
>
> dz1 = ztold - uvzlev(levold)
> dz2 = uvzlev(levold+1) - ztold
> dz = dz1 + dz2
>
> wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz
> ztra1(abs(ipart)) = ztold+wsubpart*real(lsynctime)
> if (ztra1(abs(ipart)).lt.0.) then
> ztra1(abs(ipart))=-1.*ztra1(abs(ipart))
> endif
>
> endif !(levnew.le.nconvtop.and.levnew.eq.levold)
>
> ! Maximum altitude .5 meter below uppermost model level
> !*******************************************************
>
> 90 continue
>
> if (ztra1(abs(ipart)) .gt. height(nz)-0.5) &
> ztra1(abs(ipart)) = height(nz)-0.5
>
> end subroutine redist
releaseparticles.f90
----------------------------------------------
1,401c1,402
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine releaseparticles(itime)
< ! o
< !*****************************************************************************
< ! *
< ! This subroutine releases particles from the release locations. *
< ! *
< ! It searches for a "vacant" storage space and assigns all particle *
< ! information to that space. A space is vacant either when no particle *
< ! is yet assigned to it, or when it's particle is expired and, thus, *
< ! the storage space is made available to a new particle. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 29 June 2002 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! itime [s] current time *
< ! ireleasestart, ireleaseend start and end times of all releases *
< ! npart(maxpoint) number of particles to be released in total *
< ! numrel number of particles to be released during this time *
< ! step *
< ! *
< !*****************************************************************************
<
< use point_mod
< use xmass_mod
< use par_mod
< use com_mod
<
< implicit none
<
< !real xaux,yaux,zaux,ran1,rfraction,xmasssave(maxpoint)
< real :: xaux,yaux,zaux,ran1,rfraction
< real :: topo,rhoaux(2),r,t,rhoout,ddx,ddy,rddx,rddy,p1,p2,p3,p4
< real :: dz1,dz2,dz,xtn,ytn,xlonav,timecorrect(maxspec),press,pressold
< real :: presspart,average_timecorrect
< integer :: itime,numrel,i,j,k,n,ix,jy,ixp,jyp,ipart,minpart,ii
< integer :: indz,indzp,kz,ngrid
< integer :: nweeks,ndayofweek,nhour,jjjjmmdd,ihmmss,mm
< real(kind=dp) :: juldate,julmonday,jul,jullocal,juldiff
< real,parameter :: eps=nxmax/3.e5,eps2=1.e-6
<
< integer :: idummy = -7
< !save idummy,xmasssave
< !data idummy/-7/,xmasssave/maxpoint*0./
<
<
< ! Determine the actual date and time in Greenwich (i.e., UTC + correction for daylight savings time)
< !*****************************************************************************
<
< julmonday=juldate(19000101,0) ! this is a Monday
< jul=bdate+real(itime,kind=dp)/86400._dp ! this is the current day
< call caldate(jul,jjjjmmdd,ihmmss)
< mm=(jjjjmmdd-10000*(jjjjmmdd/10000))/100
< if ((mm.ge.4).and.(mm.le.9)) jul=jul+1._dp/24._dp ! daylight savings time in summer
<
<
< ! For every release point, check whether we are in the release time interval
< !***************************************************************************
<
< minpart=1
< do i=1,numpoint
< if ((itime.ge.ireleasestart(i)).and. &! are we within release interval?
< (itime.le.ireleaseend(i))) then
<
< ! Determine the local day and time
< !*********************************
<
< xlonav=xlon0+(xpoint2(i)+xpoint1(i))/2.*dx ! longitude needed to determine local time
< if (xlonav.lt.-180.) xlonav=xlonav+360.
< if (xlonav.gt.180.) xlonav=xlonav-360.
< jullocal=jul+real(xlonav,kind=dp)/360._dp ! correct approximately for time zone to obtain local time
<
< juldiff=jullocal-julmonday
< nweeks=int(juldiff/7._dp)
< juldiff=juldiff-real(nweeks,kind=dp)*7._dp
< ndayofweek=int(juldiff)+1 ! this is the current day of week, starting with Monday
< nhour=nint((juldiff-real(ndayofweek-1,kind=dp))*24._dp) ! this is the current hour
< if (nhour.eq.0) then
< nhour=24
< ndayofweek=ndayofweek-1
< if (ndayofweek.eq.0) ndayofweek=7
< endif
<
< ! Calculate a species- and time-dependent correction factor, distinguishing between
< ! area (those with release starting at surface) and point (release starting above surface) sources
< ! Also, calculate an average time correction factor (species independent)
< !*****************************************************************************
< average_timecorrect=0.
< do k=1,nspec
< if (zpoint1(i).gt.0.5) then ! point source
< timecorrect(k)=point_hour(k,nhour)*point_dow(k,ndayofweek)
< else ! area source
< timecorrect(k)=area_hour(k,nhour)*area_dow(k,ndayofweek)
< endif
< average_timecorrect=average_timecorrect+timecorrect(k)
< end do
< average_timecorrect=average_timecorrect/real(nspec)
<
< ! Determine number of particles to be released this time; at start and at end of release,
< ! only half the particles are released
< !*****************************************************************************
<
< if (ireleasestart(i).ne.ireleaseend(i)) then
< rfraction=abs(real(npart(i))*real(lsynctime)/ &
< real(ireleaseend(i)-ireleasestart(i)))
< if ((itime.eq.ireleasestart(i)).or. &
< (itime.eq.ireleaseend(i))) rfraction=rfraction/2.
<
< ! Take the species-average time correction factor in order to scale the
< ! number of particles released this time
< !**********************************************************************
< rfraction=rfraction*average_timecorrect
<
< rfraction=rfraction+xmasssave(i) ! number to be released at this time
< numrel=int(rfraction)
< xmasssave(i)=rfraction-real(numrel)
< else
< numrel=npart(i)
< endif
<
< xaux=xpoint2(i)-xpoint1(i)
< yaux=ypoint2(i)-ypoint1(i)
< zaux=zpoint2(i)-zpoint1(i)
< do j=1,numrel ! loop over particles to be released this time
< do ipart=minpart,maxpart ! search for free storage space
<
< ! If a free storage space is found, attribute everything to this array element
< !*****************************************************************************
<
< if (itra1(ipart).ne.itime) then
<
< ! Particle coordinates are determined by using a random position within the release volume
< !*****************************************************************************
<
< ! Determine horizontal particle position
< !***************************************
<
< xtra1(ipart)=xpoint1(i)+ran1(idummy)*xaux
< if (xglobal) then
< if (xtra1(ipart).gt.real(nxmin1)) xtra1(ipart)= &
< xtra1(ipart)-real(nxmin1)
< if (xtra1(ipart).lt.0.) xtra1(ipart)= &
< xtra1(ipart)+real(nxmin1)
< endif
< ytra1(ipart)=ypoint1(i)+ran1(idummy)*yaux
<
< ! Assign mass to particle: Total mass divided by total number of particles.
< ! Time variation has partly been taken into account already by a species-average
< ! correction factor, by which the number of particles released this time has been
< ! scaled. Adjust the mass per particle by the species-dependent time correction factor
< ! divided by the species-average one
< !*****************************************************************************
< do k=1,nspec
< xmass1(ipart,k)=xmass(i,k)/real(npart(i)) &
< *timecorrect(k)/average_timecorrect
< ! write (*,*) 'xmass1: ',xmass1(ipart,k),ipart,k
< ! Assign certain properties to particle
< !**************************************
< end do
< nclass(ipart)=min(int(ran1(idummy)*real(nclassunc))+1, &
< nclassunc)
< numparticlecount=numparticlecount+1
< if (mquasilag.eq.0) then
< npoint(ipart)=i
< else
< npoint(ipart)=numparticlecount
< endif
< idt(ipart)=mintime ! first time step
< itra1(ipart)=itime
< itramem(ipart)=itra1(ipart)
< itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
<
<
< ! Determine vertical particle position
< !*************************************
<
< ztra1(ipart)=zpoint1(i)+ran1(idummy)*zaux
<
< ! Interpolation of topography and density
< !****************************************
<
< ! Determine the nest we are in
< !*****************************
<
< ngrid=0
< do k=numbnests,1,-1
< if ((xtra1(ipart).gt.xln(k)+eps).and. &
< (xtra1(ipart).lt.xrn(k)-eps).and. &
< (ytra1(ipart).gt.yln(k)+eps).and. &
< (ytra1(ipart).lt.yrn(k)-eps)) then
< ngrid=k
< goto 43
< endif
< end do
< 43 continue
<
< ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
< !*****************************************************************************
<
< if (ngrid.gt.0) then
< xtn=(xtra1(ipart)-xln(ngrid))*xresoln(ngrid)
< ytn=(ytra1(ipart)-yln(ngrid))*yresoln(ngrid)
< ix=int(xtn)
< jy=int(ytn)
< ddy=ytn-real(jy)
< ddx=xtn-real(ix)
< else
< ix=int(xtra1(ipart))
< jy=int(ytra1(ipart))
< ddy=ytra1(ipart)-real(jy)
< ddx=xtra1(ipart)-real(ix)
< endif
< ixp=ix+1
< jyp=jy+1
< rddx=1.-ddx
< rddy=1.-ddy
< p1=rddx*rddy
< p2=ddx*rddy
< p3=rddx*ddy
< p4=ddx*ddy
<
< if (ngrid.gt.0) then
< topo=p1*oron(ix ,jy ,ngrid) &
< + p2*oron(ixp,jy ,ngrid) &
< + p3*oron(ix ,jyp,ngrid) &
< + p4*oron(ixp,jyp,ngrid)
< else
< topo=p1*oro(ix ,jy) &
< + p2*oro(ixp,jy) &
< + p3*oro(ix ,jyp) &
< + p4*oro(ixp,jyp)
< endif
<
< ! If starting height is in pressure coordinates, retrieve pressure profile and convert zpart1 to meters
< !*****************************************************************************
< if (kindz(i).eq.3) then
< presspart=ztra1(ipart)
< do kz=1,nz
< if (ngrid.gt.0) then
< r=p1*rhon(ix ,jy ,kz,2,ngrid) &
< +p2*rhon(ixp,jy ,kz,2,ngrid) &
< +p3*rhon(ix ,jyp,kz,2,ngrid) &
< +p4*rhon(ixp,jyp,kz,2,ngrid)
< t=p1*ttn(ix ,jy ,kz,2,ngrid) &
< +p2*ttn(ixp,jy ,kz,2,ngrid) &
< +p3*ttn(ix ,jyp,kz,2,ngrid) &
< +p4*ttn(ixp,jyp,kz,2,ngrid)
< else
< r=p1*rho(ix ,jy ,kz,2) &
< +p2*rho(ixp,jy ,kz,2) &
< +p3*rho(ix ,jyp,kz,2) &
< +p4*rho(ixp,jyp,kz,2)
< t=p1*tt(ix ,jy ,kz,2) &
< +p2*tt(ixp,jy ,kz,2) &
< +p3*tt(ix ,jyp,kz,2) &
< +p4*tt(ixp,jyp,kz,2)
< endif
< press=r*r_air*t/100.
< if (kz.eq.1) pressold=press
<
< if (press.lt.presspart) then
< if (kz.eq.1) then
< ztra1(ipart)=height(1)/2.
< else
< dz1=pressold-presspart
< dz2=presspart-press
< ztra1(ipart)=(height(kz-1)*dz2+height(kz)*dz1) &
< /(dz1+dz2)
< endif
< goto 71
< endif
< pressold=press
< end do
< 71 continue
< endif
<
< ! If release positions are given in meters above sea level, subtract the
< ! topography from the starting height
< !***********************************************************************
<
< if (kindz(i).eq.2) ztra1(ipart)=ztra1(ipart)-topo
< if (ztra1(ipart).lt.eps2) ztra1(ipart)=eps2 ! Minimum starting height is eps2
< if (ztra1(ipart).gt.height(nz)-0.5) ztra1(ipart)= &
< height(nz)-0.5 ! Maximum starting height is uppermost level - 0.5 meters
<
<
<
< ! For special simulations, multiply particle concentration air density;
< ! Simply take the 2nd field in memory to do this (accurate enough)
< !***********************************************************************
< !AF IND_SOURCE switches between different units for concentrations at the source
< !Af NOTE that in backward simulations the release of particles takes place at the
< !Af receptor and the sampling at the source.
< !Af 1="mass"
< !Af 2="mass mixing ratio"
< !Af IND_RECEPTOR switches between different units for concentrations at the receptor
< !Af 1="mass"
< !Af 2="mass mixing ratio"
<
< !Af switches for the releasefile:
< !Af IND_REL = 1 : xmass * rho
< !Af IND_REL = 0 : xmass * 1
<
< !Af ind_rel is defined in readcommand.f
<
< if (ind_rel .eq. 1) then
<
< ! Interpolate the air density
< !****************************
<
< do ii=2,nz
< if (height(ii).gt.ztra1(ipart)) then
< indz=ii-1
< indzp=ii
< goto 6
< endif
< end do
< 6 continue
<
< dz1=ztra1(ipart)-height(indz)
< dz2=height(indzp)-ztra1(ipart)
< dz=1./(dz1+dz2)
<
< if (ngrid.gt.0) then
< do n=1,2
< rhoaux(n)=p1*rhon(ix ,jy ,indz+n-1,2,ngrid) &
< +p2*rhon(ixp,jy ,indz+n-1,2,ngrid) &
< +p3*rhon(ix ,jyp,indz+n-1,2,ngrid) &
< +p4*rhon(ixp,jyp,indz+n-1,2,ngrid)
< end do
< else
< do n=1,2
< rhoaux(n)=p1*rho(ix ,jy ,indz+n-1,2) &
< +p2*rho(ixp,jy ,indz+n-1,2) &
< +p3*rho(ix ,jyp,indz+n-1,2) &
< +p4*rho(ixp,jyp,indz+n-1,2)
< end do
< endif
< rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz
< rho_rel(i)=rhoout
<
<
< ! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density
< !********************************************************************
<
< do k=1,nspec
< xmass1(ipart,k)=xmass1(ipart,k)*rhoout
< end do
< endif
<
<
< numpart=max(numpart,ipart)
< goto 34 ! Storage space has been found, stop searching
< endif
< end do
< if (ipart.gt.maxpart) goto 996
<
< 34 minpart=ipart+1
< end do
< endif
< end do
<
<
< return
<
< 996 continue
< write(*,*) '#####################################################'
< write(*,*) '#### FLEXPART MODEL SUBROUTINE RELEASEPARTICLES: ####'
< write(*,*) '#### ####'
< write(*,*) '#### ERROR - TOTAL NUMBER OF PARTICLES REQUIRED ####'
< write(*,*) '#### EXCEEDS THE MAXIMUM ALLOWED NUMBER. REDUCE ####'
< write(*,*) '#### EITHER NUMBER OF PARTICLES PER RELEASE POINT####'
< write(*,*) '#### OR REDUCE NUMBER OF RELEASE POINTS. ####'
< write(*,*) '#####################################################'
< stop
<
< end subroutine releaseparticles
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine releaseparticles(itime)
> ! o
> !*****************************************************************************
> ! *
> ! This subroutine releases particles from the release locations. *
> ! *
> ! It searches for a "vacant" storage space and assigns all particle *
> ! information to that space. A space is vacant either when no particle *
> ! is yet assigned to it, or when it's particle is expired and, thus, *
> ! the storage space is made available to a new particle. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 29 June 2002 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! itime [s] current time *
> ! ireleasestart, ireleaseend start and end times of all releases *
> ! npart(maxpoint) number of particles to be released in total *
> ! numrel number of particles to be released during this time *
> ! step *
> ! *
> !*****************************************************************************
>
> use point_mod
> use xmass_mod
> use par_mod
> use com_mod
> use random_mod, only: ran1
>
> implicit none
>
> !real xaux,yaux,zaux,ran1,rfraction,xmasssave(maxpoint)
> real :: xaux,yaux,zaux,rfraction
> real :: topo,rhoaux(2),r,t,rhoout,ddx,ddy,rddx,rddy,p1,p2,p3,p4
> real :: dz1,dz2,dz,xtn,ytn,xlonav,timecorrect(maxspec),press,pressold
> real :: presspart,average_timecorrect
> integer :: itime,numrel,i,j,k,n,ix,jy,ixp,jyp,ipart,minpart,ii
> integer :: indz,indzp,kz,ngrid
> integer :: nweeks,ndayofweek,nhour,jjjjmmdd,ihmmss,mm
> real(kind=dp) :: juldate,julmonday,jul,jullocal,juldiff
> real,parameter :: eps=nxmax/3.e5,eps2=1.e-6
>
> integer :: idummy = -7
> !save idummy,xmasssave
> !data idummy/-7/,xmasssave/maxpoint*0./
>
>
> ! Determine the actual date and time in Greenwich (i.e., UTC + correction for daylight savings time)
> !*****************************************************************************
>
> julmonday=juldate(19000101,0) ! this is a Monday
> jul=bdate+real(itime,kind=dp)/86400._dp ! this is the current day
> call caldate(jul,jjjjmmdd,ihmmss)
> mm=(jjjjmmdd-10000*(jjjjmmdd/10000))/100
> if ((mm.ge.4).and.(mm.le.9)) jul=jul+1._dp/24._dp ! daylight savings time in summer
>
>
> ! For every release point, check whether we are in the release time interval
> !***************************************************************************
>
> minpart=1
> do i=1,numpoint
> if ((itime.ge.ireleasestart(i)).and. &! are we within release interval?
> (itime.le.ireleaseend(i))) then
>
> ! Determine the local day and time
> !*********************************
>
> xlonav=xlon0+(xpoint2(i)+xpoint1(i))/2.*dx ! longitude needed to determine local time
> if (xlonav.lt.-180.) xlonav=xlonav+360.
> if (xlonav.gt.180.) xlonav=xlonav-360.
> jullocal=jul+real(xlonav,kind=dp)/360._dp ! correct approximately for time zone to obtain local time
>
> juldiff=jullocal-julmonday
> nweeks=int(juldiff/7._dp)
> juldiff=juldiff-real(nweeks,kind=dp)*7._dp
> ndayofweek=int(juldiff)+1 ! this is the current day of week, starting with Monday
> nhour=nint((juldiff-real(ndayofweek-1,kind=dp))*24._dp) ! this is the current hour
> if (nhour.eq.0) then
> nhour=24
> ndayofweek=ndayofweek-1
> if (ndayofweek.eq.0) ndayofweek=7
> endif
>
> ! Calculate a species- and time-dependent correction factor, distinguishing between
> ! area (those with release starting at surface) and point (release starting above surface) sources
> ! Also, calculate an average time correction factor (species independent)
> !*****************************************************************************
> average_timecorrect=0.
> do k=1,nspec
> if (zpoint1(i).gt.0.5) then ! point source
> timecorrect(k)=point_hour(k,nhour)*point_dow(k,ndayofweek)
> else ! area source
> timecorrect(k)=area_hour(k,nhour)*area_dow(k,ndayofweek)
> endif
> average_timecorrect=average_timecorrect+timecorrect(k)
> end do
> average_timecorrect=average_timecorrect/real(nspec)
>
> ! Determine number of particles to be released this time; at start and at end of release,
> ! only half the particles are released
> !*****************************************************************************
>
> if (ireleasestart(i).ne.ireleaseend(i)) then
> rfraction=abs(real(npart(i))*real(lsynctime)/ &
> real(ireleaseend(i)-ireleasestart(i)))
> if ((itime.eq.ireleasestart(i)).or. &
> (itime.eq.ireleaseend(i))) rfraction=rfraction/2.
>
> ! Take the species-average time correction factor in order to scale the
> ! number of particles released this time
> !**********************************************************************
> rfraction=rfraction*average_timecorrect
>
> rfraction=rfraction+xmasssave(i) ! number to be released at this time
> numrel=int(rfraction)
> xmasssave(i)=rfraction-real(numrel)
> else
> numrel=npart(i)
> endif
>
> xaux=xpoint2(i)-xpoint1(i)
> yaux=ypoint2(i)-ypoint1(i)
> zaux=zpoint2(i)-zpoint1(i)
> do j=1,numrel ! loop over particles to be released this time
> do ipart=minpart,maxpart ! search for free storage space
>
> ! If a free storage space is found, attribute everything to this array element
> !*****************************************************************************
>
> if (itra1(ipart).ne.itime) then
>
> ! Particle coordinates are determined by using a random position within the release volume
> !*****************************************************************************
>
> ! Determine horizontal particle position
> !***************************************
>
> xtra1(ipart)=xpoint1(i)+ran1(idummy)*xaux
> if (xglobal) then
> if (xtra1(ipart).gt.real(nxmin1)) xtra1(ipart)= &
> xtra1(ipart)-real(nxmin1)
> if (xtra1(ipart).lt.0.) xtra1(ipart)= &
> xtra1(ipart)+real(nxmin1)
> endif
> ytra1(ipart)=ypoint1(i)+ran1(idummy)*yaux
>
> ! Assign mass to particle: Total mass divided by total number of particles.
> ! Time variation has partly been taken into account already by a species-average
> ! correction factor, by which the number of particles released this time has been
> ! scaled. Adjust the mass per particle by the species-dependent time correction factor
> ! divided by the species-average one
> !*****************************************************************************
> do k=1,nspec
> xmass1(ipart,k)=xmass(i,k)/real(npart(i)) &
> *timecorrect(k)/average_timecorrect
> ! write (*,*) 'xmass1: ',xmass1(ipart,k),ipart,k
> ! Assign certain properties to particle
> !**************************************
> end do
> nclass(ipart)=min(int(ran1(idummy)*real(nclassunc))+1, &
> nclassunc)
> numparticlecount=numparticlecount+1
> if (mquasilag.eq.0) then
> npoint(ipart)=i
> else
> npoint(ipart)=numparticlecount
> endif
> idt(ipart)=mintime ! first time step
> itra1(ipart)=itime
> itramem(ipart)=itra1(ipart)
> itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
>
>
> ! Determine vertical particle position
> !*************************************
>
> ztra1(ipart)=zpoint1(i)+ran1(idummy)*zaux
>
> ! Interpolation of topography and density
> !****************************************
>
> ! Determine the nest we are in
> !*****************************
>
> ngrid=0
> do k=numbnests,1,-1
> if ((xtra1(ipart).gt.xln(k)+eps).and. &
> (xtra1(ipart).lt.xrn(k)-eps).and. &
> (ytra1(ipart).gt.yln(k)+eps).and. &
> (ytra1(ipart).lt.yrn(k)-eps)) then
> ngrid=k
> goto 43
> endif
> end do
> 43 continue
>
> ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
> !*****************************************************************************
>
> if (ngrid.gt.0) then
> xtn=(xtra1(ipart)-xln(ngrid))*xresoln(ngrid)
> ytn=(ytra1(ipart)-yln(ngrid))*yresoln(ngrid)
> ix=int(xtn)
> jy=int(ytn)
> ddy=ytn-real(jy)
> ddx=xtn-real(ix)
> else
> ix=int(xtra1(ipart))
> jy=int(ytra1(ipart))
> ddy=ytra1(ipart)-real(jy)
> ddx=xtra1(ipart)-real(ix)
> endif
> ixp=ix+1
> jyp=jy+1
> rddx=1.-ddx
> rddy=1.-ddy
> p1=rddx*rddy
> p2=ddx*rddy
> p3=rddx*ddy
> p4=ddx*ddy
>
> if (ngrid.gt.0) then
> topo=p1*oron(ix ,jy ,ngrid) &
> + p2*oron(ixp,jy ,ngrid) &
> + p3*oron(ix ,jyp,ngrid) &
> + p4*oron(ixp,jyp,ngrid)
> else
> topo=p1*oro(ix ,jy) &
> + p2*oro(ixp,jy) &
> + p3*oro(ix ,jyp) &
> + p4*oro(ixp,jyp)
> endif
>
> ! If starting height is in pressure coordinates, retrieve pressure profile and convert zpart1 to meters
> !*****************************************************************************
> if (kindz(i).eq.3) then
> presspart=ztra1(ipart)
> do kz=1,nz
> if (ngrid.gt.0) then
> r=p1*rhon(ix ,jy ,kz,2,ngrid) &
> +p2*rhon(ixp,jy ,kz,2,ngrid) &
> +p3*rhon(ix ,jyp,kz,2,ngrid) &
> +p4*rhon(ixp,jyp,kz,2,ngrid)
> t=p1*ttn(ix ,jy ,kz,2,ngrid) &
> +p2*ttn(ixp,jy ,kz,2,ngrid) &
> +p3*ttn(ix ,jyp,kz,2,ngrid) &
> +p4*ttn(ixp,jyp,kz,2,ngrid)
> else
> r=p1*rho(ix ,jy ,kz,2) &
> +p2*rho(ixp,jy ,kz,2) &
> +p3*rho(ix ,jyp,kz,2) &
> +p4*rho(ixp,jyp,kz,2)
> t=p1*tt(ix ,jy ,kz,2) &
> +p2*tt(ixp,jy ,kz,2) &
> +p3*tt(ix ,jyp,kz,2) &
> +p4*tt(ixp,jyp,kz,2)
> endif
> press=r*r_air*t/100.
> if (kz.eq.1) pressold=press
>
> if (press.lt.presspart) then
> if (kz.eq.1) then
> ztra1(ipart)=height(1)/2.
> else
> dz1=pressold-presspart
> dz2=presspart-press
> ztra1(ipart)=(height(kz-1)*dz2+height(kz)*dz1) &
> /(dz1+dz2)
> endif
> goto 71
> endif
> pressold=press
> end do
> 71 continue
> endif
>
> ! If release positions are given in meters above sea level, subtract the
> ! topography from the starting height
> !***********************************************************************
>
> if (kindz(i).eq.2) ztra1(ipart)=ztra1(ipart)-topo
> if (ztra1(ipart).lt.eps2) ztra1(ipart)=eps2 ! Minimum starting height is eps2
> if (ztra1(ipart).gt.height(nz)-0.5) ztra1(ipart)= &
> height(nz)-0.5 ! Maximum starting height is uppermost level - 0.5 meters
>
>
>
> ! For special simulations, multiply particle concentration air density;
> ! Simply take the 2nd field in memory to do this (accurate enough)
> !***********************************************************************
> !AF IND_SOURCE switches between different units for concentrations at the source
> !Af NOTE that in backward simulations the release of particles takes place at the
> !Af receptor and the sampling at the source.
> !Af 1="mass"
> !Af 2="mass mixing ratio"
> !Af IND_RECEPTOR switches between different units for concentrations at the receptor
> !Af 1="mass"
> !Af 2="mass mixing ratio"
>
> !Af switches for the releasefile:
> !Af IND_REL = 1 : xmass * rho
> !Af IND_REL = 0 : xmass * 1
>
> !Af ind_rel is defined in readcommand.f
>
> if (ind_rel .eq. 1) then
>
> ! Interpolate the air density
> !****************************
>
> do ii=2,nz
> if (height(ii).gt.ztra1(ipart)) then
> indz=ii-1
> indzp=ii
> goto 6
> endif
> end do
> 6 continue
>
> dz1=ztra1(ipart)-height(indz)
> dz2=height(indzp)-ztra1(ipart)
> dz=1./(dz1+dz2)
>
> if (ngrid.gt.0) then
> do n=1,2
> rhoaux(n)=p1*rhon(ix ,jy ,indz+n-1,2,ngrid) &
> +p2*rhon(ixp,jy ,indz+n-1,2,ngrid) &
> +p3*rhon(ix ,jyp,indz+n-1,2,ngrid) &
> +p4*rhon(ixp,jyp,indz+n-1,2,ngrid)
> end do
> else
> do n=1,2
> rhoaux(n)=p1*rho(ix ,jy ,indz+n-1,2) &
> +p2*rho(ixp,jy ,indz+n-1,2) &
> +p3*rho(ix ,jyp,indz+n-1,2) &
> +p4*rho(ixp,jyp,indz+n-1,2)
> end do
> endif
> rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz
> rho_rel(i)=rhoout
>
>
> ! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density
> !********************************************************************
>
> do k=1,nspec
> xmass1(ipart,k)=xmass1(ipart,k)*rhoout
> end do
> endif
>
>
> numpart=max(numpart,ipart)
> goto 34 ! Storage space has been found, stop searching
> endif
> end do
> if (ipart.gt.maxpart) goto 996
>
> 34 minpart=ipart+1
> end do
> endif
> end do
>
>
> return
>
> 996 continue
> write(*,*) '#####################################################'
> write(*,*) '#### FLEXPART MODEL SUBROUTINE RELEASEPARTICLES: ####'
> write(*,*) '#### ####'
> write(*,*) '#### ERROR - TOTAL NUMBER OF PARTICLES REQUIRED ####'
> write(*,*) '#### EXCEEDS THE MAXIMUM ALLOWED NUMBER. REDUCE ####'
> write(*,*) '#### EITHER NUMBER OF PARTICLES PER RELEASE POINT####'
> write(*,*) '#### OR REDUCE NUMBER OF RELEASE POINTS. ####'
> write(*,*) '#####################################################'
> stop
>
> end subroutine releaseparticles
richardson.f90
----------------------------------------------
1,182c1,182
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, &
< akz,bkz,hf,tt2,td2,h,wst,hmixplus)
< ! i i i i i i i
< ! i i i i i o o o
< !****************************************************************************
< ! *
< ! Calculation of mixing height based on the critical Richardson number. *
< ! Calculation of convective time scale. *
< ! For unstable conditions, one iteration is performed. An excess *
< ! temperature (dependent on hf and wst) is calculated, added to the *
< ! temperature at the lowest model level. Then the procedure is repeated.*
< ! *
< ! Author: A. Stohl *
< ! *
< ! 22 August 1996 *
< ! *
< ! Literature: *
< ! Vogelezang DHP and Holtslag AAM (1996): Evaluation and model impacts *
< ! of alternative boundary-layer height formulations. Boundary-Layer *
< ! Meteor. 81, 245-269. *
< ! *
< ! Update: 1999-02-01 by G. Wotawa *
< ! *
< ! Two meter level (temperature, humidity) is taken as reference level *
< ! instead of first model level. *
< ! New input variables tt2, td2 introduced. *
< ! *
< !****************************************************************************
< ! *
< ! Variables: *
< ! h mixing height [m] *
< ! hf sensible heat flux *
< ! psurf surface pressure at point (xt,yt) [Pa] *
< ! tv virtual temperature *
< ! wst convective velocity scale *
< ! *
< ! Constants: *
< ! ric critical Richardson number *
< ! *
< !****************************************************************************
<
< use par_mod
<
< implicit none
<
< integer :: i,k,nuvz,iter
< real :: tv,tvold,zref,z,zold,pint,pold,theta,thetaref,ri
< real :: akz(nuvz),bkz(nuvz),ulev(nuvz),vlev(nuvz),hf,wst,tt2,td2,ew
< real :: psurf,ust,ttlev(nuvz),qvlev(nuvz),h,excess
< real :: thetaold,zl,ul,vl,thetal,ril,hmixplus,wspeed,bvfsq,bvf
< real :: f_qvsat,rh,rhold,rhl,theta1,theta2,zl1,zl2,thetam
< real,parameter :: const=r_air/ga, ric=0.25, b=100., bs=8.5
< integer,parameter :: itmax=3
<
< excess=0.0
< iter=0
<
< ! Compute virtual temperature and virtual potential temperature at
< ! reference level (2 m)
< !*****************************************************************
<
< 30 iter=iter+1
<
< pold=psurf
< tvold=tt2*(1.+0.378*ew(td2)/psurf)
< zold=2.0
< zref=zold
< rhold=ew(td2)/ew(tt2)
<
< thetaref=tvold*(100000./pold)**(r_air/cpa)+excess
< thetaold=thetaref
<
<
< ! Integrate z up to one level above zt
< !*************************************
<
< do k=2,nuvz
< pint=akz(k)+bkz(k)*psurf ! pressure on model layers
< tv=ttlev(k)*(1.+0.608*qvlev(k))
<
< if (abs(tv-tvold).gt.0.2) then
< z=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
< else
< z=zold+const*log(pold/pint)*tv
< endif
<
< theta=tv*(100000./pint)**(r_air/cpa)
< ! Petra
< rh = qvlev(k) / f_qvsat( pint, ttlev(k) )
<
<
< !alculate Richardson number at each level
< !****************************************
<
< ri=ga/thetaref*(theta-thetaref)*(z-zref)/ &
< max(((ulev(k)-ulev(2))**2+(vlev(k)-vlev(2))**2+b*ust**2),0.1)
<
< ! addition of second condition: MH should not be placed in an
< ! unstable layer (PS / Feb 2000)
< if (ri.gt.ric .and. thetaold.lt.theta) goto 20
<
< tvold=tv
< pold=pint
< rhold=rh
< thetaold=theta
< zold=z
< end do
<
< 20 continue
<
< ! Determine Richardson number between the critical levels
< !********************************************************
<
< zl1=zold
< theta1=thetaold
< do i=1,20
< zl=zold+real(i)/20.*(z-zold)
< ul=ulev(k-1)+real(i)/20.*(ulev(k)-ulev(k-1))
< vl=vlev(k-1)+real(i)/20.*(vlev(k)-vlev(k-1))
< thetal=thetaold+real(i)/20.*(theta-thetaold)
< rhl=rhold+real(i)/20.*(rh-rhold)
< ril=ga/thetaref*(thetal-thetaref)*(zl-zref)/ &
< max(((ul-ulev(2))**2+(vl-vlev(2))**2+b*ust**2),0.1)
< zl2=zl
< theta2=thetal
< if (ril.gt.ric) goto 25
< zl1=zl
< theta1=thetal
< end do
<
< 25 continue
< h=zl
< thetam=0.5*(theta1+theta2)
< wspeed=sqrt(ul**2+vl**2) ! Wind speed at z=hmix
< bvfsq=(ga/thetam)*(theta2-theta1)/(zl2-zl1) ! Brunt-Vaisala frequency
< ! at z=hmix
<
< ! Under stable conditions, limit the maximum effect of the subgrid-scale topography
< ! by the maximum lifting possible from the available kinetic energy
< !*****************************************************************************
<
< if(bvfsq.le.0.) then
< hmixplus=9999.
< else
< bvf=sqrt(bvfsq)
< hmixplus=wspeed/bvf*convke
< endif
<
<
< ! Calculate convective velocity scale
< !************************************
<
< if (hf.lt.0.) then
< wst=(-h*ga/thetaref*hf/cpa)**0.333
< excess=-bs*hf/cpa/wst
< if (iter.lt.itmax) goto 30
< else
< wst=0.
< endif
<
< end subroutine richardson
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, &
> akz,bkz,hf,tt2,td2,h,wst,hmixplus)
> ! i i i i i i i
> ! i i i i i o o o
> !****************************************************************************
> ! *
> ! Calculation of mixing height based on the critical Richardson number. *
> ! Calculation of convective time scale. *
> ! For unstable conditions, one iteration is performed. An excess *
> ! temperature (dependent on hf and wst) is calculated, added to the *
> ! temperature at the lowest model level. Then the procedure is repeated.*
> ! *
> ! Author: A. Stohl *
> ! *
> ! 22 August 1996 *
> ! *
> ! Literature: *
> ! Vogelezang DHP and Holtslag AAM (1996): Evaluation and model impacts *
> ! of alternative boundary-layer height formulations. Boundary-Layer *
> ! Meteor. 81, 245-269. *
> ! *
> ! Update: 1999-02-01 by G. Wotawa *
> ! *
> ! Two meter level (temperature, humidity) is taken as reference level *
> ! instead of first model level. *
> ! New input variables tt2, td2 introduced. *
> ! *
> !****************************************************************************
> ! *
> ! Variables: *
> ! h mixing height [m] *
> ! hf sensible heat flux *
> ! psurf surface pressure at point (xt,yt) [Pa] *
> ! tv virtual temperature *
> ! wst convective velocity scale *
> ! *
> ! Constants: *
> ! ric critical Richardson number *
> ! *
> !****************************************************************************
>
> use par_mod
>
> implicit none
>
> integer :: i,k,nuvz,iter
> real :: tv,tvold,zref,z,zold,pint,pold,theta,thetaref,ri
> real :: akz(nuvz),bkz(nuvz),ulev(nuvz),vlev(nuvz),hf,wst,tt2,td2,ew
> real :: psurf,ust,ttlev(nuvz),qvlev(nuvz),h,excess
> real :: thetaold,zl,ul,vl,thetal,ril,hmixplus,wspeed,bvfsq,bvf
> real :: f_qvsat,rh,rhold,rhl,theta1,theta2,zl1,zl2,thetam
> real,parameter :: const=r_air/ga, ric=0.25, b=100., bs=8.5
> integer,parameter :: itmax=3
>
> excess=0.0
> iter=0
>
> ! Compute virtual temperature and virtual potential temperature at
> ! reference level (2 m)
> !*****************************************************************
>
> 30 iter=iter+1
>
> pold=psurf
> tvold=tt2*(1.+0.378*ew(td2)/psurf)
> zold=2.0
> zref=zold
> rhold=ew(td2)/ew(tt2)
>
> thetaref=tvold*(100000./pold)**(r_air/cpa)+excess
> thetaold=thetaref
>
>
> ! Integrate z up to one level above zt
> !*************************************
>
> do k=2,nuvz
> pint=akz(k)+bkz(k)*psurf ! pressure on model layers
> tv=ttlev(k)*(1.+0.608*qvlev(k))
>
> if (abs(tv-tvold).gt.0.2) then
> z=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
> else
> z=zold+const*log(pold/pint)*tv
> endif
>
> theta=tv*(100000./pint)**(r_air/cpa)
> ! Petra
> rh = qvlev(k) / f_qvsat( pint, ttlev(k) )
>
>
> !alculate Richardson number at each level
> !****************************************
>
> ri=ga/thetaref*(theta-thetaref)*(z-zref)/ &
> max(((ulev(k)-ulev(2))**2+(vlev(k)-vlev(2))**2+b*ust**2),0.1)
>
> ! addition of second condition: MH should not be placed in an
> ! unstable layer (PS / Feb 2000)
> if (ri.gt.ric .and. thetaold.lt.theta) goto 20
>
> tvold=tv
> pold=pint
> rhold=rh
> thetaold=theta
> zold=z
> end do
>
> 20 continue
>
> ! Determine Richardson number between the critical levels
> !********************************************************
>
> zl1=zold
> theta1=thetaold
> do i=1,20
> zl=zold+real(i)/20.*(z-zold)
> ul=ulev(k-1)+real(i)/20.*(ulev(k)-ulev(k-1))
> vl=vlev(k-1)+real(i)/20.*(vlev(k)-vlev(k-1))
> thetal=thetaold+real(i)/20.*(theta-thetaold)
> rhl=rhold+real(i)/20.*(rh-rhold)
> ril=ga/thetaref*(thetal-thetaref)*(zl-zref)/ &
> max(((ul-ulev(2))**2+(vl-vlev(2))**2+b*ust**2),0.1)
> zl2=zl
> theta2=thetal
> if (ril.gt.ric) goto 25
> zl1=zl
> theta1=thetal
> end do
>
> 25 continue
> h=zl
> thetam=0.5*(theta1+theta2)
> wspeed=sqrt(ul**2+vl**2) ! Wind speed at z=hmix
> bvfsq=(ga/thetam)*(theta2-theta1)/(zl2-zl1) ! Brunt-Vaisala frequency
> ! at z=hmix
>
> ! Under stable conditions, limit the maximum effect of the subgrid-scale topography
> ! by the maximum lifting possible from the available kinetic energy
> !*****************************************************************************
>
> if(bvfsq.le.0.) then
> hmixplus=9999.
> else
> bvf=sqrt(bvfsq)
> hmixplus=wspeed/bvf*convke
> endif
>
>
> ! Calculate convective velocity scale
> !************************************
>
> if (hf.lt.0.) then
> wst=(-h*ga/thetaref*hf/cpa)**0.333
> excess=-bs*hf/cpa/wst
> if (iter.lt.itmax) goto 30
> else
> wst=0.
> endif
>
> end subroutine richardson
richardson_gfs.f90
----------------------------------------------
1,196c1,196
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, &
< akz,bkz,hf,tt2,td2,h,wst,hmixplus)
< ! i i i i i i i
< ! i i i i i o o o
< !****************************************************************************
< ! *
< ! Calculation of mixing height based on the critical Richardson number. *
< ! Calculation of convective time scale. *
< ! For unstable conditions, one iteration is performed. An excess *
< ! temperature (dependent on hf and wst) is calculated, added to the *
< ! temperature at the lowest model level. Then the procedure is repeated.*
< ! *
< ! Author: A. Stohl *
< ! *
< ! 22 August 1996 *
< ! *
< ! Literature: *
< ! Vogelezang DHP and Holtslag AAM (1996): Evaluation and model impacts *
< ! of alternative boundary-layer height formulations. Boundary-Layer *
< ! Meteor. 81, 245-269. *
< ! *
< ! Update: 1999-02-01 by G. Wotawa *
< ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version *
< ! *
< ! Two meter level (temperature, humidity) is taken as reference level *
< ! instead of first model level. *
< ! New input variables tt2, td2 introduced. *
< ! *
< !****************************************************************************
< ! *
< ! Variables: *
< ! h mixing height [m] *
< ! hf sensible heat flux *
< ! psurf surface pressure at point (xt,yt) [Pa] *
< ! tv virtual temperature *
< ! wst convective velocity scale *
< ! *
< ! Constants: *
< ! ric critical Richardson number *
< ! *
< !****************************************************************************
<
< use par_mod
<
< implicit none
<
< integer :: i,k,nuvz,iter,llev
< real :: tv,tvold,zref,z,zold,pint,pold,theta,thetaref,ri
< real :: akz(nuvz),bkz(nuvz),ulev(nuvz),vlev(nuvz),hf,wst,tt2,td2,ew
< real :: psurf,ust,ttlev(nuvz),qvlev(nuvz),h,excess
< real :: thetaold,zl,ul,vl,thetal,ril,hmixplus,wspeed,bvfsq,bvf
< real :: f_qvsat,rh,rhold,rhl,theta1,theta2,zl1,zl2,thetam
< real,parameter :: const=r_air/ga, ric=0.25, b=100., bs=8.5
< integer,parameter :: itmax=3
<
< excess=0.0
< iter=0
<
< ! NCEP version: find first model level above ground
< !**************************************************
<
< llev = 0
< do i=1,nuvz
< if (psurf.lt.akz(i)) llev=i
< end do
< llev = llev+1
< ! sec llev should not be 1!
< if (llev.eq.1) llev = 2
< if (llev.gt.nuvz) llev = nuvz-1
< ! NCEP version
<
<
< ! Compute virtual temperature and virtual potential temperature at
< ! reference level (2 m)
< !*****************************************************************
<
< 30 iter=iter+1
<
< pold=psurf
< tvold=tt2*(1.+0.378*ew(td2)/psurf)
< zold=2.0
< zref=zold
< rhold=ew(td2)/ew(tt2)
<
< thetaref=tvold*(100000./pold)**(r_air/cpa)+excess
< thetaold=thetaref
<
< ! Integrate z up to one level above zt
< !*************************************
<
< do k=llev,nuvz
< pint=akz(k)+bkz(k)*psurf ! pressure on model layers
< tv=ttlev(k)*(1.+0.608*qvlev(k))
<
< if (abs(tv-tvold).gt.0.2) then
< z=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
< else
< z=zold+const*log(pold/pint)*tv
< endif
<
< theta=tv*(100000./pint)**(r_air/cpa)
< ! Petra
< rh = qvlev(k) / f_qvsat( pint, ttlev(k) )
<
<
< !alculate Richardson number at each level
< !****************************************
<
< ri=ga/thetaref*(theta-thetaref)*(z-zref)/ &
< max(((ulev(k)-ulev(2))**2+(vlev(k)-vlev(2))**2+b*ust**2),0.1)
<
< ! addition of second condition: MH should not be placed in an
< ! unstable layer (PS / Feb 2000)
< if (ri.gt.ric .and. thetaold.lt.theta) goto 20
<
< tvold=tv
< pold=pint
< rhold=rh
< thetaold=theta
< zold=z
< end do
<
< 20 continue
<
< ! Determine Richardson number between the critical levels
< !********************************************************
<
< zl1=zold
< theta1=thetaold
< do i=1,20
< zl=zold+real(i)/20.*(z-zold)
< ul=ulev(k-1)+real(i)/20.*(ulev(k)-ulev(k-1))
< vl=vlev(k-1)+real(i)/20.*(vlev(k)-vlev(k-1))
< thetal=thetaold+real(i)/20.*(theta-thetaold)
< rhl=rhold+real(i)/20.*(rh-rhold)
< ril=ga/thetaref*(thetal-thetaref)*(zl-zref)/ &
< max(((ul-ulev(2))**2+(vl-vlev(2))**2+b*ust**2),0.1)
< zl2=zl
< theta2=thetal
< if (ril.gt.ric) goto 25
< zl1=zl
< theta1=thetal
< end do
<
< 25 continue
< h=zl
< thetam=0.5*(theta1+theta2)
< wspeed=sqrt(ul**2+vl**2) ! Wind speed at z=hmix
< bvfsq=(ga/thetam)*(theta2-theta1)/(zl2-zl1) ! Brunt-Vaisala frequency
< ! at z=hmix
<
< ! Under stable conditions, limit the maximum effect of the subgrid-scale topography
< ! by the maximum lifting possible from the available kinetic energy
< !*****************************************************************************
<
< if(bvfsq.le.0.) then
< hmixplus=9999.
< else
< bvf=sqrt(bvfsq)
< hmixplus=wspeed/bvf*convke
< endif
<
<
< ! Calculate convective velocity scale
< !************************************
<
< if (hf.lt.0.) then
< wst=(-h*ga/thetaref*hf/cpa)**0.333
< excess=-bs*hf/cpa/wst
< if (iter.lt.itmax) goto 30
< else
< wst=0.
< endif
<
< end subroutine richardson
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, &
> akz,bkz,hf,tt2,td2,h,wst,hmixplus)
> ! i i i i i i i
> ! i i i i i o o o
> !****************************************************************************
> ! *
> ! Calculation of mixing height based on the critical Richardson number. *
> ! Calculation of convective time scale. *
> ! For unstable conditions, one iteration is performed. An excess *
> ! temperature (dependent on hf and wst) is calculated, added to the *
> ! temperature at the lowest model level. Then the procedure is repeated.*
> ! *
> ! Author: A. Stohl *
> ! *
> ! 22 August 1996 *
> ! *
> ! Literature: *
> ! Vogelezang DHP and Holtslag AAM (1996): Evaluation and model impacts *
> ! of alternative boundary-layer height formulations. Boundary-Layer *
> ! Meteor. 81, 245-269. *
> ! *
> ! Update: 1999-02-01 by G. Wotawa *
> ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version *
> ! *
> ! Two meter level (temperature, humidity) is taken as reference level *
> ! instead of first model level. *
> ! New input variables tt2, td2 introduced. *
> ! *
> !****************************************************************************
> ! *
> ! Variables: *
> ! h mixing height [m] *
> ! hf sensible heat flux *
> ! psurf surface pressure at point (xt,yt) [Pa] *
> ! tv virtual temperature *
> ! wst convective velocity scale *
> ! *
> ! Constants: *
> ! ric critical Richardson number *
> ! *
> !****************************************************************************
>
> use par_mod
>
> implicit none
>
> integer :: i,k,nuvz,iter,llev
> real :: tv,tvold,zref,z,zold,pint,pold,theta,thetaref,ri
> real :: akz(nuvz),bkz(nuvz),ulev(nuvz),vlev(nuvz),hf,wst,tt2,td2,ew
> real :: psurf,ust,ttlev(nuvz),qvlev(nuvz),h,excess
> real :: thetaold,zl,ul,vl,thetal,ril,hmixplus,wspeed,bvfsq,bvf
> real :: f_qvsat,rh,rhold,rhl,theta1,theta2,zl1,zl2,thetam
> real,parameter :: const=r_air/ga, ric=0.25, b=100., bs=8.5
> integer,parameter :: itmax=3
>
> excess=0.0
> iter=0
>
> ! NCEP version: find first model level above ground
> !**************************************************
>
> llev = 0
> do i=1,nuvz
> if (psurf.lt.akz(i)) llev=i
> end do
> llev = llev+1
> ! sec llev should not be 1!
> if (llev.eq.1) llev = 2
> if (llev.gt.nuvz) llev = nuvz-1
> ! NCEP version
>
>
> ! Compute virtual temperature and virtual potential temperature at
> ! reference level (2 m)
> !*****************************************************************
>
> 30 iter=iter+1
>
> pold=psurf
> tvold=tt2*(1.+0.378*ew(td2)/psurf)
> zold=2.0
> zref=zold
> rhold=ew(td2)/ew(tt2)
>
> thetaref=tvold*(100000./pold)**(r_air/cpa)+excess
> thetaold=thetaref
>
> ! Integrate z up to one level above zt
> !*************************************
>
> do k=llev,nuvz
> pint=akz(k)+bkz(k)*psurf ! pressure on model layers
> tv=ttlev(k)*(1.+0.608*qvlev(k))
>
> if (abs(tv-tvold).gt.0.2) then
> z=zold+const*log(pold/pint)*(tv-tvold)/log(tv/tvold)
> else
> z=zold+const*log(pold/pint)*tv
> endif
>
> theta=tv*(100000./pint)**(r_air/cpa)
> ! Petra
> rh = qvlev(k) / f_qvsat( pint, ttlev(k) )
>
>
> !alculate Richardson number at each level
> !****************************************
>
> ri=ga/thetaref*(theta-thetaref)*(z-zref)/ &
> max(((ulev(k)-ulev(2))**2+(vlev(k)-vlev(2))**2+b*ust**2),0.1)
>
> ! addition of second condition: MH should not be placed in an
> ! unstable layer (PS / Feb 2000)
> if (ri.gt.ric .and. thetaold.lt.theta) goto 20
>
> tvold=tv
> pold=pint
> rhold=rh
> thetaold=theta
> zold=z
> end do
>
> 20 continue
>
> ! Determine Richardson number between the critical levels
> !********************************************************
>
> zl1=zold
> theta1=thetaold
> do i=1,20
> zl=zold+real(i)/20.*(z-zold)
> ul=ulev(k-1)+real(i)/20.*(ulev(k)-ulev(k-1))
> vl=vlev(k-1)+real(i)/20.*(vlev(k)-vlev(k-1))
> thetal=thetaold+real(i)/20.*(theta-thetaold)
> rhl=rhold+real(i)/20.*(rh-rhold)
> ril=ga/thetaref*(thetal-thetaref)*(zl-zref)/ &
> max(((ul-ulev(2))**2+(vl-vlev(2))**2+b*ust**2),0.1)
> zl2=zl
> theta2=thetal
> if (ril.gt.ric) goto 25
> zl1=zl
> theta1=thetal
> end do
>
> 25 continue
> h=zl
> thetam=0.5*(theta1+theta2)
> wspeed=sqrt(ul**2+vl**2) ! Wind speed at z=hmix
> bvfsq=(ga/thetam)*(theta2-theta1)/(zl2-zl1) ! Brunt-Vaisala frequency
> ! at z=hmix
>
> ! Under stable conditions, limit the maximum effect of the subgrid-scale topography
> ! by the maximum lifting possible from the available kinetic energy
> !*****************************************************************************
>
> if(bvfsq.le.0.) then
> hmixplus=9999.
> else
> bvf=sqrt(bvfsq)
> hmixplus=wspeed/bvf*convke
> endif
>
>
> ! Calculate convective velocity scale
> !************************************
>
> if (hf.lt.0.) then
> wst=(-h*ga/thetaref*hf/cpa)**0.333
> excess=-bs*hf/cpa/wst
> if (iter.lt.itmax) goto 30
> else
> wst=0.
> endif
>
> end subroutine richardson
scalev.f90
----------------------------------------------
1,57c1,57
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< real function scalev(ps,t,td,stress)
<
< !********************************************************************
< ! *
< ! Author: G. WOTAWA *
< ! Date: 1994-06-27 *
< ! Update: 1996-05-21 A. Stohl *
< ! *
< !********************************************************************
< ! *
< ! This Programm calculates scale velocity ustar from surface *
< ! stress and air density. *
< ! *
< !********************************************************************
< ! *
< ! INPUT: *
< ! *
< ! ps surface pressure [Pa] *
< ! t surface temperature [K] *
< ! td surface dew point [K] *
< ! stress surface stress [N/m2] *
< ! *
< !********************************************************************
<
< use par_mod
<
< implicit none
<
< real :: ps,t,td,e,ew,tv,rhoa,stress
<
< e=ew(td) ! vapor pressure
< tv=t*(1.+0.378*e/ps) ! virtual temperature
< rhoa=ps/(r_air*tv) ! air density
< scalev=sqrt(abs(stress)/rhoa)
<
< end function scalev
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> real function scalev(ps,t,td,stress)
>
> !********************************************************************
> ! *
> ! Author: G. WOTAWA *
> ! Date: 1994-06-27 *
> ! Update: 1996-05-21 A. Stohl *
> ! *
> !********************************************************************
> ! *
> ! This Programm calculates scale velocity ustar from surface *
> ! stress and air density. *
> ! *
> !********************************************************************
> ! *
> ! INPUT: *
> ! *
> ! ps surface pressure [Pa] *
> ! t surface temperature [K] *
> ! td surface dew point [K] *
> ! stress surface stress [N/m2] *
> ! *
> !********************************************************************
>
> use par_mod
>
> implicit none
>
> real :: ps,t,td,e,ew,tv,rhoa,stress
>
> e=ew(td) ! vapor pressure
> tv=t*(1.+0.378*e/ps) ! virtual temperature
> rhoa=ps/(r_air*tv) ! air density
> scalev=sqrt(abs(stress)/rhoa)
>
> end function scalev
shift_field_0.f90
----------------------------------------------
1,78c1,78
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine shift_field_0(field,nxf,nyf)
< ! i/o i i
< !*****************************************************************************
< ! *
< ! This subroutine shifts global fields by nxshift grid cells, in order to *
< ! facilitate all sorts of nested wind fields, or output grids, which, *
< ! without shifting, would overlap with the domain "boundary". *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 3 July 2002 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
<
< implicit none
<
< integer :: nxf,nyf,ix,jy,ixs
< real :: field(0:nxmax-1,0:nymax-1),xshiftaux(0:nxmax-1)
<
< ! Loop over y and z
< !******************
<
< do jy=0,nyf-1
<
< ! Shift the data
< !***************
<
< if (nxshift.ne.0) then
< do ix=0,nxf-1
< if (ix.ge.nxshift) then
< ixs=ix-nxshift
< else
< ixs=nxf-nxshift+ix
< endif
< xshiftaux(ixs)=field(ix,jy)
< end do
< do ix=0,nxf-1
< field(ix,jy)=xshiftaux(ix)
< end do
< endif
<
< ! Repeat the westernmost grid cells at the easternmost domain "boundary"
< !***********************************************************************
<
< field(nxf,jy)=field(0,jy)
< end do
<
< return
< end subroutine shift_field_0
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine shift_field_0(field,nxf,nyf)
> ! i/o i i
> !*****************************************************************************
> ! *
> ! This subroutine shifts global fields by nxshift grid cells, in order to *
> ! facilitate all sorts of nested wind fields, or output grids, which, *
> ! without shifting, would overlap with the domain "boundary". *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 3 July 2002 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
>
> implicit none
>
> integer :: nxf,nyf,ix,jy,ixs
> real :: field(0:nxmax-1,0:nymax-1),xshiftaux(0:nxmax-1)
>
> ! Loop over y and z
> !******************
>
> do jy=0,nyf-1
>
> ! Shift the data
> !***************
>
> if (nxshift.ne.0) then
> do ix=0,nxf-1
> if (ix.ge.nxshift) then
> ixs=ix-nxshift
> else
> ixs=nxf-nxshift+ix
> endif
> xshiftaux(ixs)=field(ix,jy)
> end do
> do ix=0,nxf-1
> field(ix,jy)=xshiftaux(ix)
> end do
> endif
>
> ! Repeat the westernmost grid cells at the easternmost domain "boundary"
> !***********************************************************************
>
> field(nxf,jy)=field(0,jy)
> end do
>
> return
> end subroutine shift_field_0
shift_field.f90
----------------------------------------------
1,79c1,79
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine shift_field(field,nxf,nyf,nzfmax,nzf,nmax,n)
< ! i/o i i i i i i
< !*****************************************************************************
< ! *
< ! This subroutine shifts global fields by nxshift grid cells, in order to *
< ! facilitate all sorts of nested wind fields, or output grids, which, *
< ! without shifting, would overlap with the domain "boundary". *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 3 July 2002 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use par_mod
<
< implicit none
<
< integer :: nxf,nyf,nzf,n,ix,jy,kz,ixs,nzfmax,nmax
< real :: field(0:nxmax-1,0:nymax-1,nzfmax,nmax),xshiftaux(0:nxmax-1)
<
< ! Loop over y and z
< !******************
<
< do kz=1,nzf
< do jy=0,nyf-1
<
< ! Shift the data
< !***************
<
< if (nxshift.ne.0) then
< do ix=0,nxf-1
< if (ix.ge.nxshift) then
< ixs=ix-nxshift
< else
< ixs=nxf-nxshift+ix
< endif
< xshiftaux(ixs)=field(ix,jy,kz,n)
< end do
< do ix=0,nxf-1
< field(ix,jy,kz,n)=xshiftaux(ix)
< end do
< endif
<
< ! Repeat the westernmost grid cells at the easternmost domain "boundary"
< !***********************************************************************
<
< field(nxf,jy,kz,n)=field(0,jy,kz,n)
< end do
< end do
<
< end subroutine shift_field
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine shift_field(field,nxf,nyf,nzfmax,nzf,nmax,n)
> ! i/o i i i i i i
> !*****************************************************************************
> ! *
> ! This subroutine shifts global fields by nxshift grid cells, in order to *
> ! facilitate all sorts of nested wind fields, or output grids, which, *
> ! without shifting, would overlap with the domain "boundary". *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 3 July 2002 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use par_mod
>
> implicit none
>
> integer :: nxf,nyf,nzf,n,ix,jy,kz,ixs,nzfmax,nmax
> real :: field(0:nxmax-1,0:nymax-1,nzfmax,nmax),xshiftaux(0:nxmax-1)
>
> ! Loop over y and z
> !******************
>
> do kz=1,nzf
> do jy=0,nyf-1
>
> ! Shift the data
> !***************
>
> if (nxshift.ne.0) then
> do ix=0,nxf-1
> if (ix.ge.nxshift) then
> ixs=ix-nxshift
> else
> ixs=nxf-nxshift+ix
> endif
> xshiftaux(ixs)=field(ix,jy,kz,n)
> end do
> do ix=0,nxf-1
> field(ix,jy,kz,n)=xshiftaux(ix)
> end do
> endif
>
> ! Repeat the westernmost grid cells at the easternmost domain "boundary"
> !***********************************************************************
>
> field(nxf,jy,kz,n)=field(0,jy,kz,n)
> end do
> end do
>
> end subroutine shift_field
skplin.f90
----------------------------------------------
1,49c1,49
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine skplin(nlines,iunit)
< ! i i
< !*****************************************************************************
< ! *
< ! This routine reads nlines from unit iunit and discards them *
< ! *
< ! Authors: Petra Seibert *
< ! *
< ! 31 Dec 1998 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! iunit unit number from which lines are to be skipped *
< ! nlines number of lines to be skipped *
< ! *
< !*****************************************************************************
<
< implicit none
<
< integer :: i,iunit, nlines
<
< do i=1,nlines
< read(iunit,*)
< end do
<
< end subroutine skplin
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine skplin(nlines,iunit)
> ! i i
> !*****************************************************************************
> ! *
> ! This routine reads nlines from unit iunit and discards them *
> ! *
> ! Authors: Petra Seibert *
> ! *
> ! 31 Dec 1998 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! iunit unit number from which lines are to be skipped *
> ! nlines number of lines to be skipped *
> ! *
> !*****************************************************************************
>
> implicit none
>
> integer :: i,iunit, nlines
>
> do i=1,nlines
> read(iunit,*)
> end do
>
> end subroutine skplin
sort2.f90
----------------------------------------------
1,125c1,125
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< ! From numerical recipes
< ! Change by A. Stohl: Use of integer instead of real values
<
< subroutine sort2(n,arr,brr)
<
< implicit none
<
< integer :: n
< integer :: arr(n),brr(n)
< integer,parameter :: m=7,nstack=50
< integer :: i,ir,j,jstack,k,l,istack(nstack)
< integer :: a,b,temp
< jstack=0
< l=1
< ir=n
< 1 if(ir-l.lt.m)then
< do j=l+1,ir
< a=arr(j)
< b=brr(j)
< do i=j-1,1,-1
< if(arr(i).le.a)goto 2
< arr(i+1)=arr(i)
< brr(i+1)=brr(i)
< end do
< i=0
< 2 arr(i+1)=a
< brr(i+1)=b
< end do
< if(jstack.eq.0)return
< ir=istack(jstack)
< l=istack(jstack-1)
< jstack=jstack-2
< else
< k=(l+ir)/2
< temp=arr(k)
< arr(k)=arr(l+1)
< arr(l+1)=temp
< temp=brr(k)
< brr(k)=brr(l+1)
< brr(l+1)=temp
< if(arr(l+1).gt.arr(ir))then
< temp=arr(l+1)
< arr(l+1)=arr(ir)
< arr(ir)=temp
< temp=brr(l+1)
< brr(l+1)=brr(ir)
< brr(ir)=temp
< endif
< if(arr(l).gt.arr(ir))then
< temp=arr(l)
< arr(l)=arr(ir)
< arr(ir)=temp
< temp=brr(l)
< brr(l)=brr(ir)
< brr(ir)=temp
< endif
< if(arr(l+1).gt.arr(l))then
< temp=arr(l+1)
< arr(l+1)=arr(l)
< arr(l)=temp
< temp=brr(l+1)
< brr(l+1)=brr(l)
< brr(l)=temp
< endif
< i=l+1
< j=ir
< a=arr(l)
< b=brr(l)
< 3 continue
< i=i+1
< if(arr(i).lt.a)goto 3
< 4 continue
< j=j-1
< if(arr(j).gt.a)goto 4
< if(j.lt.i)goto 5
< temp=arr(i)
< arr(i)=arr(j)
< arr(j)=temp
< temp=brr(i)
< brr(i)=brr(j)
< brr(j)=temp
< goto 3
< 5 arr(l)=arr(j)
< arr(j)=a
< brr(l)=brr(j)
< brr(j)=b
< jstack=jstack+2
< if(jstack.gt.nstack) then
< print*, 'nstack too small in sort2'
< stop
< end if
< if(ir-i+1.ge.j-l)then
< istack(jstack)=ir
< istack(jstack-1)=i
< ir=j-1
< else
< istack(jstack)=j-1
< istack(jstack-1)=l
< l=i
< endif
< endif
< goto 1
< end subroutine sort2
< ! (C) Copr. 1986-92 Numerical Recipes Software us.
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> ! From numerical recipes
> ! Change by A. Stohl: Use of integer instead of real values
>
> subroutine sort2(n,arr,brr)
>
> implicit none
>
> integer :: n
> integer :: arr(n),brr(n)
> integer,parameter :: m=7,nstack=50
> integer :: i,ir,j,jstack,k,l,istack(nstack)
> integer :: a,b,temp
> jstack=0
> l=1
> ir=n
> 1 if(ir-l.lt.m)then
> do j=l+1,ir
> a=arr(j)
> b=brr(j)
> do i=j-1,1,-1
> if(arr(i).le.a)goto 2
> arr(i+1)=arr(i)
> brr(i+1)=brr(i)
> end do
> i=0
> 2 arr(i+1)=a
> brr(i+1)=b
> end do
> if(jstack.eq.0)return
> ir=istack(jstack)
> l=istack(jstack-1)
> jstack=jstack-2
> else
> k=(l+ir)/2
> temp=arr(k)
> arr(k)=arr(l+1)
> arr(l+1)=temp
> temp=brr(k)
> brr(k)=brr(l+1)
> brr(l+1)=temp
> if(arr(l+1).gt.arr(ir))then
> temp=arr(l+1)
> arr(l+1)=arr(ir)
> arr(ir)=temp
> temp=brr(l+1)
> brr(l+1)=brr(ir)
> brr(ir)=temp
> endif
> if(arr(l).gt.arr(ir))then
> temp=arr(l)
> arr(l)=arr(ir)
> arr(ir)=temp
> temp=brr(l)
> brr(l)=brr(ir)
> brr(ir)=temp
> endif
> if(arr(l+1).gt.arr(l))then
> temp=arr(l+1)
> arr(l+1)=arr(l)
> arr(l)=temp
> temp=brr(l+1)
> brr(l+1)=brr(l)
> brr(l)=temp
> endif
> i=l+1
> j=ir
> a=arr(l)
> b=brr(l)
> 3 continue
> i=i+1
> if(arr(i).lt.a)goto 3
> 4 continue
> j=j-1
> if(arr(j).gt.a)goto 4
> if(j.lt.i)goto 5
> temp=arr(i)
> arr(i)=arr(j)
> arr(j)=temp
> temp=brr(i)
> brr(i)=brr(j)
> brr(j)=temp
> goto 3
> 5 arr(l)=arr(j)
> arr(j)=a
> brr(l)=brr(j)
> brr(j)=b
> jstack=jstack+2
> if(jstack.gt.nstack) then
> print*, 'nstack too small in sort2'
> stop
> end if
> if(ir-i+1.ge.j-l)then
> istack(jstack)=ir
> istack(jstack-1)=i
> ir=j-1
> else
> istack(jstack)=j-1
> istack(jstack-1)=l
> l=i
> endif
> endif
> goto 1
> end subroutine sort2
> ! (C) Copr. 1986-92 Numerical Recipes Software us.
timemanager.f90
----------------------------------------------
1,541c1,587
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine timemanager
<
< !*****************************************************************************
< ! *
< ! Handles the computation of trajectories, i.e. determines which *
< ! trajectories have to be computed at what time. *
< ! Manages dry+wet deposition routines, radioactive decay and the computation *
< ! of concentrations. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 20 May 1996 *
< ! *
< !*****************************************************************************
< ! Changes, Bernd C. Krueger, Feb. 2001: *
< ! Call of convmix when new windfield is read *
< !------------------------------------ *
< ! Changes Petra Seibert, Sept 2002 *
< ! fix wet scavenging problem *
< ! Code may not be correct for decay of deposition! *
< ! Changes Petra Seibert, Nov 2002 *
< ! call convection BEFORE new fields are read in BWD mode *
< ! Changes Caroline Forster, Feb 2005 *
< !new interface between flexpart and convection scheme *
< !Emanuel's latest subroutine convect43c.f is used *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! DEP .true. if either wet or dry deposition is switched on *
< ! decay(maxspec) [1/s] decay constant for radioactive decay *
< ! DRYDEP .true. if dry deposition is switched on *
< ! ideltas [s] modelling period *
< ! itime [s] actual temporal position of calculation *
< ! ldeltat [s] time since computation of radioact. decay of depositions*
< ! loutaver [s] averaging period for concentration calculations *
< ! loutend [s] end of averaging for concentration calculations *
< ! loutnext [s] next time at which output fields shall be centered *
< ! loutsample [s] sampling interval for averaging of concentrations *
< ! loutstart [s] start of averaging for concentration calculations *
< ! loutstep [s] time interval for which concentrations shall be *
< ! calculated *
< ! npoint(maxpart) index, which starting point the trajectory has *
< ! starting positions of trajectories *
< ! nstop serves as indicator for fate of particles *
< ! in the particle loop *
< ! nstop1 serves as indicator for wind fields (see getfields) *
< ! outnum number of samples for each concentration calculation *
< ! outnum number of samples for each concentration calculation *
< ! prob probability of absorption at ground due to dry *
< ! deposition *
< ! WETDEP .true. if wet deposition is switched on *
< ! weight weight for each concentration sample (1/2 or 1) *
< ! uap(maxpart),ucp(maxpart),uzp(maxpart) = random velocities due to *
< ! turbulence *
< ! us(maxpart),vs(maxpart),ws(maxpart) = random velocities due to inter- *
< ! polation *
< ! xtra1(maxpart), ytra1(maxpart), ztra1(maxpart) = *
< ! spatial positions of trajectories *
< ! *
< ! Constants: *
< ! maxpart maximum number of trajectories *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use point_mod
< use xmass_mod
< use flux_mod
< use outg_mod
< use oh_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: j,ks,kp,l,n,itime,nstop,nstop1
< ! integer :: ksp
< integer :: loutnext,loutstart,loutend
< integer :: ix,jy,ldeltat,itage,nage
< real :: outnum,weight,prob(maxspec)
< real :: uap(maxpart),ucp(maxpart),uzp(maxpart),decfact
< real :: us(maxpart),vs(maxpart),ws(maxpart)
< integer(kind=2) :: cbt(maxpart)
< real :: drydeposit(maxspec),gridtotalunc,wetgridtotalunc
< real :: drygridtotalunc,xold,yold,zold,xmassfract
< !double precision xm(maxspec,maxpointspec_act),
< ! + xm_depw(maxspec,maxpointspec_act),
< ! + xm_depd(maxspec,maxpointspec_act)
<
<
< !open(88,file='TEST.dat')
<
< ! First output for time 0
< !************************
<
< loutnext=loutstep/2
< outnum=0.
< loutstart=loutnext-loutaver/2
< loutend=loutnext+loutaver/2
<
< ! open(127,file=path(2)(1:length(2))//'depostat.dat'
< ! + ,form='unformatted')
< !write (*,*) 'writing deposition statistics depostat.dat!'
<
< !**********************************************************************
< ! Loop over the whole modelling period in time steps of mintime seconds
< !**********************************************************************
<
< !write (*,*) 'starting simulation'
< do itime=0,ideltas,lsynctime
<
<
< ! Computation of wet deposition, OH reaction and mass transfer
< ! between two species every lsynctime seconds
< ! maybe wet depo frequency can be relaxed later but better be on safe side
< ! wetdepo must be called BEFORE new fields are read in but should not
< ! be called in the very beginning before any fields are loaded, or
< ! before particles are in the system
< ! Code may not be correct for decay of deposition
< ! changed by Petra Seibert 9/02
< !********************************************************************
<
< if (WETDEP .and. itime .ne. 0 .and. numpart .gt. 0) &
< call wetdepo(itime,lsynctime,loutnext)
<
< if (OHREA .and. itime .ne. 0 .and. numpart .gt. 0) &
< call ohreaction(itime,lsynctime,loutnext)
<
< if (ASSSPEC .and. itime .ne. 0 .and. numpart .gt. 0) then
< stop 'associated species not yet implemented!'
< ! call transferspec(itime,lsynctime,loutnext)
< endif
<
< ! compute convection for backward runs
< !*************************************
<
< if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(itime.lt.0)) &
< call convmix(itime)
<
< ! Get necessary wind fields if not available
< !*******************************************
<
< call getfields(itime,nstop1)
< if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE'
< ! Release particles
< !******************
<
< if (mdomainfill.ge.1) then
< if (itime.eq.0) then
< call init_domainfill
< else
< call boundcond_domainfill(itime,loutend)
< endif
< else
< call releaseparticles(itime)
< endif
<
<
< ! Compute convective mixing for forward runs
< ! for backward runs it is done before next windfield is read in
< !**************************************************************
<
< if ((ldirect.eq.1).and.(lconvection.eq.1)) &
< call convmix(itime)
<
<
< ! If middle of averaging period of output fields is reached, accumulated
< ! deposited mass radioactively decays
< !***********************************************************************
<
< if (DEP.and.(itime.eq.loutnext).and.(ldirect.gt.0)) then
< do ks=1,nspec
< do kp=1,maxpointspec_act
< if (decay(ks).gt.0.) then
< do nage=1,nageclass
< do l=1,nclassunc
< ! Mother output grid
< do jy=0,numygrid-1
< do ix=0,numxgrid-1
< wetgridunc(ix,jy,ks,kp,l,nage)= &
< wetgridunc(ix,jy,ks,kp,l,nage)* &
< exp(-1.*outstep*decay(ks))
< drygridunc(ix,jy,ks,kp,l,nage)= &
< drygridunc(ix,jy,ks,kp,l,nage)* &
< exp(-1.*outstep*decay(ks))
< end do
< end do
< ! Nested output grid
< if (nested_output.eq.1) then
< do jy=0,numygridn-1
< do ix=0,numxgridn-1
< wetgriduncn(ix,jy,ks,kp,l,nage)= &
< wetgriduncn(ix,jy,ks,kp,l,nage)* &
< exp(-1.*outstep*decay(ks))
< drygriduncn(ix,jy,ks,kp,l,nage)= &
< drygriduncn(ix,jy,ks,kp,l,nage)* &
< exp(-1.*outstep*decay(ks))
< end do
< end do
< endif
< end do
< end do
< endif
< end do
< end do
< endif
<
< !!! CHANGE: These lines may be switched on to check the conservation
< !!! of mass within FLEXPART
< ! if (itime.eq.loutnext) then
< ! do 247 ksp=1, nspec
< ! do 247 kp=1, maxpointspec_act
< !47 xm(ksp,kp)=0.
<
< ! do 249 ksp=1, nspec
< ! do 249 j=1,numpart
< ! if (ioutputforeachrelease.eq.1) then
< ! kp=npoint(j)
< ! else
< ! kp=1
< ! endif
< ! if (itra1(j).eq.itime) then
< ! xm(ksp,kp)=xm(ksp,kp)+xmass1(j,ksp)
< ! write(*,*) 'xmass: ',xmass1(j,ksp),j,ksp,nspec
< ! endif
< !49 continue
< ! do 248 ksp=1,nspec
< ! do 248 kp=1,maxpointspec_act
< ! xm_depw(ksp,kp)=0.
< ! xm_depd(ksp,kp)=0.
< ! do 248 nage=1,nageclass
< ! do 248 ix=0,numxgrid-1
< ! do 248 jy=0,numygrid-1
< ! do 248 l=1,nclassunc
< ! xm_depw(ksp,kp)=xm_depw(ksp,kp)
< ! + +wetgridunc(ix,jy,ksp,kp,l,nage)
< !48 xm_depd(ksp,kp)=xm_depd(ksp,kp)
< ! + +drygridunc(ix,jy,ksp,kp,l,nage)
< ! do 246 ksp=1,nspec
< !46 write(88,'(2i10,3e12.3)')
< ! + itime,ksp,(xm(ksp,kp),kp=1,maxpointspec_act),
< ! + (xm_depw(ksp,kp),kp=1,maxpointspec_act),
< ! + (xm_depd(ksp,kp),kp=1,maxpointspec_act)
< ! endif
< !!! CHANGE
<
<
<
< ! Check whether concentrations are to be calculated
< !**************************************************
<
< if ((ldirect*itime.ge.ldirect*loutstart).and. &
< (ldirect*itime.le.ldirect*loutend)) then ! add to grid
< if (mod(itime-loutstart,loutsample).eq.0) then
<
< ! If we are exactly at the start or end of the concentration averaging interval,
< ! give only half the weight to this sample
< !*****************************************************************************
<
< if ((itime.eq.loutstart).or.(itime.eq.loutend)) then
< weight=0.5
< else
< weight=1.0
< endif
< outnum=outnum+weight
< call conccalc(itime,weight)
< endif
<
<
< if ((mquasilag.eq.1).and.(itime.eq.(loutstart+loutend)/2)) &
< call partoutput_short(itime) ! dump particle positions in extremely compressed format
<
<
< ! Output and reinitialization of grid
< ! If necessary, first sample of new grid is also taken
< !*****************************************************
<
< if ((itime.eq.loutend).and.(outnum.gt.0.)) then
< if ((iout.le.3.).or.(iout.eq.5)) then
< call concoutput(itime,outnum,gridtotalunc, &
< wetgridtotalunc,drygridtotalunc)
< if (nested_output.eq.1) call concoutput_nest(itime,outnum)
< outnum=0.
< endif
< if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(itime)
< if (iflux.eq.1) call fluxoutput(itime)
< write(*,45) itime,numpart,gridtotalunc,wetgridtotalunc, &
< drygridtotalunc
< 45 format(i9,' SECONDS SIMULATED: ',i8, &
< ' PARTICLES: Uncertainty: ',3f7.3)
< if (ipout.ge.1) call partoutput(itime) ! dump particle positions
< loutnext=loutnext+loutstep
< loutstart=loutnext-loutaver/2
< loutend=loutnext+loutaver/2
< if (itime.eq.loutstart) then
< weight=0.5
< outnum=outnum+weight
< call conccalc(itime,weight)
< endif
<
<
< ! Check, whether particles are to be split:
< ! If so, create new particles and attribute all information from the old
< ! particles also to the new ones; old and new particles both get half the
< ! mass of the old ones
< !************************************************************************
<
< if (ldirect*itime.ge.ldirect*itsplit) then
< n=numpart
< do j=1,numpart
< if (ldirect*itime.ge.ldirect*itrasplit(j)) then
< if (n.lt.maxpart) then
< n=n+1
< itrasplit(j)=2*(itrasplit(j)-itramem(j))+itramem(j)
< itrasplit(n)=itrasplit(j)
< itramem(n)=itramem(j)
< itra1(n)=itra1(j)
< idt(n)=idt(j)
< npoint(n)=npoint(j)
< nclass(n)=nclass(j)
< xtra1(n)=xtra1(j)
< ytra1(n)=ytra1(j)
< ztra1(n)=ztra1(j)
< uap(n)=uap(j)
< ucp(n)=ucp(j)
< uzp(n)=uzp(j)
< us(n)=us(j)
< vs(n)=vs(j)
< ws(n)=ws(j)
< cbt(n)=cbt(j)
< do ks=1,nspec
< xmass1(j,ks)=xmass1(j,ks)/2.
< xmass1(n,ks)=xmass1(j,ks)
< end do
< endif
< endif
< end do
< numpart=n
< endif
< endif
< endif
<
<
< if (itime.eq.ideltas) exit ! almost finished
<
< ! Compute interval since radioactive decay of deposited mass was computed
< !************************************************************************
<
< if (itime.lt.loutnext) then
< ldeltat=itime-(loutnext-loutstep)
< else ! first half of next interval
< ldeltat=itime-loutnext
< endif
<
<
< ! Loop over all particles
< !************************
<
< do j=1,numpart
<
<
< ! If integration step is due, do it
< !**********************************
<
< if (itra1(j).eq.itime) then
<
< if (ioutputforeachrelease.eq.1) then
< kp=npoint(j)
< else
< kp=1
< endif
< ! Determine age class of the particle
< itage=abs(itra1(j)-itramem(j))
< do nage=1,nageclass
< if (itage.lt.lage(nage)) exit
< end do
<
< ! Initialize newly released particle
< !***********************************
<
< if ((itramem(j).eq.itime).or.(itime.eq.0)) &
< call initialize(itime,idt(j),uap(j),ucp(j),uzp(j), &
< us(j),vs(j),ws(j),xtra1(j),ytra1(j),ztra1(j),cbt(j))
<
< ! Memorize particle positions
< !****************************
<
< xold=xtra1(j)
< yold=ytra1(j)
< zold=ztra1(j)
<
< ! Integrate Lagevin equation for lsynctime seconds
< !*************************************************
<
< call advance(itime,npoint(j),idt(j),uap(j),ucp(j),uzp(j), &
< us(j),vs(j),ws(j),nstop,xtra1(j),ytra1(j),ztra1(j),prob, &
< cbt(j))
<
< ! Calculate the gross fluxes across layer interfaces
< !***************************************************
<
< if (iflux.eq.1) call calcfluxes(nage,j,xold,yold,zold)
<
<
< ! Determine, when next time step is due
< ! If trajectory is terminated, mark it
< !**************************************
<
< if (nstop.gt.1) then
< if (linit_cond.ge.1) call initial_cond_calc(itime,j)
< itra1(j)=-999999999
< else
< itra1(j)=itime+lsynctime
<
<
< ! Dry deposition and radioactive decay for each species
< ! Also check maximum (of all species) of initial mass remaining on the particle;
< ! if it is below a threshold value, terminate particle
< !*****************************************************************************
<
< xmassfract=0.
< do ks=1,nspec
< if (decay(ks).gt.0.) then ! radioactive decay
< decfact=exp(-real(abs(lsynctime))*decay(ks))
< else
< decfact=1.
< endif
<
< if (DRYDEPSPEC(ks)) then ! dry deposition
< drydeposit(ks)=xmass1(j,ks)*prob(ks)*decfact
< xmass1(j,ks)=xmass1(j,ks)*(1.-prob(ks))*decfact
< if (decay(ks).gt.0.) then ! correct for decay (see wetdepo)
< drydeposit(ks)=drydeposit(ks)* &
< exp(real(abs(ldeltat))*decay(ks))
< endif
< else ! no dry deposition
< xmass1(j,ks)=xmass1(j,ks)*decfact
< endif
<
<
< if (mdomainfill.eq.0) then
< if (xmass(npoint(j),ks).gt.0.) &
< xmassfract=max(xmassfract,real(npart(npoint(j)))* &
< xmass1(j,ks)/xmass(npoint(j),ks))
< else
< xmassfract=1.
< endif
< end do
<
< if (xmassfract.lt.0.0001) then ! terminate all particles carrying less mass
< itra1(j)=-999999999
< endif
<
< ! Sabine Eckhardt, June 2008
< ! don't create depofield for backward runs
< if (DRYDEP.AND.(ldirect.eq.1)) then
< call drydepokernel(nclass(j),drydeposit,real(xtra1(j)), &
< real(ytra1(j)),nage,kp)
< if (nested_output.eq.1) call drydepokernel_nest( &
< nclass(j),drydeposit,real(xtra1(j)),real(ytra1(j)), &
< nage,kp)
< endif
<
< ! Terminate trajectories that are older than maximum allowed age
< !***************************************************************
<
< if (abs(itra1(j)-itramem(j)).ge.lage(nageclass)) then
< if (linit_cond.ge.1) &
< call initial_cond_calc(itime+lsynctime,j)
< itra1(j)=-999999999
< endif
< endif
<
< endif
<
< end do
<
< end do
<
<
< ! Complete the calculation of initial conditions for particles not yet terminated
< !*****************************************************************************
<
< do j=1,numpart
< if (linit_cond.ge.1) call initial_cond_calc(itime,j)
< end do
<
< if (ipout.eq.2) call partoutput(itime) ! dump particle positions
<
< if (linit_cond.ge.1) call initial_cond_output(itime) ! dump initial cond. field
<
< close(104)
<
< ! De-allocate memory and end
< !***************************
<
< if (iflux.eq.1) then
< deallocate(flux)
< endif
< if (OHREA.eqv..TRUE.) then
< deallocate(OH_field,OH_field_height)
< endif
< if (ldirect.gt.0) then
< deallocate(drygridunc,wetgridunc)
< endif
< deallocate(gridunc)
< deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmass)
< deallocate(ireleasestart,ireleaseend,npart,kindz)
< deallocate(xmasssave)
< if (nested_output.eq.1) then
< deallocate(orooutn, arean, volumen)
< if (ldirect.gt.0) then
< deallocate(griduncn,drygriduncn,wetgriduncn)
< endif
< endif
< deallocate(outheight,outheighthalf)
< deallocate(oroout, area, volume)
<
< end subroutine timemanager
<
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine timemanager
>
> !*****************************************************************************
> ! *
> ! Handles the computation of trajectories, i.e. determines which *
> ! trajectories have to be computed at what time. *
> ! Manages dry+wet deposition routines, radioactive decay and the computation *
> ! of concentrations. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 20 May 1996 *
> ! *
> !*****************************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001: *
> ! Call of convmix when new windfield is read *
> !------------------------------------ *
> ! Changes Petra Seibert, Sept 2002 *
> ! fix wet scavenging problem *
> ! Code may not be correct for decay of deposition! *
> ! Changes Petra Seibert, Nov 2002 *
> ! call convection BEFORE new fields are read in BWD mode *
> ! Changes Caroline Forster, Feb 2005 *
> !new interface between flexpart and convection scheme *
> !Emanuel's latest subroutine convect43c.f is used *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! DEP .true. if either wet or dry deposition is switched on *
> ! decay(maxspec) [1/s] decay constant for radioactive decay *
> ! DRYDEP .true. if dry deposition is switched on *
> ! ideltas [s] modelling period *
> ! itime [s] actual temporal position of calculation *
> ! ldeltat [s] time since computation of radioact. decay of depositions*
> ! loutaver [s] averaging period for concentration calculations *
> ! loutend [s] end of averaging for concentration calculations *
> ! loutnext [s] next time at which output fields shall be centered *
> ! loutsample [s] sampling interval for averaging of concentrations *
> ! loutstart [s] start of averaging for concentration calculations *
> ! loutstep [s] time interval for which concentrations shall be *
> ! calculated *
> ! npoint(maxpart) index, which starting point the trajectory has *
> ! starting positions of trajectories *
> ! nstop serves as indicator for fate of particles *
> ! in the particle loop *
> ! nstop1 serves as indicator for wind fields (see getfields) *
> ! outnum number of samples for each concentration calculation *
> ! outnum number of samples for each concentration calculation *
> ! prob probability of absorption at ground due to dry *
> ! deposition *
> ! WETDEP .true. if wet deposition is switched on *
> ! weight weight for each concentration sample (1/2 or 1) *
> ! uap(maxpart),ucp(maxpart),uzp(maxpart) = random velocities due to *
> ! turbulence *
> ! us(maxpart),vs(maxpart),ws(maxpart) = random velocities due to inter- *
> ! polation *
> ! xtra1(maxpart), ytra1(maxpart), ztra1(maxpart) = *
> ! spatial positions of trajectories *
> ! *
> ! Constants: *
> ! maxpart maximum number of trajectories *
> ! *
> !*****************************************************************************
>
> use omp_lib
> use unc_mod
> use point_mod
> use xmass_mod
> use flux_mod
> use outg_mod
> use oh_mod
> use par_mod
> use com_mod
> use random_mod, only: ran3, ran3_initialize, ran3_advance, &
> idummy_ran3_initialize, idummy_ran3_advance
>
>
> implicit none
>
> integer :: j,ks,kp,l,n,itime,nstop,nstop1
> ! integer :: ksp
> integer :: loutnext,loutstart,loutend
> integer :: ix,jy,ldeltat,itage,nage
> real :: outnum,weight,prob(maxspec)
> real :: uap(maxpart),ucp(maxpart),uzp(maxpart),decfact
> real :: us(maxpart),vs(maxpart),ws(maxpart)
> integer(kind=2) :: cbt(maxpart)
> real :: drydeposit(maxspec),gridtotalunc,wetgridtotalunc
> real :: drygridtotalunc,xold,yold,zold,xmassfract
> !double precision xm(maxspec,maxpointspec_act),
> ! + xm_depw(maxspec,maxpointspec_act),
> ! + xm_depd(maxspec,maxpointspec_act)
> integer :: griclunc
> #if (defined _OPENMP)
> integer :: thread, nthreads
> #endif
>
>
> !open(88,file='TEST.dat')
>
> ! First output for time 0
> !************************
>
> loutnext=loutstep/2
> outnum=0.
> loutstart=loutnext-loutaver/2
> loutend=loutnext+loutaver/2
>
> ! open(127,file=path(2)(1:length(2))//'depostat.dat'
> ! + ,form='unformatted')
> !write (*,*) 'writing deposition statistics depostat.dat!'
>
> !**********************************************************************
> ! Loop over the whole modelling period in time steps of mintime seconds
> !**********************************************************************
>
> !write (*,*) 'starting simulation'
> timeloop: do itime=0,ideltas,lsynctime
>
>
> ! Computation of wet deposition, OH reaction and mass transfer
> ! between two species every lsynctime seconds
> ! maybe wet depo frequency can be relaxed later but better be on safe side
> ! wetdepo must be called BEFORE new fields are read in but should not
> ! be called in the very beginning before any fields are loaded, or
> ! before particles are in the system
> ! Code may not be correct for decay of deposition
> ! changed by Petra Seibert 9/02
> !********************************************************************
>
> if (WETDEP .and. itime .ne. 0 .and. numpart .gt. 0) &
> call wetdepo(itime,lsynctime,loutnext)
>
> if (OHREA .and. itime .ne. 0 .and. numpart .gt. 0) &
> call ohreaction(itime,lsynctime,loutnext)
>
> if (ASSSPEC .and. itime .ne. 0 .and. numpart .gt. 0) then
> stop 'associated species not yet implemented!'
> ! call transferspec(itime,lsynctime,loutnext)
> endif
>
> ! compute convection for backward runs
> !*************************************
>
> if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(itime.lt.0)) then
> ! write(*,*) "itime, memtime:", itime, memtime(1), memtime(2)
> call convmix(itime)
> end if
>
> ! Get necessary wind fields if not available
> !*******************************************
>
> call getfields(itime,nstop1)
> if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE'
> ! Release particles
> !******************
>
> if (mdomainfill.ge.1) then
> if (itime.eq.0) then
> call init_domainfill
> else
> call boundcond_domainfill(itime,loutend)
> endif
> else
> call releaseparticles(itime)
> endif
>
>
> ! Compute convective mixing for forward runs
> ! for backward runs it is done before next windfield is read in
> !**************************************************************
>
> if ((ldirect.eq.1).and.(lconvection.eq.1).and.(itime.ne.ideltas)) then
> ! write(*,*) "itime, memtime:", itime, memtime(1), memtime(2)
> call convmix(itime)
> end if
>
> ! If middle of averaging period of output fields is reached, accumulated
> ! deposited mass radioactively decays
> !***********************************************************************
>
> if (DEP.and.(itime.eq.loutnext).and.(ldirect.gt.0)) then
> do ks=1,nspec
> do kp=1,maxpointspec_act
> if (decay(ks).gt.0.) then
> do nage=1,nageclass
> do l=1,nclassunc
> ! Mother output grid
> do jy=0,numygrid-1
> do ix=0,numxgrid-1
> wetgridunc(ix,jy,ks,kp,l,nage)= &
> wetgridunc(ix,jy,ks,kp,l,nage)* &
> exp(-1.*outstep*decay(ks))
> drygridunc(ix,jy,ks,kp,l,nage)= &
> drygridunc(ix,jy,ks,kp,l,nage)* &
> exp(-1.*outstep*decay(ks))
> end do
> end do
> ! Nested output grid
> if (nested_output.eq.1) then
> do jy=0,numygridn-1
> do ix=0,numxgridn-1
> wetgriduncn(ix,jy,ks,kp,l,nage)= &
> wetgriduncn(ix,jy,ks,kp,l,nage)* &
> exp(-1.*outstep*decay(ks))
> drygriduncn(ix,jy,ks,kp,l,nage)= &
> drygriduncn(ix,jy,ks,kp,l,nage)* &
> exp(-1.*outstep*decay(ks))
> end do
> end do
> endif
> end do
> end do
> endif
> end do
> end do
> endif
>
> !!! CHANGE: These lines may be switched on to check the conservation
> !!! of mass within FLEXPART
> ! if (itime.eq.loutnext) then
> ! do 247 ksp=1, nspec
> ! do 247 kp=1, maxpointspec_act
> !47 xm(ksp,kp)=0.
>
> ! do 249 ksp=1, nspec
> ! do 249 j=1,numpart
> ! if (ioutputforeachrelease.eq.1) then
> ! kp=npoint(j)
> ! else
> ! kp=1
> ! endif
> ! if (itra1(j).eq.itime) then
> ! xm(ksp,kp)=xm(ksp,kp)+xmass1(j,ksp)
> ! write(*,*) 'xmass: ',xmass1(j,ksp),j,ksp,nspec
> ! endif
> !49 continue
> ! do 248 ksp=1,nspec
> ! do 248 kp=1,maxpointspec_act
> ! xm_depw(ksp,kp)=0.
> ! xm_depd(ksp,kp)=0.
> ! do 248 nage=1,nageclass
> ! do 248 ix=0,numxgrid-1
> ! do 248 jy=0,numygrid-1
> ! do 248 l=1,nclassunc
> ! xm_depw(ksp,kp)=xm_depw(ksp,kp)
> ! + +wetgridunc(ix,jy,ksp,kp,l,nage)
> !48 xm_depd(ksp,kp)=xm_depd(ksp,kp)
> ! + +drygridunc(ix,jy,ksp,kp,l,nage)
> ! do 246 ksp=1,nspec
> !46 write(88,'(2i10,3e12.3)')
> ! + itime,ksp,(xm(ksp,kp),kp=1,maxpointspec_act),
> ! + (xm_depw(ksp,kp),kp=1,maxpointspec_act),
> ! + (xm_depd(ksp,kp),kp=1,maxpointspec_act)
> ! endif
> !!! CHANGE
>
>
>
> ! Check whether concentrations are to be calculated
> !**************************************************
>
> if ((ldirect*itime.ge.ldirect*loutstart).and. &
> (ldirect*itime.le.ldirect*loutend)) then ! add to grid
> if (mod(itime-loutstart,loutsample).eq.0) then
>
> ! If we are exactly at the start or end of the concentration averaging interval,
> ! give only half the weight to this sample
> !*****************************************************************************
>
> if ((itime.eq.loutstart).or.(itime.eq.loutend)) then
> weight=0.5
> else
> weight=1.0
> endif
> outnum=outnum+weight
> call conccalc(itime,weight)
> endif
>
>
> if ((mquasilag.eq.1).and.(itime.eq.(loutstart+loutend)/2)) &
> call partoutput_short(itime) ! dump particle positions in extremely compressed format
>
>
> ! Output and reinitialization of grid
> ! If necessary, first sample of new grid is also taken
> !*****************************************************
>
> if ((itime.eq.loutend).and.(outnum.gt.0.)) then
> if ((iout.le.3.).or.(iout.eq.5)) then
> call concoutput(itime,outnum,gridtotalunc, &
> wetgridtotalunc,drygridtotalunc)
> if (nested_output.eq.1) call concoutput_nest(itime,outnum)
> outnum=0.
> endif
> if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(itime)
> if (iflux.eq.1) call fluxoutput(itime)
> write(*,45) itime,numpart,gridtotalunc,wetgridtotalunc, &
> drygridtotalunc
> 45 format(i9,' SECONDS SIMULATED: ',i8, &
> ' PARTICLES: Uncertainty: ',3f7.3)
> if (ipout.ge.1) call partoutput(itime) ! dump particle positions
> loutnext=loutnext+loutstep
> loutstart=loutnext-loutaver/2
> loutend=loutnext+loutaver/2
> if (itime.eq.loutstart) then
> weight=0.5
> outnum=outnum+weight
> call conccalc(itime,weight)
> endif
>
>
> ! Check, whether particles are to be split:
> ! If so, create new particles and attribute all information from the old
> ! particles also to the new ones; old and new particles both get half the
> ! mass of the old ones
> !************************************************************************
>
> if (ldirect*itime.ge.ldirect*itsplit) then
> n=numpart
> do j=1,numpart
> if (ldirect*itime.ge.ldirect*itrasplit(j)) then
> if (n.lt.maxpart) then
> n=n+1
> itrasplit(j)=2*(itrasplit(j)-itramem(j))+itramem(j)
> itrasplit(n)=itrasplit(j)
> itramem(n)=itramem(j)
> itra1(n)=itra1(j)
> idt(n)=idt(j)
> npoint(n)=npoint(j)
> nclass(n)=nclass(j)
> xtra1(n)=xtra1(j)
> ytra1(n)=ytra1(j)
> ztra1(n)=ztra1(j)
> uap(n)=uap(j)
> ucp(n)=ucp(j)
> uzp(n)=uzp(j)
> us(n)=us(j)
> vs(n)=vs(j)
> ws(n)=ws(j)
> cbt(n)=cbt(j)
> do ks=1,nspec
> xmass1(j,ks)=xmass1(j,ks)/2.
> xmass1(n,ks)=xmass1(j,ks)
> end do
> endif
> endif
> end do
> numpart=n
> endif
> endif
> endif
>
>
> if (itime.eq.ideltas) exit ! almost finished
>
> ! Compute interval since radioactive decay of deposited mass was computed
> !************************************************************************
>
> if (itime.lt.loutnext) then
> ldeltat=itime-(loutnext-loutstep)
> else ! first half of next interval
> ldeltat=itime-loutnext
> endif
>
>
> ! Calculate random numbers before entering into parallel region
> !**************************************************************
>
> do j = 1, numpart
> if ((itramem(j) .eq. itime) .or. (itime .eq. 0)) &
> ran3_initialize(j) = ran3(idummy_ran3_initialize)
> ran3_advance(j) = ran3(idummy_ran3_advance)
> end do
>
> !$OMP PARALLEL PRIVATE (kp,itage, nage, xold, yold, zold, nstop, prob, &
> !$OMP xmassfract, ks, decfact, drydeposit, j, thread, griclunc)
>
> #if (defined _OPENMP)
> thread = OMP_GET_THREAD_NUM()
> nthreads = OMP_GET_NUM_THREADS()
> #endif
>
> ! Loop over all particles
> !************************
> #if (defined STATIC_SCHED)
> !$OMP DO SCHEDULE(static, ceiling(real(numpart)/real(nthreads)))
> #else
> !$OMP DO SCHEDULE(dynamic, max(1,numpart/1000))
> #endif
>
> particleloop: do j=1,numpart
>
>
> ! If integration step is due, do it
> !**********************************
>
> if (itra1(j).eq.itime) then
>
> if (ioutputforeachrelease.eq.1) then
> kp=npoint(j)
> else
> kp=1
> endif
> ! Determine age class of the particle
> itage=abs(itra1(j)-itramem(j))
> do nage=1,nageclass
> if (itage.lt.lage(nage)) exit
> end do
>
> ! Initialize newly released particle
> !***********************************
>
> if ((itramem(j).eq.itime).or.(itime.eq.0)) &
> call initialize(j, itime,idt(j),uap(j),ucp(j),uzp(j), &
> us(j),vs(j),ws(j),xtra1(j),ytra1(j),ztra1(j),cbt(j))
>
> ! Memorize particle positions
> !****************************
>
> xold=xtra1(j)
> yold=ytra1(j)
> zold=ztra1(j)
>
> ! Integrate Lagevin equation for lsynctime seconds
> !*************************************************
>
> call advance(j, itime,npoint(j),idt(j),uap(j),ucp(j),uzp(j), &
> us(j),vs(j),ws(j),nstop,xtra1(j),ytra1(j),ztra1(j),prob, &
> cbt(j))
>
> ! Calculate the gross fluxes across layer interfaces
> !***************************************************
>
> ! TODO: there is a race condition in here; solved with CRITICAL in COSMO version
> if (iflux.eq.1) call calcfluxes(nage,j,xold,yold,zold)
>
>
> ! Determine, when next time step is due
> ! If trajectory is terminated, mark it
> !**************************************
>
> ! TODO: might contain race condition; not available in COSMO version; either additional dimension per thread or REDUCE
> if (nstop.gt.1) then
> if (linit_cond.ge.1) call initial_cond_calc(itime,j)
> itra1(j)=-999999999
> else
> itra1(j)=itime+lsynctime
>
>
> ! Dry deposition and radioactive decay for each species
> ! Also check maximum (of all species) of initial mass remaining on the particle;
> ! if it is below a threshold value, terminate particle
> !*****************************************************************************
>
> xmassfract=0.
> do ks=1,nspec
> if (decay(ks).gt.0.) then ! radioactive decay
> decfact=exp(-real(abs(lsynctime))*decay(ks))
> else
> decfact=1.
> endif
>
> if (DRYDEPSPEC(ks)) then ! dry deposition
> drydeposit(ks)=xmass1(j,ks)*prob(ks)*decfact
> xmass1(j,ks)=xmass1(j,ks)*(1.-prob(ks))*decfact
> if (decay(ks).gt.0.) then ! correct for decay (see wetdepo)
> drydeposit(ks)=drydeposit(ks)* &
> exp(real(abs(ldeltat))*decay(ks))
> endif
> else ! no dry deposition
> xmass1(j,ks)=xmass1(j,ks)*decfact
> endif
>
>
> if (mdomainfill.eq.0) then
> if (xmass(npoint(j),ks).gt.0.) &
> xmassfract=max(xmassfract,real(npart(npoint(j)))* &
> xmass1(j,ks)/xmass(npoint(j),ks))
> else
> xmassfract=1.
> endif
> end do
>
> if (xmassfract.lt.0.0001) then ! terminate all particles carrying less mass
> itra1(j)=-999999999
> endif
>
> ! Sabine Eckhardt, June 2008
> ! don't create depofield for backward runs
> if (DRYDEP.AND.(ldirect.eq.1)) then
>
> ! TODO: race conditions
> #if (defined _OPENMP)
> griclunc = thread + 1
> #else
> griclunc = mod(nclass(j)-1, nclassunc) + 1
> #endif
> call drydepokernel(griclunc,drydeposit,real(xtra1(j)), &
> real(ytra1(j)),nage,kp)
> if (nested_output.eq.1) call drydepokernel_nest( &
> griclunc,drydeposit,real(xtra1(j)),real(ytra1(j)), &
> nage,kp)
> endif
>
> ! Terminate trajectories that are older than maximum allowed age
> !***************************************************************
>
> if (abs(itra1(j)-itramem(j)).ge.lage(nageclass)) then
> if (linit_cond.ge.1) &
> ! TODO: race conditions
> call initial_cond_calc(itime+lsynctime,j)
> itra1(j)=-999999999
> endif
> endif
>
> endif
>
> end do particleloop
> !$OMP END DO
>
> !$OMP END PARALLEL
>
> end do timeloop
>
>
> ! Complete the calculation of initial conditions for particles not yet terminated
> !*****************************************************************************
>
> do j=1,numpart
> if (linit_cond.ge.1) call initial_cond_calc(itime,j)
> end do
>
> if (ipout.eq.2) call partoutput(itime) ! dump particle positions
>
> if (linit_cond.ge.1) call initial_cond_output(itime) ! dump initial cond. field
>
> close(104)
>
> ! De-allocate memory and end
> !***************************
>
> if (iflux.eq.1) then
> deallocate(flux)
> endif
> if (OHREA.eqv..TRUE.) then
> deallocate(OH_field,OH_field_height)
> endif
> if (ldirect.gt.0) then
> deallocate(drygridunc,wetgridunc)
> endif
> deallocate(gridunc)
> deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmass)
> deallocate(ireleasestart,ireleaseend,npart,kindz)
> deallocate(xmasssave)
> if (nested_output.eq.1) then
> deallocate(orooutn, arean, volumen)
> if (ldirect.gt.0) then
> deallocate(griduncn,drygriduncn,wetgriduncn)
> endif
> endif
> deallocate(outheight,outheighthalf)
> deallocate(oroout, area, volume)
>
> end subroutine timemanager
>
unc_mod.f90
----------------------------------------------
1,35c1,35
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< module unc_mod
<
< implicit none
<
< real,allocatable, dimension (:,:,:,:,:,:,:) :: gridunc
< real,allocatable, dimension (:,:,:,:,:,:,:) :: griduncn
< real,allocatable, dimension (:,:,:,:,:,:) :: drygridunc
< real,allocatable, dimension (:,:,:,:,:,:) :: drygriduncn
< real,allocatable, dimension (:,:,:,:,:,:) :: wetgridunc
< real,allocatable, dimension (:,:,:,:,:,:) :: wetgriduncn
<
< real,allocatable, dimension (:,:,:,:,:) :: init_cond
<
< end module unc_mod
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> module unc_mod
>
> implicit none
>
> real,allocatable, dimension (:,:,:,:,:,:,:) :: gridunc
> real,allocatable, dimension (:,:,:,:,:,:,:) :: griduncn
> real,allocatable, dimension (:,:,:,:,:,:) :: drygridunc
> real,allocatable, dimension (:,:,:,:,:,:) :: drygriduncn
> real,allocatable, dimension (:,:,:,:,:,:) :: wetgridunc
> real,allocatable, dimension (:,:,:,:,:,:) :: wetgriduncn
>
> real,allocatable, dimension (:,:,:,:,:) :: init_cond
>
> end module unc_mod
verttransform.f90
----------------------------------------------
1,607c1,607
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine verttransform(n,uuh,vvh,wwh,pvh)
< ! i i i i i
< !*****************************************************************************
< ! *
< ! This subroutine transforms temperature, dew point temperature and *
< ! wind components from eta to meter coordinates. *
< ! The vertical wind component is transformed from Pa/s to m/s using *
< ! the conversion factor pinmconv. *
< ! In addition, this routine calculates vertical density gradients *
< ! needed for the parameterization of the turbulent velocities. *
< ! *
< ! Author: A. Stohl, G. Wotawa *
< ! *
< ! 12 August 1996 *
< ! Update: 16 January 1998 *
< ! *
< ! Major update: 17 February 1999 *
< ! by G. Wotawa *
< ! *
< ! - Vertical levels for u, v and w are put together *
< ! - Slope correction for vertical velocity: Modification of calculation *
< ! procedure *
< ! *
< !*****************************************************************************
< ! Changes, Bernd C. Krueger, Feb. 2001:
< ! Variables tth and qvh (on eta coordinates) from common block
< !*****************************************************************************
< ! Sabine Eckhardt, March 2007
< ! added the variable cloud for use with scavenging - descr. in com_mod
< !*****************************************************************************
< ! *
< ! Variables: *
< ! nx,ny,nz field dimensions in x,y and z direction *
< ! clouds(0:nxmax,0:nymax,0:nzmax,2) cloud field for wet deposition *
< ! uu(0:nxmax,0:nymax,nzmax,2) wind components in x-direction [m/s] *
< ! vv(0:nxmax,0:nymax,nzmax,2) wind components in y-direction [m/s] *
< ! ww(0:nxmax,0:nymax,nzmax,2) wind components in z-direction [deltaeta/s]*
< ! tt(0:nxmax,0:nymax,nzmax,2) temperature [K] *
< ! pv(0:nxmax,0:nymax,nzmax,2) potential voriticity (pvu) *
< ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use cmapf_mod, only: cc2gll
<
< implicit none
<
< integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym
< integer :: rain_cloud_above,kz_inv
< real :: f_qvsat,pressure
< real :: rh,lsp,convp
< real :: uvzlev(nuvzmax),rhoh(nuvzmax),pinmconv(nzmax)
< real :: ew,pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
< real :: xlon,ylat,xlonr,dzdx,dzdy
< real :: dzdx1,dzdx2,dzdy1,dzdy2
< real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy
< real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
< real :: wzlev(nwzmax),uvwzlev(0:nxmax-1,0:nymax-1,nzmax)
< real,parameter :: const=r_air/ga
<
< logical :: init = .true.
<
<
< !*************************************************************************
< ! If verttransform is called the first time, initialize heights of the *
< ! z levels in meter. The heights are the heights of model levels, where *
< ! u,v,T and qv are given, and of the interfaces, where w is given. So, *
< ! the vertical resolution in the z system is doubled. As reference point,*
< ! the lower left corner of the grid is used. *
< ! Unlike in the eta system, no difference between heights for u,v and *
< ! heights for w exists. *
< !*************************************************************************
<
<
< ! do 897 kz=1,nuvz
< ! write (*,*) 'akz: ',akz(kz),'bkz',bkz(kz)
< !897 continue
<
< if (init) then
<
< ! Search for a point with high surface pressure (i.e. not above significant topography)
< ! Then, use this point to construct a reference z profile, to be used at all times
< !*****************************************************************************
<
< do jy=0,nymin1
< do ix=0,nxmin1
< if (ps(ix,jy,1,n).gt.100000.) then
< ixm=ix
< jym=jy
< goto 3
< endif
< end do
< end do
< 3 continue
<
<
< tvold=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n))/ &
< ps(ixm,jym,1,n))
< pold=ps(ixm,jym,1,n)
< height(1)=0.
<
< do kz=2,nuvz
< pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n)
< tv=tth(ixm,jym,kz,n)*(1.+0.608*qvh(ixm,jym,kz,n))
<
<
< ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
< ! upon the transformation to z levels. In order to save computer memory, this is
< ! not done anymore in the standard version. However, this option can still be
< ! switched on by replacing the following lines with those below, that are
< ! currently commented out.
< ! Note that two more changes are necessary in this subroutine below.
< ! One change is also necessary in gridcheck.f, and another one in verttransform_nests.
< !*****************************************************************************
<
< if (abs(tv-tvold).gt.0.2) then
< height(kz)= &
< height(kz-1)+const*log(pold/pint)* &
< (tv-tvold)/log(tv/tvold)
< else
< height(kz)=height(kz-1)+ &
< const*log(pold/pint)*tv
< endif
<
< ! Switch on following lines to use doubled vertical resolution
< !*************************************************************
< ! if (abs(tv-tvold).gt.0.2) then
< ! height((kz-1)*2)=
< ! + height(max((kz-2)*2,1))+const*log(pold/pint)*
< ! + (tv-tvold)/log(tv/tvold)
< ! else
< ! height((kz-1)*2)=height(max((kz-2)*2,1))+
< ! + const*log(pold/pint)*tv
< ! endif
< ! End doubled vertical resolution
<
< tvold=tv
< pold=pint
< end do
<
<
< ! Switch on following lines to use doubled vertical resolution
< !*************************************************************
< ! do 7 kz=3,nz-1,2
< ! height(kz)=0.5*(height(kz-1)+height(kz+1))
< ! height(nz)=height(nz-1)+height(nz-1)-height(nz-2)
< ! End doubled vertical resolution
<
<
< ! Determine highest levels that can be within PBL
< !************************************************
<
< do kz=1,nz
< if (height(kz).gt.hmixmax) then
< nmixz=kz
< goto 9
< endif
< end do
< 9 continue
<
< ! Do not repeat initialization of the Cartesian z grid
< !*****************************************************
<
< init=.false.
<
< endif
<
<
< ! Loop over the whole grid
< !*************************
<
< do jy=0,nymin1
< do ix=0,nxmin1
< tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
< ps(ix,jy,1,n))
< pold=ps(ix,jy,1,n)
< uvzlev(1)=0.
< wzlev(1)=0.
< rhoh(1)=pold/(r_air*tvold)
<
<
< ! Compute heights of eta levels
< !******************************
<
< do kz=2,nuvz
< pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n)
< tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
< rhoh(kz)=pint/(r_air*tv)
<
< if (abs(tv-tvold).gt.0.2) then
< uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)* &
< (tv-tvold)/log(tv/tvold)
< else
< uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)*tv
< endif
<
< tvold=tv
< pold=pint
< end do
<
<
< do kz=2,nwz-1
< wzlev(kz)=(uvzlev(kz+1)+uvzlev(kz))/2.
< end do
< wzlev(nwz)=wzlev(nwz-1)+ &
< uvzlev(nuvz)-uvzlev(nuvz-1)
<
< uvwzlev(ix,jy,1)=0.0
< do kz=2,nuvz
< uvwzlev(ix,jy,kz)=uvzlev(kz)
< end do
<
< ! Switch on following lines to use doubled vertical resolution
< ! Switch off the three lines above.
< !*************************************************************
< !22 uvwzlev(ix,jy,(kz-1)*2)=uvzlev(kz)
< ! do 23 kz=2,nwz
< !23 uvwzlev(ix,jy,(kz-1)*2+1)=wzlev(kz)
< ! End doubled vertical resolution
<
< ! pinmconv=(h2-h1)/(p2-p1)
<
< pinmconv(1)=(uvwzlev(ix,jy,2)-uvwzlev(ix,jy,1))/ &
< ((aknew(2)+bknew(2)*ps(ix,jy,1,n))- &
< (aknew(1)+bknew(1)*ps(ix,jy,1,n)))
< do kz=2,nz-1
< pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
< ((aknew(kz+1)+bknew(kz+1)*ps(ix,jy,1,n))- &
< (aknew(kz-1)+bknew(kz-1)*ps(ix,jy,1,n)))
< end do
< pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
< ((aknew(nz)+bknew(nz)*ps(ix,jy,1,n))- &
< (aknew(nz-1)+bknew(nz-1)*ps(ix,jy,1,n)))
<
< ! Levels, where u,v,t and q are given
< !************************************
<
< uu(ix,jy,1,n)=uuh(ix,jy,1)
< vv(ix,jy,1,n)=vvh(ix,jy,1)
< tt(ix,jy,1,n)=tth(ix,jy,1,n)
< qv(ix,jy,1,n)=qvh(ix,jy,1,n)
< pv(ix,jy,1,n)=pvh(ix,jy,1)
< rho(ix,jy,1,n)=rhoh(1)
< uu(ix,jy,nz,n)=uuh(ix,jy,nuvz)
< vv(ix,jy,nz,n)=vvh(ix,jy,nuvz)
< tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n)
< qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n)
< pv(ix,jy,nz,n)=pvh(ix,jy,nuvz)
< rho(ix,jy,nz,n)=rhoh(nuvz)
< kmin=2
< do iz=2,nz-1
< do kz=kmin,nuvz
< if(height(iz).gt.uvzlev(nuvz)) then
< uu(ix,jy,iz,n)=uu(ix,jy,nz,n)
< vv(ix,jy,iz,n)=vv(ix,jy,nz,n)
< tt(ix,jy,iz,n)=tt(ix,jy,nz,n)
< qv(ix,jy,iz,n)=qv(ix,jy,nz,n)
< pv(ix,jy,iz,n)=pv(ix,jy,nz,n)
< rho(ix,jy,iz,n)=rho(ix,jy,nz,n)
< goto 30
< endif
< if ((height(iz).gt.uvzlev(kz-1)).and. &
< (height(iz).le.uvzlev(kz))) then
< dz1=height(iz)-uvzlev(kz-1)
< dz2=uvzlev(kz)-height(iz)
< dz=dz1+dz2
< uu(ix,jy,iz,n)=(uuh(ix,jy,kz-1)*dz2+uuh(ix,jy,kz)*dz1)/dz
< vv(ix,jy,iz,n)=(vvh(ix,jy,kz-1)*dz2+vvh(ix,jy,kz)*dz1)/dz
< tt(ix,jy,iz,n)=(tth(ix,jy,kz-1,n)*dz2 &
< +tth(ix,jy,kz,n)*dz1)/dz
< qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2 &
< +qvh(ix,jy,kz,n)*dz1)/dz
< pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz
< rho(ix,jy,iz,n)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
< kmin=kz
< goto 30
< endif
< end do
< 30 continue
< end do
<
<
< ! Levels, where w is given
< !*************************
<
< ww(ix,jy,1,n)=wwh(ix,jy,1)*pinmconv(1)
< ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(nz)
< kmin=2
< do iz=2,nz
< do kz=kmin,nwz
< if ((height(iz).gt.wzlev(kz-1)).and. &
< (height(iz).le.wzlev(kz))) then
< dz1=height(iz)-wzlev(kz-1)
< dz2=wzlev(kz)-height(iz)
< dz=dz1+dz2
< ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(kz-1)*dz2 &
< +wwh(ix,jy,kz)*pinmconv(kz)*dz1)/dz
< kmin=kz
< goto 40
< endif
< end do
< 40 continue
< end do
<
< ! Compute density gradients at intermediate levels
< !*************************************************
<
< drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/ &
< (height(2)-height(1))
< do kz=2,nz-1
< drhodz(ix,jy,kz,n)=(rho(ix,jy,kz+1,n)-rho(ix,jy,kz-1,n))/ &
< (height(kz+1)-height(kz-1))
< end do
< drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n)
<
< end do
< end do
<
<
< !****************************************************************
< ! Compute slope of eta levels in windward direction and resulting
< ! vertical wind correction
< !****************************************************************
<
< do jy=1,ny-2
< do ix=1,nx-2
<
< kmin=2
< do iz=2,nz-1
<
< ui=uu(ix,jy,iz,n)*dxconst/cos((real(jy)*dy+ylat0)*pi180)
< vi=vv(ix,jy,iz,n)*dyconst
<
< do kz=kmin,nz
< if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
< (height(iz).le.uvwzlev(ix,jy,kz))) then
< dz1=height(iz)-uvwzlev(ix,jy,kz-1)
< dz2=uvwzlev(ix,jy,kz)-height(iz)
< dz=dz1+dz2
< kl=kz-1
< klp=kz
< kmin=kz
< goto 47
< endif
< end do
<
< 47 ix1=ix-1
< jy1=jy-1
< ixp=ix+1
< jyp=jy+1
<
< dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
< dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
< dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
<
< dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
< dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
< dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
<
< ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*ui+dzdy*vi)
<
< end do
<
< end do
< end do
<
<
< ! If north pole is in the domain, calculate wind velocities in polar
< ! stereographic coordinates
< !*******************************************************************
<
< if (nglobal) then
< do jy=int(switchnorthg)-2,nymin1
< ylat=ylat0+real(jy)*dy
< do ix=0,nxmin1
< xlon=xlon0+real(ix)*dx
< do iz=1,nz
< call cc2gll(northpolemap,ylat,xlon,uu(ix,jy,iz,n), &
< vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
< vvpol(ix,jy,iz,n))
< end do
< end do
< end do
<
<
< do iz=1,nz
<
< ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
< !
< ! AMSnauffer Nov 18 2004 Added check for case vv=0
< !
< xlon=xlon0+real(nx/2-1)*dx
< xlonr=xlon*pi/180.
< ffpol=sqrt(uu(nx/2-1,nymin1,iz,n)**2+ &
< vv(nx/2-1,nymin1,iz,n)**2)
< if (vv(nx/2-1,nymin1,iz,n).lt.0.) then
< ddpol=atan(uu(nx/2-1,nymin1,iz,n)/ &
< vv(nx/2-1,nymin1,iz,n))-xlonr
< else if (vv(nx/2-1,nymin1,iz,n).gt.0.) then
< ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ &
< vv(nx/2-1,nymin1,iz,n))-xlonr
< else
< ddpol=pi/2-xlonr
< endif
< if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
< if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
<
< ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
< xlon=180.0
< xlonr=xlon*pi/180.
< ylat=90.0
< uuaux=-ffpol*sin(xlonr+ddpol)
< vvaux=-ffpol*cos(xlonr+ddpol)
< call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
< vvpolaux)
<
< jy=nymin1
< do ix=0,nxmin1
< uupol(ix,jy,iz,n)=uupolaux
< vvpol(ix,jy,iz,n)=vvpolaux
< end do
< end do
<
<
< ! Fix: Set W at pole to the zonally averaged W of the next equator-
< ! ward parallel of latitude
<
< do iz=1,nz
< wdummy=0.
< jy=ny-2
< do ix=0,nxmin1
< wdummy=wdummy+ww(ix,jy,iz,n)
< end do
< wdummy=wdummy/real(nx)
< jy=nymin1
< do ix=0,nxmin1
< ww(ix,jy,iz,n)=wdummy
< end do
< end do
<
< endif
<
<
< ! If south pole is in the domain, calculate wind velocities in polar
< ! stereographic coordinates
< !*******************************************************************
<
< if (sglobal) then
< do jy=0,int(switchsouthg)+3
< ylat=ylat0+real(jy)*dy
< do ix=0,nxmin1
< xlon=xlon0+real(ix)*dx
< do iz=1,nz
< call cc2gll(southpolemap,ylat,xlon,uu(ix,jy,iz,n), &
< vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
< vvpol(ix,jy,iz,n))
< end do
< end do
< end do
<
< do iz=1,nz
<
< ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
< !
< ! AMSnauffer Nov 18 2004 Added check for case vv=0
< !
< xlon=xlon0+real(nx/2-1)*dx
< xlonr=xlon*pi/180.
< ffpol=sqrt(uu(nx/2-1,0,iz,n)**2+ &
< vv(nx/2-1,0,iz,n)**2)
< if (vv(nx/2-1,0,iz,n).lt.0.) then
< ddpol=atan(uu(nx/2-1,0,iz,n)/ &
< vv(nx/2-1,0,iz,n))+xlonr
< else if (vv(nx/2-1,0,iz,n).gt.0.) then
< ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ &
< vv(nx/2-1,0,iz,n))+xlonr
< else
< ddpol=pi/2-xlonr
< endif
< if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
< if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
<
< ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
< xlon=180.0
< xlonr=xlon*pi/180.
< ylat=-90.0
< uuaux=+ffpol*sin(xlonr-ddpol)
< vvaux=-ffpol*cos(xlonr-ddpol)
< call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
< vvpolaux)
<
< jy=0
< do ix=0,nxmin1
< uupol(ix,jy,iz,n)=uupolaux
< vvpol(ix,jy,iz,n)=vvpolaux
< end do
< end do
<
<
< ! Fix: Set W at pole to the zonally averaged W of the next equator-
< ! ward parallel of latitude
<
< do iz=1,nz
< wdummy=0.
< jy=1
< do ix=0,nxmin1
< wdummy=wdummy+ww(ix,jy,iz,n)
< end do
< wdummy=wdummy/real(nx)
< jy=0
< do ix=0,nxmin1
< ww(ix,jy,iz,n)=wdummy
< end do
< end do
< endif
<
<
< !write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz
< ! create a cloud and rainout/washout field, clouds occur where rh>80%
< ! total cloudheight is stored at level 0
< do jy=0,nymin1
< do ix=0,nxmin1
< rain_cloud_above=0
< lsp=lsprec(ix,jy,1,n)
< convp=convprec(ix,jy,1,n)
< cloudsh(ix,jy,n)=0
< do kz_inv=1,nz-1
< kz=nz-kz_inv+1
< pressure=rho(ix,jy,kz,n)*r_air*tt(ix,jy,kz,n)
< rh=qv(ix,jy,kz,n)/f_qvsat(pressure,tt(ix,jy,kz,n))
< clouds(ix,jy,kz,n)=0
< if (rh.gt.0.8) then ! in cloud
< if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
< rain_cloud_above=1
< cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+ &
< height(kz)-height(kz-1)
< if (lsp.ge.convp) then
< clouds(ix,jy,kz,n)=3 ! lsp dominated rainout
< else
< clouds(ix,jy,kz,n)=2 ! convp dominated rainout
< endif
< else ! no precipitation
< clouds(ix,jy,kz,n)=1 ! cloud
< endif
< else ! no cloud
< if (rain_cloud_above.eq.1) then ! scavenging
< if (lsp.ge.convp) then
< clouds(ix,jy,kz,n)=5 ! lsp dominated washout
< else
< clouds(ix,jy,kz,n)=4 ! convp dominated washout
< endif
< endif
< endif
< end do
< end do
< end do
<
< !do 102 kz=1,nuvz
< !write(an,'(i02)') kz+10
< !write(*,*) nuvz,nymin1,nxmin1,'--',an,'--'
< !open(4,file='/nilu_wrk2/sec/cloudtest/cloud'//an,form='formatted')
< !do 101 jy=0,nymin1
< ! write(4,*) (clouds(ix,jy,kz,n),ix=1,nxmin1)
< !101 continue
< ! close(4)
< !102 continue
<
< ! open(4,file='/nilu_wrk2/sec/cloudtest/height',form='formatted')
< ! do 103 jy=0,nymin1
< ! write (4,*)
< !+ (height(kz),kz=1,nuvz)
< !103 continue
< ! close(4)
<
< !open(4,file='/nilu_wrk2/sec/cloudtest/p',form='formatted')
< ! do 104 jy=0,nymin1
< ! write (4,*)
< !+ (r_air*tt(ix,jy,1,n)*rho(ix,jy,1,n),ix=1,nxmin1)
< !104 continue
< ! close(4)
< end subroutine verttransform
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine verttransform(n,uuh,vvh,wwh,pvh)
> ! i i i i i
> !*****************************************************************************
> ! *
> ! This subroutine transforms temperature, dew point temperature and *
> ! wind components from eta to meter coordinates. *
> ! The vertical wind component is transformed from Pa/s to m/s using *
> ! the conversion factor pinmconv. *
> ! In addition, this routine calculates vertical density gradients *
> ! needed for the parameterization of the turbulent velocities. *
> ! *
> ! Author: A. Stohl, G. Wotawa *
> ! *
> ! 12 August 1996 *
> ! Update: 16 January 1998 *
> ! *
> ! Major update: 17 February 1999 *
> ! by G. Wotawa *
> ! *
> ! - Vertical levels for u, v and w are put together *
> ! - Slope correction for vertical velocity: Modification of calculation *
> ! procedure *
> ! *
> !*****************************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001:
> ! Variables tth and qvh (on eta coordinates) from common block
> !*****************************************************************************
> ! Sabine Eckhardt, March 2007
> ! added the variable cloud for use with scavenging - descr. in com_mod
> !*****************************************************************************
> ! *
> ! Variables: *
> ! nx,ny,nz field dimensions in x,y and z direction *
> ! clouds(0:nxmax,0:nymax,0:nzmax,2) cloud field for wet deposition *
> ! uu(0:nxmax,0:nymax,nzmax,2) wind components in x-direction [m/s] *
> ! vv(0:nxmax,0:nymax,nzmax,2) wind components in y-direction [m/s] *
> ! ww(0:nxmax,0:nymax,nzmax,2) wind components in z-direction [deltaeta/s]*
> ! tt(0:nxmax,0:nymax,nzmax,2) temperature [K] *
> ! pv(0:nxmax,0:nymax,nzmax,2) potential voriticity (pvu) *
> ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use cmapf_mod, only: cc2gll
>
> implicit none
>
> integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym
> integer :: rain_cloud_above,kz_inv
> real :: f_qvsat,pressure
> real :: rh,lsp,convp
> real :: uvzlev(nuvzmax),rhoh(nuvzmax),pinmconv(nzmax)
> real :: ew,pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
> real :: xlon,ylat,xlonr,dzdx,dzdy
> real :: dzdx1,dzdx2,dzdy1,dzdy2
> real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy
> real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
> real :: wzlev(nwzmax),uvwzlev(0:nxmax-1,0:nymax-1,nzmax)
> real,parameter :: const=r_air/ga
>
> logical :: init = .true.
>
>
> !*************************************************************************
> ! If verttransform is called the first time, initialize heights of the *
> ! z levels in meter. The heights are the heights of model levels, where *
> ! u,v,T and qv are given, and of the interfaces, where w is given. So, *
> ! the vertical resolution in the z system is doubled. As reference point,*
> ! the lower left corner of the grid is used. *
> ! Unlike in the eta system, no difference between heights for u,v and *
> ! heights for w exists. *
> !*************************************************************************
>
>
> ! do 897 kz=1,nuvz
> ! write (*,*) 'akz: ',akz(kz),'bkz',bkz(kz)
> !897 continue
>
> if (init) then
>
> ! Search for a point with high surface pressure (i.e. not above significant topography)
> ! Then, use this point to construct a reference z profile, to be used at all times
> !*****************************************************************************
>
> do jy=0,nymin1
> do ix=0,nxmin1
> if (ps(ix,jy,1,n).gt.100000.) then
> ixm=ix
> jym=jy
> goto 3
> endif
> end do
> end do
> 3 continue
>
>
> tvold=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n))/ &
> ps(ixm,jym,1,n))
> pold=ps(ixm,jym,1,n)
> height(1)=0.
>
> do kz=2,nuvz
> pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n)
> tv=tth(ixm,jym,kz,n)*(1.+0.608*qvh(ixm,jym,kz,n))
>
>
> ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
> ! upon the transformation to z levels. In order to save computer memory, this is
> ! not done anymore in the standard version. However, this option can still be
> ! switched on by replacing the following lines with those below, that are
> ! currently commented out.
> ! Note that two more changes are necessary in this subroutine below.
> ! One change is also necessary in gridcheck.f, and another one in verttransform_nests.
> !*****************************************************************************
>
> if (abs(tv-tvold).gt.0.2) then
> height(kz)= &
> height(kz-1)+const*log(pold/pint)* &
> (tv-tvold)/log(tv/tvold)
> else
> height(kz)=height(kz-1)+ &
> const*log(pold/pint)*tv
> endif
>
> ! Switch on following lines to use doubled vertical resolution
> !*************************************************************
> ! if (abs(tv-tvold).gt.0.2) then
> ! height((kz-1)*2)=
> ! + height(max((kz-2)*2,1))+const*log(pold/pint)*
> ! + (tv-tvold)/log(tv/tvold)
> ! else
> ! height((kz-1)*2)=height(max((kz-2)*2,1))+
> ! + const*log(pold/pint)*tv
> ! endif
> ! End doubled vertical resolution
>
> tvold=tv
> pold=pint
> end do
>
>
> ! Switch on following lines to use doubled vertical resolution
> !*************************************************************
> ! do 7 kz=3,nz-1,2
> ! height(kz)=0.5*(height(kz-1)+height(kz+1))
> ! height(nz)=height(nz-1)+height(nz-1)-height(nz-2)
> ! End doubled vertical resolution
>
>
> ! Determine highest levels that can be within PBL
> !************************************************
>
> do kz=1,nz
> if (height(kz).gt.hmixmax) then
> nmixz=kz
> goto 9
> endif
> end do
> 9 continue
>
> ! Do not repeat initialization of the Cartesian z grid
> !*****************************************************
>
> init=.false.
>
> endif
>
>
> ! Loop over the whole grid
> !*************************
>
> do jy=0,nymin1
> do ix=0,nxmin1
> tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n))/ &
> ps(ix,jy,1,n))
> pold=ps(ix,jy,1,n)
> uvzlev(1)=0.
> wzlev(1)=0.
> rhoh(1)=pold/(r_air*tvold)
>
>
> ! Compute heights of eta levels
> !******************************
>
> do kz=2,nuvz
> pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n)
> tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
> rhoh(kz)=pint/(r_air*tv)
>
> if (abs(tv-tvold).gt.0.2) then
> uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)* &
> (tv-tvold)/log(tv/tvold)
> else
> uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)*tv
> endif
>
> tvold=tv
> pold=pint
> end do
>
>
> do kz=2,nwz-1
> wzlev(kz)=(uvzlev(kz+1)+uvzlev(kz))/2.
> end do
> wzlev(nwz)=wzlev(nwz-1)+ &
> uvzlev(nuvz)-uvzlev(nuvz-1)
>
> uvwzlev(ix,jy,1)=0.0
> do kz=2,nuvz
> uvwzlev(ix,jy,kz)=uvzlev(kz)
> end do
>
> ! Switch on following lines to use doubled vertical resolution
> ! Switch off the three lines above.
> !*************************************************************
> !22 uvwzlev(ix,jy,(kz-1)*2)=uvzlev(kz)
> ! do 23 kz=2,nwz
> !23 uvwzlev(ix,jy,(kz-1)*2+1)=wzlev(kz)
> ! End doubled vertical resolution
>
> ! pinmconv=(h2-h1)/(p2-p1)
>
> pinmconv(1)=(uvwzlev(ix,jy,2)-uvwzlev(ix,jy,1))/ &
> ((aknew(2)+bknew(2)*ps(ix,jy,1,n))- &
> (aknew(1)+bknew(1)*ps(ix,jy,1,n)))
> do kz=2,nz-1
> pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
> ((aknew(kz+1)+bknew(kz+1)*ps(ix,jy,1,n))- &
> (aknew(kz-1)+bknew(kz-1)*ps(ix,jy,1,n)))
> end do
> pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
> ((aknew(nz)+bknew(nz)*ps(ix,jy,1,n))- &
> (aknew(nz-1)+bknew(nz-1)*ps(ix,jy,1,n)))
>
> ! Levels, where u,v,t and q are given
> !************************************
>
> uu(ix,jy,1,n)=uuh(ix,jy,1)
> vv(ix,jy,1,n)=vvh(ix,jy,1)
> tt(ix,jy,1,n)=tth(ix,jy,1,n)
> qv(ix,jy,1,n)=qvh(ix,jy,1,n)
> pv(ix,jy,1,n)=pvh(ix,jy,1)
> rho(ix,jy,1,n)=rhoh(1)
> uu(ix,jy,nz,n)=uuh(ix,jy,nuvz)
> vv(ix,jy,nz,n)=vvh(ix,jy,nuvz)
> tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n)
> qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n)
> pv(ix,jy,nz,n)=pvh(ix,jy,nuvz)
> rho(ix,jy,nz,n)=rhoh(nuvz)
> kmin=2
> do iz=2,nz-1
> do kz=kmin,nuvz
> if(height(iz).gt.uvzlev(nuvz)) then
> uu(ix,jy,iz,n)=uu(ix,jy,nz,n)
> vv(ix,jy,iz,n)=vv(ix,jy,nz,n)
> tt(ix,jy,iz,n)=tt(ix,jy,nz,n)
> qv(ix,jy,iz,n)=qv(ix,jy,nz,n)
> pv(ix,jy,iz,n)=pv(ix,jy,nz,n)
> rho(ix,jy,iz,n)=rho(ix,jy,nz,n)
> goto 30
> endif
> if ((height(iz).gt.uvzlev(kz-1)).and. &
> (height(iz).le.uvzlev(kz))) then
> dz1=height(iz)-uvzlev(kz-1)
> dz2=uvzlev(kz)-height(iz)
> dz=dz1+dz2
> uu(ix,jy,iz,n)=(uuh(ix,jy,kz-1)*dz2+uuh(ix,jy,kz)*dz1)/dz
> vv(ix,jy,iz,n)=(vvh(ix,jy,kz-1)*dz2+vvh(ix,jy,kz)*dz1)/dz
> tt(ix,jy,iz,n)=(tth(ix,jy,kz-1,n)*dz2 &
> +tth(ix,jy,kz,n)*dz1)/dz
> qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2 &
> +qvh(ix,jy,kz,n)*dz1)/dz
> pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz
> rho(ix,jy,iz,n)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
> kmin=kz
> goto 30
> endif
> end do
> 30 continue
> end do
>
>
> ! Levels, where w is given
> !*************************
>
> ww(ix,jy,1,n)=wwh(ix,jy,1)*pinmconv(1)
> ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(nz)
> kmin=2
> do iz=2,nz
> do kz=kmin,nwz
> if ((height(iz).gt.wzlev(kz-1)).and. &
> (height(iz).le.wzlev(kz))) then
> dz1=height(iz)-wzlev(kz-1)
> dz2=wzlev(kz)-height(iz)
> dz=dz1+dz2
> ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(kz-1)*dz2 &
> +wwh(ix,jy,kz)*pinmconv(kz)*dz1)/dz
> kmin=kz
> goto 40
> endif
> end do
> 40 continue
> end do
>
> ! Compute density gradients at intermediate levels
> !*************************************************
>
> drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/ &
> (height(2)-height(1))
> do kz=2,nz-1
> drhodz(ix,jy,kz,n)=(rho(ix,jy,kz+1,n)-rho(ix,jy,kz-1,n))/ &
> (height(kz+1)-height(kz-1))
> end do
> drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n)
>
> end do
> end do
>
>
> !****************************************************************
> ! Compute slope of eta levels in windward direction and resulting
> ! vertical wind correction
> !****************************************************************
>
> do jy=1,ny-2
> do ix=1,nx-2
>
> kmin=2
> do iz=2,nz-1
>
> ui=uu(ix,jy,iz,n)*dxconst/cos((real(jy)*dy+ylat0)*pi180)
> vi=vv(ix,jy,iz,n)*dyconst
>
> do kz=kmin,nz
> if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
> (height(iz).le.uvwzlev(ix,jy,kz))) then
> dz1=height(iz)-uvwzlev(ix,jy,kz-1)
> dz2=uvwzlev(ix,jy,kz)-height(iz)
> dz=dz1+dz2
> kl=kz-1
> klp=kz
> kmin=kz
> goto 47
> endif
> end do
>
> 47 ix1=ix-1
> jy1=jy-1
> ixp=ix+1
> jyp=jy+1
>
> dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
> dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
> dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
>
> dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
> dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
> dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
>
> ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*ui+dzdy*vi)
>
> end do
>
> end do
> end do
>
>
> ! If north pole is in the domain, calculate wind velocities in polar
> ! stereographic coordinates
> !*******************************************************************
>
> if (nglobal) then
> do jy=int(switchnorthg)-2,nymin1
> ylat=ylat0+real(jy)*dy
> do ix=0,nxmin1
> xlon=xlon0+real(ix)*dx
> do iz=1,nz
> call cc2gll(northpolemap,ylat,xlon,uu(ix,jy,iz,n), &
> vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
> vvpol(ix,jy,iz,n))
> end do
> end do
> end do
>
>
> do iz=1,nz
>
> ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
> !
> ! AMSnauffer Nov 18 2004 Added check for case vv=0
> !
> xlon=xlon0+real(nx/2-1)*dx
> xlonr=xlon*pi/180.
> ffpol=sqrt(uu(nx/2-1,nymin1,iz,n)**2+ &
> vv(nx/2-1,nymin1,iz,n)**2)
> if (vv(nx/2-1,nymin1,iz,n).lt.0.) then
> ddpol=atan(uu(nx/2-1,nymin1,iz,n)/ &
> vv(nx/2-1,nymin1,iz,n))-xlonr
> else if (vv(nx/2-1,nymin1,iz,n).gt.0.) then
> ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ &
> vv(nx/2-1,nymin1,iz,n))-xlonr
> else
> ddpol=pi/2-xlonr
> endif
> if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
> if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
>
> ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
> xlon=180.0
> xlonr=xlon*pi/180.
> ylat=90.0
> uuaux=-ffpol*sin(xlonr+ddpol)
> vvaux=-ffpol*cos(xlonr+ddpol)
> call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
> vvpolaux)
>
> jy=nymin1
> do ix=0,nxmin1
> uupol(ix,jy,iz,n)=uupolaux
> vvpol(ix,jy,iz,n)=vvpolaux
> end do
> end do
>
>
> ! Fix: Set W at pole to the zonally averaged W of the next equator-
> ! ward parallel of latitude
>
> do iz=1,nz
> wdummy=0.
> jy=ny-2
> do ix=0,nxmin1
> wdummy=wdummy+ww(ix,jy,iz,n)
> end do
> wdummy=wdummy/real(nx)
> jy=nymin1
> do ix=0,nxmin1
> ww(ix,jy,iz,n)=wdummy
> end do
> end do
>
> endif
>
>
> ! If south pole is in the domain, calculate wind velocities in polar
> ! stereographic coordinates
> !*******************************************************************
>
> if (sglobal) then
> do jy=0,int(switchsouthg)+3
> ylat=ylat0+real(jy)*dy
> do ix=0,nxmin1
> xlon=xlon0+real(ix)*dx
> do iz=1,nz
> call cc2gll(southpolemap,ylat,xlon,uu(ix,jy,iz,n), &
> vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
> vvpol(ix,jy,iz,n))
> end do
> end do
> end do
>
> do iz=1,nz
>
> ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
> !
> ! AMSnauffer Nov 18 2004 Added check for case vv=0
> !
> xlon=xlon0+real(nx/2-1)*dx
> xlonr=xlon*pi/180.
> ffpol=sqrt(uu(nx/2-1,0,iz,n)**2+ &
> vv(nx/2-1,0,iz,n)**2)
> if (vv(nx/2-1,0,iz,n).lt.0.) then
> ddpol=atan(uu(nx/2-1,0,iz,n)/ &
> vv(nx/2-1,0,iz,n))+xlonr
> else if (vv(nx/2-1,0,iz,n).gt.0.) then
> ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ &
> vv(nx/2-1,0,iz,n))+xlonr
> else
> ddpol=pi/2-xlonr
> endif
> if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
> if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
>
> ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
> xlon=180.0
> xlonr=xlon*pi/180.
> ylat=-90.0
> uuaux=+ffpol*sin(xlonr-ddpol)
> vvaux=-ffpol*cos(xlonr-ddpol)
> call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
> vvpolaux)
>
> jy=0
> do ix=0,nxmin1
> uupol(ix,jy,iz,n)=uupolaux
> vvpol(ix,jy,iz,n)=vvpolaux
> end do
> end do
>
>
> ! Fix: Set W at pole to the zonally averaged W of the next equator-
> ! ward parallel of latitude
>
> do iz=1,nz
> wdummy=0.
> jy=1
> do ix=0,nxmin1
> wdummy=wdummy+ww(ix,jy,iz,n)
> end do
> wdummy=wdummy/real(nx)
> jy=0
> do ix=0,nxmin1
> ww(ix,jy,iz,n)=wdummy
> end do
> end do
> endif
>
>
> !write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz
> ! create a cloud and rainout/washout field, clouds occur where rh>80%
> ! total cloudheight is stored at level 0
> do jy=0,nymin1
> do ix=0,nxmin1
> rain_cloud_above=0
> lsp=lsprec(ix,jy,1,n)
> convp=convprec(ix,jy,1,n)
> cloudsh(ix,jy,n)=0
> do kz_inv=1,nz-1
> kz=nz-kz_inv+1
> pressure=rho(ix,jy,kz,n)*r_air*tt(ix,jy,kz,n)
> rh=qv(ix,jy,kz,n)/f_qvsat(pressure,tt(ix,jy,kz,n))
> clouds(ix,jy,kz,n)=0
> if (rh.gt.0.8) then ! in cloud
> if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
> rain_cloud_above=1
> cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+ &
> height(kz)-height(kz-1)
> if (lsp.ge.convp) then
> clouds(ix,jy,kz,n)=3 ! lsp dominated rainout
> else
> clouds(ix,jy,kz,n)=2 ! convp dominated rainout
> endif
> else ! no precipitation
> clouds(ix,jy,kz,n)=1 ! cloud
> endif
> else ! no cloud
> if (rain_cloud_above.eq.1) then ! scavenging
> if (lsp.ge.convp) then
> clouds(ix,jy,kz,n)=5 ! lsp dominated washout
> else
> clouds(ix,jy,kz,n)=4 ! convp dominated washout
> endif
> endif
> endif
> end do
> end do
> end do
>
> !do 102 kz=1,nuvz
> !write(an,'(i02)') kz+10
> !write(*,*) nuvz,nymin1,nxmin1,'--',an,'--'
> !open(4,file='/nilu_wrk2/sec/cloudtest/cloud'//an,form='formatted')
> !do 101 jy=0,nymin1
> ! write(4,*) (clouds(ix,jy,kz,n),ix=1,nxmin1)
> !101 continue
> ! close(4)
> !102 continue
>
> ! open(4,file='/nilu_wrk2/sec/cloudtest/height',form='formatted')
> ! do 103 jy=0,nymin1
> ! write (4,*)
> !+ (height(kz),kz=1,nuvz)
> !103 continue
> ! close(4)
>
> !open(4,file='/nilu_wrk2/sec/cloudtest/p',form='formatted')
> ! do 104 jy=0,nymin1
> ! write (4,*)
> !+ (r_air*tt(ix,jy,1,n)*rho(ix,jy,1,n),ix=1,nxmin1)
> !104 continue
> ! close(4)
> end subroutine verttransform
verttransform_gfs.f90
----------------------------------------------
1,590c1,590
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine verttransform(n,uuh,vvh,wwh,pvh)
< ! i i i i i
< !*****************************************************************************
< ! *
< ! This subroutine transforms temperature, dew point temperature and *
< ! wind components from eta to meter coordinates. *
< ! The vertical wind component is transformed from Pa/s to m/s using *
< ! the conversion factor pinmconv. *
< ! In addition, this routine calculates vertical density gradients *
< ! needed for the parameterization of the turbulent velocities. *
< ! *
< ! Author: A. Stohl, G. Wotawa *
< ! *
< ! 12 August 1996 *
< ! Update: 16 January 1998 *
< ! *
< ! Major update: 17 February 1999 *
< ! by G. Wotawa *
< ! CHANGE 17/11/2005 Caroline Forster, NCEP GFS version *
< ! *
< ! - Vertical levels for u, v and w are put together *
< ! - Slope correction for vertical velocity: Modification of calculation *
< ! procedure *
< ! *
< !*****************************************************************************
< ! Changes, Bernd C. Krueger, Feb. 2001:
< ! Variables tth and qvh (on eta coordinates) from common block
< !*****************************************************************************
< ! *
< ! Variables: *
< ! nx,ny,nz field dimensions in x,y and z direction *
< ! uu(0:nxmax,0:nymax,nzmax,2) wind components in x-direction [m/s] *
< ! vv(0:nxmax,0:nymax,nzmax,2) wind components in y-direction [m/s] *
< ! ww(0:nxmax,0:nymax,nzmax,2) wind components in z-direction [deltaeta/s]*
< ! tt(0:nxmax,0:nymax,nzmax,2) temperature [K] *
< ! pv(0:nxmax,0:nymax,nzmax,2) potential voriticity (pvu) *
< ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
< ! clouds(0:nxmax,0:nymax,0:nzmax,2) cloud field for wet deposition *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
< use cmapf_mod
<
< implicit none
<
< integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym
< integer :: rain_cloud_above,kz_inv
< real :: f_qvsat,pressure
< real :: rh,lsp,convp
< real :: uvzlev(nuvzmax),rhoh(nuvzmax),pinmconv(nzmax)
< real :: ew,pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
< real :: xlon,ylat,xlonr,dzdx,dzdy
< real :: dzdx1,dzdx2,dzdy1,dzdy2
< real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy
< real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
< real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
< real :: wzlev(nwzmax),uvwzlev(0:nxmax-1,0:nymax-1,nzmax)
< real,parameter :: const=r_air/ga
<
< ! NCEP version
< integer :: llev, i
<
< logical :: init = .true.
<
<
< !*************************************************************************
< ! If verttransform is called the first time, initialize heights of the *
< ! z levels in meter. The heights are the heights of model levels, where *
< ! u,v,T and qv are given, and of the interfaces, where w is given. So, *
< ! the vertical resolution in the z system is doubled. As reference point,*
< ! the lower left corner of the grid is used. *
< ! Unlike in the eta system, no difference between heights for u,v and *
< ! heights for w exists. *
< !*************************************************************************
<
< if (init) then
<
< ! Search for a point with high surface pressure (i.e. not above significant topography)
< ! Then, use this point to construct a reference z profile, to be used at all times
< !*****************************************************************************
<
< do jy=0,nymin1
< do ix=0,nxmin1
< if (ps(ix,jy,1,n).gt.100000.) then
< ixm=ix
< jym=jy
< goto 3
< endif
< end do
< end do
< 3 continue
<
<
< tvold=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n))/ &
< ps(ixm,jym,1,n))
< pold=ps(ixm,jym,1,n)
< height(1)=0.
<
< do kz=2,nuvz
< pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n)
< tv=tth(ixm,jym,kz,n)*(1.+0.608*qvh(ixm,jym,kz,n))
<
<
< ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
< ! upon the transformation to z levels. In order to save computer memory, this is
< ! not done anymore in the standard version. However, this option can still be
< ! switched on by replacing the following lines with those below, that are
< ! currently commented out.
< ! Note that two more changes are necessary in this subroutine below.
< ! One change is also necessary in gridcheck.f, and another one in verttransform_nests.
< !*****************************************************************************
<
< if (abs(tv-tvold).gt.0.2) then
< height(kz)= &
< height(kz-1)+const*log(pold/pint)* &
< (tv-tvold)/log(tv/tvold)
< else
< height(kz)=height(kz-1)+ &
< const*log(pold/pint)*tv
< endif
<
< ! Switch on following lines to use doubled vertical resolution
< !*************************************************************
< ! if (abs(tv-tvold).gt.0.2) then
< ! height((kz-1)*2)=
< ! + height(max((kz-2)*2,1))+const*log(pold/pint)*
< ! + (tv-tvold)/log(tv/tvold)
< ! else
< ! height((kz-1)*2)=height(max((kz-2)*2,1))+
< ! + const*log(pold/pint)*tv
< ! endif
< ! End doubled vertical resolution
<
< tvold=tv
< pold=pint
< end do
<
<
< ! Switch on following lines to use doubled vertical resolution
< !*************************************************************
< ! do 7 kz=3,nz-1,2
< ! height(kz)=0.5*(height(kz-1)+height(kz+1))
< ! height(nz)=height(nz-1)+height(nz-1)-height(nz-2)
< ! End doubled vertical resolution
<
<
< ! Determine highest levels that can be within PBL
< !************************************************
<
< do kz=1,nz
< if (height(kz).gt.hmixmax) then
< nmixz=kz
< goto 9
< endif
< end do
< 9 continue
<
< ! Do not repeat initialization of the Cartesian z grid
< !*****************************************************
<
< init=.false.
<
< endif
<
<
< ! Loop over the whole grid
< !*************************
<
< do jy=0,nymin1
< do ix=0,nxmin1
<
< ! NCEP version: find first level above ground
< llev = 0
< do i=1,nuvz
< if (ps(ix,jy,1,n).lt.akz(i)) llev=i
< end do
< llev = llev+1
< if (llev.gt.nuvz-2) llev = nuvz-2
< ! if (llev.eq.nuvz-2) write(*,*) 'verttransform
< ! +WARNING: LLEV eq NUZV-2'
< ! NCEP version
<
<
< ! compute height of pressure levels above ground
< !***********************************************
<
< tvold=tth(ix,jy,llev,n)*(1.+0.608*qvh(ix,jy,llev,n))
< pold=akz(llev)
< uvzlev(llev)=0.
< wzlev(llev)=0.
< uvwzlev(ix,jy,llev)=0.
< rhoh(llev)=pold/(r_air*tvold)
<
< do kz=llev+1,nuvz
< pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n)
< tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
< rhoh(kz)=pint/(r_air*tv)
<
< if (abs(tv-tvold).gt.0.2) then
< uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)* &
< (tv-tvold)/log(tv/tvold)
< else
< uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)*tv
< endif
< wzlev(kz)=uvzlev(kz)
< uvwzlev(ix,jy,kz)=uvzlev(kz)
<
< tvold=tv
< pold=pint
< end do
<
<
< ! Switch on following lines to use doubled vertical resolution
< ! Switch off the three lines above.
< !*************************************************************
< !22 uvwzlev(ix,jy,(kz-1)*2)=uvzlev(kz)
< ! do 23 kz=2,nwz
< !23 uvwzlev(ix,jy,(kz-1)*2+1)=wzlev(kz)
< ! End doubled vertical resolution
<
< ! pinmconv=(h2-h1)/(p2-p1)
<
< pinmconv(llev)=(uvwzlev(ix,jy,llev+1)-uvwzlev(ix,jy,llev))/ &
< ((aknew(llev+1)+bknew(llev+1)*ps(ix,jy,1,n))- &
< (aknew(llev)+bknew(llev)*ps(ix,jy,1,n)))
< do kz=llev+1,nz-1
< pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
< ((aknew(kz+1)+bknew(kz+1)*ps(ix,jy,1,n))- &
< (aknew(kz-1)+bknew(kz-1)*ps(ix,jy,1,n)))
< end do
< pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
< ((aknew(nz)+bknew(nz)*ps(ix,jy,1,n))- &
< (aknew(nz-1)+bknew(nz-1)*ps(ix,jy,1,n)))
<
<
< ! Levels, where u,v,t and q are given
< !************************************
<
< uu(ix,jy,1,n)=uuh(ix,jy,llev)
< vv(ix,jy,1,n)=vvh(ix,jy,llev)
< tt(ix,jy,1,n)=tth(ix,jy,llev,n)
< qv(ix,jy,1,n)=qvh(ix,jy,llev,n)
< pv(ix,jy,1,n)=pvh(ix,jy,llev)
< rho(ix,jy,1,n)=rhoh(llev)
< pplev(ix,jy,1,n)=akz(llev)
< uu(ix,jy,nz,n)=uuh(ix,jy,nuvz)
< vv(ix,jy,nz,n)=vvh(ix,jy,nuvz)
< tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n)
< qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n)
< pv(ix,jy,nz,n)=pvh(ix,jy,nuvz)
< rho(ix,jy,nz,n)=rhoh(nuvz)
< pplev(ix,jy,nz,n)=akz(nuvz)
< kmin=llev+1
< do iz=2,nz-1
< do kz=kmin,nuvz
< if(height(iz).gt.uvzlev(nuvz)) then
< uu(ix,jy,iz,n)=uu(ix,jy,nz,n)
< vv(ix,jy,iz,n)=vv(ix,jy,nz,n)
< tt(ix,jy,iz,n)=tt(ix,jy,nz,n)
< qv(ix,jy,iz,n)=qv(ix,jy,nz,n)
< pv(ix,jy,iz,n)=pv(ix,jy,nz,n)
< rho(ix,jy,iz,n)=rho(ix,jy,nz,n)
< pplev(ix,jy,iz,n)=pplev(ix,jy,nz,n)
< goto 30
< endif
< if ((height(iz).gt.uvzlev(kz-1)).and. &
< (height(iz).le.uvzlev(kz))) then
< dz1=height(iz)-uvzlev(kz-1)
< dz2=uvzlev(kz)-height(iz)
< dz=dz1+dz2
< uu(ix,jy,iz,n)=(uuh(ix,jy,kz-1)*dz2+uuh(ix,jy,kz)*dz1)/dz
< vv(ix,jy,iz,n)=(vvh(ix,jy,kz-1)*dz2+vvh(ix,jy,kz)*dz1)/dz
< tt(ix,jy,iz,n)=(tth(ix,jy,kz-1,n)*dz2 &
< +tth(ix,jy,kz,n)*dz1)/dz
< qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2 &
< +qvh(ix,jy,kz,n)*dz1)/dz
< pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz
< rho(ix,jy,iz,n)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
< pplev(ix,jy,iz,n)=(akz(kz-1)*dz2+akz(kz)*dz1)/dz
< endif
< end do
< 30 continue
< end do
<
<
< ! Levels, where w is given
< !*************************
<
< ww(ix,jy,1,n)=wwh(ix,jy,llev)*pinmconv(llev)
< ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(nz)
< kmin=llev+1
< do iz=2,nz
< do kz=kmin,nwz
< if ((height(iz).gt.wzlev(kz-1)).and. &
< (height(iz).le.wzlev(kz))) then
< dz1=height(iz)-wzlev(kz-1)
< dz2=wzlev(kz)-height(iz)
< dz=dz1+dz2
< ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(kz-1)*dz2 &
< +wwh(ix,jy,kz)*pinmconv(kz)*dz1)/dz
<
< endif
< end do
< end do
<
<
< ! Compute density gradients at intermediate levels
< !*************************************************
<
< drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/ &
< (height(2)-height(1))
< do kz=2,nz-1
< drhodz(ix,jy,kz,n)=(rho(ix,jy,kz+1,n)-rho(ix,jy,kz-1,n))/ &
< (height(kz+1)-height(kz-1))
< end do
< drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n)
<
< end do
< end do
<
<
< !****************************************************************
< ! Compute slope of eta levels in windward direction and resulting
< ! vertical wind correction
< !****************************************************************
<
< do jy=1,ny-2
< do ix=1,nx-2
<
< ! NCEP version: find first level above ground
< llev = 0
< do i=1,nuvz
< if (ps(ix,jy,1,n).lt.akz(i)) llev=i
< end do
< llev = llev+1
< if (llev.gt.nuvz-2) llev = nuvz-2
< ! if (llev.eq.nuvz-2) write(*,*) 'verttransform
< ! +WARNING: LLEV eq NUZV-2'
< ! NCEP version
<
< kmin=llev+1
< do iz=2,nz-1
<
< ui=uu(ix,jy,iz,n)*dxconst/cos((real(jy)*dy+ylat0)*pi180)
< vi=vv(ix,jy,iz,n)*dyconst
<
< do kz=kmin,nz
< if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
< (height(iz).le.uvwzlev(ix,jy,kz))) then
< dz1=height(iz)-uvwzlev(ix,jy,kz-1)
< dz2=uvwzlev(ix,jy,kz)-height(iz)
< dz=dz1+dz2
< kl=kz-1
< klp=kz
< goto 47
< endif
< end do
<
< 47 ix1=ix-1
< jy1=jy-1
< ixp=ix+1
< jyp=jy+1
<
< dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
< dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
< dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
<
< dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
< dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
< dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
<
< ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*ui+dzdy*vi)
<
< end do
<
< end do
< end do
<
<
< ! If north pole is in the domain, calculate wind velocities in polar
< ! stereographic coordinates
< !*******************************************************************
<
< if (nglobal) then
< do jy=int(switchnorthg)-2,nymin1
< ylat=ylat0+real(jy)*dy
< do ix=0,nxmin1
< xlon=xlon0+real(ix)*dx
< do iz=1,nz
< call cc2gll(northpolemap,ylat,xlon,uu(ix,jy,iz,n), &
< vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
< vvpol(ix,jy,iz,n))
< end do
< end do
< end do
<
<
< do iz=1,nz
<
< ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
< xlon=xlon0+real(nx/2-1)*dx
< xlonr=xlon*pi/180.
< ffpol=sqrt(uu(nx/2-1,nymin1,iz,n)**2+ &
< vv(nx/2-1,nymin1,iz,n)**2)
< if(vv(nx/2-1,nymin1,iz,n).lt.0.) then
< ddpol=atan(uu(nx/2-1,nymin1,iz,n)/ &
< vv(nx/2-1,nymin1,iz,n))-xlonr
< elseif (vv(nx/2-1,nymin1,iz,n).gt.0.) then
< ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ &
< vv(nx/2-1,nymin1,iz,n))-xlonr
< else
< ddpol=pi/2-xlonr
< endif
< if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
< if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
<
< ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
< xlon=180.0
< xlonr=xlon*pi/180.
< ylat=90.0
< uuaux=-ffpol*sin(xlonr+ddpol)
< vvaux=-ffpol*cos(xlonr+ddpol)
< call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
< vvpolaux)
<
< jy=nymin1
< do ix=0,nxmin1
< uupol(ix,jy,iz,n)=uupolaux
< vvpol(ix,jy,iz,n)=vvpolaux
< end do
< end do
<
<
< ! Fix: Set W at pole to the zonally averaged W of the next equator-
< ! ward parallel of latitude
<
< do iz=1,nz
< wdummy=0.
< jy=ny-2
< do ix=0,nxmin1
< wdummy=wdummy+ww(ix,jy,iz,n)
< end do
< wdummy=wdummy/real(nx)
< jy=nymin1
< do ix=0,nxmin1
< ww(ix,jy,iz,n)=wdummy
< end do
< end do
<
< endif
<
<
< ! If south pole is in the domain, calculate wind velocities in polar
< ! stereographic coordinates
< !*******************************************************************
<
< if (sglobal) then
< do jy=0,int(switchsouthg)+3
< ylat=ylat0+real(jy)*dy
< do ix=0,nxmin1
< xlon=xlon0+real(ix)*dx
< do iz=1,nz
< call cc2gll(southpolemap,ylat,xlon,uu(ix,jy,iz,n), &
< vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
< vvpol(ix,jy,iz,n))
< end do
< end do
< end do
<
< do iz=1,nz
<
< ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
< xlon=xlon0+real(nx/2-1)*dx
< xlonr=xlon*pi/180.
< ffpol=sqrt(uu(nx/2-1,0,iz,n)**2+ &
< vv(nx/2-1,0,iz,n)**2)
< if(vv(nx/2-1,0,iz,n).lt.0.) then
< ddpol=atan(uu(nx/2-1,0,iz,n)/ &
< vv(nx/2-1,0,iz,n))+xlonr
< elseif (vv(nx/2-1,0,iz,n).gt.0.) then
< ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ &
< vv(nx/2-1,0,iz,n))-xlonr
< else
< ddpol=pi/2-xlonr
< endif
< if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
< if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
<
< ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
< xlon=180.0
< xlonr=xlon*pi/180.
< ylat=-90.0
< uuaux=+ffpol*sin(xlonr-ddpol)
< vvaux=-ffpol*cos(xlonr-ddpol)
< call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
< vvpolaux)
<
< jy=0
< do ix=0,nxmin1
< uupol(ix,jy,iz,n)=uupolaux
< vvpol(ix,jy,iz,n)=vvpolaux
< end do
< end do
<
<
< ! Fix: Set W at pole to the zonally averaged W of the next equator-
< ! ward parallel of latitude
<
< do iz=1,nz
< wdummy=0.
< jy=1
< do ix=0,nxmin1
< wdummy=wdummy+ww(ix,jy,iz,n)
< end do
< wdummy=wdummy/real(nx)
< jy=0
< do ix=0,nxmin1
< ww(ix,jy,iz,n)=wdummy
< end do
< end do
< endif
<
<
< ! write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz
< ! create a cloud and rainout/washout field, clouds occur where rh>80%
< ! total cloudheight is stored at level 0
< do jy=0,nymin1
< do ix=0,nxmin1
< rain_cloud_above=0
< lsp=lsprec(ix,jy,1,n)
< convp=convprec(ix,jy,1,n)
< cloudsh(ix,jy,n)=0
< do kz_inv=1,nz-1
< kz=nz-kz_inv+1
< pressure=rho(ix,jy,kz,n)*r_air*tt(ix,jy,kz,n)
< rh=qv(ix,jy,kz,n)/f_qvsat(pressure,tt(ix,jy,kz,n))
< clouds(ix,jy,kz,n)=0
< if (rh.gt.0.8) then ! in cloud
< if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
< rain_cloud_above=1
< cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+ &
< height(kz)-height(kz-1)
< if (lsp.ge.convp) then
< clouds(ix,jy,kz,n)=3 ! lsp dominated rainout
< else
< clouds(ix,jy,kz,n)=2 ! convp dominated rainout
< endif
< else ! no precipitation
< clouds(ix,jy,kz,n)=1 ! cloud
< endif
< else ! no cloud
< if (rain_cloud_above.eq.1) then ! scavenging
< if (lsp.ge.convp) then
< clouds(ix,jy,kz,n)=5 ! lsp dominated washout
< else
< clouds(ix,jy,kz,n)=4 ! convp dominated washout
< endif
< endif
< endif
< end do
< end do
< end do
<
<
< end subroutine verttransform
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine verttransform(n,uuh,vvh,wwh,pvh)
> ! i i i i i
> !*****************************************************************************
> ! *
> ! This subroutine transforms temperature, dew point temperature and *
> ! wind components from eta to meter coordinates. *
> ! The vertical wind component is transformed from Pa/s to m/s using *
> ! the conversion factor pinmconv. *
> ! In addition, this routine calculates vertical density gradients *
> ! needed for the parameterization of the turbulent velocities. *
> ! *
> ! Author: A. Stohl, G. Wotawa *
> ! *
> ! 12 August 1996 *
> ! Update: 16 January 1998 *
> ! *
> ! Major update: 17 February 1999 *
> ! by G. Wotawa *
> ! CHANGE 17/11/2005 Caroline Forster, NCEP GFS version *
> ! *
> ! - Vertical levels for u, v and w are put together *
> ! - Slope correction for vertical velocity: Modification of calculation *
> ! procedure *
> ! *
> !*****************************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001:
> ! Variables tth and qvh (on eta coordinates) from common block
> !*****************************************************************************
> ! *
> ! Variables: *
> ! nx,ny,nz field dimensions in x,y and z direction *
> ! uu(0:nxmax,0:nymax,nzmax,2) wind components in x-direction [m/s] *
> ! vv(0:nxmax,0:nymax,nzmax,2) wind components in y-direction [m/s] *
> ! ww(0:nxmax,0:nymax,nzmax,2) wind components in z-direction [deltaeta/s]*
> ! tt(0:nxmax,0:nymax,nzmax,2) temperature [K] *
> ! pv(0:nxmax,0:nymax,nzmax,2) potential voriticity (pvu) *
> ! ps(0:nxmax,0:nymax,2) surface pressure [Pa] *
> ! clouds(0:nxmax,0:nymax,0:nzmax,2) cloud field for wet deposition *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
> use cmapf_mod
>
> implicit none
>
> integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym
> integer :: rain_cloud_above,kz_inv
> real :: f_qvsat,pressure
> real :: rh,lsp,convp
> real :: uvzlev(nuvzmax),rhoh(nuvzmax),pinmconv(nzmax)
> real :: ew,pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
> real :: xlon,ylat,xlonr,dzdx,dzdy
> real :: dzdx1,dzdx2,dzdy1,dzdy2
> real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy
> real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax)
> real :: wwh(0:nxmax-1,0:nymax-1,nwzmax)
> real :: wzlev(nwzmax),uvwzlev(0:nxmax-1,0:nymax-1,nzmax)
> real,parameter :: const=r_air/ga
>
> ! NCEP version
> integer :: llev, i
>
> logical :: init = .true.
>
>
> !*************************************************************************
> ! If verttransform is called the first time, initialize heights of the *
> ! z levels in meter. The heights are the heights of model levels, where *
> ! u,v,T and qv are given, and of the interfaces, where w is given. So, *
> ! the vertical resolution in the z system is doubled. As reference point,*
> ! the lower left corner of the grid is used. *
> ! Unlike in the eta system, no difference between heights for u,v and *
> ! heights for w exists. *
> !*************************************************************************
>
> if (init) then
>
> ! Search for a point with high surface pressure (i.e. not above significant topography)
> ! Then, use this point to construct a reference z profile, to be used at all times
> !*****************************************************************************
>
> do jy=0,nymin1
> do ix=0,nxmin1
> if (ps(ix,jy,1,n).gt.100000.) then
> ixm=ix
> jym=jy
> goto 3
> endif
> end do
> end do
> 3 continue
>
>
> tvold=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n))/ &
> ps(ixm,jym,1,n))
> pold=ps(ixm,jym,1,n)
> height(1)=0.
>
> do kz=2,nuvz
> pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n)
> tv=tth(ixm,jym,kz,n)*(1.+0.608*qvh(ixm,jym,kz,n))
>
>
> ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
> ! upon the transformation to z levels. In order to save computer memory, this is
> ! not done anymore in the standard version. However, this option can still be
> ! switched on by replacing the following lines with those below, that are
> ! currently commented out.
> ! Note that two more changes are necessary in this subroutine below.
> ! One change is also necessary in gridcheck.f, and another one in verttransform_nests.
> !*****************************************************************************
>
> if (abs(tv-tvold).gt.0.2) then
> height(kz)= &
> height(kz-1)+const*log(pold/pint)* &
> (tv-tvold)/log(tv/tvold)
> else
> height(kz)=height(kz-1)+ &
> const*log(pold/pint)*tv
> endif
>
> ! Switch on following lines to use doubled vertical resolution
> !*************************************************************
> ! if (abs(tv-tvold).gt.0.2) then
> ! height((kz-1)*2)=
> ! + height(max((kz-2)*2,1))+const*log(pold/pint)*
> ! + (tv-tvold)/log(tv/tvold)
> ! else
> ! height((kz-1)*2)=height(max((kz-2)*2,1))+
> ! + const*log(pold/pint)*tv
> ! endif
> ! End doubled vertical resolution
>
> tvold=tv
> pold=pint
> end do
>
>
> ! Switch on following lines to use doubled vertical resolution
> !*************************************************************
> ! do 7 kz=3,nz-1,2
> ! height(kz)=0.5*(height(kz-1)+height(kz+1))
> ! height(nz)=height(nz-1)+height(nz-1)-height(nz-2)
> ! End doubled vertical resolution
>
>
> ! Determine highest levels that can be within PBL
> !************************************************
>
> do kz=1,nz
> if (height(kz).gt.hmixmax) then
> nmixz=kz
> goto 9
> endif
> end do
> 9 continue
>
> ! Do not repeat initialization of the Cartesian z grid
> !*****************************************************
>
> init=.false.
>
> endif
>
>
> ! Loop over the whole grid
> !*************************
>
> do jy=0,nymin1
> do ix=0,nxmin1
>
> ! NCEP version: find first level above ground
> llev = 0
> do i=1,nuvz
> if (ps(ix,jy,1,n).lt.akz(i)) llev=i
> end do
> llev = llev+1
> if (llev.gt.nuvz-2) llev = nuvz-2
> ! if (llev.eq.nuvz-2) write(*,*) 'verttransform
> ! +WARNING: LLEV eq NUZV-2'
> ! NCEP version
>
>
> ! compute height of pressure levels above ground
> !***********************************************
>
> tvold=tth(ix,jy,llev,n)*(1.+0.608*qvh(ix,jy,llev,n))
> pold=akz(llev)
> uvzlev(llev)=0.
> wzlev(llev)=0.
> uvwzlev(ix,jy,llev)=0.
> rhoh(llev)=pold/(r_air*tvold)
>
> do kz=llev+1,nuvz
> pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n)
> tv=tth(ix,jy,kz,n)*(1.+0.608*qvh(ix,jy,kz,n))
> rhoh(kz)=pint/(r_air*tv)
>
> if (abs(tv-tvold).gt.0.2) then
> uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)* &
> (tv-tvold)/log(tv/tvold)
> else
> uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)*tv
> endif
> wzlev(kz)=uvzlev(kz)
> uvwzlev(ix,jy,kz)=uvzlev(kz)
>
> tvold=tv
> pold=pint
> end do
>
>
> ! Switch on following lines to use doubled vertical resolution
> ! Switch off the three lines above.
> !*************************************************************
> !22 uvwzlev(ix,jy,(kz-1)*2)=uvzlev(kz)
> ! do 23 kz=2,nwz
> !23 uvwzlev(ix,jy,(kz-1)*2+1)=wzlev(kz)
> ! End doubled vertical resolution
>
> ! pinmconv=(h2-h1)/(p2-p1)
>
> pinmconv(llev)=(uvwzlev(ix,jy,llev+1)-uvwzlev(ix,jy,llev))/ &
> ((aknew(llev+1)+bknew(llev+1)*ps(ix,jy,1,n))- &
> (aknew(llev)+bknew(llev)*ps(ix,jy,1,n)))
> do kz=llev+1,nz-1
> pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
> ((aknew(kz+1)+bknew(kz+1)*ps(ix,jy,1,n))- &
> (aknew(kz-1)+bknew(kz-1)*ps(ix,jy,1,n)))
> end do
> pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
> ((aknew(nz)+bknew(nz)*ps(ix,jy,1,n))- &
> (aknew(nz-1)+bknew(nz-1)*ps(ix,jy,1,n)))
>
>
> ! Levels, where u,v,t and q are given
> !************************************
>
> uu(ix,jy,1,n)=uuh(ix,jy,llev)
> vv(ix,jy,1,n)=vvh(ix,jy,llev)
> tt(ix,jy,1,n)=tth(ix,jy,llev,n)
> qv(ix,jy,1,n)=qvh(ix,jy,llev,n)
> pv(ix,jy,1,n)=pvh(ix,jy,llev)
> rho(ix,jy,1,n)=rhoh(llev)
> pplev(ix,jy,1,n)=akz(llev)
> uu(ix,jy,nz,n)=uuh(ix,jy,nuvz)
> vv(ix,jy,nz,n)=vvh(ix,jy,nuvz)
> tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n)
> qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n)
> pv(ix,jy,nz,n)=pvh(ix,jy,nuvz)
> rho(ix,jy,nz,n)=rhoh(nuvz)
> pplev(ix,jy,nz,n)=akz(nuvz)
> kmin=llev+1
> do iz=2,nz-1
> do kz=kmin,nuvz
> if(height(iz).gt.uvzlev(nuvz)) then
> uu(ix,jy,iz,n)=uu(ix,jy,nz,n)
> vv(ix,jy,iz,n)=vv(ix,jy,nz,n)
> tt(ix,jy,iz,n)=tt(ix,jy,nz,n)
> qv(ix,jy,iz,n)=qv(ix,jy,nz,n)
> pv(ix,jy,iz,n)=pv(ix,jy,nz,n)
> rho(ix,jy,iz,n)=rho(ix,jy,nz,n)
> pplev(ix,jy,iz,n)=pplev(ix,jy,nz,n)
> goto 30
> endif
> if ((height(iz).gt.uvzlev(kz-1)).and. &
> (height(iz).le.uvzlev(kz))) then
> dz1=height(iz)-uvzlev(kz-1)
> dz2=uvzlev(kz)-height(iz)
> dz=dz1+dz2
> uu(ix,jy,iz,n)=(uuh(ix,jy,kz-1)*dz2+uuh(ix,jy,kz)*dz1)/dz
> vv(ix,jy,iz,n)=(vvh(ix,jy,kz-1)*dz2+vvh(ix,jy,kz)*dz1)/dz
> tt(ix,jy,iz,n)=(tth(ix,jy,kz-1,n)*dz2 &
> +tth(ix,jy,kz,n)*dz1)/dz
> qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2 &
> +qvh(ix,jy,kz,n)*dz1)/dz
> pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz
> rho(ix,jy,iz,n)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
> pplev(ix,jy,iz,n)=(akz(kz-1)*dz2+akz(kz)*dz1)/dz
> endif
> end do
> 30 continue
> end do
>
>
> ! Levels, where w is given
> !*************************
>
> ww(ix,jy,1,n)=wwh(ix,jy,llev)*pinmconv(llev)
> ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(nz)
> kmin=llev+1
> do iz=2,nz
> do kz=kmin,nwz
> if ((height(iz).gt.wzlev(kz-1)).and. &
> (height(iz).le.wzlev(kz))) then
> dz1=height(iz)-wzlev(kz-1)
> dz2=wzlev(kz)-height(iz)
> dz=dz1+dz2
> ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(kz-1)*dz2 &
> +wwh(ix,jy,kz)*pinmconv(kz)*dz1)/dz
>
> endif
> end do
> end do
>
>
> ! Compute density gradients at intermediate levels
> !*************************************************
>
> drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/ &
> (height(2)-height(1))
> do kz=2,nz-1
> drhodz(ix,jy,kz,n)=(rho(ix,jy,kz+1,n)-rho(ix,jy,kz-1,n))/ &
> (height(kz+1)-height(kz-1))
> end do
> drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n)
>
> end do
> end do
>
>
> !****************************************************************
> ! Compute slope of eta levels in windward direction and resulting
> ! vertical wind correction
> !****************************************************************
>
> do jy=1,ny-2
> do ix=1,nx-2
>
> ! NCEP version: find first level above ground
> llev = 0
> do i=1,nuvz
> if (ps(ix,jy,1,n).lt.akz(i)) llev=i
> end do
> llev = llev+1
> if (llev.gt.nuvz-2) llev = nuvz-2
> ! if (llev.eq.nuvz-2) write(*,*) 'verttransform
> ! +WARNING: LLEV eq NUZV-2'
> ! NCEP version
>
> kmin=llev+1
> do iz=2,nz-1
>
> ui=uu(ix,jy,iz,n)*dxconst/cos((real(jy)*dy+ylat0)*pi180)
> vi=vv(ix,jy,iz,n)*dyconst
>
> do kz=kmin,nz
> if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
> (height(iz).le.uvwzlev(ix,jy,kz))) then
> dz1=height(iz)-uvwzlev(ix,jy,kz-1)
> dz2=uvwzlev(ix,jy,kz)-height(iz)
> dz=dz1+dz2
> kl=kz-1
> klp=kz
> goto 47
> endif
> end do
>
> 47 ix1=ix-1
> jy1=jy-1
> ixp=ix+1
> jyp=jy+1
>
> dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
> dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
> dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
>
> dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
> dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
> dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
>
> ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*ui+dzdy*vi)
>
> end do
>
> end do
> end do
>
>
> ! If north pole is in the domain, calculate wind velocities in polar
> ! stereographic coordinates
> !*******************************************************************
>
> if (nglobal) then
> do jy=int(switchnorthg)-2,nymin1
> ylat=ylat0+real(jy)*dy
> do ix=0,nxmin1
> xlon=xlon0+real(ix)*dx
> do iz=1,nz
> call cc2gll(northpolemap,ylat,xlon,uu(ix,jy,iz,n), &
> vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
> vvpol(ix,jy,iz,n))
> end do
> end do
> end do
>
>
> do iz=1,nz
>
> ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
> xlon=xlon0+real(nx/2-1)*dx
> xlonr=xlon*pi/180.
> ffpol=sqrt(uu(nx/2-1,nymin1,iz,n)**2+ &
> vv(nx/2-1,nymin1,iz,n)**2)
> if(vv(nx/2-1,nymin1,iz,n).lt.0.) then
> ddpol=atan(uu(nx/2-1,nymin1,iz,n)/ &
> vv(nx/2-1,nymin1,iz,n))-xlonr
> elseif (vv(nx/2-1,nymin1,iz,n).gt.0.) then
> ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ &
> vv(nx/2-1,nymin1,iz,n))-xlonr
> else
> ddpol=pi/2-xlonr
> endif
> if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
> if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
>
> ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
> xlon=180.0
> xlonr=xlon*pi/180.
> ylat=90.0
> uuaux=-ffpol*sin(xlonr+ddpol)
> vvaux=-ffpol*cos(xlonr+ddpol)
> call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
> vvpolaux)
>
> jy=nymin1
> do ix=0,nxmin1
> uupol(ix,jy,iz,n)=uupolaux
> vvpol(ix,jy,iz,n)=vvpolaux
> end do
> end do
>
>
> ! Fix: Set W at pole to the zonally averaged W of the next equator-
> ! ward parallel of latitude
>
> do iz=1,nz
> wdummy=0.
> jy=ny-2
> do ix=0,nxmin1
> wdummy=wdummy+ww(ix,jy,iz,n)
> end do
> wdummy=wdummy/real(nx)
> jy=nymin1
> do ix=0,nxmin1
> ww(ix,jy,iz,n)=wdummy
> end do
> end do
>
> endif
>
>
> ! If south pole is in the domain, calculate wind velocities in polar
> ! stereographic coordinates
> !*******************************************************************
>
> if (sglobal) then
> do jy=0,int(switchsouthg)+3
> ylat=ylat0+real(jy)*dy
> do ix=0,nxmin1
> xlon=xlon0+real(ix)*dx
> do iz=1,nz
> call cc2gll(southpolemap,ylat,xlon,uu(ix,jy,iz,n), &
> vv(ix,jy,iz,n),uupol(ix,jy,iz,n), &
> vvpol(ix,jy,iz,n))
> end do
> end do
> end do
>
> do iz=1,nz
>
> ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT
> xlon=xlon0+real(nx/2-1)*dx
> xlonr=xlon*pi/180.
> ffpol=sqrt(uu(nx/2-1,0,iz,n)**2+ &
> vv(nx/2-1,0,iz,n)**2)
> if(vv(nx/2-1,0,iz,n).lt.0.) then
> ddpol=atan(uu(nx/2-1,0,iz,n)/ &
> vv(nx/2-1,0,iz,n))+xlonr
> elseif (vv(nx/2-1,0,iz,n).gt.0.) then
> ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ &
> vv(nx/2-1,0,iz,n))-xlonr
> else
> ddpol=pi/2-xlonr
> endif
> if(ddpol.lt.0.) ddpol=2.0*pi+ddpol
> if(ddpol.gt.2.0*pi) ddpol=ddpol-2.0*pi
>
> ! CALCULATE U,V FOR 180 DEG, TRANSFORM TO POLAR STEREOGRAPHIC GRID
> xlon=180.0
> xlonr=xlon*pi/180.
> ylat=-90.0
> uuaux=+ffpol*sin(xlonr-ddpol)
> vvaux=-ffpol*cos(xlonr-ddpol)
> call cc2gll(northpolemap,ylat,xlon,uuaux,vvaux,uupolaux, &
> vvpolaux)
>
> jy=0
> do ix=0,nxmin1
> uupol(ix,jy,iz,n)=uupolaux
> vvpol(ix,jy,iz,n)=vvpolaux
> end do
> end do
>
>
> ! Fix: Set W at pole to the zonally averaged W of the next equator-
> ! ward parallel of latitude
>
> do iz=1,nz
> wdummy=0.
> jy=1
> do ix=0,nxmin1
> wdummy=wdummy+ww(ix,jy,iz,n)
> end do
> wdummy=wdummy/real(nx)
> jy=0
> do ix=0,nxmin1
> ww(ix,jy,iz,n)=wdummy
> end do
> end do
> endif
>
>
> ! write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz
> ! create a cloud and rainout/washout field, clouds occur where rh>80%
> ! total cloudheight is stored at level 0
> do jy=0,nymin1
> do ix=0,nxmin1
> rain_cloud_above=0
> lsp=lsprec(ix,jy,1,n)
> convp=convprec(ix,jy,1,n)
> cloudsh(ix,jy,n)=0
> do kz_inv=1,nz-1
> kz=nz-kz_inv+1
> pressure=rho(ix,jy,kz,n)*r_air*tt(ix,jy,kz,n)
> rh=qv(ix,jy,kz,n)/f_qvsat(pressure,tt(ix,jy,kz,n))
> clouds(ix,jy,kz,n)=0
> if (rh.gt.0.8) then ! in cloud
> if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation
> rain_cloud_above=1
> cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+ &
> height(kz)-height(kz-1)
> if (lsp.ge.convp) then
> clouds(ix,jy,kz,n)=3 ! lsp dominated rainout
> else
> clouds(ix,jy,kz,n)=2 ! convp dominated rainout
> endif
> else ! no precipitation
> clouds(ix,jy,kz,n)=1 ! cloud
> endif
> else ! no cloud
> if (rain_cloud_above.eq.1) then ! scavenging
> if (lsp.ge.convp) then
> clouds(ix,jy,kz,n)=5 ! lsp dominated washout
> else
> clouds(ix,jy,kz,n)=4 ! convp dominated washout
> endif
> endif
> endif
> end do
> end do
> end do
>
>
> end subroutine verttransform
verttransform_nests.f90
----------------------------------------------
1,345c1,345
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine verttransform_nests(n,uuhn,vvhn,wwhn,pvhn)
< ! i i i i i
< !*****************************************************************************
< ! *
< ! This subroutine transforms temperature, dew point temperature and *
< ! wind components from eta to meter coordinates. *
< ! The vertical wind component is transformed from Pa/s to m/s using *
< ! the conversion factor pinmconv. *
< ! In addition, this routine calculates vertical density gradients *
< ! needed for the parameterization of the turbulent velocities. *
< ! It is similar to verttransform, but makes the transformations for *
< ! the nested grids. *
< ! *
< ! Author: A. Stohl, G. Wotawa *
< ! *
< ! 12 August 1996 *
< ! Update: 16 January 1998 *
< ! *
< ! Major update: 17 February 1999 *
< ! by G. Wotawa *
< ! *
< ! - Vertical levels for u, v and w are put together *
< ! - Slope correction for vertical velocity: Modification of calculation *
< ! procedure *
< ! *
< !*****************************************************************************
< ! Changes, Bernd C. Krueger, Feb. 2001: (marked "C-cv")
< ! Variables tthn and qvhn (on eta coordinates) from common block
< !*****************************************************************************
< ! Sabine Eckhardt, March 2007
< ! add the variable cloud for use with scavenging - descr. in com_mod
< !*****************************************************************************
< ! *
< ! Variables: *
< ! nxn,nyn,nuvz,nwz field dimensions in x,y and z direction *
< ! uun wind components in x-direction [m/s] *
< ! vvn wind components in y-direction [m/s] *
< ! wwn wind components in z-direction [deltaeta/s]*
< ! ttn temperature [K] *
< ! pvn potential vorticity (pvu) *
< ! psn surface pressure [Pa] *
< ! *
< !*****************************************************************************
<
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: ix,jy,kz,iz,n,l,kmin,kl,klp,ix1,jy1,ixp,jyp
< integer :: rain_cloud_above,kz_inv
< real :: f_qvsat,pressure,rh,lsp,convp
< real :: uvzlev(nuvzmax),wzlev(nwzmax),rhoh(nuvzmax),pinmconv(nzmax)
< real :: uvwzlev(0:nxmaxn-1,0:nymaxn-1,nzmax)
< real :: ew,pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
< real :: dzdx,dzdy
< real :: dzdx1,dzdx2,dzdy1,dzdy2
< real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
< real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
< real,parameter :: const=r_air/ga
<
<
< ! Loop over all nests
< !********************
<
< do l=1,numbnests
<
< ! Loop over the whole grid
< !*************************
<
< do jy=0,nyn(l)-1
< do ix=0,nxn(l)-1
<
< tvold=tt2n(ix,jy,1,n,l)*(1.+0.378*ew(td2n(ix,jy,1,n,l))/ &
< psn(ix,jy,1,n,l))
< pold=psn(ix,jy,1,n,l)
< uvzlev(1)=0.
< wzlev(1)=0.
< rhoh(1)=pold/(r_air*tvold)
<
<
< ! Compute heights of eta levels
< !******************************
<
< do kz=2,nuvz
< pint=akz(kz)+bkz(kz)*psn(ix,jy,1,n,l)
< tv=tthn(ix,jy,kz,n,l)*(1.+0.608*qvhn(ix,jy,kz,n,l))
< rhoh(kz)=pint/(r_air*tv)
<
< if (abs(tv-tvold).gt.0.2) then
< uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)* &
< (tv-tvold)/log(tv/tvold)
< else
< uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)*tv
< endif
<
< tvold=tv
< pold=pint
< end do
<
<
< do kz=2,nwz-1
< wzlev(kz)=(uvzlev(kz+1)+uvzlev(kz))/2.
< end do
< wzlev(nwz)=wzlev(nwz-1)+ &
< uvzlev(nuvz)-uvzlev(nuvz-1)
<
< ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
< ! upon the transformation to z levels. In order to save computer memory, this is
< ! not done anymore in the standard version. However, this option can still be
< ! switched on by replacing the following lines with those below, that are
< ! currently commented out.
< ! Note that one change is also necessary in gridcheck.f,
< ! and three changes in verttransform.f
< !*****************************************************************************
< uvwzlev(ix,jy,1)=0.0
< do kz=2,nuvz
< uvwzlev(ix,jy,kz)=uvzlev(kz)
< end do
<
< ! Switch on following lines to use doubled vertical resolution
< ! Switch off the three lines above.
< !*************************************************************
< !22 uvwzlev(ix,jy,(kz-1)*2)=uvzlev(kz)
< ! do 23 kz=2,nwz
< !23 uvwzlev(ix,jy,(kz-1)*2+1)=wzlev(kz)
< ! End doubled vertical resolution
<
< ! pinmconv=(h2-h1)/(p2-p1)
<
< pinmconv(1)=(uvwzlev(ix,jy,2)-uvwzlev(ix,jy,1))/ &
< ((aknew(2)+bknew(2)*psn(ix,jy,1,n,l))- &
< (aknew(1)+bknew(1)*psn(ix,jy,1,n,l)))
< do kz=2,nz-1
< pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
< ((aknew(kz+1)+bknew(kz+1)*psn(ix,jy,1,n,l))- &
< (aknew(kz-1)+bknew(kz-1)*psn(ix,jy,1,n,l)))
< end do
< pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
< ((aknew(nz)+bknew(nz)*psn(ix,jy,1,n,l))- &
< (aknew(nz-1)+bknew(nz-1)*psn(ix,jy,1,n,l)))
<
<
< ! Levels, where u,v,t and q are given
< !************************************
<
< uun(ix,jy,1,n,l)=uuhn(ix,jy,1,l)
< vvn(ix,jy,1,n,l)=vvhn(ix,jy,1,l)
< ttn(ix,jy,1,n,l)=tthn(ix,jy,1,n,l)
< qvn(ix,jy,1,n,l)=qvhn(ix,jy,1,n,l)
< pvn(ix,jy,1,n,l)=pvhn(ix,jy,1,l)
< rhon(ix,jy,1,n,l)=rhoh(1)
< uun(ix,jy,nz,n,l)=uuhn(ix,jy,nuvz,l)
< vvn(ix,jy,nz,n,l)=vvhn(ix,jy,nuvz,l)
< ttn(ix,jy,nz,n,l)=tthn(ix,jy,nuvz,n,l)
< qvn(ix,jy,nz,n,l)=qvhn(ix,jy,nuvz,n,l)
< pvn(ix,jy,nz,n,l)=pvhn(ix,jy,nuvz,l)
< rhon(ix,jy,nz,n,l)=rhoh(nuvz)
< kmin=2
< do iz=2,nz-1
< do kz=kmin,nuvz
< if(height(iz).gt.uvzlev(nuvz)) then
< uun(ix,jy,iz,n,l)=uun(ix,jy,nz,n,l)
< vvn(ix,jy,iz,n,l)=vvn(ix,jy,nz,n,l)
< ttn(ix,jy,iz,n,l)=ttn(ix,jy,nz,n,l)
< qvn(ix,jy,iz,n,l)=qvn(ix,jy,nz,n,l)
< pvn(ix,jy,iz,n,l)=pvn(ix,jy,nz,n,l)
< rhon(ix,jy,iz,n,l)=rhon(ix,jy,nz,n,l)
< goto 30
< endif
< if ((height(iz).gt.uvzlev(kz-1)).and. &
< (height(iz).le.uvzlev(kz))) then
< dz1=height(iz)-uvzlev(kz-1)
< dz2=uvzlev(kz)-height(iz)
< dz=dz1+dz2
< uun(ix,jy,iz,n,l)=(uuhn(ix,jy,kz-1,l)*dz2+ &
< uuhn(ix,jy,kz,l)*dz1)/dz
< vvn(ix,jy,iz,n,l)=(vvhn(ix,jy,kz-1,l)*dz2+ &
< vvhn(ix,jy,kz,l)*dz1)/dz
< ttn(ix,jy,iz,n,l)=(tthn(ix,jy,kz-1,n,l)*dz2+ &
< tthn(ix,jy,kz,n,l)*dz1)/dz
< qvn(ix,jy,iz,n,l)=(qvhn(ix,jy,kz-1,n,l)*dz2+ &
< qvhn(ix,jy,kz,n,l)*dz1)/dz
< pvn(ix,jy,iz,n,l)=(pvhn(ix,jy,kz-1,l)*dz2+ &
< pvhn(ix,jy,kz,l)*dz1)/dz
< rhon(ix,jy,iz,n,l)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
< kmin=kz
< goto 30
< endif
< end do
< 30 continue
< end do
<
<
< ! Levels, where w is given
< !*************************
<
< wwn(ix,jy,1,n,l)=wwhn(ix,jy,1,l)*pinmconv(1)
< wwn(ix,jy,nz,n,l)=wwhn(ix,jy,nwz,l)*pinmconv(nz)
< kmin=2
< do iz=2,nz
< do kz=kmin,nwz
< if ((height(iz).gt.wzlev(kz-1)).and. &
< (height(iz).le.wzlev(kz))) then
< dz1=height(iz)-wzlev(kz-1)
< dz2=wzlev(kz)-height(iz)
< dz=dz1+dz2
< wwn(ix,jy,iz,n,l)=(wwhn(ix,jy,kz-1,l)*pinmconv(kz-1)*dz2 &
< +wwhn(ix,jy,kz,l)*pinmconv(kz)*dz1)/dz
< kmin=kz
< goto 40
< endif
< end do
< 40 continue
< end do
<
< ! Compute density gradients at intermediate levels
< !*************************************************
<
< drhodzn(ix,jy,1,n,l)=(rhon(ix,jy,2,n,l)-rhon(ix,jy,1,n,l))/ &
< (height(2)-height(1))
< do kz=2,nz-1
< drhodzn(ix,jy,kz,n,l)=(rhon(ix,jy,kz+1,n,l)- &
< rhon(ix,jy,kz-1,n,l))/(height(kz+1)-height(kz-1))
< end do
< drhodzn(ix,jy,nz,n,l)=drhodzn(ix,jy,nz-1,n,l)
<
< end do
< end do
<
<
< !****************************************************************
< ! Compute slope of eta levels in windward direction and resulting
< ! vertical wind correction
< !****************************************************************
<
< do jy=1,nyn(l)-2
< do ix=1,nxn(l)-2
<
< kmin=2
< do iz=2,nz-1
<
< ui=uun(ix,jy,iz,n,l)*dxconst*xresoln(l)/ &
< cos((real(jy)*dyn(l)+ylat0n(l))*pi180)
< vi=vvn(ix,jy,iz,n,l)*dyconst*yresoln(l)
<
< do kz=kmin,nz
< if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
< (height(iz).le.uvwzlev(ix,jy,kz))) then
< dz1=height(iz)-uvwzlev(ix,jy,kz-1)
< dz2=uvwzlev(ix,jy,kz)-height(iz)
< dz=dz1+dz2
< kl=kz-1
< klp=kz
< kmin=kz
< goto 47
< endif
< end do
<
< 47 ix1=ix-1
< jy1=jy-1
< ixp=ix+1
< jyp=jy+1
<
< dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
< dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
< dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
<
< dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
< dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
< dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
<
< wwn(ix,jy,iz,n,l)=wwn(ix,jy,iz,n,l)+(dzdx*ui+dzdy*vi)
<
< end do
<
< end do
< end do
<
<
< !write (*,*) 'initializing nested cloudsn, n:',n
< ! create a cloud and rainout/washout field, cloudsn occur where rh>80%
< do jy=0,nyn(l)-1
< do ix=0,nxn(l)-1
< rain_cloud_above=0
< lsp=lsprecn(ix,jy,1,n,l)
< convp=convprecn(ix,jy,1,n,l)
< cloudsnh(ix,jy,n,l)=0
< do kz_inv=1,nz-1
< kz=nz-kz_inv+1
< pressure=rhon(ix,jy,kz,n,l)*r_air*ttn(ix,jy,kz,n,l)
< rh=qvn(ix,jy,kz,n,l)/f_qvsat(pressure,ttn(ix,jy,kz,n,l))
< cloudsn(ix,jy,kz,n,l)=0
< if (rh.gt.0.8) then ! in cloud
< if ((lsp.gt.0.01).or.(convp.gt.0.01)) then
< rain_cloud_above=1
< cloudsnh(ix,jy,n,l)=cloudsnh(ix,jy,n,l)+ &
< height(kz)-height(kz-1)
< if (lsp.ge.convp) then
< cloudsn(ix,jy,kz,n,l)=3 ! lsp dominated rainout
< else
< cloudsn(ix,jy,kz,n,l)=2 ! convp dominated rainout
< endif
< else ! no precipitation
< cloudsn(ix,jy,kz,n,l)=1 ! cloud
< endif
< else ! no cloud
< if (rain_cloud_above.eq.1) then ! scavenging
< if (lsp.ge.convp) then
< cloudsn(ix,jy,kz,n,l)=5 ! lsp dominated washout
< else
< cloudsn(ix,jy,kz,n,l)=4 ! convp dominated washout
< endif
< endif
< endif
< end do
< end do
< end do
<
< end do
<
< end subroutine verttransform_nests
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine verttransform_nests(n,uuhn,vvhn,wwhn,pvhn)
> ! i i i i i
> !*****************************************************************************
> ! *
> ! This subroutine transforms temperature, dew point temperature and *
> ! wind components from eta to meter coordinates. *
> ! The vertical wind component is transformed from Pa/s to m/s using *
> ! the conversion factor pinmconv. *
> ! In addition, this routine calculates vertical density gradients *
> ! needed for the parameterization of the turbulent velocities. *
> ! It is similar to verttransform, but makes the transformations for *
> ! the nested grids. *
> ! *
> ! Author: A. Stohl, G. Wotawa *
> ! *
> ! 12 August 1996 *
> ! Update: 16 January 1998 *
> ! *
> ! Major update: 17 February 1999 *
> ! by G. Wotawa *
> ! *
> ! - Vertical levels for u, v and w are put together *
> ! - Slope correction for vertical velocity: Modification of calculation *
> ! procedure *
> ! *
> !*****************************************************************************
> ! Changes, Bernd C. Krueger, Feb. 2001: (marked "C-cv")
> ! Variables tthn and qvhn (on eta coordinates) from common block
> !*****************************************************************************
> ! Sabine Eckhardt, March 2007
> ! add the variable cloud for use with scavenging - descr. in com_mod
> !*****************************************************************************
> ! *
> ! Variables: *
> ! nxn,nyn,nuvz,nwz field dimensions in x,y and z direction *
> ! uun wind components in x-direction [m/s] *
> ! vvn wind components in y-direction [m/s] *
> ! wwn wind components in z-direction [deltaeta/s]*
> ! ttn temperature [K] *
> ! pvn potential vorticity (pvu) *
> ! psn surface pressure [Pa] *
> ! *
> !*****************************************************************************
>
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: ix,jy,kz,iz,n,l,kmin,kl,klp,ix1,jy1,ixp,jyp
> integer :: rain_cloud_above,kz_inv
> real :: f_qvsat,pressure,rh,lsp,convp
> real :: uvzlev(nuvzmax),wzlev(nwzmax),rhoh(nuvzmax),pinmconv(nzmax)
> real :: uvwzlev(0:nxmaxn-1,0:nymaxn-1,nzmax)
> real :: ew,pint,tv,tvold,pold,dz1,dz2,dz,ui,vi
> real :: dzdx,dzdy
> real :: dzdx1,dzdx2,dzdy1,dzdy2
> real :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests)
> real :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests)
> real,parameter :: const=r_air/ga
>
>
> ! Loop over all nests
> !********************
>
> do l=1,numbnests
>
> ! Loop over the whole grid
> !*************************
>
> do jy=0,nyn(l)-1
> do ix=0,nxn(l)-1
>
> tvold=tt2n(ix,jy,1,n,l)*(1.+0.378*ew(td2n(ix,jy,1,n,l))/ &
> psn(ix,jy,1,n,l))
> pold=psn(ix,jy,1,n,l)
> uvzlev(1)=0.
> wzlev(1)=0.
> rhoh(1)=pold/(r_air*tvold)
>
>
> ! Compute heights of eta levels
> !******************************
>
> do kz=2,nuvz
> pint=akz(kz)+bkz(kz)*psn(ix,jy,1,n,l)
> tv=tthn(ix,jy,kz,n,l)*(1.+0.608*qvhn(ix,jy,kz,n,l))
> rhoh(kz)=pint/(r_air*tv)
>
> if (abs(tv-tvold).gt.0.2) then
> uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)* &
> (tv-tvold)/log(tv/tvold)
> else
> uvzlev(kz)=uvzlev(kz-1)+const*log(pold/pint)*tv
> endif
>
> tvold=tv
> pold=pint
> end do
>
>
> do kz=2,nwz-1
> wzlev(kz)=(uvzlev(kz+1)+uvzlev(kz))/2.
> end do
> wzlev(nwz)=wzlev(nwz-1)+ &
> uvzlev(nuvz)-uvzlev(nuvz-1)
>
> ! NOTE: In FLEXPART versions up to 4.0, the number of model levels was doubled
> ! upon the transformation to z levels. In order to save computer memory, this is
> ! not done anymore in the standard version. However, this option can still be
> ! switched on by replacing the following lines with those below, that are
> ! currently commented out.
> ! Note that one change is also necessary in gridcheck.f,
> ! and three changes in verttransform.f
> !*****************************************************************************
> uvwzlev(ix,jy,1)=0.0
> do kz=2,nuvz
> uvwzlev(ix,jy,kz)=uvzlev(kz)
> end do
>
> ! Switch on following lines to use doubled vertical resolution
> ! Switch off the three lines above.
> !*************************************************************
> !22 uvwzlev(ix,jy,(kz-1)*2)=uvzlev(kz)
> ! do 23 kz=2,nwz
> !23 uvwzlev(ix,jy,(kz-1)*2+1)=wzlev(kz)
> ! End doubled vertical resolution
>
> ! pinmconv=(h2-h1)/(p2-p1)
>
> pinmconv(1)=(uvwzlev(ix,jy,2)-uvwzlev(ix,jy,1))/ &
> ((aknew(2)+bknew(2)*psn(ix,jy,1,n,l))- &
> (aknew(1)+bknew(1)*psn(ix,jy,1,n,l)))
> do kz=2,nz-1
> pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ &
> ((aknew(kz+1)+bknew(kz+1)*psn(ix,jy,1,n,l))- &
> (aknew(kz-1)+bknew(kz-1)*psn(ix,jy,1,n,l)))
> end do
> pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ &
> ((aknew(nz)+bknew(nz)*psn(ix,jy,1,n,l))- &
> (aknew(nz-1)+bknew(nz-1)*psn(ix,jy,1,n,l)))
>
>
> ! Levels, where u,v,t and q are given
> !************************************
>
> uun(ix,jy,1,n,l)=uuhn(ix,jy,1,l)
> vvn(ix,jy,1,n,l)=vvhn(ix,jy,1,l)
> ttn(ix,jy,1,n,l)=tthn(ix,jy,1,n,l)
> qvn(ix,jy,1,n,l)=qvhn(ix,jy,1,n,l)
> pvn(ix,jy,1,n,l)=pvhn(ix,jy,1,l)
> rhon(ix,jy,1,n,l)=rhoh(1)
> uun(ix,jy,nz,n,l)=uuhn(ix,jy,nuvz,l)
> vvn(ix,jy,nz,n,l)=vvhn(ix,jy,nuvz,l)
> ttn(ix,jy,nz,n,l)=tthn(ix,jy,nuvz,n,l)
> qvn(ix,jy,nz,n,l)=qvhn(ix,jy,nuvz,n,l)
> pvn(ix,jy,nz,n,l)=pvhn(ix,jy,nuvz,l)
> rhon(ix,jy,nz,n,l)=rhoh(nuvz)
> kmin=2
> do iz=2,nz-1
> do kz=kmin,nuvz
> if(height(iz).gt.uvzlev(nuvz)) then
> uun(ix,jy,iz,n,l)=uun(ix,jy,nz,n,l)
> vvn(ix,jy,iz,n,l)=vvn(ix,jy,nz,n,l)
> ttn(ix,jy,iz,n,l)=ttn(ix,jy,nz,n,l)
> qvn(ix,jy,iz,n,l)=qvn(ix,jy,nz,n,l)
> pvn(ix,jy,iz,n,l)=pvn(ix,jy,nz,n,l)
> rhon(ix,jy,iz,n,l)=rhon(ix,jy,nz,n,l)
> goto 30
> endif
> if ((height(iz).gt.uvzlev(kz-1)).and. &
> (height(iz).le.uvzlev(kz))) then
> dz1=height(iz)-uvzlev(kz-1)
> dz2=uvzlev(kz)-height(iz)
> dz=dz1+dz2
> uun(ix,jy,iz,n,l)=(uuhn(ix,jy,kz-1,l)*dz2+ &
> uuhn(ix,jy,kz,l)*dz1)/dz
> vvn(ix,jy,iz,n,l)=(vvhn(ix,jy,kz-1,l)*dz2+ &
> vvhn(ix,jy,kz,l)*dz1)/dz
> ttn(ix,jy,iz,n,l)=(tthn(ix,jy,kz-1,n,l)*dz2+ &
> tthn(ix,jy,kz,n,l)*dz1)/dz
> qvn(ix,jy,iz,n,l)=(qvhn(ix,jy,kz-1,n,l)*dz2+ &
> qvhn(ix,jy,kz,n,l)*dz1)/dz
> pvn(ix,jy,iz,n,l)=(pvhn(ix,jy,kz-1,l)*dz2+ &
> pvhn(ix,jy,kz,l)*dz1)/dz
> rhon(ix,jy,iz,n,l)=(rhoh(kz-1)*dz2+rhoh(kz)*dz1)/dz
> kmin=kz
> goto 30
> endif
> end do
> 30 continue
> end do
>
>
> ! Levels, where w is given
> !*************************
>
> wwn(ix,jy,1,n,l)=wwhn(ix,jy,1,l)*pinmconv(1)
> wwn(ix,jy,nz,n,l)=wwhn(ix,jy,nwz,l)*pinmconv(nz)
> kmin=2
> do iz=2,nz
> do kz=kmin,nwz
> if ((height(iz).gt.wzlev(kz-1)).and. &
> (height(iz).le.wzlev(kz))) then
> dz1=height(iz)-wzlev(kz-1)
> dz2=wzlev(kz)-height(iz)
> dz=dz1+dz2
> wwn(ix,jy,iz,n,l)=(wwhn(ix,jy,kz-1,l)*pinmconv(kz-1)*dz2 &
> +wwhn(ix,jy,kz,l)*pinmconv(kz)*dz1)/dz
> kmin=kz
> goto 40
> endif
> end do
> 40 continue
> end do
>
> ! Compute density gradients at intermediate levels
> !*************************************************
>
> drhodzn(ix,jy,1,n,l)=(rhon(ix,jy,2,n,l)-rhon(ix,jy,1,n,l))/ &
> (height(2)-height(1))
> do kz=2,nz-1
> drhodzn(ix,jy,kz,n,l)=(rhon(ix,jy,kz+1,n,l)- &
> rhon(ix,jy,kz-1,n,l))/(height(kz+1)-height(kz-1))
> end do
> drhodzn(ix,jy,nz,n,l)=drhodzn(ix,jy,nz-1,n,l)
>
> end do
> end do
>
>
> !****************************************************************
> ! Compute slope of eta levels in windward direction and resulting
> ! vertical wind correction
> !****************************************************************
>
> do jy=1,nyn(l)-2
> do ix=1,nxn(l)-2
>
> kmin=2
> do iz=2,nz-1
>
> ui=uun(ix,jy,iz,n,l)*dxconst*xresoln(l)/ &
> cos((real(jy)*dyn(l)+ylat0n(l))*pi180)
> vi=vvn(ix,jy,iz,n,l)*dyconst*yresoln(l)
>
> do kz=kmin,nz
> if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. &
> (height(iz).le.uvwzlev(ix,jy,kz))) then
> dz1=height(iz)-uvwzlev(ix,jy,kz-1)
> dz2=uvwzlev(ix,jy,kz)-height(iz)
> dz=dz1+dz2
> kl=kz-1
> klp=kz
> kmin=kz
> goto 47
> endif
> end do
>
> 47 ix1=ix-1
> jy1=jy-1
> ixp=ix+1
> jyp=jy+1
>
> dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2.
> dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2.
> dzdx=(dzdx1*dz2+dzdx2*dz1)/dz
>
> dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2.
> dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2.
> dzdy=(dzdy1*dz2+dzdy2*dz1)/dz
>
> wwn(ix,jy,iz,n,l)=wwn(ix,jy,iz,n,l)+(dzdx*ui+dzdy*vi)
>
> end do
>
> end do
> end do
>
>
> !write (*,*) 'initializing nested cloudsn, n:',n
> ! create a cloud and rainout/washout field, cloudsn occur where rh>80%
> do jy=0,nyn(l)-1
> do ix=0,nxn(l)-1
> rain_cloud_above=0
> lsp=lsprecn(ix,jy,1,n,l)
> convp=convprecn(ix,jy,1,n,l)
> cloudsnh(ix,jy,n,l)=0
> do kz_inv=1,nz-1
> kz=nz-kz_inv+1
> pressure=rhon(ix,jy,kz,n,l)*r_air*ttn(ix,jy,kz,n,l)
> rh=qvn(ix,jy,kz,n,l)/f_qvsat(pressure,ttn(ix,jy,kz,n,l))
> cloudsn(ix,jy,kz,n,l)=0
> if (rh.gt.0.8) then ! in cloud
> if ((lsp.gt.0.01).or.(convp.gt.0.01)) then
> rain_cloud_above=1
> cloudsnh(ix,jy,n,l)=cloudsnh(ix,jy,n,l)+ &
> height(kz)-height(kz-1)
> if (lsp.ge.convp) then
> cloudsn(ix,jy,kz,n,l)=3 ! lsp dominated rainout
> else
> cloudsn(ix,jy,kz,n,l)=2 ! convp dominated rainout
> endif
> else ! no precipitation
> cloudsn(ix,jy,kz,n,l)=1 ! cloud
> endif
> else ! no cloud
> if (rain_cloud_above.eq.1) then ! scavenging
> if (lsp.ge.convp) then
> cloudsn(ix,jy,kz,n,l)=5 ! lsp dominated washout
> else
> cloudsn(ix,jy,kz,n,l)=4 ! convp dominated washout
> endif
> endif
> endif
> end do
> end do
> end do
>
> end do
>
> end subroutine verttransform_nests
wetdepo.f90
----------------------------------------------
1,308c1,308
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine wetdepo(itime,ltsample,loutnext)
< ! i i i
< !*****************************************************************************
< ! *
< ! Calculation of wet deposition using the concept of scavenging coefficients.*
< ! For lack of detailed information, washout and rainout are jointly treated. *
< ! It is assumed that precipitation does not occur uniformly within the whole *
< ! grid cell, but that only a fraction of the grid cell experiences rainfall. *
< ! This fraction is parameterized from total cloud cover and rates of large *
< ! scale and convective precipitation. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 1 December 1996 *
< ! *
< ! Correction by Petra Seibert, Sept 2002: *
< ! use centred precipitation data for integration *
< ! Code may not be correct for decay of deposition! *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! cc [0-1] total cloud cover *
< ! convp [mm/h] convective precipitation rate *
< ! grfraction [0-1] fraction of grid, for which precipitation occurs *
< ! ix,jy indices of output grid cell for each particle *
< ! itime [s] actual simulation time [s] *
< ! jpart particle index *
< ! ldeltat [s] interval since radioactive decay was computed *
< ! lfr, cfr area fraction covered by precipitation for large scale *
< ! and convective precipitation (dependent on prec. rate) *
< ! loutnext [s] time for which gridded deposition is next output *
< ! loutstep [s] interval at which gridded deposition is output *
< ! lsp [mm/h] large scale precipitation rate *
< ! ltsample [s] interval over which mass is deposited *
< ! prec [mm/h] precipitation rate in subgrid, where precipitation occurs*
< ! wetdeposit mass that is wet deposited *
< ! wetgrid accumulated deposited mass on output grid *
< ! wetscav scavenging coefficient *
< ! *
< ! Constants: *
< ! *
< !*****************************************************************************
<
< use point_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: jpart,itime,ltsample,loutnext,ldeltat,i,j,ix,jy
< integer :: ngrid,itage,nage,hz,il,interp_time, n, clouds_v
< integer :: ks, kp
< real :: S_i, act_temp, cl, cle ! in cloud scavenging
< real :: clouds_h ! cloud height for the specific grid point
< real :: xtn,ytn,lsp,convp,cc,grfraction,prec,wetscav
< real :: wetdeposit(maxspec),restmass
< real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
< save lfr,cfr
<
<
< real :: lfr(5) = (/ 0.5,0.65,0.8,0.9,0.95/)
< real :: cfr(5) = (/ 0.4,0.55,0.7,0.8,0.9 /)
<
< ! Compute interval since radioactive decay of deposited mass was computed
< !************************************************************************
<
< if (itime.le.loutnext) then
< ldeltat=itime-(loutnext-loutstep)
< else ! first half of next interval
< ldeltat=itime-loutnext
< endif
<
<
< ! Loop over all particles
< !************************
<
< do jpart=1,numpart
< if (itra1(jpart).eq.-999999999) goto 20
< if(ldirect.eq.1)then
< if (itra1(jpart).gt.itime) goto 20
< else
< if (itra1(jpart).lt.itime) goto 20
< endif
< ! Determine age class of the particle
< itage=abs(itra1(jpart)-itramem(jpart))
< do nage=1,nageclass
< if (itage.lt.lage(nage)) goto 33
< end do
< 33 continue
<
<
< ! Determine which nesting level to be used
< !*****************************************
<
< ngrid=0
< do j=numbnests,1,-1
< if ((xtra1(jpart).gt.xln(j)).and.(xtra1(jpart).lt.xrn(j)).and. &
< (ytra1(jpart).gt.yln(j)).and.(ytra1(jpart).lt.yrn(j))) then
< ngrid=j
< goto 23
< endif
< end do
< 23 continue
<
<
< ! Determine nested grid coordinates
< !**********************************
<
< if (ngrid.gt.0) then
< xtn=(xtra1(jpart)-xln(ngrid))*xresoln(ngrid)
< ytn=(ytra1(jpart)-yln(ngrid))*yresoln(ngrid)
< ix=int(xtn)
< jy=int(ytn)
< else
< ix=int(xtra1(jpart))
< jy=int(ytra1(jpart))
< endif
<
<
< ! Interpolate large scale precipitation, convective precipitation and
< ! total cloud cover
< ! Note that interpolated time refers to itime-0.5*ltsample [PS]
< !********************************************************************
< interp_time=nint(itime-0.5*ltsample)
<
< if (ngrid.eq.0) then
< call interpol_rain(lsprec,convprec,tcc,nxmax,nymax, &
< 1,nx,ny,memind,real(xtra1(jpart)),real(ytra1(jpart)),1, &
< memtime(1),memtime(2),interp_time,lsp,convp,cc)
< else
< call interpol_rain_nests(lsprecn,convprecn,tccn, &
< nxmaxn,nymaxn,1,maxnests,ngrid,nxn,nyn,memind,xtn,ytn,1, &
< memtime(1),memtime(2),interp_time,lsp,convp,cc)
< endif
<
< if ((lsp.lt.0.01).and.(convp.lt.0.01)) goto 20
<
< ! get the level were the actual particle is in
< do il=2,nz
< if (height(il).gt.ztra1(jpart)) then
< hz=il-1
< goto 26
< endif
< end do
< 26 continue
<
< n=memind(2)
< if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) &
< n=memind(1)
<
< ! if there is no precipitation or the particle is above the clouds no
< ! scavenging is done
<
< if (ngrid.eq.0) then
< clouds_v=clouds(ix,jy,hz,n)
< clouds_h=cloudsh(ix,jy,n)
< else
< clouds_v=cloudsn(ix,jy,hz,n,ngrid)
< clouds_h=cloudsnh(ix,jy,n,ngrid)
< endif
< !write(*,*) 'there is
< ! + precipitation',(clouds(ix,jy,ihz,n),ihz=1,20),lsp,convp,hz
< if (clouds_v.le.1) goto 20
< !write (*,*) 'there is scavenging'
<
< ! 1) Parameterization of the the area fraction of the grid cell where the
< ! precipitation occurs: the absolute limit is the total cloud cover, but
< ! for low precipitation rates, an even smaller fraction of the grid cell
< ! is used. Large scale precipitation occurs over larger areas than
< ! convective precipitation.
< !**************************************************************************
<
< if (lsp.gt.20.) then
< i=5
< else if (lsp.gt.8.) then
< i=4
< else if (lsp.gt.3.) then
< i=3
< else if (lsp.gt.1.) then
< i=2
< else
< i=1
< endif
<
< if (convp.gt.20.) then
< j=5
< else if (convp.gt.8.) then
< j=4
< else if (convp.gt.3.) then
< j=3
< else if (convp.gt.1.) then
< j=2
< else
< j=1
< endif
<
< grfraction=max(0.05,cc*(lsp*lfr(i)+convp*cfr(j))/(lsp+convp))
<
< ! 2) Computation of precipitation rate in sub-grid cell
< !******************************************************
<
< prec=(lsp+convp)/grfraction
<
< ! 3) Computation of scavenging coefficients for all species
< ! Computation of wet deposition
< !**********************************************************
<
< do ks=1,nspec ! loop over species
< wetdeposit(ks)=0.
< if (weta(ks).gt.0.) then
< if (clouds_v.ge.4) then
< ! BELOW CLOUD SCAVENGING
< ! for aerosols and not highliy soluble substances weta=5E-6
< wetscav=weta(ks)*prec**wetb(ks) ! scavenging coeff.
< ! write(*,*) 'bel. wetscav: ',wetscav
< else ! below_cloud clouds_v is lt 4 and gt 1 -> in cloud scavenging
< ! IN CLOUD SCAVENGING
< ! BUGFIX tt for nested fields should be ttn
< ! sec may 2008
< if (ngrid.gt.0) then
< act_temp=ttn(ix,jy,hz,n,ngrid)
< else
< act_temp=tt(ix,jy,hz,n)
< endif
< cl=2E-7*prec**0.36
< if (dquer(ks).gt.0) then ! is particle
< S_i=0.9/cl
< else ! is gas
< cle=(1-cl)/(henry(ks)*(r_air/3500.)*act_temp)+cl
< S_i=1/cle
< endif
< wetscav=S_i*prec/3.6E6/clouds_h
< ! write(*,*) 'in. wetscav:'
< ! + ,wetscav,cle,cl,act_temp,prec,clouds_h
< endif
<
<
< ! if (wetscav.le.0) write (*,*) 'neg, or 0 wetscav!'
< ! + ,wetscav,cle,cl,act_temp,prec,clouds_h,clouds_v
< wetdeposit(ks)=xmass1(jpart,ks)* &
< (1.-exp(-wetscav*abs(ltsample)))*grfraction ! wet deposition
< ! new particle mass:
< ! if (wetdeposit(ks).gt.0) then
< ! write(*,*) 'wetdepo: ',wetdeposit(ks),ks
< ! endif
< restmass = xmass1(jpart,ks)-wetdeposit(ks)
< if (ioutputforeachrelease.eq.1) then
< kp=npoint(jpart)
< else
< kp=1
< endif
< if (restmass .gt. smallnum) then
< xmass1(jpart,ks)=restmass
< !ccccccccccccccc depostatistic
< ! wetdepo_sum(ks,kp)=wetdepo_sum(ks,kp)+wetdeposit(ks)
< !ccccccccccccccc depostatistic
< else
< xmass1(jpart,ks)=0.
< endif
< ! Correct deposited mass to the last time step when radioactive decay of
< ! gridded deposited mass was calculated
< if (decay(ks).gt.0.) then
< wetdeposit(ks)=wetdeposit(ks) &
< *exp(abs(ldeltat)*decay(ks))
< endif
< else ! weta(k)
< wetdeposit(ks)=0.
< endif ! weta(k)
< end do
<
< ! Sabine Eckhard, June 2008 create deposition runs only for forward runs
< ! Add the wet deposition to accumulated amount on output grid and nested output grid
< !*****************************************************************************
<
< if (ldirect.eq.1) then
< call wetdepokernel(nclass(jpart),wetdeposit,real(xtra1(jpart)), &
< real(ytra1(jpart)),nage,kp)
< if (nested_output.eq.1) call wetdepokernel_nest(nclass(jpart), &
< wetdeposit,real(xtra1(jpart)),real(ytra1(jpart)), &
< nage,kp)
< endif
<
< 20 continue
< end do
<
< end subroutine wetdepo
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine wetdepo(itime,ltsample,loutnext)
> ! i i i
> !*****************************************************************************
> ! *
> ! Calculation of wet deposition using the concept of scavenging coefficients.*
> ! For lack of detailed information, washout and rainout are jointly treated. *
> ! It is assumed that precipitation does not occur uniformly within the whole *
> ! grid cell, but that only a fraction of the grid cell experiences rainfall. *
> ! This fraction is parameterized from total cloud cover and rates of large *
> ! scale and convective precipitation. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 1 December 1996 *
> ! *
> ! Correction by Petra Seibert, Sept 2002: *
> ! use centred precipitation data for integration *
> ! Code may not be correct for decay of deposition! *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! cc [0-1] total cloud cover *
> ! convp [mm/h] convective precipitation rate *
> ! grfraction [0-1] fraction of grid, for which precipitation occurs *
> ! ix,jy indices of output grid cell for each particle *
> ! itime [s] actual simulation time [s] *
> ! jpart particle index *
> ! ldeltat [s] interval since radioactive decay was computed *
> ! lfr, cfr area fraction covered by precipitation for large scale *
> ! and convective precipitation (dependent on prec. rate) *
> ! loutnext [s] time for which gridded deposition is next output *
> ! loutstep [s] interval at which gridded deposition is output *
> ! lsp [mm/h] large scale precipitation rate *
> ! ltsample [s] interval over which mass is deposited *
> ! prec [mm/h] precipitation rate in subgrid, where precipitation occurs*
> ! wetdeposit mass that is wet deposited *
> ! wetgrid accumulated deposited mass on output grid *
> ! wetscav scavenging coefficient *
> ! *
> ! Constants: *
> ! *
> !*****************************************************************************
>
> use point_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: jpart,itime,ltsample,loutnext,ldeltat,i,j,ix,jy
> integer :: ngrid,itage,nage,hz,il,interp_time, n, clouds_v
> integer :: ks, kp
> real :: S_i, act_temp, cl, cle ! in cloud scavenging
> real :: clouds_h ! cloud height for the specific grid point
> real :: xtn,ytn,lsp,convp,cc,grfraction,prec,wetscav
> real :: wetdeposit(maxspec),restmass
> real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled
> save lfr,cfr
>
>
> real :: lfr(5) = (/ 0.5,0.65,0.8,0.9,0.95/)
> real :: cfr(5) = (/ 0.4,0.55,0.7,0.8,0.9 /)
>
> ! Compute interval since radioactive decay of deposited mass was computed
> !************************************************************************
>
> if (itime.le.loutnext) then
> ldeltat=itime-(loutnext-loutstep)
> else ! first half of next interval
> ldeltat=itime-loutnext
> endif
>
>
> ! Loop over all particles
> !************************
>
> do jpart=1,numpart
> if (itra1(jpart).eq.-999999999) goto 20
> if(ldirect.eq.1)then
> if (itra1(jpart).gt.itime) goto 20
> else
> if (itra1(jpart).lt.itime) goto 20
> endif
> ! Determine age class of the particle
> itage=abs(itra1(jpart)-itramem(jpart))
> do nage=1,nageclass
> if (itage.lt.lage(nage)) goto 33
> end do
> 33 continue
>
>
> ! Determine which nesting level to be used
> !*****************************************
>
> ngrid=0
> do j=numbnests,1,-1
> if ((xtra1(jpart).gt.xln(j)).and.(xtra1(jpart).lt.xrn(j)).and. &
> (ytra1(jpart).gt.yln(j)).and.(ytra1(jpart).lt.yrn(j))) then
> ngrid=j
> goto 23
> endif
> end do
> 23 continue
>
>
> ! Determine nested grid coordinates
> !**********************************
>
> if (ngrid.gt.0) then
> xtn=(xtra1(jpart)-xln(ngrid))*xresoln(ngrid)
> ytn=(ytra1(jpart)-yln(ngrid))*yresoln(ngrid)
> ix=int(xtn)
> jy=int(ytn)
> else
> ix=int(xtra1(jpart))
> jy=int(ytra1(jpart))
> endif
>
>
> ! Interpolate large scale precipitation, convective precipitation and
> ! total cloud cover
> ! Note that interpolated time refers to itime-0.5*ltsample [PS]
> !********************************************************************
> interp_time=nint(itime-0.5*ltsample)
>
> if (ngrid.eq.0) then
> call interpol_rain(lsprec,convprec,tcc,nxmax,nymax, &
> 1,nx,ny,memind,real(xtra1(jpart)),real(ytra1(jpart)),1, &
> memtime(1),memtime(2),interp_time,lsp,convp,cc)
> else
> call interpol_rain_nests(lsprecn,convprecn,tccn, &
> nxmaxn,nymaxn,1,maxnests,ngrid,nxn,nyn,memind,xtn,ytn,1, &
> memtime(1),memtime(2),interp_time,lsp,convp,cc)
> endif
>
> if ((lsp.lt.0.01).and.(convp.lt.0.01)) goto 20
>
> ! get the level were the actual particle is in
> do il=2,nz
> if (height(il).gt.ztra1(jpart)) then
> hz=il-1
> goto 26
> endif
> end do
> 26 continue
>
> n=memind(2)
> if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) &
> n=memind(1)
>
> ! if there is no precipitation or the particle is above the clouds no
> ! scavenging is done
>
> if (ngrid.eq.0) then
> clouds_v=clouds(ix,jy,hz,n)
> clouds_h=cloudsh(ix,jy,n)
> else
> clouds_v=cloudsn(ix,jy,hz,n,ngrid)
> clouds_h=cloudsnh(ix,jy,n,ngrid)
> endif
> !write(*,*) 'there is
> ! + precipitation',(clouds(ix,jy,ihz,n),ihz=1,20),lsp,convp,hz
> if (clouds_v.le.1) goto 20
> !write (*,*) 'there is scavenging'
>
> ! 1) Parameterization of the the area fraction of the grid cell where the
> ! precipitation occurs: the absolute limit is the total cloud cover, but
> ! for low precipitation rates, an even smaller fraction of the grid cell
> ! is used. Large scale precipitation occurs over larger areas than
> ! convective precipitation.
> !**************************************************************************
>
> if (lsp.gt.20.) then
> i=5
> else if (lsp.gt.8.) then
> i=4
> else if (lsp.gt.3.) then
> i=3
> else if (lsp.gt.1.) then
> i=2
> else
> i=1
> endif
>
> if (convp.gt.20.) then
> j=5
> else if (convp.gt.8.) then
> j=4
> else if (convp.gt.3.) then
> j=3
> else if (convp.gt.1.) then
> j=2
> else
> j=1
> endif
>
> grfraction=max(0.05,cc*(lsp*lfr(i)+convp*cfr(j))/(lsp+convp))
>
> ! 2) Computation of precipitation rate in sub-grid cell
> !******************************************************
>
> prec=(lsp+convp)/grfraction
>
> ! 3) Computation of scavenging coefficients for all species
> ! Computation of wet deposition
> !**********************************************************
>
> do ks=1,nspec ! loop over species
> wetdeposit(ks)=0.
> if (weta(ks).gt.0.) then
> if (clouds_v.ge.4) then
> ! BELOW CLOUD SCAVENGING
> ! for aerosols and not highliy soluble substances weta=5E-6
> wetscav=weta(ks)*prec**wetb(ks) ! scavenging coeff.
> ! write(*,*) 'bel. wetscav: ',wetscav
> else ! below_cloud clouds_v is lt 4 and gt 1 -> in cloud scavenging
> ! IN CLOUD SCAVENGING
> ! BUGFIX tt for nested fields should be ttn
> ! sec may 2008
> if (ngrid.gt.0) then
> act_temp=ttn(ix,jy,hz,n,ngrid)
> else
> act_temp=tt(ix,jy,hz,n)
> endif
> cl=2E-7*prec**0.36
> if (dquer(ks).gt.0) then ! is particle
> S_i=0.9/cl
> else ! is gas
> cle=(1-cl)/(henry(ks)*(r_air/3500.)*act_temp)+cl
> S_i=1/cle
> endif
> wetscav=S_i*prec/3.6E6/clouds_h
> ! write(*,*) 'in. wetscav:'
> ! + ,wetscav,cle,cl,act_temp,prec,clouds_h
> endif
>
>
> ! if (wetscav.le.0) write (*,*) 'neg, or 0 wetscav!'
> ! + ,wetscav,cle,cl,act_temp,prec,clouds_h,clouds_v
> wetdeposit(ks)=xmass1(jpart,ks)* &
> (1.-exp(-wetscav*abs(ltsample)))*grfraction ! wet deposition
> ! new particle mass:
> ! if (wetdeposit(ks).gt.0) then
> ! write(*,*) 'wetdepo: ',wetdeposit(ks),ks
> ! endif
> restmass = xmass1(jpart,ks)-wetdeposit(ks)
> if (ioutputforeachrelease.eq.1) then
> kp=npoint(jpart)
> else
> kp=1
> endif
> if (restmass .gt. smallnum) then
> xmass1(jpart,ks)=restmass
> !ccccccccccccccc depostatistic
> ! wetdepo_sum(ks,kp)=wetdepo_sum(ks,kp)+wetdeposit(ks)
> !ccccccccccccccc depostatistic
> else
> xmass1(jpart,ks)=0.
> endif
> ! Correct deposited mass to the last time step when radioactive decay of
> ! gridded deposited mass was calculated
> if (decay(ks).gt.0.) then
> wetdeposit(ks)=wetdeposit(ks) &
> *exp(abs(ldeltat)*decay(ks))
> endif
> else ! weta(k)
> wetdeposit(ks)=0.
> endif ! weta(k)
> end do
>
> ! Sabine Eckhard, June 2008 create deposition runs only for forward runs
> ! Add the wet deposition to accumulated amount on output grid and nested output grid
> !*****************************************************************************
>
> if (ldirect.eq.1) then
> call wetdepokernel(nclass(jpart),wetdeposit,real(xtra1(jpart)), &
> real(ytra1(jpart)),nage,kp)
> if (nested_output.eq.1) call wetdepokernel_nest(nclass(jpart), &
> wetdeposit,real(xtra1(jpart)),real(ytra1(jpart)), &
> nage,kp)
> endif
>
> 20 continue
> end do
>
> end subroutine wetdepo
wetdepokernel.f90
----------------------------------------------
1,110c1,110
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine wetdepokernel(nunc,deposit,x,y,nage,kp)
< ! i i i i i
< !*****************************************************************************
< ! *
< ! Attribution of the deposition from an individual particle to the *
< ! deposition fields using a uniform kernel with bandwidths dxout and dyout.*
< ! *
< ! Author: A. Stohl *
< ! *
< ! 26 December 1996 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! nunc uncertainty class of the respective particle *
< ! nage age class of the respective particle *
< ! deposit amount (kg) to be deposited *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use par_mod
< use com_mod
<
< implicit none
<
< real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
< integer :: ix,jy,ixp,jyp,nunc,nage,ks,kp
<
< xl=(x*dx+xoutshift)/dxout
< yl=(y*dy+youtshift)/dyout
< ix=int(xl)
< jy=int(yl)
< ddx=xl-real(ix) ! distance to left cell border
< ddy=yl-real(jy) ! distance to lower cell border
<
< if (ddx.gt.0.5) then
< ixp=ix+1
< wx=1.5-ddx
< else
< ixp=ix-1
< wx=0.5+ddx
< endif
<
< if (ddy.gt.0.5) then
< jyp=jy+1
< wy=1.5-ddy
< else
< jyp=jy-1
< wy=0.5+ddy
< endif
<
<
< ! Determine mass fractions for four grid points
< !**********************************************
<
< do ks=1,nspec
<
< if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
< (jy.le.numygrid-1)) then
< w=wx*wy
< wetgridunc(ix,jy,ks,kp,nunc,nage)= &
< wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgrid-1).and. &
< (jyp.le.numygrid-1)) then
< w=(1.-wx)*(1.-wy)
< wetgridunc(ixp,jyp,ks,kp,nunc,nage)= &
< wetgridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. &
< (jy.le.numygrid-1)) then
< w=(1.-wx)*wy
< wetgridunc(ixp,jy,ks,kp,nunc,nage)= &
< wetgridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. &
< (jyp.le.numygrid-1)) then
< w=wx*(1.-wy)
< wetgridunc(ix,jyp,ks,kp,nunc,nage)= &
< wetgridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
< endif
< end do
<
< end subroutine wetdepokernel
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine wetdepokernel(nunc,deposit,x,y,nage,kp)
> ! i i i i i
> !*****************************************************************************
> ! *
> ! Attribution of the deposition from an individual particle to the *
> ! deposition fields using a uniform kernel with bandwidths dxout and dyout.*
> ! *
> ! Author: A. Stohl *
> ! *
> ! 26 December 1996 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! nunc uncertainty class of the respective particle *
> ! nage age class of the respective particle *
> ! deposit amount (kg) to be deposited *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use par_mod
> use com_mod
>
> implicit none
>
> real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
> integer :: ix,jy,ixp,jyp,nunc,nage,ks,kp
>
> xl=(x*dx+xoutshift)/dxout
> yl=(y*dy+youtshift)/dyout
> ix=int(xl)
> jy=int(yl)
> ddx=xl-real(ix) ! distance to left cell border
> ddy=yl-real(jy) ! distance to lower cell border
>
> if (ddx.gt.0.5) then
> ixp=ix+1
> wx=1.5-ddx
> else
> ixp=ix-1
> wx=0.5+ddx
> endif
>
> if (ddy.gt.0.5) then
> jyp=jy+1
> wy=1.5-ddy
> else
> jyp=jy-1
> wy=0.5+ddy
> endif
>
>
> ! Determine mass fractions for four grid points
> !**********************************************
>
> do ks=1,nspec
>
> if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. &
> (jy.le.numygrid-1)) then
> w=wx*wy
> wetgridunc(ix,jy,ks,kp,nunc,nage)= &
> wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgrid-1).and. &
> (jyp.le.numygrid-1)) then
> w=(1.-wx)*(1.-wy)
> wetgridunc(ixp,jyp,ks,kp,nunc,nage)= &
> wetgridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. &
> (jy.le.numygrid-1)) then
> w=(1.-wx)*wy
> wetgridunc(ixp,jy,ks,kp,nunc,nage)= &
> wetgridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. &
> (jyp.le.numygrid-1)) then
> w=wx*(1.-wy)
> wetgridunc(ix,jyp,ks,kp,nunc,nage)= &
> wetgridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
> endif
> end do
>
> end subroutine wetdepokernel
wetdepokernel_nest.f90
----------------------------------------------
1,117c1,117
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine wetdepokernel_nest &
< (nunc,deposit,x,y,nage,kp)
< ! i i i i i i
< !*****************************************************************************
< ! *
< ! Attribution of the deposition from an individual particle to the *
< ! nested deposition fields using a uniform kernel with bandwidths *
< ! dxoutn and dyoutn. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 26 December 1996 *
< ! *
< ! 2 September 2004: Adaptation from wetdepokernel. *
< ! *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! nunc uncertainty class of the respective particle *
< ! nage age class of the respective particle *
< ! deposit amount (kg) to be deposited *
< ! *
< !*****************************************************************************
<
< use unc_mod
< use par_mod
< use com_mod
<
< implicit none
<
< real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
< integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage
<
<
<
< xl=(x*dx+xoutshiftn)/dxoutn
< yl=(y*dy+youtshiftn)/dyoutn
< ix=int(xl)
< jy=int(yl)
< ddx=xl-real(ix) ! distance to left cell border
< ddy=yl-real(jy) ! distance to lower cell border
<
< if (ddx.gt.0.5) then
< ixp=ix+1
< wx=1.5-ddx
< else
< ixp=ix-1
< wx=0.5+ddx
< endif
<
< if (ddy.gt.0.5) then
< jyp=jy+1
< wy=1.5-ddy
< else
< jyp=jy-1
< wy=0.5+ddy
< endif
<
<
< ! Determine mass fractions for four grid points
< !**********************************************
<
< do ks=1,nspec
<
< if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
< (jy.le.numygridn-1)) then
< w=wx*wy
< wetgriduncn(ix,jy,ks,kp,nunc,nage)= &
< wetgriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgridn-1).and. &
< (jyp.le.numygridn-1)) then
< w=(1.-wx)*(1.-wy)
< wetgriduncn(ixp,jyp,ks,kp,nunc,nage)= &
< wetgriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. &
< (jy.le.numygridn-1)) then
< w=(1.-wx)*wy
< wetgriduncn(ixp,jy,ks,kp,nunc,nage)= &
< wetgriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. &
< (jyp.le.numygridn-1)) then
< w=wx*(1.-wy)
< wetgriduncn(ix,jyp,ks,kp,nunc,nage)= &
< wetgriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
< endif
<
< end do
< end subroutine wetdepokernel_nest
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine wetdepokernel_nest &
> (nunc,deposit,x,y,nage,kp)
> ! i i i i i i
> !*****************************************************************************
> ! *
> ! Attribution of the deposition from an individual particle to the *
> ! nested deposition fields using a uniform kernel with bandwidths *
> ! dxoutn and dyoutn. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 26 December 1996 *
> ! *
> ! 2 September 2004: Adaptation from wetdepokernel. *
> ! *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! nunc uncertainty class of the respective particle *
> ! nage age class of the respective particle *
> ! deposit amount (kg) to be deposited *
> ! *
> !*****************************************************************************
>
> use unc_mod
> use par_mod
> use com_mod
>
> implicit none
>
> real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w
> integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage
>
>
>
> xl=(x*dx+xoutshiftn)/dxoutn
> yl=(y*dy+youtshiftn)/dyoutn
> ix=int(xl)
> jy=int(yl)
> ddx=xl-real(ix) ! distance to left cell border
> ddy=yl-real(jy) ! distance to lower cell border
>
> if (ddx.gt.0.5) then
> ixp=ix+1
> wx=1.5-ddx
> else
> ixp=ix-1
> wx=0.5+ddx
> endif
>
> if (ddy.gt.0.5) then
> jyp=jy+1
> wy=1.5-ddy
> else
> jyp=jy-1
> wy=0.5+ddy
> endif
>
>
> ! Determine mass fractions for four grid points
> !**********************************************
>
> do ks=1,nspec
>
> if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. &
> (jy.le.numygridn-1)) then
> w=wx*wy
> wetgriduncn(ix,jy,ks,kp,nunc,nage)= &
> wetgriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ixp.ge.0).and.(jyp.ge.0).and.(ixp.le.numxgridn-1).and. &
> (jyp.le.numygridn-1)) then
> w=(1.-wx)*(1.-wy)
> wetgriduncn(ixp,jyp,ks,kp,nunc,nage)= &
> wetgriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. &
> (jy.le.numygridn-1)) then
> w=(1.-wx)*wy
> wetgriduncn(ixp,jy,ks,kp,nunc,nage)= &
> wetgriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. &
> (jyp.le.numygridn-1)) then
> w=wx*(1.-wy)
> wetgriduncn(ix,jyp,ks,kp,nunc,nage)= &
> wetgriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w
> endif
>
> end do
> end subroutine wetdepokernel_nest
windalign.f90
----------------------------------------------
1,74c1,74
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine windalign(u,v,ffap,ffcp,ux,vy)
< ! i i i i o o
< !*****************************************************************************
< ! *
< ! Transformation from along- and cross-wind components to u and v *
< ! components. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 3 June 1996 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! ffap turbulent wind in along wind direction *
< ! ffcp turbulent wind in cross wind direction *
< ! u main wind component in x direction *
< ! ux turbulent wind in x direction *
< ! v main wind component in y direction *
< ! vy turbulent wind in y direction *
< ! *
< !*****************************************************************************
<
< implicit none
<
< real :: u,v,ffap,ffcp,ux,vy,ffinv,ux1,ux2,vy1,vy2,sinphi,cosphi
< real,parameter :: eps=1.e-30
<
<
< ! Transform along wind components
< !********************************
<
< ffinv=1./max(sqrt(u*u+v*v),eps)
< sinphi=v*ffinv
< vy1=sinphi*ffap
< cosphi=u*ffinv
< ux1=cosphi*ffap
<
<
< ! Transform cross wind components
< !********************************
<
< ux2=-sinphi*ffcp
< vy2=cosphi*ffcp
<
<
< ! Add contributions from along and cross wind components
< !*******************************************************
<
< ux=ux1+ux2
< vy=vy1+vy2
<
< end subroutine windalign
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine windalign(u,v,ffap,ffcp,ux,vy)
> ! i i i i o o
> !*****************************************************************************
> ! *
> ! Transformation from along- and cross-wind components to u and v *
> ! components. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 3 June 1996 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! ffap turbulent wind in along wind direction *
> ! ffcp turbulent wind in cross wind direction *
> ! u main wind component in x direction *
> ! ux turbulent wind in x direction *
> ! v main wind component in y direction *
> ! vy turbulent wind in y direction *
> ! *
> !*****************************************************************************
>
> implicit none
>
> real :: u,v,ffap,ffcp,ux,vy,ffinv,ux1,ux2,vy1,vy2,sinphi,cosphi
> real,parameter :: eps=1.e-30
>
>
> ! Transform along wind components
> !********************************
>
> ffinv=1./max(sqrt(u*u+v*v),eps)
> sinphi=v*ffinv
> vy1=sinphi*ffap
> cosphi=u*ffinv
> ux1=cosphi*ffap
>
>
> ! Transform cross wind components
> !********************************
>
> ux2=-sinphi*ffcp
> vy2=cosphi*ffcp
>
>
> ! Add contributions from along and cross wind components
> !*******************************************************
>
> ux=ux1+ux2
> vy=vy1+vy2
>
> end subroutine windalign
writeheader.f90
----------------------------------------------
1,156c1,156
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine writeheader
<
< !*****************************************************************************
< ! *
< ! This routine produces a file header containing basic information on the *
< ! settings of the FLEXPART run. *
< ! The header file is essential and must be read in by any postprocessing *
< ! program before reading in the output data. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 7 August 2002 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! xlon longitude *
< ! xl model x coordinate *
< ! ylat latitude *
< ! yl model y coordinate *
< ! *
< !*****************************************************************************
<
< use point_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: jjjjmmdd,ihmmss,i,ix,jy,j
< real :: xp1,yp1,xp2,yp2
<
<
< !************************
< ! Open header output file
< !************************
<
< open(unitheader,file=path(2)(1:length(2))//'header', &
< form='unformatted',err=998)
<
<
< ! Write the header information
< !*****************************
<
< if (ldirect.eq.1) then
< write(unitheader) ibdate,ibtime,'FLEXPART V9.0'
< else
< write(unitheader) iedate,ietime,'FLEXPART V9.0'
< endif
<
< ! Write info on output interval, averaging time, sampling time
< !*************************************************************
<
< write(unitheader) loutstep,loutaver,loutsample
<
< ! Write information on output grid setup
< !***************************************
<
< write(unitheader) outlon0,outlat0,numxgrid,numygrid, &
< dxout,dyout
< write(unitheader) numzgrid,(outheight(i),i=1,numzgrid)
<
< call caldate(bdate,jjjjmmdd,ihmmss)
< write(unitheader) jjjjmmdd,ihmmss
<
< ! Write number of species, and name for each species (+extra name for depositions)
< ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
< ! concentration fields
< !*****************************************************************************
<
< write(unitheader) 3*nspec,maxpointspec_act
< do i=1,nspec
< write(unitheader) 1,'WD_'//species(i)(1:7)
< write(unitheader) 1,'DD_'//species(i)(1:7)
< write(unitheader) numzgrid,species(i)
< end do
<
< ! Write information on release points: total number, then for each point:
< ! start, end, coordinates, # of particles, name, mass
< !************************************************************************
<
< write(unitheader) numpoint
< do i=1,numpoint
< write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
< xp1=xpoint1(i)*dx+xlon0
< yp1=ypoint1(i)*dy+ylat0
< xp2=xpoint2(i)*dx+xlon0
< yp2=ypoint2(i)*dy+ylat0
< write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
< write(unitheader) npart(i),1
< if (numpoint.le.1000) then
< write(unitheader) compoint(i)
< else
< write(unitheader) compoint(1001)
< endif
< do j=1,nspec
< write(unitheader) xmass(i,j)
< write(unitheader) xmass(i,j)
< write(unitheader) xmass(i,j)
< end do
< end do
<
< ! Write information on some model switches
< !*****************************************
<
< write(unitheader) method,lsubgrid,lconvection, &
< ind_source,ind_receptor
<
< ! Write age class information
< !****************************
<
< write(unitheader) nageclass,(lage(i),i=1,nageclass)
<
<
< ! Write topography to output file
< !********************************
<
< do ix=0,numxgrid-1
< write(unitheader) (oroout(ix,jy),jy=0,numygrid-1)
< end do
< close(unitheader)
<
< return
<
<
< 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
< write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
< write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
< write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
< write(*,*) ' #### THE PROGRAM AGAIN. #### '
< stop
<
< end subroutine writeheader
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine writeheader
>
> !*****************************************************************************
> ! *
> ! This routine produces a file header containing basic information on the *
> ! settings of the FLEXPART run. *
> ! The header file is essential and must be read in by any postprocessing *
> ! program before reading in the output data. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 7 August 2002 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! xlon longitude *
> ! xl model x coordinate *
> ! ylat latitude *
> ! yl model y coordinate *
> ! *
> !*****************************************************************************
>
> use point_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: jjjjmmdd,ihmmss,i,ix,jy,j
> real :: xp1,yp1,xp2,yp2
>
>
> !************************
> ! Open header output file
> !************************
>
> open(unitheader,file=path(2)(1:length(2))//'header', &
> form='unformatted',err=998)
>
>
> ! Write the header information
> !*****************************
>
> if (ldirect.eq.1) then
> write(unitheader) ibdate,ibtime,'FLEXPART V9.0'
> else
> write(unitheader) iedate,ietime,'FLEXPART V9.0'
> endif
>
> ! Write info on output interval, averaging time, sampling time
> !*************************************************************
>
> write(unitheader) loutstep,loutaver,loutsample
>
> ! Write information on output grid setup
> !***************************************
>
> write(unitheader) outlon0,outlat0,numxgrid,numygrid, &
> dxout,dyout
> write(unitheader) numzgrid,(outheight(i),i=1,numzgrid)
>
> call caldate(bdate,jjjjmmdd,ihmmss)
> write(unitheader) jjjjmmdd,ihmmss
>
> ! Write number of species, and name for each species (+extra name for depositions)
> ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
> ! concentration fields
> !*****************************************************************************
>
> write(unitheader) 3*nspec,maxpointspec_act
> do i=1,nspec
> write(unitheader) 1,'WD_'//species(i)(1:7)
> write(unitheader) 1,'DD_'//species(i)(1:7)
> write(unitheader) numzgrid,species(i)
> end do
>
> ! Write information on release points: total number, then for each point:
> ! start, end, coordinates, # of particles, name, mass
> !************************************************************************
>
> write(unitheader) numpoint
> do i=1,numpoint
> write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
> xp1=xpoint1(i)*dx+xlon0
> yp1=ypoint1(i)*dy+ylat0
> xp2=xpoint2(i)*dx+xlon0
> yp2=ypoint2(i)*dy+ylat0
> write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
> write(unitheader) npart(i),1
> if (numpoint.le.1000) then
> write(unitheader) compoint(i)
> else
> write(unitheader) compoint(1001)
> endif
> do j=1,nspec
> write(unitheader) xmass(i,j)
> write(unitheader) xmass(i,j)
> write(unitheader) xmass(i,j)
> end do
> end do
>
> ! Write information on some model switches
> !*****************************************
>
> write(unitheader) method,lsubgrid,lconvection, &
> ind_source,ind_receptor
>
> ! Write age class information
> !****************************
>
> write(unitheader) nageclass,(lage(i),i=1,nageclass)
>
>
> ! Write topography to output file
> !********************************
>
> do ix=0,numxgrid-1
> write(unitheader) (oroout(ix,jy),jy=0,numygrid-1)
> end do
> close(unitheader)
>
> return
>
>
> 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
> write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
> write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
> write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
> write(*,*) ' #### THE PROGRAM AGAIN. #### '
> stop
>
> end subroutine writeheader
writeheader_nest.f90
----------------------------------------------
1,156c1,156
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< subroutine writeheader_nest
<
< !*****************************************************************************
< ! *
< ! This routine produces a file header containing basic information on the *
< ! settings of the FLEXPART run. *
< ! The header file is essential and must be read in by any postprocessing *
< ! program before reading in the output data. *
< ! *
< ! Author: A. Stohl *
< ! *
< ! 7 August 2002 *
< ! *
< !*****************************************************************************
< ! *
< ! Variables: *
< ! *
< ! xlon longitude *
< ! xl model x coordinate *
< ! ylat latitude *
< ! yl model y coordinate *
< ! *
< !*****************************************************************************
<
< use point_mod
< use outg_mod
< use par_mod
< use com_mod
<
< implicit none
<
< integer :: jjjjmmdd,ihmmss,i,ix,jy,j
< real :: xp1,yp1,xp2,yp2
<
<
< !************************
< ! Open header output file
< !************************
<
< open(unitheader,file=path(2)(1:length(2))//'header_nest', &
< form='unformatted',err=998)
<
<
< ! Write the header information
< !*****************************
<
< if (ldirect.eq.1) then
< write(unitheader) ibdate,ibtime,'FLEXPART V8.2'
< else
< write(unitheader) iedate,ietime,'FLEXPART V8.2'
< endif
<
< ! Write info on output interval, averaging time, sampling time
< !*************************************************************
<
< write(unitheader) loutstep,loutaver,loutsample
<
< ! Write information on output grid setup
< !***************************************
<
< write(unitheader) outlon0n,outlat0n,numxgridn,numygridn, &
< dxoutn,dyoutn
< write(unitheader) numzgrid,(outheight(i),i=1,numzgrid)
<
< call caldate(bdate,jjjjmmdd,ihmmss)
< write(unitheader) jjjjmmdd,ihmmss
<
< ! Write number of species, and name for each species (+extra name for depositions)
< ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
< ! concentration fields
< !*****************************************************************************
<
< write(unitheader) 3*nspec,maxpointspec_act
< do i=1,nspec
< write(unitheader) 1,'WD_'//species(i)(1:7)
< write(unitheader) 1,'DD_'//species(i)(1:7)
< write(unitheader) numzgrid,species(i)
< end do
<
< ! Write information on release points: total number, then for each point:
< ! start, end, coordinates, # of particles, name, mass
< !************************************************************************
<
< write(unitheader) numpoint
< do i=1,numpoint
< write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
< xp1=xpoint1(i)*dx+xlon0
< yp1=ypoint1(i)*dy+ylat0
< xp2=xpoint2(i)*dx+xlon0
< yp2=ypoint2(i)*dy+ylat0
< write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
< write(unitheader) npart(i),1
< if (numpoint.le.1000) then
< write(unitheader) compoint(i)
< else
< write(unitheader) compoint(1001)
< endif
< do j=1,nspec
< write(unitheader) xmass(i,j)
< write(unitheader) xmass(i,j)
< write(unitheader) xmass(i,j)
< end do
< end do
<
< ! Write information on some model switches
< !*****************************************
<
< write(unitheader) method,lsubgrid,lconvection, &
< ind_source,ind_receptor
<
< ! Write age class information
< !****************************
<
< write(unitheader) nageclass,(lage(i),i=1,nageclass)
<
<
< ! Write topography to output file
< !********************************
<
< do ix=0,numxgridn-1
< write(unitheader) (orooutn(ix,jy),jy=0,numygridn-1)
< end do
< close(unitheader)
<
< return
<
<
< 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
< write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
< write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
< write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
< write(*,*) ' #### THE PROGRAM AGAIN. #### '
< stop
<
< end subroutine writeheader_nest
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> subroutine writeheader_nest
>
> !*****************************************************************************
> ! *
> ! This routine produces a file header containing basic information on the *
> ! settings of the FLEXPART run. *
> ! The header file is essential and must be read in by any postprocessing *
> ! program before reading in the output data. *
> ! *
> ! Author: A. Stohl *
> ! *
> ! 7 August 2002 *
> ! *
> !*****************************************************************************
> ! *
> ! Variables: *
> ! *
> ! xlon longitude *
> ! xl model x coordinate *
> ! ylat latitude *
> ! yl model y coordinate *
> ! *
> !*****************************************************************************
>
> use point_mod
> use outg_mod
> use par_mod
> use com_mod
>
> implicit none
>
> integer :: jjjjmmdd,ihmmss,i,ix,jy,j
> real :: xp1,yp1,xp2,yp2
>
>
> !************************
> ! Open header output file
> !************************
>
> open(unitheader,file=path(2)(1:length(2))//'header_nest', &
> form='unformatted',err=998)
>
>
> ! Write the header information
> !*****************************
>
> if (ldirect.eq.1) then
> write(unitheader) ibdate,ibtime,'FLEXPART V8.2'
> else
> write(unitheader) iedate,ietime,'FLEXPART V8.2'
> endif
>
> ! Write info on output interval, averaging time, sampling time
> !*************************************************************
>
> write(unitheader) loutstep,loutaver,loutsample
>
> ! Write information on output grid setup
> !***************************************
>
> write(unitheader) outlon0n,outlat0n,numxgridn,numygridn, &
> dxoutn,dyoutn
> write(unitheader) numzgrid,(outheight(i),i=1,numzgrid)
>
> call caldate(bdate,jjjjmmdd,ihmmss)
> write(unitheader) jjjjmmdd,ihmmss
>
> ! Write number of species, and name for each species (+extra name for depositions)
> ! Indicate the dimension of the fields (i.e., 1 for deposition fields, numzgrid for
> ! concentration fields
> !*****************************************************************************
>
> write(unitheader) 3*nspec,maxpointspec_act
> do i=1,nspec
> write(unitheader) 1,'WD_'//species(i)(1:7)
> write(unitheader) 1,'DD_'//species(i)(1:7)
> write(unitheader) numzgrid,species(i)
> end do
>
> ! Write information on release points: total number, then for each point:
> ! start, end, coordinates, # of particles, name, mass
> !************************************************************************
>
> write(unitheader) numpoint
> do i=1,numpoint
> write(unitheader) ireleasestart(i),ireleaseend(i),kindz(i)
> xp1=xpoint1(i)*dx+xlon0
> yp1=ypoint1(i)*dy+ylat0
> xp2=xpoint2(i)*dx+xlon0
> yp2=ypoint2(i)*dy+ylat0
> write(unitheader) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i)
> write(unitheader) npart(i),1
> if (numpoint.le.1000) then
> write(unitheader) compoint(i)
> else
> write(unitheader) compoint(1001)
> endif
> do j=1,nspec
> write(unitheader) xmass(i,j)
> write(unitheader) xmass(i,j)
> write(unitheader) xmass(i,j)
> end do
> end do
>
> ! Write information on some model switches
> !*****************************************
>
> write(unitheader) method,lsubgrid,lconvection, &
> ind_source,ind_receptor
>
> ! Write age class information
> !****************************
>
> write(unitheader) nageclass,(lage(i),i=1,nageclass)
>
>
> ! Write topography to output file
> !********************************
>
> do ix=0,numxgridn-1
> write(unitheader) (orooutn(ix,jy),jy=0,numygridn-1)
> end do
> close(unitheader)
>
> return
>
>
> 998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### '
> write(*,*) ' #### '//path(2)(1:length(2))//'header'//' #### '
> write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### '
> write(*,*) ' #### NAME ALREADY EXISTS, DELETE IT AND START #### '
> write(*,*) ' #### THE PROGRAM AGAIN. #### '
> stop
>
> end subroutine writeheader_nest
xmass_mod.f90
----------------------------------------------
1,28c1,28
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< module xmass_mod
<
< implicit none
<
< real,allocatable, dimension (:) :: xmasssave
<
< end module xmass_mod
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> module xmass_mod
>
> implicit none
>
> real,allocatable, dimension (:) :: xmasssave
>
> end module xmass_mod
zenithangle.f90
----------------------------------------------
1,95c1,95
< !**********************************************************************
< ! 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 . *
< !**********************************************************************
<
< real function zenithangle(ylat,xlon,jul)
<
< !*********************************************************************
< ! *
< ! Author: G. WOTAWA *
< ! Date: 1993-11-17 *
< ! Project: POP-M *
< ! Last update: *
< ! *
< !*********************************************************************
< ! *
< ! DESCRIPTION: This function returns the sinus of solar *
< ! elevation as a function of geographic longitude, *
< ! latitude and GMT-Time. *
< ! *
< !*********************************************************************
< ! *
< ! INPUT: *
< ! *
< ! ylat geographical latitude [DEG] *
< ! xlon geographical longitude [DEG] *
< ! jjjj Year *
< ! mm Month *
< ! dd Day *
< ! hh Hour *
< ! minute Minute *
< ! *
< !*********************************************************************
<
< use par_mod, only: dp
<
< implicit none
<
< integer :: jjjj,mm,id,iu,minute,yyyymmdd,hhmmss
< integer :: ndaynum
< real :: sinsol,solelev,ylat,xlon
< real :: rnum,rylat,ttime,dekl,rdekl,eq
< real,parameter :: pi=3.1415927
< real(kind=dp) :: jul
<
< call caldate(jul,yyyymmdd,hhmmss)
< jjjj=yyyymmdd/10000
< mm=yyyymmdd/100-jjjj*100
< id=yyyymmdd-jjjj*10000-mm*100
< iu=hhmmss/10000
< minute=hhmmss/100-100*iu
<
< ndaynum=31*(mm-1)+id
< if(mm.gt.2) ndaynum=ndaynum-int(0.4*mm+2.3)
< if((mm.gt.2).and.(jjjj/4*4.eq.jjjj)) ndaynum=ndaynum+1
<
< rnum=2.*pi*ndaynum/365.
< rylat=pi*ylat/180.
< ttime=real(iu)+real(minute)/60.
<
< dekl=0.396+3.631*sin(rnum)+0.038*sin(2.*rnum)+0.077*sin(3.*rnum)- &
< 22.97*cos(rnum)-0.389*cos(2.*rnum)-0.158*cos(3.*rnum)
< rdekl=pi*dekl/180.
<
< eq=(0.003-7.343*sin(rnum)-9.47*sin(2.*rnum)- &
< 0.329*sin(3.*rnum)-0.196*sin(4.*rnum)+ &
< 0.552*cos(rnum)-3.020*cos(2.*rnum)- &
< 0.076*cos(3.*rnum)-0.125*cos(4.*rnum))/60.
<
< sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)* &
< cos((ttime-12.+xlon/15.+eq)*pi/12.)
< ! Calculate the maximum solar elevation on that day
< !sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)*
< ! & cos((eq)*pi/12.)
< solelev=asin(sinsol)*180./pi
< zenithangle=90.-solelev
<
< return
< end function zenithangle
---
> !**********************************************************************
> ! 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 . *
> !**********************************************************************
>
> real function zenithangle(ylat,xlon,jul)
>
> !*********************************************************************
> ! *
> ! Author: G. WOTAWA *
> ! Date: 1993-11-17 *
> ! Project: POP-M *
> ! Last update: *
> ! *
> !*********************************************************************
> ! *
> ! DESCRIPTION: This function returns the sinus of solar *
> ! elevation as a function of geographic longitude, *
> ! latitude and GMT-Time. *
> ! *
> !*********************************************************************
> ! *
> ! INPUT: *
> ! *
> ! ylat geographical latitude [DEG] *
> ! xlon geographical longitude [DEG] *
> ! jjjj Year *
> ! mm Month *
> ! dd Day *
> ! hh Hour *
> ! minute Minute *
> ! *
> !*********************************************************************
>
> use par_mod, only: dp
>
> implicit none
>
> integer :: jjjj,mm,id,iu,minute,yyyymmdd,hhmmss
> integer :: ndaynum
> real :: sinsol,solelev,ylat,xlon
> real :: rnum,rylat,ttime,dekl,rdekl,eq
> real,parameter :: pi=3.1415927
> real(kind=dp) :: jul
>
> call caldate(jul,yyyymmdd,hhmmss)
> jjjj=yyyymmdd/10000
> mm=yyyymmdd/100-jjjj*100
> id=yyyymmdd-jjjj*10000-mm*100
> iu=hhmmss/10000
> minute=hhmmss/100-100*iu
>
> ndaynum=31*(mm-1)+id
> if(mm.gt.2) ndaynum=ndaynum-int(0.4*mm+2.3)
> if((mm.gt.2).and.(jjjj/4*4.eq.jjjj)) ndaynum=ndaynum+1
>
> rnum=2.*pi*ndaynum/365.
> rylat=pi*ylat/180.
> ttime=real(iu)+real(minute)/60.
>
> dekl=0.396+3.631*sin(rnum)+0.038*sin(2.*rnum)+0.077*sin(3.*rnum)- &
> 22.97*cos(rnum)-0.389*cos(2.*rnum)-0.158*cos(3.*rnum)
> rdekl=pi*dekl/180.
>
> eq=(0.003-7.343*sin(rnum)-9.47*sin(2.*rnum)- &
> 0.329*sin(3.*rnum)-0.196*sin(4.*rnum)+ &
> 0.552*cos(rnum)-3.020*cos(2.*rnum)- &
> 0.076*cos(3.*rnum)-0.125*cos(4.*rnum))/60.
>
> sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)* &
> cos((ttime-12.+xlon/15.+eq)*pi/12.)
> ! Calculate the maximum solar elevation on that day
> !sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)*
> ! & cos((eq)*pi/12.)
> solelev=asin(sinsol)*180./pi
> zenithangle=90.-solelev
>
> return
> end function zenithangle