diff --git a/src_flexwrf_v3.1/README.txt b/src_flexwrf_v3.1/README.txt new file mode 100644 index 0000000000000000000000000000000000000000..69ddd12e68f2f32b37abbc9b85f673de86782bef --- /dev/null +++ b/src_flexwrf_v3.1/README.txt @@ -0,0 +1,123 @@ +J. Brioude, Sept 19 2013 +************************************************************** +To compile flexwrf, choose your compiler in makefile.mom (line 23), the path to the NetCDF library and then type +make -f makefile.mom mpi for MPI+OPENMP hybrid run +make -f makefile.mom omp for OPENMP parallel run +make -f makefile.mom serial for a serial run +******************************************************************** +To run flexwrf, you can pass an argument to the executable that gives the name of the input file. +for instance +./flexwrf31_mpi /home/jbrioude/inputfile.txt +Otherwise, the file flexwrf.input in the current directory is read by default. + +Examples of forward and backward runs are available in the examples directory. + + +***************************************************************** +Versions timeline + +version 3.1: bug fix on the sign of sshf in readwind.f90 + modifications of advance.f90 to limit the vertical velocity from cbl scheme + bug fix in write_ncconc.f90 + modifications of interpol*f90 routines to avoid crashes using tke_partition_hanna.f90 and tke_partition_my.f90 +version 3.0 First public version + +version 2.4.1: New modifications on the wet deposition scheme from Petra Seibert + +version 2.3.1: a NetCDF format output is implemented. + +version 2.2.7: CBL scheme is implemented. a new random generator is implemented. + +version 2.0.6: +-map factors are used in advance.f90 when converting the calculated distance +into a WRF grid distance. +-fix on the divergence based vertical wind + +version 2.0.5: +the time over which the kernel is not used has been reduced from 10800 seconds +to 7200 seconds. Those numbers depend on the horizontal resolution, and a more +flexible solution might come up in a future version +version 2.0.4: +- bug fix for regular output grid +- IO problems in ASCII have been fixed +- add the option of running flexpart with an argument that gives the name of + the inputfile instead of flexwrf.input +version 2.0.3: +- bug fix when flexpart is restarted. +-bug fix in coordtrafo.f90 +- a new option that let the user decide if the time for the the time average + fields from WRF has to be corrected or not. + +version 2.0.2: +- bug fix in sendint2_mpi_old.f90 +- all the *mpi*.f90 have been changed to handle more properly the memory. +- timemanager_mpi has changed accordingly. Some bug fix too +- bug fix in writeheader +- parallelization of calcpar and verttransform.f90, same for the nests. + +version 2.0.1: +-1 option added in flexwrf.input to define the output grid with dxout and dyout +-fix in readinput.f90 to calculate maxpart more accurately + +version 2.0: first OPENMP/MPI version + +version 1.0: +This is a fortran 90 version of FLEXPART. +Compared to PILT, the version from Jerome Fast available on the NILU flexpart website, several bugs and improvements have been made (not +necessarily commented) in the subroutines. +non exhaustive list: +1) optimization of the kein-fritch convective scheme (expensive) +2) possibility to output the flexpart run in a regular lat/lon output grid. +flexwrf.input has 2 options to let the model know which coordinates are used +for the output domaine and the release boxes. +3) Differences in earth radius between WRF and WRF-chem is handled. +4) time averaged wind, instantaneous omega or a vertical velocity internally calculated in FLEXPART can be used now. +5) a bug fix in pbl_profile.f due to the variable kappa. + +Turb option 2 and 3 from Jerome Fast's version lose mass in the model. Those +options are not recommended. + +*********************************************************************** +General comments on The hybrid version of flexpart wrf: +This version includes a parallelized hybrid version of FLEXPART that can be +used with: +- 1 node (1 computer) with multi threads using openmp in shared memory, +- or several nodes (computers) in distributed memory (using mpi) and several threads in shared memory (using openmp). +if a mpi library is not available with your compiler, use makefile.nompi to compile flexwrf + +The system variable OMP_NUM_THREADS has to be set before running the model to define the number of thread used. +it can also be fixed in timemanager*f90. +If not, flexwrf20_mpi will use 1 thread. + +When submitting a job to several nodes, mpiexec or mpirun needs to know that 1 task has to be allocated per node to let openmp doing the work within each node in shared memory. +See submit.sh as an example. + +Compared to the single node version, this version includes modifications of: + +- flexwrf.f90 that is renamed into flexwrf_mpi.f90 +- timemanager.f90 that is renamed into timemanager_mpi.f90 +- the interpol*f90 and hanna* has been modified. +- the routines *mpi*.f90 are used to send or receive data between nodes. + +The most important modifications are in timemanager_mpi.f90, initialize.f90 and advance.f90. +search for JB in timemanager_mpi.f90 to have additional comments. +in advance.f90, I modified the way the random number is picked up (line 187). I use a simple count and the id of the thread instead of the random pick up that uses ran3. +If the series of random number is output for a give release box (uncomment lines 195 to 198), the distribution is quite good, and I don't see any bigger bias that the one in the single thread version. +of course, the distribution is less and less random when you increase the number of nodes or threads. + + +********************************************************* +performance: +this is the performance of the loop line 581 in timemanager_mpi.f90 that calculates the trajectories. +I use the version v74 as the reference (single thread, fortran 77). +There is a loss in performance between v74 and v90 because of the temporary variables th_* that has to be used as private variables in timemanager_mpi.f90 + v74 +v90 1thread 0.96 +v90 2threads 1.86 +v90 4threads 3.57 +v90 8threads 6.22 + +performance of the communication between nodes: +depends on the system. The super computer that I use can transfer about 1Gb in 1 second. +in timemanager_mpi.f90, the output lines 540 and 885 give the time needed by the system to communicate between nodes. using 100 millions particles and say 4 nodes, it takes about 1 second. + diff --git a/src_flexwrf_v3.1/advance.f90 b/src_flexwrf_v3.1/advance.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c3b2832e6b9947242c4796791bb72ba4a2f492f7 --- /dev/null +++ b/src_flexwrf_v3.1/advance.f90 @@ -0,0 +1,1368 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine advance(itime,nrelpoint,ldt,up,vp,wp, & + usigold,vsigold,wsigold,nstop,xt,yt,zt,prob,icbt, & + ngrid,depoindicator,indzindicator,cpt2,ompid,myid,n_threads,mts) !comment by mc: ...,ompid,myid,n_threads) added n_threads for MT parallel random number generator + +! i i i/oi/oi/o +! i/o i/o i/o o i/oi/oi/o i/o i/o +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine gridcheck. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 'includeinterpol'. 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 * +! * +! 26 Oct 2005, R. Easter - changes for horizontal grid in m instead of lat,lon* +! 10 Nov 2005, R. Easter - zero turbulent wind components is * +! turbulence is turned off * +! Mar 2012, J. Brioude: modification to handle openmp. * +! turbulence option 3 is not going * +! to work. but it shouldn't be used anyway ^M +! Jan 2013 M. Cassiani (look for mc or MC in the code): +! *^M +! introduction of CBL skewed turbulence model +! *^M +! & parallel random number generation +! * * +!******************************************************************************** +!******************************************************************************* +! * +! Variables: * +! cbt 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 mt_stream !added by mc for random number generation^M +! use test_well_mod !added by mc for testting well mixed +! use interpol_mod +! use hanna_mod + use cmapf_mod +! use ieee_arithmetic +! include 'sprng_f.h' +! use ran_mod +! include 'includepar' +! include 'includecom' +! include 'includeinterpol' +! include 'includehanna' + + 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,ii,ompid,myid,nombre + 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,mu,mv + 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 + real :: ptot_lhh,Q_lhh,phi_lhh,ath,bth !modified by mc added for CBL scheme + real :: old_wp_buf,del_test !modified by mc added for CBL scheme re-initlization fo particle after NaN + integer(kind=2) :: icbt + real,parameter :: eps=nxmax/3.e5,eps2=1.e-9 + integer :: flagrein !re-initialization flag for particles: modified by mc + + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(nzmax) + real :: u,v,w,usig,vsig,wsig,pvi + real(kind=dp) :: xtold + real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2 + integer :: ix,jy,ixp,jyp,ngrid,indz,indzp,cpt2,maxrand2 + logical :: depoindicator(maxspec) + logical :: indzindicator(nzmax) + + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + + real :: wp2, zt2, ust2, wst2, h2, rhoa2, rhograd2, sigw2, & + dsigwdz2, tlw2, ptot_lhh2, Q_lhh2, phi_lhh2, ath2, bth2, ol2 + + logical :: isnan2 + +!!! CHANGE: TEST OF THE WELL-MIXED CRITERION +! integer iclass +! parameter(iclass=10) +! double precision zacc,tacc,t(iclass),th(0:iclass),hsave +! logical dump +! save zacc,tacc,t,th,hsave,dump +!c itimeod=0 +!!! CHANGE + + integer :: idummy = 7 + real :: settling = 0. + !added by mc for random number generation --------------------- + integer :: n_threads !added by mc for parallel random number generation + integer(4) :: rannum + real(4) :: real_rannum + type (mt_state) :: mts (0: MAX_STREAM) + integer,SAVE :: nan_count(max_STREAM)=0 +!------------------------------------------------------- + + +!!! CHANGE: TEST OF THE WELL-MIXED CRITERION +! if (idummy.eq.-7) then +! open(550,file='WELLMIXEDTEST') +! do 17 i=0,iclass +!17 th(i)=real(i)/real(iclass) +! endif +!!! CHANGE + +! if (nombre.eq.103) print*,'usig -1',usig,xts,yts,zt + if (xt.ne.xt .or. abs(xt).gt.1000.) print*,'problem 0', xt,yt,zt,itime,myid,ompid + xtold=xt +! print *,'aa',xt,yt,zt,u,v,w + nstop=0 + do i=1,nmixz + indzindicator(i)=.true. + enddo + + if (DRYDEP) then ! reset probability for deposition + do ks=1,nspec + depoindicator(ks)=.true. + prob(ks)=0. + enddo + endif + + dxsave=0. ! reset position displacements + dysave=0. ! due to mean wind + dawsave=0. ! and turbulent wind + dcwsave=0. + usig=0. + vsig=0. + wsig=0. + ust=0. + wst=0. + ol=0. + h=0. + zeta=0. + sigu=0. + sigv=0. + tlu=0. + tlv=0. + tlw=0. + sigw=0. + dsigwdz=0. + dsigw2dz=0. +! wp=0. + itimec=itime + idummy=7 + if (newrandomgen.eq.0) then +! cpt2=cpt2+ompid+1 + cpt2=cpt2+1 +! cpt2=cpt2+1000367 + cpt2=mod(cpt2,maxrand)+1; + +! nrand=int(ran3(idummy,inext,inextp,ma,iff)*real(maxrand-1))+1 +! nrand=cpt + nrand=cpt2+ompid*maxrand +! print*,cpt2,maxrand,maxrandomp,maxomp +! print*, rannumb(nrand),nrelpoint +! print*,rannumb(nrand),myid,ompid +! if (nrelpoint.ge.993 .and. nrelpoint.le.998) then +! write(22,*),itime,cpt2,rannumb(nrand),nrelpoint +!!,myid,OMP_GET_THREAD_NUM() + !! write(22,*),itime,cpt2,rannumb(nrand),nrelpoint +! endif + + +! if (nrand+2.gt.maxrand) nrand=1 +! print*,rannumb(nrand) + maxrand2=maxrandomp + + else +!------------------------------------------------------------------------------------------------- +!----- added by MC: parallel random nuymber generation using MT generator ------------------------ + !print *,'varie3',ompid,myid,n_threads +! rannum=genrand_int32(mts(ompid+1+(myid*n_threads))) !integer random number at 32 bit resolution + rannum=genrand_int32(mts(ompid+1)) !integer random number at 32 bit resolution + real_rannum = sngl(0.5_DP + 0.2328306e-9_DP * rannum) !conversion to single precision 32bit real + nrand=int(real_rannum*real(maxrand-1))+1 + !print *,'varie4',rannum,real_rannum,nrand +!-------------------------------------------------------------------------------------------------- + maxrand2=maxrand + + end if + +! 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 + write(*,*) + write(*,*) '*** stopping in advance ***' + write(*,*) ' the n-pole code section should not be active' + write(*,*) + ngrid=-1 + else if (sglobal.and.(yt.lt.switchsouthg)) then + write(*,*) + write(*,*) '*** stopping in advance ***' + write(*,*) ' the s-pole code section should not be active' + write(*,*) + 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 + enddo +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 + + if (ix.lt.0) print*,'problem', xt,xtold,yt,zt,itime,myid,ompid,nrelpoint + +! 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 +!************************************************************* +! print*,'zeta',zeta,h,zt,xt + 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 + + +! print *,'xx0',OMP_GET_THREAD_NUM(),loop,xt,yt,zt,xts,yts,u,v,w + if (loop.eq.1) then +! if (nombre.eq.103) print*,'usig 0',usig,xt,yt,zt + if (ngrid.le.0) then + xts=real(xt) + yts=real(yt) +! if (nombre.eq.103) print*,'usig 0',usig,xts,yts,zt + call interpol_all(itime,xts,yts,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,mu,mv) + + else + call interpol_all_nests(itime,xtn,ytn,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,mu,mv) + endif +! if (nombre.eq.103) print*,'usig 1',usig,xts,yts,zt + + else + + +! print *,'xx',OMP_GET_THREAD_NUM(),xt,yt,zt,xts,yts,u,v,w +! 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 + enddo +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 +! if (nombre.eq.103) print*,'in usig 2',usig + call interpol_misslev(i,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) +!JB mw not needed here + else + call interpol_misslev_nests(i,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + endif + endif + enddo + endif + +! if (nombre.eq.103) print*,'usig 2',usig + +! 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 (turb_option .eq. turb_option_mytke) then +! FLEXPART-WRF + +! write(*,*)'itime=',itime,'xt=',xt,'yt=',yt + call tke_partition_my(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,uprof,vprof,tkeprof,pttprof,indz,indzp) + else if (turb_option .eq. turb_option_tke) then + call tke_partition_hanna(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,uprof,vprof,tkeprof,pttprof,indz,indzp) + else + if (turbswitch) then + call hanna(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + + else + call hanna1(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + + endif + endif +! print*, ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & +! sigw,dsigwdz,dsigw2dz,indz,indzp +!JB +! if (h/abs(ol).lt.1.) then +!c print*,itime,'h and ol',h,ol,'neutral' +! reflect_switch=0 +! else if (ol.lt.0.) then +!c print*,itime,'h and ol',h,ol,'unstable' +!c reflect_switch=1 +! reflect_switch=0 +! else +!c print*,itime,'h and ol',h,ol,'stable' +! reflect_switch=0 +! endif +!***************************************** +! Determine the new diffusivity velocities +!***************************************** + +! Horizontal components +!********************** + +! if (nrand+1.gt.maxrandomp) nrand=1 + if (nrand+1.gt.maxrand2) 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.maxrandomp) nrand=1 + if (nrand+ifine.gt.maxrand2) 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 +! Determine the drift velocity and density correction velocity +!************************************************************* +!--------------- lines below are teh original FLEXPART and are commented out to insert teh cbl options comment by mc +! 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 +!************ CBL scheme integrated in FLEXPART: added by mc **********! + if (turbswitch) then + if (dtftlw.lt..5) then + if (cblflag.eq.1) then +! wp2=wp +! zt2=zt +! ust2=ust +! wst2=wst +! h2=h +! rhoa2=rhoa +! rhograd2=rhograd +! sigw2=sigw +! dsigwdz2=dsigwdz +! tlw2=tlw +! ptot_lhh2=ptot_lhh +! Q_lhh2=Q_lhh +! phi_lhh2=phi_lhh +! ath2=ath +! bth2=bth +! ol2=ol + if (-h/ol.gt.5) then !modified by mc + !if (ol.lt.0.) then !modified by mc + !if (ol.gt.0.) then !modified by mc : for test + !print *,zt,wp,ath,bth,tlw,dtf,'prima' + flagrein=0 + nrand=nrand+1 + old_wp_buf=wp + del_test=(1.-old_wp_buf)/old_wp_buf + + !rhoa=1. !for testing vertical well mixed state, by mc + !rhograd=0. !for testing vertical well mixed state, by mc + call cbl(wp,zt,ust,wst,h,rhoa,rhograd,sigw,dsigwdz,tlw,ptot_lhh,Q_lhh,phi_lhh,ath,bth,ol,flagrein) +! see inside the routine for inverse time + wp=(wp+ath*dtf+bth*rannumb(nrand)*sqrt(dtf))*real(icbt) + delz=wp*dtf +! if ((ieee_is_nan(zt).or.ieee_is_nan(wp)).and.(flagrein.eq.0)) print*,'pb4',wp2,zt2,ust2,wst2,h2,rhoa2,rhograd2,sigw2,dsigwdz2,tlw2,ptot_lhh2,Q_lhh2,phi_lhh2,ath2,bth2,ol2,flagrein,i + if (abs(wp).gt.50.) flagrein=1 + if (flagrein.eq.1) then !added for re-initlization of particle vertical velcoity based on condition inside routine cbl.f90 + call re_initialize_particle(zt,ust,wst,h,sigw,old_wp_buf,nrand,ol) +! if (ieee_is_nan(old_wp_buf)) print*,"PROBLEM WP",wp,old_wp_buf,nrand,ol,zt,ust,wst,h,sigw + wp=old_wp_buf + delz=wp*dtf + !nan_count(myid)=nan_count(myid)+1 + nan_count(ompid+1)=nan_count(ompid+1)+1 + else + del_test=(1.-wp)/wp !catch infinity value +! if (ieee_is_nan(wp) .or. ieee_is_nan(del_test)) then + if (isnan2(wp).or.isnan2(del_test)) then !note that, given the test on particle velocity inside the routine cbl.f90, this condition should never be true!! +! if (isnan(wp).or.isnan(del_test)) then !note that, given the test on particle velocity inside the routine cbl.f90, this condition should never be true!! + nrand=nrand+1 + call re_initialize_particle(zt,ust,wst,h,sigw,old_wp_buf,nrand,ol) + wp=old_wp_buf + delz=wp*dtf + nan_count(ompid+1)=nan_count(ompid+1)+1 + !nan_count(myid)=nan_count(myid)+1 + print *,'NaN counter equal to:',nan_count(ompid+1),'omp',ompid,'mpi',myid +! ,'increase +! !ifine if this number became a non-negligible fraction of +! !the particle number' + end if + end if + else + !rhoa=1. !for testing vertical well mixed state, by mc + !rhograd=0. !for testing vertical well mixed state, by mc + nrand=nrand+1 + old_wp_buf=wp + ath=-wp/tlw+sigw*dsigwdz+wp*wp/sigw*dsigwdz+sigw*sigw/rhoa*rhograd !1-note for inverse time should be -wp/tlw*ldirect+... calculated for wp=-wp + !2-but since ldirect =-1 for inverse time and this must be calculated for (-wp) and + !3-the gaussian pdf is symmetric (i.e. pdf(w)=pdf(-w) ldirect can be discarded + bth=sigw*rannumb(nrand)*sqrt(2.*dtftlw) + wp=(wp+ath*dtf+bth)*real(icbt) + delz=wp*dtf + del_test=(1.-wp)/wp !catch infinity value +! if (ieee_is_nan(wp).or.ieee_is_nan(del_test)) then +! print*,'PB',wp2,zt2,ust2,wst2,h2,rhoa2,rhograd2,sigw2,dsigwdz2,tlw2,ptot_lhh2,Q_lhh2,phi_lhh2,ath2,bth2,ol2,flagrein,i +! print*,'PB2',ath,old_wp_buf,bth,wp,sigw + if (isnan2(wp).or.isnan2(del_test).or.abs(wp).gt.50.) then +! if (wp.ne.wp .or. del_test.ne.del_test) then +! if (ieee_is_nan(wp) .or. ieee_is_nan(del_test).or.abs(wp).gt.50.) then + nrand=nrand+1 + wp=sigw*rannumb(nrand) + delz=wp*dtf + nan_count(ompid+1)=nan_count(ompid+1)+1 + print *,'NaN counter equal to:',nan_count(ompid+1),'omp',ompid,'mpi',myid & + ,'increase ifine if this number became a non-negligible fraction of the particle number' + end if + end if + else + wp=((1.-dtftlw)*wp+rannumb(nrand+i)*sqrt(2.*dtftlw) & + +dtf*(dsigwdz+rhoaux*sigw))*real(icbt) + delz=wp*sigw*dtf + end if + else + rw=exp(-dtftlw) + wp=(rw*wp+rannumb(nrand+i)*sqrt(1.-rw**2) & + +tlw*(1.-rw)*(dsigwdz+rhoaux*sigw))*real(icbt) + delz=wp*sigw*dtf + endif + + 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 + +!***************** end turbulent options : comemnt by mc *********************************! + +! if (ieee_is_nan(wp)) then +! print*,"PROBLEM WP OUT",wp,old_wp_buf,nrand,ol,zt,ust,wst,h,sigw +! endif +! FLEXPART_WRF - zero up,vp,wp if turbulence is turned off + if (turb_option .eq. turb_option_none) then + up=0.0 + vp=0.0 + wp=0.0 + delz=0. + end if +! print*,'delz',delz,zt +!**************************************************** +! Compute turbulent vertical displacement of particle +!**************************************************** +! if (nrelpoint.eq.970) then +! write(15,*),rannumb(nrand),nrand,nrelpoint,OMP_GET_THREAD_NUM() +! endif + + 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 if (delz.gt.(h-zt) .and. reflect_switch==1) then ! reflection at h +! 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 +! FLEXPART_WRF, TKE option + if (turb_option .gt. 1) then + do ii=2,nz + if (height(ii).gt.zt) then + indz=ii-1 + indzp=ii + goto 69 + endif + enddo +69 continue + +! If one of the levels necessary is not yet available, +! calculate it +!***************************************************** + + do ii=indz,indzp !i + if (indzindicator(ii)) then + if (ngrid.le.0) then + call interpol_misslev(ii,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + else + call interpol_misslev_nests(ii,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + endif + endif + enddo !i +! write(*,*)'after reflection' + if(turb_option .eq. turb_option_mytke) & + call tke_partition_my(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,uprof,vprof,tkeprof,pttprof,indz,indzp) + if(turb_option .eq. turb_option_tke) & + call tke_partition_hanna(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,uprof,vprof,tkeprof,pttprof,indz,indzp) + else + zeta=zt/h + call hanna_short(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + + endif + endif + + enddo + + if (cblflag.ne.1) nrand=nrand+i !------>>>>>>>>>>>>>>>> modified by mc for accounting of different increment of nrand in cbl flag +! if (nombre.eq.103) print*,'usig 3',usig + +! 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 +! print*,nrelpoint,nsp + if (xmass(nrelpoint,nsp).gt.eps2) goto 887 + end do +887 nsp=min(nsp,nspec) + if (density(nsp).gt.0.) then +! print*,'settle' +! print*,'settle 1' + call get_settling(itime,real(xt),real(yt),zt,nsp,settling) !bugfix + endif + 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 +! if (nombre.eq.103) print*,'xt-2',dxsave,u,dt + dysave=dysave+v*dt + dawsave=dawsave+up*dt + dcwsave=dcwsave+vp*dt + zt=zt+w*dt*real(ldirect) ! comment out and put zt=zt for testing equation based on the well_mixed conditin comemnt by mc + + + if (zt.gt.h) then + if (itimec.eq.itime+lsynctime) goto 99 + goto 700 ! complete the current interval above PBL + endif + if (zt.lt.0.) zt=-1.*zt ! if particle below ground -> refletion + + +!!!! 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 +!67 continue +! endif +!c print*,'itime',itime +!c if ((mod(abs(itime),3600).eq.0)) then +!c if ((mod(abs(itime),3600).eq.0).and.dump) then +! if (itime<itimeold) then +! print*,'dump well',itime,itimeold +! dump=.false. +! itimeold=itimeold-3600 +! write(550,'(i8,12f10.3)') itime,hsave/tacc,zacc/tacc, +!c write(550,'(i8,22f10.3)') itime,hsave/tacc,zacc/tacc, +! + (t(i)/tacc*real(iclass),i=1,iclass) +! flush(550) +! zacc=0. +! tacc=0. +! do 68 i=1,iclass +!68 t(i)=0. +! hsave=0. +! endif +! if (mod(abs(itime),3600).ne.0) dump=.true. +!c print*,'itime',itime,3600,mod(abs(itime),3600),dump +!!!! CHANGE +!!!****************** NEW test for THE WELL MIXED CRITERION by mc *************** +!$OMP CRITICAL +!if (zt.lt.h) then +! i_well=int(zt/h*num_lvl*1.)+1 !per fare il test qui devo considerare OMP and MPI... +! well_mixed_vector(i_well,ompid+1)=well_mixed_vector(i_well,ompid+1)+dt +! well_mixed_norm(ompid+1)=well_mixed_norm(ompid+1)+dt +! avg_air_dens(i_well,ompid+1)=avg_air_dens(i_well,ompid+1)+rhoa*dt +! +! end if +! h_well(ompid+1)=h +!$OMP END CRITICAL +!!********************************************************************************* + +! 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),ix,jy,ixp,jyp, & + p1,p2,p3,p4,dt1,dt2,dtt,depoindicator) + else + call interpol_vdep_nests(ks,vdepo(ks),ix,jy,ixp,jyp, & + p1,p2,p3,p4,dt1,dt2,dtt,depoindicator,ngrid) + 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 +! if (nombre.eq.103) print*,'usig',usig,usigprof(indzp)+usigprof(indz),indz + 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 +!********************* + +!JB needs to define mu and mv +700 continue + if (ngrid.le.0) then + xts=real(xt) + yts=real(yt) + call interpol_wind(itime,xts,yts,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator,mu,mv) + !JB mw not needed here + else + call interpol_wind_nests(itime,xtn,ytn,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator,mu,mv) + endif + +! if (nombre.eq.103) print*,'usig 4',usig +! 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.maxrandomp) nrand=1 + if (nrand+1.gt.maxrand2) 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.maxrandomp) nrand=1 + if (nrand+2.gt.maxrand2) 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.maxrandomp) nrand=1 + if (nrand.gt.maxrand2) nrand=1 + ux=0. + vy=0. + wpscale=sqrt(2.*d_strat/dt) + wp=rannumb(nrand)*wpscale + nrand=nrand+1 + endif + +! FLEXPART_WRF - zero ux,vy,wp if turbulence is turned off + if (turb_option .eq. turb_option_none) then + ux=0.0 + vy=0.0 + wp=0.0 + end if + + +! 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.) then +! print*,'settle 2, bef',real(xt),real(yt),zt,cpt + call get_settling(itime,real(xt),real(yt),zt,nsp,settling) !bugfix +! print*,'settle 2, aft',real(xt),real(yt),zt,cpt,w +! print*,'settle' + endif + w=w+settling + endif + +! Calculate position at time step itime+lsynctime +!************************************************ + +! print*,'settle 2, aft1.5',zt,settling,wp,dt + dxsave=dxsave+(u+ux)*dt +! if (nombre.eq.103) print*,'xt-1',dxsave,u,ux,dt + dysave=dysave+(v+vy)*dt + zt=zt+(w+wp)*dt*real(ldirect) +! print*,'settle 2, aft2',zt,cpt + if (zt.lt.0.) zt=min(h-eps2,-1.*zt) ! if particle below ground -> reflection +! print*,'settle 2, aft3',zt,cpt + +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.maxrandomp) nrand=1 + if (nrand+2.gt.maxrand2) nrand=1 +! if (nombre.eq.103) print*,'usgig0',r,usigold,rannumb(nrand) + usigold=r*usigold+rs*rannumb(nrand)*usig*turbmesoscale +! if (nombre.eq.103) print*,'usgig1',usigold,usig,turbmesoscale + vsigold=r*vsigold+rs*rannumb(nrand+1)*vsig*turbmesoscale + wsigold=r*wsigold+rs*rannumb(nrand+2)*wsig*turbmesoscale + +! FLEXPART_WRF - zero u/v/wsigold if turbulence is turned off +! Note: for mesoscale model applications this component should be ignored! +! if (turb_option .eq. turb_option_none) then +! usigold=0.0 +! vsigold=0.0 +! wsigold=0.0 +! end if + + dxsave=dxsave+usigold*real(lsynctime) + dysave=dysave+vsigold*real(lsynctime) + + zt=zt+wsigold*real(lsynctime) +! print*,'settle 2, aft4',zt,cpt + if (zt.lt.0.) zt=-1.*zt ! if particle below ground -> refletion +! print*,'settle 2, aft5',zt,cpt + +!************************************************************* +! 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 +! if (nombre.eq.103) print*,'xt0',dxsave,usigold,ux + dysave=dysave+vy + if (ngrid.ge.0) then +! for FLEXPART_WRF, dx & dy are in meters, +! dxconst=1/dx, dyconst=1/dy, and no cos(lat) is needed +! cosfact=dxconst/cos((yt*dy+ylat0)*pi180) +! if (nombre.eq.103) print*,'xt1',xt,dxsave,dxconst +! xt=xt+real(dxsave*dxconst*real(ldirect),kind=dp) +! yt=yt+real(dysave*dyconst*real(ldirect),kind=dp) +! xt=xt+real(dxsave/mu*dxconst*real(ldirect),kind=dp) +! yt=yt+real(dysave/mv*dyconst*real(ldirect),kind=dp) + xt=xt +real(dxsave*mu*dxconst*real(ldirect),kind=dp) !IF COOMMENTED OUT TO is to ISOLate VERTCAL FORMULAITON FOR TEST REASON BY mc + yt=yt +real(dysave*mv*dyconst*real(ldirect),kind=dp) !IF COOMMENTED OUT TO is to ISOLate VERTCAL FORMULAITON FOR TEST REASON BY mc +! JB: needs interpolate m_w on the coordinates +! 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 + else + write(*,*) 'advance -- bad ngrid = ', ngrid + stop + 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 +! print*,'settle 2, aft6',zt,cpt + + +!************************************************************************ +! 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, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator) + else + call interpol_wind_short_nests(itime+ldt*ldirect,xtn,ytn,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator) + + endif +! print*,'settle 2, aft7',zt,cpt + + 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.) then +! print*,'settle 3, bef',real(xt),real(yt),zt,cpt + call get_settling(itime+ldt,real(xt),real(yt),zt,nsp,settling) !bugfix +! print*,'settle 3, aft',real(xt),real(yt),zt,cpt +! print*,'settle' + endif + 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 +! for FLEXPART_WRF, dx & dy are in meters, +! dxconst=1/dx, dyconst=1/dy, and no cos(lat) is needed +! cosfact=dxconst/cos((yt*dy+ylat0)*pi180) +! if (nombre.eq.103) print*,'xt2',xt,u,dxconst,ldt +! xt=xt+real(u*dxconst*real(ldt*ldirect),kind=dp) +! yt=yt+real(v*dyconst*real(ldt*ldirect),kind=dp) +! print*,'mw',mu,mv +! xt=xt+real(u*dxconst/mu*real(ldt*ldirect),kind=dp) +! yt=yt+real(v*dyconst/mv*real(ldt*ldirect),kind=dp) + xt=xt +real(u*dxconst*mu*real(ldt*ldirect),kind=dp) !IF COOMMENTED OUT TO is to ISOLate VERTCAL FORMULAITON FOR TEST REASON BY mc + yt=yt +real(v*dyconst*mv*real(ldt*ldirect),kind=dp) !IF COOMMENTED OUT TO is to ISOLate VERTCAL FORMULAITON FOR TEST REASON BY mc +! 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 + else + write(*,*) 'advance -- bad ngrid = ', ngrid + stop + 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 + +! if (nombre.eq.103) print*,'end',xt,u,dxconst,ldt + + end subroutine advance + +! logical function isnan2(a) +! real :: a +! if ((a.ne.a)) then !.or.((a*0.).ne.0.)) then +! isnan2 = .true. +! else +! isnan2 = .false. +! end if +! return +! end diff --git a/src_flexwrf_v3.1/assignland.f90 b/src_flexwrf_v3.1/assignland.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5136ae00681697b4fc0ae47a38430c6fd7eb7f69 --- /dev/null +++ b/src_flexwrf_v3.1/assignland.f90 @@ -0,0 +1,238 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine assignland +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine assignland. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! This routine assigns fractions of the 8 landuse classes to each ECMWF * +! grid point. * +! The landuse inventory of * +! * +! van de Velde R.J., Faber W.S., van Katwijk V.F., Kuylenstierna J.C.I., * +! Scholten H.J., Thewessen T.J.M., Verspuij M., Zevenbergen M. (1994): * +! The Preparation of a European Land Use Database. National Institute of * +! Public Health and Environmental Protection, Report nr 712401001, * +! Bilthoven, The Netherlands. * +! * +! is used to create a detailed landuse inventory for Europe. * +! * +! Outside of Europe, 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 * +! * +! 14 October 2005 R. Easter -- modified for WRF. * +! The landuse inventory is not used at all. * +! The land/sea mask is used everywhere. * +! Feb 2012 J. Brioude: modified to fortran 90 * +!******************************************************************************* +! * +! Variables: * +! xlanduse fractions of numclass landuses for each model grid point * +! xlandinvent landuse inventory (1/6 deg resolution) * +! * +!******************************************************************************* + + use par_mod + use com_mod + + implicit none + integer :: ix,jy,k,l,li,nrefine,iix,jjy,n,nxn2,nyn2 + integer,parameter :: lumaxx=1200,lumaxy=600 + real,parameter :: xlon0lu=-180.,ylat0lu=-90. + real,parameter :: dxlu=0.3 + real :: xlon,ylat,sumperc,p,xi,yj + real :: xlandusep(lumaxx,lumaxy,numclass) +! real :: xlanduse(0:nxmax-1,0:nymax-1,numclass) +! real :: xlandusen(0:nxmaxn-1,0:nymaxn-1,numclass,maxnests) + +! include 'includepar' +! include 'includecom' +! +! integer ix,jy,i,j,k,n,l +! real x,y,xlon,ylat + + 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 + + nrefine=10 + + do ix=0,nxmin1 +! xlon=real(ix)*dx+xlon0 ! long. + do jy=0,nymin1 +! ylat=real(jy)*dy+ylat0 ! and lat. of each gridpoint +! FLEXPART_WRF - use this routine to get lat,lon + do k=1,numclass + sumperc=0. + xlanduse(ix,jy,k)=0. + enddo + +! do iix=1, nrefine +! do jjy=1, nrefine + do iix=1, 1 + do jjy=1, 1 + +! xlon=(ix+(iix-1)/real(nrefine))*dx+xlon0 ! longitude, should be between -180 and 179 +! ylat=(jy+(jjy-1)/real(nrefine))*dy+ylat0 ! and lat. of each gridpoint + + call xyindex_to_ll_wrf( 0, real(ix), real(jy), xlon, ylat ) + + if (xlon.ge.(xlon0lu+lumaxx*dxlu)) then + xlon=xlon-lumaxx*dxlu + endif + 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 + + +! 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' + + + do l=1,numbnests + do jy=0,nyn(l)-1 + do ix=0,nxn(l)-1 + + do k=1,numclass + xlandusen(ix,jy,k,l)=0.0 + sumperc=0. + enddo + + do iix=1, 1 + do jjy=1, 1 + +! xlon=(ix+(iix-1)/real(nrefine))*dx+xlon0 ! longitude, should be between -180 and 179 +! ylat=(jy+(jjy-1)/real(nrefine))*dy+ylat0 ! and lat. of each gridpoint + + call xyindex_to_ll_wrf( l, real(ix), real(jy), xlon, ylat ) + + 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 + + + end subroutine assignland diff --git a/src_flexwrf_v3.1/boundcond_domainfill.f90 b/src_flexwrf_v3.1/boundcond_domainfill.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d21800c9293d93bc453ac9ba12a98db2eee3eb5b --- /dev/null +++ b/src_flexwrf_v3.1/boundcond_domainfill.f90 @@ -0,0 +1,637 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine boundcond_domainfill(itime,loutend) +! i i +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subr. boundcond_domainfill. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 * +! * +! 26 Oct 2005, R. Easter - changes to calc. of boundarea * +! associated with WRF horizontal grid. * +! Also need to get true ylat for pv calcs. * +! 11 Nov 2005, R. Easter - fixed error involving xy to latlong * +! 2012, J. Brioude: coded in fortran 90 * +!******************************************************************************* +! * +! 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,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),dumx,dumy,xlon,ylat + 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 + enddo + + +! 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 + +! for FLEXPART_WRF, x & y coords are in meters. +! In the "do 70" loop, ylat is only needed for for pv calcs, +! "if (ylat.lt.0.) pvpart=-1.*pvpart" +! Note: in the FLEXPART_ECMWF code, ylat was not defined +! in the "do 70" loop (a bug). + dumx=real(nx_we(k)) + dumy=real(jy) +! Are these dumx,dumy correct ??? + call xyindex_to_ll_wrf( 0, dumx, dumy, xlon, ylat ) + +! 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 + +! for FLEXPART_ECMWF, dy is in degrees-lat, and 111198.5 converts +! from degrees-latitude to m +! for FLEXPART_WRF, dy is in meters +! 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 + if ((jy.eq.ny_sn(1)).or.(jy.eq.ny_sn(2))) then + boundarea=deltaz/2.*dy + else + boundarea=deltaz*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 + enddo +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) + enddo + + windhl(m)=(dz2*windl(1)+dz1*windl(2))*dz + rhohl(m)=(dz2*rhol(1)+dz1*rhol(2))*dz + enddo + + 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 + enddo +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) + enddo + yh1(mm)=(dz2*y1(1)+dz1*y1(2))*dz + enddo + pvpart=(yh1(1)*dt2+yh1(2)*dt1)*dtt +!JB +! 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 +! if (((ztra1(ipart).lt.8000.) +! + ).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 +! + xmass1(ipart,1)*60.*48./29./10.**9 + else + goto 71 + endif + + +! Increase numpart, if necessary +!******************************* + + numpart=max(numpart,ipart) + goto 73 ! Storage space has been found, stop searching + endif + enddo + if (ipart.gt.maxpart) & + stop 'boundcond_domainfill.f: too many particles required' +73 minpart=ipart+1 +71 continue + + enddo + + enddo + enddo + enddo + +!***************************************** +! 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 + +! for FLEXPART_WRF, x & y coords are in meters. +! ylat=ylat0+real(ny_sn(k))*dy +! cosfact=cos(ylat*pi180) +! In the "do 170" loop, ylat is only needed for for pv calcs, +! "if (ylat.lt.0.) pvpart=-1.*pvpart" + dumx=real(ix) + dumy=real(ny_sn(k)) +! Are these dumx,dumy correct ??? + call xyindex_to_ll_wrf( 0, dumx, dumy, xlon, ylat ) + +! 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 + +! for FLEXPART_ECMWF, dx is in degrees-long, and 111198.5*cosfact converts +! from degrees-longitude to m +! for FLEXPART_WRF, dx is in meters +! 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 + if ((ix.eq.nx_we(1)).or.(ix.eq.nx_we(2))) then + boundarea=deltaz/2.*dx + else + boundarea=deltaz*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 + enddo +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 + enddo +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 + enddo + if (ipart.gt.maxpart) & + stop 'boundcond_domainfill.f: too many particles required' +173 minpart=ipart+1 +171 continue + enddo + + enddo + enddo + enddo + + 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 + diff --git a/src_flexwrf_v3.1/calc_uvmet.f90 b/src_flexwrf_v3.1/calc_uvmet.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fca372388c77ffc626b50941894bc600ba0084d9 --- /dev/null +++ b/src_flexwrf_v3.1/calc_uvmet.f90 @@ -0,0 +1,86 @@ +!! Diagnostics: U & V on earth coordinates +! from ARWpost postprocessing routine from the WRF package. + + SUBROUTINE calc_uvmet(UUU,VVV,SCRa, SCRb, i3dflag) + + IMPLICIT NONE + + !Arguments + real, allocatable, dimension(:,:,:) :: SCRa, SCRb + character (len=128) :: cname, cdesc, cunits + + !Local + integer :: i, j, k + integer :: i3dflag + real :: cone + real, dimension(west_east_dim,south_north_dim) :: diff, alpha + + cname = "uvmet" + cdesc = "Rotated wind component" + cunits = "m s-1" + + use com_mod + + IF ( map_proj .ge. 3 ) THEN ! No need to rotate + IF ( i3dflag == 1 ) THEN + SCRa = UUU + SCRb = VVV + ENDIF + IF ( i3dflag == 0 ) THEN + SCRa(:,:,1) = U10(:,:) + SCRb(:,:,1) = V10(:,:) + END IF + RETURN + END IF + + + cone = 1. ! PS + IF ( map_proj .eq. 1) THEN ! Lambert Conformal mapping + IF (ABS(truelat1-truelat2) .GT. 0.1) THEN + cone=(ALOG(COS(truelat1*RAD_PER_DEG))- & + ALOG(COS(truelat2*RAD_PER_DEG))) / & + (ALOG(TAN((90.-ABS(truelat1))*RAD_PER_DEG*0.5 ))- & + ALOG(TAN((90.-ABS(truelat2))*RAD_PER_DEG*0.5 )) ) + ELSE + cone = SIN(ABS(truelat1)*RAD_PER_DEG ) + ENDIF + END IF + + + diff = XLONG - stand_lon + DO i = 1, west_east_dim + DO j = 1, south_north_dim + IF ( diff(i,j) .gt. 180. ) THEN + diff(i,j) = diff(i,j) - 360. + END IF + IF ( diff(i,j) .lt. -180. ) THEN + diff(i,j) = diff(i,j) + 360. + END IF + END DO + END DO + + + DO i = 1, west_east_dim + DO j = 1, south_north_dim + IF ( XLAT(i,j) .lt. 0. ) THEN + alpha(i,j) = - diff(i,j) * cone * RAD_PER_DEG + ELSE + alpha(i,j) = diff(i,j) * cone * RAD_PER_DEG + END IF + END DO + END DO + + + + IF ( i3dflag == 1 ) THEN + DO k = 1,bottom_top_dim + SCRa(:,:,k) = VVV(:,:,k)*sin(alpha) + UUU(:,:,k)*cos(alpha) + SCRb(:,:,k) = VVV(:,:,k)*cos(alpha) - UUU(:,:,k)*sin(alpha) + END DO + ELSE + SCRa(:,:,1) = V10(:,:)*sin(alpha) + U10(:,:)*cos(alpha) + SCRb(:,:,1) = V10(:,:)*cos(alpha) - U10(:,:)*sin(alpha) + END IF + + END SUBROUTINE calc_uvmet + diff --git a/src_flexwrf_v3.1/calcfluxes.f90 b/src_flexwrf_v3.1/calcfluxes.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6713da4b7f8a3c0947bd2428d552a012f10e7108 --- /dev/null +++ b/src_flexwrf_v3.1/calcfluxes.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 + diff --git a/src_flexwrf_v3.1/calcmatrix.f90 b/src_flexwrf_v3.1/calcmatrix.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3efaaed7e586869e85d5b7f57870858d281a7ff4 --- /dev/null +++ b/src_flexwrf_v3.1/calcmatrix.f90 @@ -0,0 +1,148 @@ +!*********************************************************************** +!* Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +!* Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +!* Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +!* * +!* This file is part of FLEXPART. * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine 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 +! +! 20 Oct 2005 - R. Easter - added calc of pconv_hpa(nconvlev+1) +! 16 Nov 2005 - R. Easter - pconv,phconv are set in convmix +! using pph & pphn +! +!****************************************************************** + +! lconv indicates whether there is convection in this cell, or not +! delt time step for convection [s] +! cbmf cloud base mass flux + +! include 'includepar' +! include 'includecom' +! include 'includeconv' + 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 +! dp(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+1 + pconv_hpa(k)=pconv(k)/100. + phconv_hpa(k)=phconv(k)/100. + enddo + pconv_hpa(nconvlev+1)=pconv(nconvlev+1)/100. + 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 diff --git a/src_flexwrf_v3.1/calcpar.f90 b/src_flexwrf_v3.1/calcpar.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a8a32098a40f6b493445f5f67df7c6f4c5f090c9 --- /dev/null +++ b/src_flexwrf_v3.1/calcpar.f90 @@ -0,0 +1,323 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine 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. * +! * +! Note: This is the FLEXPART_WRF version of subroutine calcpar. * +! * +! 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 +! * +! 17 Oct 2005 - R. Easter - added ierr in call to richardson * +! 18 Oct 2005 - J. Fast - limit ustar to < 5.0 m/s * +! -- Oct 2005 - R. Easter - use xy_to_ll_wrf to get latitude * +! use pph for calculating zlev * +! pass level-2 pph directly to obukhov * +! 11 Nov 2005 - R. Easter - changed name of "xy to latlon" routine * +! 15 Nov 2005 - R. Easter - pass pplev to richardson instead of akz,bkz * +! July 2012: J. Brioude: coded in fortran 90 and parallelized * +!******************************************************************************* +! * +! 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,ierr + 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(kind=4) :: uuh(0:nxmax-1,0:nymax-1,nuvzmax) + real(kind=4) :: vvh(0:nxmax-1,0:nymax-1,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 + + real :: xlon,dumx,dumy,dumxb,dumyb,pplev(nuvzmax),hmixdummy + +! Loop over entire grid +!********************** +! ientry = ientry + 1 + +!$OMP PARALLEL DEFAULT(SHARED) & +!$OMP PRIVATE(i,ix,jy,kz,lz,kzmin,tvold,pold,zold,zlev,tv,pint, & +!$OMP rh,ierr,subsceff,ulev,vlev,pplev,ttlev,qvlev,ol,altmin,xlon,ylat ) +!$OMP DO + do jy=0,nymin1 + + do ix=0,nxmin1 + +! Set minimum height for tropopause +!********************************** + +! FLEXPART_WRF - use this routine to get lat,lon +! ylat=ylat0+real(jy)*dy + call xyindex_to_ll_wrf( 0, real(ix), real(jy), xlon, ylat ) + +! if ( ((ix.eq.0) .or. (ix.eq.nxmin1) .or. +! & (ix.eq.nxmin1/2)) .and. +! & ((jy.eq.0) .or. (jy.eq.nymin1) .or. +! & (jy.eq.nymin1/2)) ) then +! if (ientry .eq. 1) then +! write(*,'(a,2i4,2f12.5)') +! & 'calcpar i,j, xlon,ylat', ix, jy, xlon, ylat +! write(*,'(a, 8x,2f12.5)') +! & ' dlon,dlat', +! & (xlon-xlon2d(ix,jy)), (ylat-ylat2d(ix,jy)) +! call ll_to_xyindex_wrf( +! & xlon2d(ix,jy), ylat2d(ix,jy), dumx, dumy ) +! write(*,'(a, 8x,2f12.5)') +! & ' dxkm,dykm', +! & ((dumx-ix)*dx*1.0e-3), ((dumy-jy)*dy*1.0e-3) +! +! if ((ix .eq. 0) .and. (jy .eq. 0)) then +! dumxb = 2.33 +! dumyb = 3.44 +! call xyindex_to_ll_wrf( 0, dumxb, dumyb, dumx, dumy ) +! call ll_to_xyindex_wrf( dumx, dumy, dumx, dumy ) +! write(*,'(a,2f5.2,2f12.5)') +! & 'xi,yj, dxkm,dykm', dumxb, dumyb, +! & ((dumx-dumxb)*dx*1.0e-3), ((dumy-dumyb)*dy*1.0e-3) +! dumxb = 4.55 +! dumyb = 6.77 +! call xyindex_to_ll_wrf( 0, dumxb, dumyb, dumx, dumy ) +! call ll_to_xyindex_wrf( dumx, dumy, dumx, dumy ) +! write(*,'(a,2f5.2,2f12.5)') +! & 'xi,yj, dxkm,dykm', dumxb, dumyb, +! & ((dumx-dumxb)*dx*1.0e-3), ((dumy-dumyb)*dy*1.0e-3) +! end if +! +! end if +! end if + + 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 + +! 1) Calculation of friction velocity +!************************************ + if ( (.not.strswitch)) then + 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)) + endif + if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8 +! FLEXPART_WRF - limit ustar + if (ustar(ix,jy,1,n).ge.5.0) ustar(ix,jy,1,n)=5.0 + +! 2) Calculation of inverse Obukhov length scale +!*********************************************** + +! FLEXPART_WRF - pass k=2 pressure directly +! 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) + 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), & + pph(ix,jy,2,n) ) + 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) + pplev(i)=pph(ix,jy,i,n) + ttlev(i)=tth(ix,jy,i,n) + qvlev(i)=qvh(ix,jy,i,n) + zlev(i)=0.5*(zzh(ix,jy,i+1,n)+zzh(ix,jy,i,n))-zzh(ix,jy,1,n) + enddo +! FLEXPART_WRF - use & check ierr argument +! FLEXPART_WRF - pass pplev instead of akz,bkz +! 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) + call richardson(ps(ix,jy,1,n),ustar(ix,jy,1,n),ttlev,qvlev, & + ulev,vlev,nuvz, pplev,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, & +! td2(ix,jy,1,n),hmixdummy,wstar(ix,jy,1,n),hmixplus, & + ierr,sfc_option ) +!JB +! no reflec +! hmix(ix,jy,1,n)=5000. + + if (ierr .gt. 0) then + write(*,9500) 'warning', ix, jy + else if (ierr .lt. 0) then + write(*,9500) 'failure', ix, jy + stop + end if +9500 format( 'calcpar - richardson ', a, ' - ix,jy=', 2i5 ) + + + if(lsubgrid.eq.1) then + subsceff=min(excessoro(ix,jy),hmixplus) +! subsceff=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 +! print*,'hmix',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 + z0(4)=0.016*ustar(ix,jy,1,n)*ustar(ix,jy,1,n)/ga + z0(9)=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),vd) + + do i=1,nspec + vdep(ix,jy,i,n)=vd(i) + enddo + 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. +! FLEXPART_WRF - set zlev(1) + zlev(1)=zold + do kz=2,nuvz +! FLEXPART_WRF - use pph for pressure +! pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) ! pressure on model layers + pint=pph(ix,jy,kz,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) + enddo + +! 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 +!$OMP END DO +!$OMP END PARALLEL + +! Calculation of potential vorticity on 3-d grid, if plume trajectory mode is used +!********************************************************************************* + + if ((iout.eq.4).or.(iout.eq.5).or.(mdomainfill.eq.2)) then + call calcpv(n,uuh,vvh,pvh) + endif + + +end subroutine calcpar + diff --git a/src_flexwrf_v3.1/calcpar_nests.f90 b/src_flexwrf_v3.1/calcpar_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1e1906f7c15d683b2ae6db0523ab7c74f9bafca0 --- /dev/null +++ b/src_flexwrf_v3.1/calcpar_nests.f90 @@ -0,0 +1,301 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine 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. * +! * +! Note: This is the FLEXPART_WRF version of subroutine calcpar. * +! * +! 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 * +! * +! 14 Nov 2005 - R. Easter - * +! use xyindex_to_ll_wrf to get latitude * +! limit ustar to < 5.0 m/s * +! added ierr in call to richardson * +! use pph for calculating zlev * +! pass level-2 pph directly to obukhov * +! 15 Nov 2005 - R. Easter - pass pplev to richardson instead of akz,bkz * +! Jul 2012: J. Brioude: coded in fortran90 and parallelized * +!******************************************************************************* +! * +! 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,ierr + real :: ttlev(nuvzmax),qvlev(nuvzmax),obukhov,scalev,ol,hmixplus + real :: pplev(nuvzmax),xlon + real :: ulev(nuvzmax),vlev(nuvzmax),ew,rh,vd(maxspec),subsceff,ylat + real :: altmin,tvold,pold,zold,pint,tv,zlev(nuvzmax) + real(kind=4) :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: 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 +!******************** +! ientry = ientry + 1 + + do l=1,numbnests + +! Loop over entire grid +!********************** +!$OMP PARALLEL DEFAULT(SHARED) & +!$OMP PRIVATE(i,ix,jy,kz,lz,kzmin,tvold,pold,zold,zlev,tv,pint, & +!$OMP rh,ierr,subsceff,ulev,vlev,pplev,ttlev,qvlev,ol,altmin,xlon,ylat ) +!$OMP DO + do jy=0,nyn(l)-1 + + do ix=0,nxn(l)-1 + +! Set minimum height for tropopause +!********************************** + +! FLEXPART_WRF - use this routine to get lat,lon +! ylat=ylat0n(l)+real(jy)*dyn(l) + call xyindex_to_ll_wrf( l, real(ix), real(jy), xlon, ylat ) + +! if ( ((ix.eq.0) .or. (ix.eq.(nxn(l)-1)) .or. +! & (ix.eq.(nxn(l)-1)/2)) .and. +! & ((jy.eq.0) .or. (jy.eq.(nyn(l)-1)) .or. +! & (jy.eq.(nyn(l)-1)/2)) ) then +! if (ientry .eq. 1) then +! write(*,'(a,3i4,2f12.5)') +! & 'calcpar_nests l,i,j, xlon,ylat', +! & l, ix, jy, xlon, ylat +! write(*,'(a,12x,2f12.5)') +! & ' dlon,dlat', +! & (xlon-xlon2dn(ix,jy,l)), (ylat-ylat2dn(ix,jy,l)) +! end if +! end if + + 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 + +! 1) Calculation of friction velocity +!************************************ + if ( (.not.strswitch)) then + + 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)) + endif +! FLEXPART_WRF - limit ustar + if (ustarn(ix,jy,1,n,l).le.1.e-8) ustarn(ix,jy,1,n,l)=1.e-8 + if (ustarn(ix,jy,1,n,l).ge.5.0) ustarn(ix,jy,1,n,l)=5.0 + +! 2) Calculation of inverse Obukhov length scale +!*********************************************** + +! FLEXPART_WRF - pass k=2 pressure directly +! 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) + 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),pphn(ix,jy,2,n,l) ) + 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) + pplev(i)=pphn(ix,jy,i,n,l) + ttlev(i)=tthn(ix,jy,i,n,l) + qvlev(i)=qvhn(ix,jy,i,n,l) + end do + +! FLEXPART_WRF - use & check ierr argument +! FLEXPART_WRF - pass pplev instead of akz,bkz +! 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) + call richardson(psn(ix,jy,1,n,l),ustarn(ix,jy,1,n,l),ttlev, & + qvlev,ulev,vlev,nuvz, pplev,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,ierr,sfc_option) + + if (ierr .gt. 0) then + write(*,9500) 'warning', l, ix, jy + else if (ierr .lt. 0) then + write(*,9500) 'failure', l, ix, jy + stop + end if +9500 format( 'calcpar_nests - richardson ', a, ' - l,ix,jy=', 3i5 ) + + 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),vd,l) + + do i=1,nspec + vdepn(ix,jy,i,n,l)=vd(i) + enddo + 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. +! FLEXPART_WRF - set zlev(1) + zlev(1)=zold + 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 +!$OMP END DO +!$OMP END PARALLEL + +! Calculation of potential vorticity on 3-d grid, if plume trajectory mode is used +!********************************************************************************* + + if ((iout.eq.4).or.(iout.eq.5)) then + call calcpv_nests(l,n,uuhn,vvhn,pvhn) + endif + + enddo + + +end subroutine calcpar_nests + diff --git a/src_flexwrf_v3.1/calcpv.f90 b/src_flexwrf_v3.1/calcpv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7d3f8a7519a57a58665f6581368dcaaaf5b03687 --- /dev/null +++ b/src_flexwrf_v3.1/calcpv.f90 @@ -0,0 +1,400 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine calcpv(n,uuh,vvh,pvh) +! i i i o +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine calcpv. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! Calculation of potential vorticity on 3-d grid. * +! * +! Author: P. James * +! 3 February 2000 * +! * +! Adaptation to FLEXPART, A. Stohl, 1 May 2000 * +! * +! 26 Oct 2005, R. Easter - changes associated with WRF horizontal grid. * +! For pressure use pph instead of (akz + bkz*ps) * +! *** Note -- see ??? comments below regarding the pvh calculation. * +! 11 Nov 2005, R. Easter - fixed error involving xy to latlon * +! * +!******************************************************************************* +! * +! Variables: * +! n temporal index for meteorological fields (1 to 2) * +! * +! Constants: * +! * +!******************************************************************************* + +! include 'includepar' +! include 'includecom' +! +! 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 thup,thdn,eps,p0 +! 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) + 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(kind=4) :: uuh(0:nxmax-1,0:nymax-1,nuvzmax) + real(kind=4) :: vvh(0:nxmax-1,0:nymax-1,nuvzmax) + real :: pvh(0:nxmax-1,0:nymax-1,nuvzmax) + + + + real :: dumlon,dumlat + real :: thh(0:nxmax-1,0:nymax-1,nuvzmax) + real :: altit(nuvzmax) + +! Set number of levels to check for adjacent theta + nlck=nuvz/3 +! FLEXPART_WRF -- altit is never used, so don't calculate it +! do 5 k=1,nuvz +! altit(k)=akz(k)/p0+bkz(k) +!5 continue +! *** Precalculate all theta levels for efficiency + do jy=0,nymin1 + do kl=1,nuvz + do ix=0,nxmin1 +! FLEXPART_WRF -- use pph here +! ppmk=akz(kl)+bkz(kl)*ps(ix,jy,1,n) + ppmk=pph(ix,jy,kl,n) + thh(ix,jy,kl)=tth(ix,jy,kl,n)*(100000./ppmk)**kappa + enddo + enddo + enddo +! +! Loop over entire grid +!********************** + do jy=0,nymin1 + if (sglobal.and.jy.eq.0) goto 10 + if (nglobal.and.jy.eq.nymin1) goto 10 + +! for FLEXPART_WRF, x & y coords are in meters +! and true latitude varies with both i and j +! 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 + +! for FLEXPART_WRF, x & y coords are in meters, +! and true latitude varies with both i and j + call xyindex_to_ll_wrf( & + 0, real(ix), real(jy), dumlon, dumlat ) + phi = dumlat * pi / 180. + f = 0.00014585 * sin(phi) + tanphi = tan(phi) + cosphi = cos(phi) + +! 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 +! FLEXPART_WRF -- use pph here +! ppml(kl)=akz(kl)+bkz(kl)*ps(ix,jy,1,n) + ppml(kl)=pph(ix,jy,kl,n) + enddo +! +! Loop over the vertical +!*********************** + + do kl=1,nuvz + theta=thh(ix,jy,kl) + 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 + thetap=thh(ix,jy,klvrp) + thetam=thh(ix,jy,klvrm) + 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 + thdn=thh(ivr,jy,k) + thup=thh(ivr,jy,k+1) + 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 + thdn=thh(ivr,jy,k) + thup=thh(ivr,jy,k+1) + 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 +! for FLEXPART_WRF, dx & dy are in meters. +! dvdx=(vx(2)-vx(1))/real(jux)/(dx*pi/180.) + dvdx=(vx(2)-vx(1))/real(jux)/dx + else + dvdx=vvh(ivrp,jy,kl)-vvh(ivrm,jy,kl) +! dvdx=dvdx/real(jumpx)/(dx*pi/180.) + dvdx=dvdx/real(jumpx)/dx +! 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 + thdn=thh(ix,j,k) + thup=thh(ix,j,k+1) + 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 + thdn=thh(ix,j,k) + thup=thh(ix,j,k+1) + 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 +! for FLEXPART_WRF, dx & dy are in meters. +! dudy=(uy(2)-uy(1))/real(juy)/(dy*pi/180.) + dudy=(uy(2)-uy(1))/real(juy)/dy + else + dudy=uuh(ix,jyvp,kl)-uuh(ix,jyvm,kl) +! dudy=dudy/real(jumpy)/(dy*pi/180.) + dudy=dudy/real(jumpy)/dy + end if +! + +! for FLEXPART_WRF, dx & dy are in meters. +! don't need to divide by r_earth when doing d/dy +! don't need to divide by r_earth*cosphi when doing d/dx +! ??? I don't understand the uuh*tanphi term, but leave it in for now ??? +! ??? What is the "-1.e6" factor ??? +! +! pvh(ix,jy,kl)=dthetadp*(f+(dvdx/cosphi-dudy +! + +uuh(ix,jy,kl)*tanphi)/r_earth)*(-1.e6)*9.81 + pvh(ix,jy,kl)=dthetadp*( f + dvdx - 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 + diff --git a/src_flexwrf_v3.1/calcpv_nests.f90 b/src_flexwrf_v3.1/calcpv_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a198eb513d26faae29ea6856baaf0c2454c4cb0b --- /dev/null +++ b/src_flexwrf_v3.1/calcpv_nests.f90 @@ -0,0 +1,341 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine calcpv_nests(l,n,uuhn,vvhn,pvhn) +! i i i i o +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine calcpv_nests. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! Calculation of potential vorticity on 3-d nested grid * +! * +! Author: P. James * +! 22 February 2000 * +! * +! 11 Nov 2005, R. Easter - changes associated with WRF horizontal grid. * +! For pressure use pph instead of (akz + bkz*ps) * +! *** Note -- see ??? comments below regarding the pvh calculation. * +! * +!******************************************************************************* +! * +! Variables: * +! n temporal index for meteorological fields (1 to 2) * +! l index of current nest * +! * +! Constants: * +! * +!******************************************************************************* + +! include 'includepar' +! include 'includecom' +! +! 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 altit(nuvzmax),ppml(nuvzmax) +! real thup,thdn,eps,p0 +! parameter(eps=1.e-5,p0=101325) +! real thhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) +! 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) + + 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(kind=4) :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + + real :: dumlon,dumlat + real :: thhn(0:nxmax-1,0:nymax-1,nuvzmax,maxnests) + real :: altit(nuvzmax) + +! Set number of levels to check for adjacent theta + nlck=nuvz/3 +! FLEXPART_WRF -- altit is never used, so don't calculate it +! do 5 k=1,nuvz +! altit(k)=akz(k)/p0+bkz(k) +!5 continue +! *** Precalculate all theta levels for efficiency + do jy=0,nyn(l)-1 + do kl=1,nuvz + do ix=0,nxn(l)-1 +! FLEXPART_WRF -- use pph here +! ppmk=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l) + ppmk=pphn(ix,jy,kl,n,l) + thhn(ix,jy,kl,l)=tthn(ix,jy,kl,n,l)*(100000./ppmk)**kappa + enddo + enddo + enddo +! +! Loop over entire grid +!********************** + do jy=0,nyn(l)-1 +! for FLEXPART_WRF, x & y coords are in meters +! and true latitude varies with both i and j +! 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 + +! for FLEXPART_WRF, x & y coords are in meters +! and true latitude varies with both i and j + call xyindex_to_ll_wrf( & + l, real(ix), real(jy), dumlon, dumlat ) + phi = dumlat * pi / 180. + f = 0.00014585 * sin(phi) + tanphi = tan(phi) + cosphi = cos(phi) + +! 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 +! FLEXPART_WRF -- use pph here +! ppml(kl)=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l) + ppml(kl)=pphn(ix,jy,kl,n,l) + enddo +! +! Loop over the vertical +!*********************** + + do kl=1,nuvz + theta=thhn(ix,jy,kl,l) + 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 + thetap=thhn(ix,jy,klvrp,l) + thetam=thhn(ix,jy,klvrm,l) + 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 + thdn=thhn(ivr,jy,k,l) + thup=thhn(ivr,jy,k+1,l) + 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 + thdn=thhn(ivr,jy,k,l) + thup=thhn(ivr,jy,k+1,l) + 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 +! for FLEXPART_WRF, dx & dy are in meters. +! dvdx=(vx(2)-vx(1))/real(jux)/(dxn(l)*pi/180.) + dvdx=(vx(2)-vx(1))/real(jux)/dxn(l) + else + dvdx=vvhn(ivrp,jy,kl,l)-vvhn(ivrm,jy,kl,l) +! dvdx=dvdx/real(jumpx)/(dxn(l)*pi/180.) + dvdx=dvdx/real(jumpx)/dxn(l) +! 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 + thdn=thhn(ix,j,k,l) + thup=thhn(ix,j,k+1,l) + 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 + thdn=thhn(ix,j,k,l) + thup=thhn(ix,j,k+1,l) + 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 +! for FLEXPART_WRF, dx & dy are in meters. +! dudy=(uy(2)-uy(1))/real(juy)/(dyn(l)*pi/180.) + dudy=(uy(2)-uy(1))/real(juy)/dyn(l) + else + dudy=uuhn(ix,jyvp,kl,l)-uuhn(ix,jyvm,kl,l) +! dudy=dudy/real(jumpy)/(dyn(l)*pi/180.) + dudy=dudy/real(jumpy)/dyn(l) + end if +! +! for FLEXPART_WRF, dx & dy are in meters. +! don't need to divide by r_earth when doing d/dy +! don't need to divide by r_earth*cosphi when doing d/dx +! ??? I don't understand the uuhn*tanphi term, but leave it in for now ??? +! ??? What is the "-1.e6" factor ??? +! +! pvhn(ix,jy,kl,l)=dthetadp*(f+(dvdx/cosphi-dudy +! + +uuhn(ix,jy,kl,l)*tanphi)/r_earth)*(-1.e6)*9.81 + pvhn(ix,jy,kl,l)=dthetadp*( f + dvdx - 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 diff --git a/src_flexwrf_v3.1/caldate.f90 b/src_flexwrf_v3.1/caldate.f90 new file mode 100644 index 0000000000000000000000000000000000000000..99d1fee3ec8975b45e83fecd05ae6ba45cfb8194 --- /dev/null +++ b/src_flexwrf_v3.1/caldate.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/cbl.f90 b/src_flexwrf_v3.1/cbl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..696d727941ebb79c55c866ba06aa9513058d2482 --- /dev/null +++ b/src_flexwrf_v3.1/cbl.f90 @@ -0,0 +1,314 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine cbl(wp,zp,ust,wst,h,rhoa,rhograd,sigmaw,dsigmawdz,tlw,ptot,Q,phi,ath,bth,ol,flagrein) +! i i i i i i i i i i o o o o o o i i/o +!=============== well mixed formulation of CBL skewed vertical profiles following LHH 1996 with profile of w3 from lHB 2000 ======== +!=============== LHH formulation has been modified to account for variable density profiles and backward in time or forward in time simulations ======== +!=============== by Massimo Cassiani ( mc ), NILU, 2012-2013, reference to Cassiani et al. 2013 (to be submitted...) ======== +!======================================================================================================================================================= +!====================================================================================================== +! wp: particle velocity +! zp: particle position +! ust: velcotiy scale +! wst: convective velcotiy scale +! h: boundary layer top +! rhoa: air density +! rhograd: air densiy vertical gradient +! sigmaw: turbulent flutuation of vertical velocity standard deviation +! dsigmawdz: derivative of above +! tlw: local lagrangina time scale +! ptot: pdf value for the particle velocity in drift coefficient, see Cassiani et al. 2013, not used +! Q: part of drift coefficient, not used +! phi: part of drift coeffcient, not used +! ath: drift coefficient, used +! bth: diffusion coeffcient, sued +! ol: Obukhov lenght +! flagrein: set accordingly to conditon below if 1 then re-initialize particle velocity +!====================================================================================================== + use par_mod, only:pi + use com_mod, only:ldirect +! use ieee_arithmetic + implicit none + + + real :: usurad2,usurad2p,C0,costluar4,eps + parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=2,costluar4=0.66667,eps=0.000001) + + integer flagrein !re-initlization flag for the particle velocity + + real :: wp,zp,ust,wst,h,dens,ddens,sigmaw,dsigmawdz,tlw,rhoa,rhograd + real ::fluarw,fluarw2 + real ::w3,w2 + real ::dw3,dw2 + real ::wb,wa + real ::deltawa,deltawb + real ::wold,wold2,wold_z + real ::pa,pb,alfa + real ::Phi,Q,ptot + real :: timedir + real ::cuberoot + real ::z0,ol,transition !added ol & transition with respect to cbl.f90 without transition + + + real :: & + erf, & + aperfa, & + aperfb, & + ath, & + bth + + real :: & + pow, & + z, & + skew, & + skew2, & + radw2, & + rluarw, & + xluarw, & + aluarw, & + bluarw, & + sigmawa, & + sigmawb, & + dskew, & + dradw2, & + dfluarw, & + drluarw, & + dxluarw, & + daluarw, & + dbluarw, & + dsigmawa, & + dsigmawb, & + dwa, & + dwb, & + sigmawa2, & + sigmawb2 + + + dens=rhoa + ddens=rhograd + + + timedir=ldirect !direction of time forward (1) or backward(-1) + !========================= assign z ============================== + z=(zp/h) + + transition=1. + !if (ol.lt.-50) transition=((sin(((ol+100.)/100.)*pi))-1.)/2. + if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5 !transition fucntion to smoohtly + !========================= secondo moment of vertical velocity ===================== + !!! w2=1.4*(z**1.5*(1.-z))**(2./3.) + !w2=(1.7*(z*(1.-0.7*z)*(1.-z))**(2./3.))*(wst**2) + w2=(sigmaw*sigmaw) + dw2=(2.*sigmaw*dsigmawdz) + !dw2=(1.7*(2./3.)*(z*(1.-0.7*z)*(1.-z))**(-1./3.)* & + !(((1.-0.7*z)*(1.-z))+z*(-0.7)*(1.-z)+z*(1.-0.7*z)*(-1.))) *(wst**2)*1/h + + !=================== dissipation fo turbulent tke ========================= + !alfa=0.4 !(0.75-(0.5*z*z))**(3./2.) DISSIPAZIONE ADIMENSIONALE + alfa=2.*w2/(C0*tlw) + + !======================================================================== + wold=timedir*wp !time direction enter here for backward calculualtions + !wold_z=wp + ! ======================================================================= + !------------------------------ momento terzo ============================ + !! w3=0.8*(w2**(3./2.)) + !! dw3=0.8*1.5*w2**0.5*dw2 + + ! dw3=((1.2*z*((1.-z)**(3./2.)))+eps)*(wst**3) + ! dw3=(1.2*(((1.-z)**(3./2.))+z*1.5*((1.-z)**(1./2.))*(-1.)))*(wst**3) + ! 3=(1.2*z*((1.-z)**(3./2.))) + ! w3=(1.2*(((1.-z)**(3./2.))+z*1.5*((1.-z)**(1./2.))*(-1.))) + + !w3=((1.2*z*((1.-z)**(3./2.)))*1.5+eps)*(wst**3) !§1.5 to increase skeweness see also initalize_cbl_vel.f90 + !dw3=(1.2*(((1.-z)**(3./2.))+z*1.5*((1.-z)**(1./2.))*(-1.)))*(wst**3)*(1./h)*1.5 + + w3=((1.2*z*((1.-z)**(3./2.)))+eps)*(wst**3)*transition + dw3=(1.2*(((1.-z)**(3./2.))+z*1.5*((1.-z)**(1./2.))*(-1.)))*(wst**3)*(1./h)*transition + !============================================================================0 + + + skew=w3/(w2**1.5) + skew2=skew*skew + dskew=(dw3*w2**(1.5)-w3*1.5*w2**0.5*dw2)/w2**3 + radw2=w2**0.5 + dradw2=0.5*w2**(-0.5)*dw2 + !costluar4=0.66667 ! costante da LHH + fluarw=costluar4*(cuberoot(skew)) ! + fluarw2=fluarw*fluarw + + + if (skew.ne.0) then + + dfluarw=costluar4*(1./3.)*cuberoot(skew**(-2.))*dskew + + rluarw=(1.+fluarw2)**3.*skew2/((3.+fluarw2)**2.*fluarw2) !-> r + xluarw=(1.+fluarw2)**1.5*skew/((3.+fluarw2)*fluarw) ! + + drluarw=( ((3.*(1.+fluarw2)**2*(2.*fluarw*dfluarw)*skew2)+ & + (1.+fluarw2)**3*2.*skew*dskew) *(3.+fluarw2)**2.*fluarw2 - & + (1.+fluarw2)**3*skew2* & + ( (2.*(3.+fluarw2)*(2.*fluarw*dfluarw)*fluarw2) + & + (3.+fluarw2)**2*2.*fluarw*dfluarw) )/ & + (((3.+fluarw2)**2.*fluarw2)**2) + + dxluarw=( ((1.5*(1.+fluarw2)**0.5*(2.*fluarw*dfluarw)*skew)+ & + (1.+fluarw2)**1.5*dskew) *(3.+fluarw2)*fluarw - & + (1.+fluarw2)**1.5*skew* & + (3.*dfluarw+3*fluarw2*dfluarw) )/ & + (((3.+fluarw2)*fluarw)**2) + + + else + dfluarw=0. + rluarw=0. + drluarw=0. + xluarw=0. + dxluarw=0. + end if + + + + aluarw=0.5*(1.-xluarw/(4.+rluarw)**0.5) + bluarw=1.-aluarw + + daluarw=-0.5*( (dxluarw*(4.+rluarw)**0.5) - & + (0.5*xluarw*(4.+rluarw)**(-0.5)*drluarw) ) & + /(4.+rluarw) + dbluarw=-daluarw + + + sigmawa=radw2*(bluarw/(aluarw*(1.+fluarw2)))**0.5 + sigmawb=radw2*(aluarw/(bluarw*(1.+fluarw2)))**0.5 + + + dsigmawa=dradw2*(bluarw/(aluarw*(1.+fluarw2)))**0.5+ & + radw2*( & + (0.5*(bluarw/(aluarw*(1.+fluarw2)))**(-0.5)) * & + ( & + (dbluarw*(aluarw*(1.+fluarw2))- & + bluarw*(daluarw*(1.+fluarw2)+aluarw*2.*fluarw*dfluarw)) & + /((aluarw*(1.+fluarw2))**2) & + ) & + ) + + dsigmawb=dradw2*(aluarw/(bluarw*(1.+fluarw2)))**0.5+ & + radw2*( & + (0.5*(aluarw/(bluarw*(1.+fluarw2)))**(-0.5)) * & + ( & + (daluarw*(bluarw*(1.+fluarw2))- & + aluarw*(dbluarw*(1.+fluarw2)+bluarw*2.*fluarw*dfluarw)) & + /((bluarw*(1.+fluarw2))**2) & + ) & + ) + + wa=(fluarw*sigmawa) + wb=(fluarw*sigmawb) + dwa=dfluarw*sigmawa+fluarw*dsigmawa + dwb=dfluarw*sigmawb+fluarw*dsigmawb + + deltawa=wold-wa + deltawb=wold+wb + wold2=wold*wold + sigmawa2=sigmawa*sigmawa + sigmawb2=sigmawb*sigmawb + + pa=(usurad2p*(1./sigmawa))*(exp(-(0.5*((deltawa/sigmawa)**2.)))) + pb=(usurad2p*(1./sigmawb))*(exp(-(0.5*((deltawb/sigmawb)**2.)))) + + if (abs(deltawa).gt.10.*sigmawa.and.abs(deltawb).gt.10.*sigmawb) flagrein=1 !added control flag for re-initialization of velocity +! if (abs(deltawa).gt.6.*sigmawa.and.abs(deltawb).gt.6.*sigmawb) flagrein=1 !added control flag for re-initialization of velocity + + ptot=dens*aluarw*pa+dens*bluarw*pb + + aperfa=deltawa*usurad2/sigmawa + aperfb=deltawb*usurad2/sigmawb + +! if ((ieee_is_nan(aperfa).or.ieee_is_nan(aperfb)).and.flagrein.eq.0) & +! print*,'PROBLEM',deltawa,deltawb,sigmawa,sigmawb,wp,zp,ust,wst,h,rhoa,rhograd,sigmaw,dsigmawdz,tlw,ptot,Q,phi,ath,bth,ol,flagrein + Phi=-0.5* & + (aluarw*dens*dwa+dens*wa*daluarw+aluarw*wa*ddens)*erf(aperfa) & + +sigmawa*(aluarw*dens*dsigmawa*(wold2/sigmawa2+1.)+ & + sigmawa*dens*daluarw+sigmawa*ddens*aluarw+ & + aluarw*wold*dens/sigmawa2*(sigmawa*dwa-wa*dsigmawa))*pa & + +0.5* & + (bluarw*dens*dwb+wb*dens*dbluarw+wb*bluarw*ddens)*erf(aperfb) & + +sigmawb*(bluarw*dens*dsigmawb*(wold2/sigmawb2+1.)+ & + sigmawb*dens*dbluarw+sigmawb*ddens*bluarw+ & + bluarw*wold*dens/sigmawb2*(-sigmawb*dwb+wb*dsigmawb))*pb + + + Q=timedir*((aluarw*dens*deltawa/sigmawa2)*pa+ & + (bluarw*dens*deltawb/sigmawb2)*pb) + + + + + ath=(1./ptot)*(-(C0/2.)*alfa*Q+phi) !drift coefficient + bth=sqrt(C0*alfa) !diffusion coefficient + + + + + return + + + end + + + + + + FUNCTION CUBEROOT (X) RESULT (Y) + + IMPLICIT NONE + + real, INTENT(IN) :: X + real:: Y + + real, PARAMETER :: THIRD = 0.333333333 + + + Y = SIGN((ABS(X))**THIRD, X) + + RETURN + + END FUNCTION CUBEROOT + + + + + FUNCTION CUBEROOTD (X) RESULT (Y) + + IMPLICIT NONE + + DOUBLE PRECISION, INTENT(IN) :: X + DOUBLE PRECISION :: Y + + DOUBLE PRECISION, PARAMETER :: THIRD = 0.33333333333333333333333333333333333333333333333333333333333333333333333333333333333D0 + + + Y = SIGN((ABS(X))**THIRD, X) + + RETURN + + END FUNCTION CUBEROOTD diff --git a/src_flexwrf_v3.1/centerofmass.f90 b/src_flexwrf_v3.1/centerofmass.f90 new file mode 100644 index 0000000000000000000000000000000000000000..942ba67c914dc5f6c9e26019b4aff61663577149 --- /dev/null +++ b/src_flexwrf_v3.1/centerofmass.f90 @@ -0,0 +1,107 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine centerofmass(xl,yl,n,xcenter,ycenter) +! i i i o o +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine assignland. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 * +! * +! 26 Oct 2005, R. Easter - changes associated with WRF horizontal grid. * +! Since x & y coords are in meters, * +! so just sum/average the xl & yl. * +! * +!******************************************************************************* + + 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 +!******************************************************* + +! for FLEXPART_WRF, x & y coords are in meters, +! so just sum/average the xl & yl +! xll=xl(l)*pi180 +! yll=yl(l)*pi180 + +! Calculate 3D coordinates from longitude and latitude +!***************************************************** + +! for FLEXPART_WRF, this isn't necessary +! 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 + xav=xav+xl(l) + yav=yav+yl(l) + + enddo + + xav=xav/real(n) + yav=yav/real(n) +! zav=zav/float(n) + + +! Project the point back onto Earth's surface +!******************************************** + +! for FLEXPART_WRF, this isn't necessary +! xcenter=atan2(xav,-1.*yav) +! ycenter=atan2(zav,sqrt(xav*xav+yav*yav)) + +! Convert back to degrees +!************************ + +! for FLEXPART_WRF, this isn't necessary +! xcenter=xcenter/pi180 +! ycenter=ycenter/pi180 + xcenter=xav + ycenter=yav + +end subroutine centerofmass + diff --git a/src_flexwrf_v3.1/check_ncerror.f90 b/src_flexwrf_v3.1/check_ncerror.f90 new file mode 100644 index 0000000000000000000000000000000000000000..275d73d6a13cca237f9c3359bff3116f5ccf406c --- /dev/null +++ b/src_flexwrf_v3.1/check_ncerror.f90 @@ -0,0 +1,45 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Adam Dingwell, * +!* * +!* This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by * +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine check_ncerror(errcode) + + !***************************************************************************** + ! * + ! This function checks the return value of any call to the netcdf interface. * + ! The subroutine should be called directly after any call to any nf_* * + ! functions, unless some other means of erro handling has been implemented. * + ! * + ! Author: A. Dingwell * + ! * + ! 27 May 2013 * + ! * + !***************************************************************************** + + implicit none + include 'netcdf.inc' + integer errcode + + if( errcode.ne.nf_noerr ) then + print*, 'Error: ', nf_strerror(errcode) + stop + endif + return +end subroutine check_ncerror + diff --git a/src_flexwrf_v3.1/clustering.f90 b/src_flexwrf_v3.1/clustering.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7d86f3760fb53a16f3c399225025236b0ccb28b2 --- /dev/null +++ b/src_flexwrf_v3.1/clustering.f90 @@ -0,0 +1,252 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine clustering(xl,yl,zl,n,xclust,yclust,zclust,fclust,rms, & + rmsclust,zrms) +! i i i i o o o o o +! o o +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine clustering. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 * +! * +! 26 Oct 2005, R. Easter - changes associated with WRF horizontal grid. * +! x and y coordinates are in m, so the clustering * +! calculations are simpler, with no coordinate conversions. * +! 10 Mar 2006, R. Easter - bug fix at (new) lines 131-2 * +! change "yclust(j)" to "yclust(nclust(i))", same for xclust * +! * +!******************************************************************************* +! * +! 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,numb(ncluster),ncl,stat + 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 + integer,allocatable, dimension (:) :: nclust + + allocate(nclust(maxpart) ,stat=stat) + + if (n.lt.ncluster) return + rmsold=-5. + +! Convert longitude and latitude from degrees to radians +!******************************************************* + + do i=1,n + nclust(i)=i + +! for FLEXPART_WRF, x & y coords are in meters +! xl(i)=xl(i)*pi180 +!5 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 + +! for FLEXPART_WRF, x & y coords are in meters, so calc distance directly +! distances=distance2(yl(i),xl(i),yclust(j),xclust(j)) + distances=sqrt( (yl(i)-yclust(j))**2 + & + (xl(i)-xclust(j))**2 ) + + 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 + +! for FLEXPART_WRF, x & y coords are in meters, so calc distance directly +! distances=distance2(yl(i),xl(i), +! + yclust(nclust(i)),xclust(nclust(i))) +! 10-mar-2006 rce - bug fix - change "yclust(j)" to +! "yclust(nclust(i))", same for xclust + distances=sqrt( (yl(i)-yclust(nclust(i)))**2 + & + (xl(i)-xclust(nclust(i)))**2 ) + +! 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 +!*************************************************************** + +! for FLEXPART_WRF, x & y coords are in meters, +! so no conversion is needed +! 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 +!50 zav(nclust(i))=zav(nclust(i))+z + xav(nclust(i))=xav(nclust(i))+xl(i) + yav(nclust(i))=yav(nclust(i))+yl(i) + zav(nclust(i))=0.0 + 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 +!******************************************** + +! for FLEXPART_WRF, x & y coords are in meters, +! so no conversion is needed +! xclust(j)=atan2(xav(j),-1.*yav(j)) +! yclust(j)=atan2(zav(j),sqrt(xav(j)*xav(j)+yav(j)*yav(j))) + xclust(j)=xav(j) + yclust(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 +! for FLEXPART_WRF, x & y coords are in meters +! xl(i)=xl(i)/pi180 +! yl(i)=yl(i)/pi180 + zclust(nclust(i))=zclust(nclust(i))+zl(i) + end do + + do j=1,ncluster +! for FLEXPART_WRF, x & y coords are in meters +! 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 + diff --git a/src_flexwrf_v3.1/cmapf_mod.f90 b/src_flexwrf_v3.1/cmapf_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..018deb19b2d2b7cde3667a1ba797e8d1db0026d5 --- /dev/null +++ b/src_flexwrf_v3.1/cmapf_mod.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +! 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 = real(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 diff --git a/src_flexwrf_v3.1/com_mod.f90 b/src_flexwrf_v3.1/com_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d216ba55a6a9313a231badf05ee163ab7d3ade4f --- /dev/null +++ b/src_flexwrf_v3.1/com_mod.f90 @@ -0,0 +1,806 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* Adam Dingwell, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** +!******************************************************************************* +! 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,maxomp,maxrandomp, & + maxrand3,max_stream + implicit none + + !**************************************************************** + ! Variables defining where FLEXPART input/output files are stored + !**************************************************************** + + character :: path(numpath+2*maxnests)*120 + integer :: length(numpath+2*maxnests) + character :: inputname*200 + integer :: len2 + integer :: ncout,ncoutn + + ! path path names needed for trajectory model + ! length length of path names needed for trajectory model + ! ncout file handle of netcdf output file + ! ncoutn file handle of netcdf output nest file + + + !******************************************************** + ! 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 + integer :: ncirec,ncnumrec + + ! 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)) + ! ncired record index for netcdf files + ! ncnumrec maximum record length of netcdf output files + + real :: ctl,fine,dt_conv + integer :: ifine,iout,ipout,ipin,iflux,mdomainfill + integer :: mquasilag,nested_output,ind_source,ind_receptor + integer :: ind_rel,ind_samp,ioutputforeachrelease,linit_cond + integer :: turb_option, method_w_terrain_correction + integer :: sfc_option + integer :: wind_option,time_option + integer :: outgrid_option + integer :: numpoint_option,option_verbose + integer :: iouttype + integer :: cblflag ! added by mc for CBL skewed pdf calculations + + 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(2001)*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,link(maxspec) + 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,wfdt(maxwf) + 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) + integer :: add_sfc_level,itimeold + integer :: map_proj_id, map_proj_method + real :: xmet0,ymet0,coefdx + real :: heightmid(nzmax) + real :: xlon2d(0:nxmax-1,0:nymax-1),ylat2d(0:nxmax-1,0:nymax-1) + real :: map_stdlon, map_truelat1, map_truelat2 + integer :: mp_physics + + ! 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) + real :: eta_w_wrf(nzmax), eta_u_wrf(nzmax), p_top_wrf + + ! 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 :: pph(0:nxmax-1,0:nymax-1,nuvzmax,2) + real :: zzh(0:nxmax-1,0:nymax-1,nwzmax+1,2) + real :: tkeh(0:nxmax-1,0:nymax-1,nuvzmax,2) + real :: tke(0:nxmax-1,0:nymax-1,nzmax,2) + real :: ptth(0:nxmax-1,0:nymax-1,nuvzmax,2) + real :: ptt(0:nxmax-1,0:nymax-1,nzmax,2) + real :: u_wrf(0:nxmax-1,0:nymax-1,nuvzmax,2) + real :: v_wrf(0:nxmax-1,0:nymax-1,nuvzmax,2) + real :: w_wrf(0:nxmax-1,0:nymax-1,nwzmax,2) +! CDA added for new wet depo scheme + integer :: icloudbot(0:nxmax-1,0:nymax-1,2) + integer :: icloudthck(0:nxmax-1,0:nymax-1,2) + + +! real :: pplev(0:nxmax-1,0:nymax-1,nuvzmax,2) +! CDA Commented old cloud variables +! 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(kind=4) :: m_x(0:nxmax-1,0:nymax-1,1) + real(kind=4) :: m_y(0:nxmax-1,0:nymax-1,1) +! real :: m_x(0:nxmax-1,0:nymax-1,1) +! real :: m_y(0:nxmax-1,0:nymax-1,1) + 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) + real :: xmet0n(maxnests),ymet0n(maxnests) + real :: xlon2dn(0:nxmaxn-1,0:nymaxn-1,maxnests) + real :: ylat2dn(0:nxmaxn-1,0:nymaxn-1,maxnests) + integer :: m_grid_id(0:maxnests), m_parent_grid_id(0:maxnests) + integer :: m_parent_grid_ratio(0:maxnests) + integer :: l_parent_nest_id(0:maxnests) + integer :: i_parent_start(0:maxnests), j_parent_start(0:maxnests) + integer :: mp_physicsn(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) + +! CDA added for new wet depo scheme + integer :: icloudbotn(0:nxmaxn-1,0:nymaxn-1,2,maxnests) + integer :: icloudthckn(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) + real :: pphn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests) + real :: zzhn(0:nxmaxn-1,0:nymaxn-1,nwzmax+1,2,maxnests) + real :: tkehn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests) + real :: tken(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests) + real :: ptthn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests) + real :: pttn(0:nxmaxn-1,0:nymaxn-1,nzmax,2,maxnests) + + real :: un_wrf(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests) + real :: vn_wrf(0:nxmaxn-1,0:nymaxn-1,nuvzmax,2,maxnests) + real :: wn_wrf(0:nxmaxn-1,0:nymaxn-1,nwzmax,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(kind=4) :: m_yn(0:nxmaxn-1,0:nymaxn-1,1,maxnests) + real(kind=4) :: m_xn(0:nxmaxn-1,0:nymaxn-1,1,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 + real :: dyoutl, dxoutl,out_xm0,out_ym0 + real :: dxoutln,dyoutln + integer :: numxgridn,numygridn + real :: dxoutn,dyoutn,outlon0n,outlat0n,xoutshiftn,youtshiftn + real :: outgrid_swlon,outgrid_swlat,outgrid_nelon,outgrid_nelat + real :: outgridn_swlon,outgridn_swlat,outgridn_nelon,outgridn_nelat + real :: out_xm0n,out_ym0n + !real outheight(maxzgrid),outheighthalf(maxzgrid) + logical :: DEP,DRYDEP,DRYDEPSPEC(maxspec),WETDEP,OHREA,ASSSPEC + integer nccovid,ncravid,ncwdvid,ncddvid,ncrecvid + !integer nccovidn,ncravidn,ncwdvidn,ncddvidn + + ! 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 + ! out_xm0,out_ym0 lower left corner of output grid in grid metres + ! 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 + ! nccovid netcdf variable ID of concentration grid + ! ncravid netcdf variable ID of mixing ratio grid + ! ncddvid netcdf variable ID of drydep grid + ! ncwdvid netcdf variable ID of wetdep grid + ! nccovidn, ncravidn, Nested output equivalents of the above variable IDs + ! ncddvidn, ncwdvidn + + + + ! 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 :: receptor_lon(maxreceptor),receptor_lat(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 + integer :: numparticlecount +! integer :: itra1(maxpart) +! integer :: npoint(maxpart),nclass(maxpart) +! integer :: idt(maxpart),itramem(maxpart),itrasplit(maxpart) +! real(kind=dp) :: xtra1(maxpart),ytra1(maxpart) +! real :: ztra1(maxpart) +! real :: xmass1(maxpart,maxspec) + + real,allocatable, dimension (:,:) :: xmass1 +! real,allocatable, dimension (:,:) :: drydep1 + real,allocatable, dimension(:) :: xmasssave + integer,allocatable, dimension (:) :: itra1 + integer,allocatable, dimension (:) :: npoint,nclass + integer,allocatable, dimension (:) :: idt,itramem,itrasplit + real(kind=dp),allocatable, dimension (:) :: xtra1,ytra1 + real,allocatable, dimension (:) :: ztra1 + real,allocatable, dimension (:) :: uap,ucp,uzp + real,allocatable, dimension (:) :: us,vs,ws + integer(kind=2),allocatable, dimension (:) :: cbt + + +! real,save :: xmasssave(maxpart) + + ! 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(maxspec),wetscava(maxspec),wetscavb(maxspec) + real :: drydiff(maxspec),dryhenry(maxspec),dryactiv(maxspec) + real :: partrho(maxspec),partmean(maxspec),partsig(maxspec) + real :: dryvelo(maxspec),weightmol(maxspec) + + ! 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(maxrandomp) +!#if newrandomgen.EQ.1 ! added by mc: if not commented use a +!preprocessor to select + real :: rannumb(maxrand3) !modified by mc^M + real :: uniform_rannumb(maxrand3) !modified by mc^M + +!#else ! if not commented use a preprocessor +! real :: rannumb(maxrandomp) !modified by mc^M +! real :: uniform_rannumb(maxrandomp) !modified by mc^M +! integer :: nan_count(MAX_STREAM)=0 !modified by mc +!#endif ! if not commented use a preprocessor + + + +end module com_mod diff --git a/src_flexwrf_v3.1/conccalc_irreg.f90 b/src_flexwrf_v3.1/conccalc_irreg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..eca175b550bbc8e546d0444c01b924da8f5444a4 --- /dev/null +++ b/src_flexwrf_v3.1/conccalc_irreg.f90 @@ -0,0 +1,425 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine conccalc_irreg(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,ii,temp,incl + 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 .or. abs(npoint(i)).gt.numpoint) 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) + !***************************************************************************** + if (xtra1(i).ne.xtra1(i)) print*,i,itra1(i),xtra1(i),ytra1(i),ix,jy + 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.7200).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 +! print*,'bef ks' +! print*,ix,jy,kz,ks,nrelpointer,nclass(i),nage + incl=nclass(i) + gridunc(ix,jy,kz,ks,nrelpointer,incl,nage)= & + gridunc(ix,jy,kz,ks,nrelpointer,incl,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.7200).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_irreg diff --git a/src_flexwrf_v3.1/conccalc_reg.f90 b/src_flexwrf_v3.1/conccalc_reg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4031778ed51ab0bfa4a28129383f024ea8ba7214 --- /dev/null +++ b/src_flexwrf_v3.1/conccalc_reg.f90 @@ -0,0 +1,441 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Jerome Fast, +!* Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa * +!* Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +subroutine conccalc_reg(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 * + ! * + ! J. Brioude, Oct 2011: changed to handle regular output * + !***************************************************************************** + ! * + ! 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,cpt3,cpt4 + 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,xlon,ylat,xl2,yl2 + 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 + !*************************************************************************** + cpt3=0 + cpt4=0 + + do i=1,numpart +! cpt3=cpt3+1 +! if (itra1(i).ne.itime .or. abs(npoint(i)).gt.numpoint) goto 20 + if (itra1(i).ne.itime .or. abs(npoint(i)).gt.numpoint) then +! print*,'part in question',i,itra1(i),npoint(i),xtra1(i) + goto 20 + 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. + !***************************************************************************** +! cpt4=cpt4+1 + + 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 +! JB + xl2=xtra1(i)*dx+xmet0 + yl2=ytra1(i)*dy+ymet0 + call xymeter_to_ll_wrf(xl2, yl2, xlon,ylat ) + xl=(xlon-outlon0)/dxoutl + yl=(ylat-outlat0)/dyoutl + + 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 2 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.7200).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 +! print*,ix,jy,kz,ks,nrelpointer,nclass(i),nage + 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 + !************************************ + +! JB + if (nested_output.eq.1) then +! xl=(xtra1(i)*dx+xoutshiftn)/dxoutn +! yl=(ytra1(i)*dy+youtshiftn)/dyoutn + + xl2=xtra1(i)*dx+xmet0 + yl2=ytra1(i)*dy+ymet0 + call xymeter_to_ll_wrf(xl2, yl2, xlon,ylat ) + xl=(xlon-outlon0n)/dxoutln + yl=(ylat-outlat0n)/dyoutln + 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.7200).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 +! print*,'nb pt used in conccalc, try2',cpt3,cpt4,numpart +end subroutine conccalc_reg diff --git a/src_flexwrf_v3.1/concoutput_irreg.f90 b/src_flexwrf_v3.1/concoutput_irreg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ca2d1d691d1392c760ba0c0e103e519db1d07eac --- /dev/null +++ b/src_flexwrf_v3.1/concoutput_irreg.f90 @@ -0,0 +1,686 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Jerome Fast, +!* Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa * +!* Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine concoutput_irreg(itime,outnum,gridtotalunc,wetgridtotalunc, & + drygridtotalunc) +! i i o o +! o +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine concoutput * +! * +! 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 includepar * +! * +! Dec 2005, J. Fast - Output files can be either binary or ascii. * +! Sparse output option is turned off. * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! 2012, J. Brioude- modify output format to flexpart 8*, latlon output * +!******************************************************************************* +! * +! Variables: * +! outnum number of samples * +! ncells number of cells with non-zero concentrations * +! sparse .true. if in sparse matrix format, else .false. * +! nspeciesdim either nspec (forward runs), or numpoint (backward runs) * +! tot_mu 1 for forward, initial mass mixing ration for backw. runs * +! maxpointspec maxspec for forward runs, maxpoint for backward runs * +! * +!******************************************************************************* + +! include 'includepar' +! include 'includecom' +! +! double precision jul +! integer itime,i,ix,jy,kz,k,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss +! integer ncells(maxpointspec,maxageclass) +! integer ncellsd(maxpointspec,maxageclass) +! integer ncellsw(maxpointspec,maxageclass),nspeciesdim +! real outnum,weightair,densityoutrecept(maxreceptor),xl,yl +! real densityoutgrid(0:maxxgrid-1,0:maxygrid-1,maxzgrid), +! +grid(0:maxxgrid-1,0:maxygrid-1,maxzgrid,maxpointspec,maxageclass) +! real wetgrid(0:maxxgrid-1,0:maxygrid-1,maxpointspec,maxageclass) +! real drygrid(0:maxxgrid-1,0:maxygrid-1,maxpointspec,maxageclass) +! real gridsigma(0:maxxgrid-1,0:maxygrid-1,maxzgrid,maxpointspec, +! +maxageclass), +! +drygridsigma(0:maxxgrid-1,0:maxygrid-1,maxpointspec,maxageclass), +! +wetgridsigma(0:maxxgrid-1,0:maxygrid-1,maxpointspec,maxageclass) +! real auxgrid(nclassunc),gridtotal,gridsigmatotal,gridtotalunc +! real wetgridtotal,wetgridsigmatotal,wetgridtotalunc +! real drygridtotal,drygridsigmatotal,drygridtotalunc +! real factor(0:maxxgrid-1,0:maxygrid-1,maxzgrid) +! real halfheight,dz,dz1,dz2,tot_mu(maxpointspec) +! real xnelat,xnelon +! real xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat +! parameter(weightair=28.97) +! logical sparse(maxpointspec,maxageclass) +! logical sparsed(maxpointspec,maxageclass) +! logical sparsew(maxpointspec,maxageclass) +! character adate*8,atime*6 + 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 :: auxgrid(nclassunc),gridtotal,gridsigmatotal,gridtotalunc + real :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc + real :: drygridtotal,drygridsigmatotal,drygridtotalunc + real :: halfheight,dz,dz1,dz2,tot_mu(maxspec,maxpointspec_act) + real :: xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat + real :: start, finish + + real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled + ! real,parameter :: weightair=28.97 !AD: moved this to par_mod.f90 + 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=out_xm0+float(ix)*dxout + yl=out_ym0+float(jy)*dyout +! xl=(xl-xlon0)/dx +! yl=(yl-ylat0)/dx + xl=(xl-xmet0)/dx + yl=(yl-ymet0)/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. + +!******************************************************************* +! Generate output: may be in concentration (ng/m3) or in mixing +! ratio (ppt) or both +! Output either in full grid dump or sparse matrix format +! For backward simulations, the unit is seconds, stored in grid_conc +!******************************************************************* + +! Concentration output +!********************* + +! open(53,file=path(1)(1:length(1))//'latlon.txt',form='formatted') +! open(54,file=path(1)(1:length(1))//'latlon_corner.txt' & +! ,form='formatted') +! +!! xnelat=outgrid_nelat +!! xnelon=outgrid_nelon +! print*,'before ll_to',outgrid_swlon,outgrid_swlat,outgrid_nelon,outgrid_nelat +! call ll_to_xymeter_wrf(outgrid_swlon,outgrid_swlat,xsw,ysw) +! call ll_to_xymeter_wrf(outgrid_nelon,outgrid_nelat,xne,yne) +! print*,'after ll_to' +! do jy=1,numygrid +! do ix=1,numxgrid +!! tmpx=out_xm0+(ix-1)*dxout +!! tmpy=out_ym0+(jy-1)*dyout +! tmpx=out_xm0+(float(ix)-0.5)*dxout +! tmpy=out_ym0+(float(jy)-0.5)*dyout +!! print*,'jb','tmpx','tmpy',dxout,dyout,ix,jy +! call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) +!!jb if(iouttype.eq.0) write(unitoutgrid) tmplon,tmplat +!! if(iouttype.eq.1) write(unitoutgrid,*) tmplon,tmplat +! write(53,*) tmplon,tmplat +!! tmpx=out_xm0+(ix-1-0.5)*dxout +!! tmpy=out_ym0+(jy-1-0.5)*dyout +! tmpx=out_xm0+(float(ix)-1.)*dxout +! tmpy=out_ym0+(float(jy)-1.)*dyout +!! tmpx=xsw+(xne-xsw)*float(ix-1)/float(numxgrid-1) +!! tmpy=ysw+(yne-ysw)*float(jy-1)/float(numygrid-1) +!! print*,'jb2','tmpx','tmpy',dxout,dyout,ix,jy +!! call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) +! call xymeter_to_ll_wrf_out(tmpx,tmpy,tmplon,tmplat) +! write(54,*) tmplon,tmplat +! enddo +! enddo +! close(53) +! close(54) + +! print*,'in grid conc',nspec,iout,adate,atime + do ks=1,nspec + if (iouttype.ne.2) then ! Not netcdf output, open the standard files + ! AD: I don't think this is right, there is no distinction between ascii + ! or binary files as there is in concoutput_reg... + 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(1)(1:length(1))//'grid_conc_'//adate// & + atime//'_'//anspec,form='unformatted') + else + open(unitoutgrid,file=path(1)(1:length(1))//'grid_time_'//adate// & + atime//'_'//anspec,form='unformatted') + endif + write(unitoutgrid) itime + endif + endif ! iouttype.ne.2 + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + if(iouttype.ne.2) then ! Not netcdf output, open standard file + ! AD: still the same issue as my previous comment... + open(unitoutgridppt,file=path(1)(1:length(1))//'grid_pptv_'//adate// & + atime//'_'//anspec,form='unformatted') + write(unitoutgridppt) itime + endif + endif + + +! print*,'in grid conc step 2',maxpointspec_act,nageclass,numygrid,numxgrid,numzgrid + 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 +! if (grid(ix,jy,kz).gt.0. ) print*,grid(ix,jy,kz) + 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 + !******************************************************************* + + if (iouttype.eq.2) then ! netcdf output + if (option_verbose.ge.1) then + write(*,*) 'concoutput_irreg: Calling write_ncconc for main outgrid' + endif +! print*,'itime',itime +! call cpu_time(start) + call write_ncconc(itime,outnum,ks,kp,nage,tot_mu(ks,kp),0) ! 0= nest level +! call cpu_time(finish) +! print*,'write netcdf',finish-start + + else ! binary or ascii output + + ! 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 + + endif ! iouttype.eq.2 + + end do + end do + + if((iouttype.eq.0).or.(iouttype.eq.1)) then ! binary or ascii output + close(unitoutgridppt) + close(unitoutgrid) + endif + + 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 + + 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_irreg + diff --git a/src_flexwrf_v3.1/concoutput_nest_irreg.f90 b/src_flexwrf_v3.1/concoutput_nest_irreg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..338494d3fe6c03664415f071ce90b10f8b969678 --- /dev/null +++ b/src_flexwrf_v3.1/concoutput_nest_irreg.f90 @@ -0,0 +1,647 @@ +!********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +! * +! This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine concoutput_nest_irreg(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 * + ! JB: TO BE MODIFIED * + !***************************************************************************** + ! * + ! 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 !AD: moved this to par_mod.f90 + logical :: sp_zer + character :: adate*8,atime*6 + character(len=3) :: anspec + + +! write(*,'(//a,a//)') & +! '*** Stopping in concoutput_nest ***', & +! ' This is not implemented for FLEXPART_WRF yet' +! stop + + ! 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=out_xm0n+float(ix)*dxoutn + yl=out_ym0n+float(jy)*dyoutn +! xl=outlon0n+real(ix)*dxoutn +! yl=outlat0n+real(jy)*dyoutn +! xl=(xl-xlon0)/dx +! yl=(yl-ylat0)/dy + xl=(xl-xmet0)/dx + yl=(yl-ymet0)/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 + !********************************************************************* +! print*,'IN CONCOUT',nspec,iout,iouttype,ldirect + 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 + if (iouttype.eq.0) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_conc_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + if (iouttype.eq.1) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_conc_nest_' & + //adate// & + atime//'_'//anspec,form='formatted') + else + if (iouttype.eq.0) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_time_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + if (iouttype.eq.1) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_time_nest_' & + //adate// & + atime//'_'//anspec,form='formatted') + endif + if (iouttype.eq.0) write(unitoutgrid) itime + if (iouttype.eq.1) write(unitoutgrid,*) itime + endif + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + if (iouttype.eq.0) & + open(unitoutgridppt,file=path(1)(1:length(1))//'grid_pptv_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + if (iouttype.eq.1) & + open(unitoutgridppt,file=path(1)(1:length(1))//'grid_pptv_nest_' & + //adate// & + atime//'_'//anspec,form='formatted') + +! write(unitoutgridppt) itime + if (iouttype.eq.0) write(unitoutgridppt) itime + if (iouttype.eq.1) 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 + !******************************************************************* + + if (iouttype.eq.2) then ! netcdf output + if (option_verbose.ge.1) then + write(*,*) 'concoutput_irreg: Calling write_ncconc for main outgrid' + endif + call write_ncconc(itime,outnum,ks,kp,nage,tot_mu(ks,kp),1) ! 1= nest level + else ! binary or ascii output + + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif +! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif +! write(unitoutgridppt) sp_count_u +! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r) + + endif ! output for ppt + + endif ! iouttype.eq.2 + + end do + end do + + if ((iouttype.eq.0).or.(iouttype.eq.1)) then ! binary or ascii output + close(unitoutgridppt) + close(unitoutgrid) + endif + + end do ! ks=1,nspec + + ! 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_irreg + diff --git a/src_flexwrf_v3.1/concoutput_nest_reg.f90 b/src_flexwrf_v3.1/concoutput_nest_reg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fd73ccc5cfa12dd66977c85c27d4a656429aeb29 --- /dev/null +++ b/src_flexwrf_v3.1/concoutput_nest_reg.f90 @@ -0,0 +1,645 @@ +!********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +! * +! This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine concoutput_nest_reg(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 * + ! JB: TO BE MODIFIED * + !***************************************************************************** + ! * + ! 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,xl2,yl2 + + !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 !AD: moved this to par_mod.f90 + logical :: sp_zer + character :: adate*8,atime*6 + character(len=3) :: anspec + + +! write(*,'(//a,a//)') & +! '*** Stopping in concoutput_nest ***', & +! ' This is not implemented for FLEXPART_WRF yet' +! stop + + ! 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 + xl2=outlon0n+real(ix)*dxoutln + yl2=outlat0n+real(jy)*dyoutln + call ll_to_xymeter_wrf(xl2,yl2,xl,yl) !xl is coord + xl=(xl-xmet0)/dx + yl=(yl-ymet0)/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 + if (iouttype.eq.0) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_conc_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + if (iouttype.eq.1) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_conc_nest_' & + //adate// & + atime//'_'//anspec,form='formatted') + else + if (iouttype.eq.0) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_time_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + if (iouttype.eq.1) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_time_nest_' & + //adate// & + atime//'_'//anspec,form='formatted') + endif + if (iouttype.eq.0) write(unitoutgrid) itime + if (iouttype.eq.1) write(unitoutgrid,*) itime + endif + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + if (iouttype.eq.0) & + open(unitoutgridppt,file=path(1)(1:length(1))//'grid_pptv_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + if (iouttype.eq.1) & + open(unitoutgridppt,file=path(1)(1:length(1))//'grid_pptv_nest_' & + //adate// & + atime//'_'//anspec,form='formatted') + + if (iouttype.eq.0) write(unitoutgridppt) itime + if (iouttype.eq.1) 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 + !******************************************************************* + + if (iouttype.eq.2) then ! netcdf output + if (option_verbose.ge.1) then + write(*,*) 'concoutput_irreg: Calling write_ncconc for main outgrid' + endif + call write_ncconc(itime,outnum,ks,kp,nage,tot_mu(ks,kp),1) ! 1= nest level + else ! binary or ascii output + + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! write(unitoutgridppt) sp_count_u + ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r) + + endif ! output for ppt + + endif ! iouttype.eq.2 + + end do + end do + + if (iouttype.ne.2) then ! binary (or ascii) output + close(unitoutgridppt) + close(unitoutgrid) + endif + + 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_reg + diff --git a/src_flexwrf_v3.1/concoutput_reg.f90 b/src_flexwrf_v3.1/concoutput_reg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1b94bf914d757163302829e5879d4df374e2935e --- /dev/null +++ b/src_flexwrf_v3.1/concoutput_reg.f90 @@ -0,0 +1,741 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine concoutput_reg(itime,outnum,gridtotalunc,wetgridtotalunc, & + drygridtotalunc) +! i i o o +! o +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine concoutput * +! * +! 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 includepar * +! * +! Dec 2005, J. Fast - Output files can be either binary or ascii. * +! Sparse output option is turned off. * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! 2012, J. Brioude- modify output format to flexpart 8*, latlon regular output * +! * +!******************************************************************************* +! * +! Variables: * +! outnum number of samples * +! ncells number of cells with non-zero concentrations * +! sparse .true. if in sparse matrix format, else .false. * +! nspeciesdim either nspec (forward runs), or numpoint (backward runs) * +! tot_mu 1 for forward, initial mass mixing ration for backw. runs * +! maxpointspec maxspec for forward runs, maxpoint for backward runs * +! * +!******************************************************************************* + +! include 'includepar' +! include 'includecom' +! +! double precision jul +! integer itime,i,ix,jy,kz,k,l,iix,jjy,kzz,nage,jjjjmmdd,ihmmss +! integer ncells(maxpointspec,maxageclass) +! integer ncellsd(maxpointspec,maxageclass) +! integer ncellsw(maxpointspec,maxageclass),nspeciesdim +! real outnum,weightair,densityoutrecept(maxreceptor),xl,yl +! real densityoutgrid(0:maxxgrid-1,0:maxygrid-1,maxzgrid), +! +grid(0:maxxgrid-1,0:maxygrid-1,maxzgrid,maxpointspec,maxageclass) +! real wetgrid(0:maxxgrid-1,0:maxygrid-1,maxpointspec,maxageclass) +! real drygrid(0:maxxgrid-1,0:maxygrid-1,maxpointspec,maxageclass) +! real gridsigma(0:maxxgrid-1,0:maxygrid-1,maxzgrid,maxpointspec, +! +maxageclass), +! +drygridsigma(0:maxxgrid-1,0:maxygrid-1,maxpointspec,maxageclass), +! +wetgridsigma(0:maxxgrid-1,0:maxygrid-1,maxpointspec,maxageclass) +! real auxgrid(nclassunc),gridtotal,gridsigmatotal,gridtotalunc +! real wetgridtotal,wetgridsigmatotal,wetgridtotalunc +! real drygridtotal,drygridsigmatotal,drygridtotalunc +! real factor(0:maxxgrid-1,0:maxygrid-1,maxzgrid) +! real halfheight,dz,dz1,dz2,tot_mu(maxpointspec) +! real xnelat,xnelon +! real xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat +! parameter(weightair=28.97) +! logical sparse(maxpointspec,maxageclass) +! logical sparsed(maxpointspec,maxageclass) +! logical sparsew(maxpointspec,maxageclass) +! character adate*8,atime*6 + 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,xl2,yl2 + 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 :: xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat + real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled + ! real,parameter :: weightair=28.97 !AD: moved this to par_mod.f90 + 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=out_xm0+float(ix)*dxout +! yl=out_ym0+float(jy)*dyout +! xl=(xl-xmet0)/dx +! yl=(yl-ymet0)/dx + xl2=outlon0+float(ix)*dxoutl !long + yl2=outlat0+float(jy)*dyoutl !lat + call ll_to_xymeter_wrf(xl2,yl2,xl,yl) !xl is coord + xl=(xl-xmet0)/dx + yl=(yl-ymet0)/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. + +!******************************************************************* +! Generate output: may be in concentration (ng/m3) or in mixing +! ratio (ppt) or both +! Output either in full grid dump or sparse matrix format +! For backward simulations, the unit is seconds, stored in grid_conc +!******************************************************************* + +! Concentration output +!********************* +! +! open(23,file=path(1)(1:length(1))//'latlon.txt' & +! ,form='formatted') +! open(24,file=path(1)(1:length(1))//'latlon_corner.txt' & +! ,form='formatted') +! +!! xnelat=outgrid_nelat +!! xnelon=outgrid_nelon +! call ll_to_xymeter_wrf(outgrid_swlon,outgrid_swlat,xsw,ysw) +! call ll_to_xymeter_wrf(outgrid_nelon,outgrid_nelat,xne,yne) +! do jy=1,numygrid +! do ix=1,numxgrid +!! tmpx=out_xm0+(ix-1)*dxout +!! tmpy=out_ym0+(jy-1)*dyout +!! tmpx=out_xm0+(float(ix)-0.5)*dxout +!! tmpy=out_ym0+(float(jy)-0.5)*dyout +! tmpx=xsw+(xne-xsw)*float(ix-1)/float(numxgrid-1) +! tmpy=ysw+(yne-ysw)*float(jy-1)/float(numygrid-1) +!! print*,'jb','tmpx','tmpy',dxout,dyout,ix,jy +! call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) +! xl2=outlon0+(float(ix)-0.5)*dxoutl !long +! yl2=outlat0+(float(jy)-0.5)*dyoutl !lat +! +!!jb if(iouttype.eq.0) write(unitoutgrid) tmplon,tmplat +!! if(iouttype.eq.1) write(unitoutgrid,*) tmplon,tmplat +!! write(23,*) tmplon,tmplat +! write(23,*) xl2,yl2 +!! tmpx=out_xm0+(ix-1-0.5)*dxout +!! tmpy=out_ym0+(jy-1-0.5)*dyout +!! tmpx=out_xm0+(float(ix)-1.)*dxout +!! tmpy=out_ym0+(float(jy)-1.)*dyout +! xl2=outlon0+float(ix-1)*dxoutl !long +! yl2=outlat0+float(jy-1)*dyoutl !lat +! write(24,*) xl2,yl2 +!! tmpx=xsw+(xne-xsw)*float(ix-1)/float(numxgrid-1) +!! tmpy=ysw+(yne-ysw)*float(jy-1)/float(numygrid-1) +!! print*,'jb2','tmpx','tmpy',dxout,dyout,ix,jy +!! call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) +!! call xymeter_to_ll_wrf_out(tmpx,tmpy,tmplon,tmplat) +!! write(24,*) tmplon,tmplat +! enddo +! enddo +! close(23) +! close(24) + + 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 + if (iouttype.eq.0) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_conc_'//adate// & + atime//'_'//anspec,form='unformatted') + if (iouttype.eq.1) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_conc_'//adate// & + atime//'_'//anspec,form='formatted') + else + if (iouttype.eq.0) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_time_'//adate// & + atime//'_'//anspec,form='unformatted') + if (iouttype.eq.1) & + open(unitoutgrid,file=path(1)(1:length(1))//'grid_time_'//adate// & + atime//'_'//anspec,form='formatted') + endif + write(unitoutgrid) itime + endif + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + if (iouttype.eq.0) & + open(unitoutgridppt,file=path(1)(1:length(1))//'grid_pptv_'//adate// & + atime//'_'//anspec,form='unformatted') + if (iouttype.eq.1) & + open(unitoutgridppt,file=path(1)(1:length(1))//'grid_pptv_'//adate// & + atime//'_'//anspec,form='formatted') + + 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 + !******************************************************************* + + if (iouttype.eq.2) then ! netcdf output + if (option_verbose.ge.1) then + write(*,*) 'concoutput_irreg: Calling write_ncconc for main outgrid' + endif + call write_ncconc(itime,outnum,ks,kp,nage,tot_mu(ks,kp),0) ! 0= nest level + else ! binary or ascii output + + ! 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 + ! concentraion 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! 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 + if (iouttype.eq.0) then + 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) + endif + if (iouttype.eq.1) then + 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) + endif + ! write(unitoutgridppt) sp_count_u + ! write(unitoutgridppt) (sparse_dump_u(i),i=1,sp_count_r) + + endif ! output for ppt + + endif ! iouttype.eq.2 + + end do + end do + + if((iouttype.eq.0).or.(iouttype.eq.1)) then ! binary or ascii output + close(unitoutgridppt) + close(unitoutgrid) + endif + + 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 + + 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_reg + diff --git a/src_flexwrf_v3.1/conv_mod.f90 b/src_flexwrf_v3.1/conv_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e323e4417d6114a5111f1f05bc2817c6a9341cf7 --- /dev/null +++ b/src_flexwrf_v3.1/conv_mod.f90 @@ -0,0 +1,71 @@ +!*********************************************************************** +!* Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +!* Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +!* Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +!* * +!* This file is part of FLEXPART. * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** +!******************************************************************************* +! 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, nuvzmax + + 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 + real :: umf3(0:nxmax-1,0:nymax-1,nuvzmax) + real :: uer3(0:nxmax-1,0:nymax-1,nuvzmax) + real :: udr3(0:nxmax-1,0:nymax-1,nuvzmax) + real :: dmf3(0:nxmax-1,0:nymax-1,nuvzmax) + real :: der3(0:nxmax-1,0:nymax-1,nuvzmax) + real :: ddr3(0:nxmax-1,0:nymax-1,nuvzmax) + real :: cu_top(0:nxmax-1,0:nymax-1) + real :: cu_bot(0:nxmax-1,0:nymax-1) + + real :: umf3n(0:nxmax-1,0:nymax-1,nuvzmax,maxnests) + real :: uer3n(0:nxmax-1,0:nymax-1,nuvzmax,maxnests) + real :: udr3n(0:nxmax-1,0:nymax-1,nuvzmax,maxnests) + real :: dmf3n(0:nxmax-1,0:nymax-1,nuvzmax,maxnests) + real :: der3n(0:nxmax-1,0:nymax-1,nuvzmax,maxnests) + real :: ddr3n(0:nxmax-1,0:nymax-1,nuvzmax,maxnests) + real :: cu_topn(0:nxmax-1,0:nymax-1,maxnests) + real :: cu_botn(0:nxmax-1,0:nymax-1,maxnests) + + integer :: nconvlev,nconvtop + +end module conv_mod diff --git a/src_flexwrf_v3.1/convect43c.f90 b/src_flexwrf_v3.1/convect43c.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d51388fc9efc3a8f8d2e68e3c62ac27299f088f0 --- /dev/null +++ b/src_flexwrf_v3.1/convect43c.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +!************************************************************************** +!**** 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 diff --git a/src_flexwrf_v3.1/convection_kfeta.f90 b/src_flexwrf_v3.1/convection_kfeta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2bdde15324f2fe417cb2c38b79895e175cc02189 --- /dev/null +++ b/src_flexwrf_v3.1/convection_kfeta.f90 @@ -0,0 +1,2799 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** +! 8/9/2007 TEST the extracted CU model offline +! input from WRF output +! 3_D: U,V,W, PH(geo potential, can change to height) +! T,Pressure, +! need to change to pressure point -- see phy_prep +! CUDT is read from namelist, +! 1-d is enough + +! using a common block for KFLUTAB, will use a " include " + +! This code is extracted from WRF, KFeta cumulus convection paramerization +! +! INPUT variables are all defioned in p-grid (or T-grid) +! + SUBROUTINE KF_ETA(nzmax,u1d,v1d,t1d,dz1d,qv1d,p1d,rho1d, & ! IN + & w0avg1d,cudt,dx,dt,warm_rain,kts,kte, & ! IN + & umf,uer,udr,dmf,der,ddr,cu_bot1,cu_top1) ! OUT + + IMPLICIT NONE + + INTEGER :: ids,ide,jds,jde,kds,kde, & + ims,ime,jms,jme,kms,kme, & + its,ite,jts,jte,kts,kte,nzmax + + parameter (ids=1,ide=1,jds=1,jde=1) + parameter (ims=1,ime=1,jms=1,jme=1) + parameter (its=1,ite=1,jts=1,jte=1) +!! parameter (kts=1,kte=10) + + LOGICAL :: flag_qr, flag_qi, flag_qs,warm_rain + LOGICAL, DIMENSION(ims:ime,jms:jme):: CU_ACT_FLAG + REAL, DIMENSION(ims:ime,jms:jme):: NCA,CUBOT,CUTOP + + REAL, DIMENSION( 1:nzmax ),intent(in) :: & + U1D, & + V1D, & + T1D, & + DZ1D, & + QV1D, & + P1D, & + RHO1D, & + W0AVG1D + REAL, DIMENSION(1:nzmax), INTENT(OUT) :: umf, & + uer, & + udr, & + dmf, & + der, & + ddr + + REAL :: TST,tv,PRS,RHOE,W0,SCR1,DXSQ,tmp,RTHCUMAX + REAL :: XLV0,XLV1,XLS0,XLS1,R_d,r_v,SVP1,SVP2,SVP3,SVPT0 + REAL :: G, CP, EP1,EP2 + REAL :: CUDT, DT, DX, STEPCU + INTEGER :: KTAU ,kk + INTEGER :: i,j,k,NTST,ICLDCK + REAL :: cu_top1,cu_bot1 + + data xlv0,xlv1,xls0,xls1/3.15E6,2370.0,2.905E6,259.532/ + data r_d,r_v/287.04,461.6/ + data svp1,svp2,svp3,svpt0/0.6112,17.67,29.65,273.15/ + data g/9.81/ + + kds = kts + kde = kte + kms = kts + kme = kte + + cp=7.0*r_d/2.0 + ep1=r_v/r_d-1.0 + ep2=r_d/r_v + +! cudt=10 ! mintue +! dt=900.0 ! model time step (s) +! dx=25000.0 +! warm_rain = .true. + +! if mp_physics = kesslerschene , warm_rain= .true. + +!!!!!!! + + stepcu=nint(cudt*60.0/dt) + stepcu=amax1(stepcu,1.0) + +! initial conditions; note that some from WRF are not needed for this dispersion applicaiton +! Note the order of index in WRF (i,k,j), we use (i,j,k) +! can put this in the main program somewhere. +! KTAU is total time/dt + + call KF_LUTAB(SVP1,SVP2,SVP3,SVPT0) + + write(*,*)'stepcu=',stepcu + KTAU=0 + + DXSQ=DX*DX + +!---------------------- + NTST=STEPCU + TST=float(NTST*2) + flag_qr = .FALSE. + flag_qi = .FALSE. + flag_qs = .FALSE. +! +!...CHECK FOR CONVECTIVE INITIATION EVERY 5 MINUTES (OR NTST/2)... +! +!---------------------- + ICLDCK=MOD(KTAU,NTST) + IF(ICLDCK.EQ.0 .or. KTAU .eq. 1) then +! +! Let the code always check the convection by imposing NCA=-1 and CU_ACT_FLAG=.true. +! still keep the 2-D variable here just for modifying original code as little as possible + + DO J = jts,jte + DO I= its,ite + CU_ACT_FLAG(i,j) = .true. + NCA(i,j) = -100 + ENDDO + ENDDO + + DO J = jts,jte + DO I=its,ite + + CUTOP(I,J)=KTS + CUBOT(I,J)=KTE+1 + + IF ( NINT(NCA(I,J)) .gt. 0 ) then + CU_ACT_FLAG(i,j) = .false. + ELSE + +! CUTOP(I,J)=KTS +! CUBOT(I,J)=KTE+1 + DO kk=kts,kte + umf(kk)=0.0 + uer(kk)=0.0 + udr(kk)=0.0 + dmf(kk)=0.0 + der(kk)=0.0 + ddr(kk)=0.0 + ENDDO + +! +! Comment out DQDT,,,,, RAINV (not used in dispersion modeling) + + CALL KF_eta_PARA(I, J, & + U1D,V1D,T1D,QV1D,P1D,DZ1D, & + W0AVG1D,DT,DX,DXSQ,RHO1D, & + XLV0,XLV1,XLS0,XLS1,CP,R_D,G, & + EP2,SVP1,SVP2,SVP3,SVPT0, & +! DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & +! RAINCV, & + NCA,NTST, & + flag_QI,flag_QS,warm_rain, & + CUTOP,CUBOT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & +! added flux output + umf,uer,udr,dmf,der,ddr) + + write(*,*)'after call KF_eta_para' +! + ENDIF + ENDDO + ENDDO + ENDIF +! + cu_top1=cutop(1,1) + cu_bot1=cubot(1,1) + + end + +! **************************************************************************** +!----------------------------------------------------------- + SUBROUTINE KF_eta_PARA (I, J, & + U0,V0,T0,QV0,P0,DZQ,W0AVG1D, & + DT,DX,DXSQ,rhoe, & + XLV0,XLV1,XLS0,XLS1,CP,R,G, & + EP2,SVP1,SVP2,SVP3,SVPT0, & +! DQDT,DQIDT,DQCDT,DQRDT,DQSDT,DTDT, & +! RAINCV, & + NCA,NTST, & + F_QI,F_QS,warm_rain, & + CUTOP,CUBOT, & + ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + umf,uer,udr,dmf,der,ddr) +!----------------------------------------------------------- +!***** The KF scheme that is currently used in experimental runs of EMCs +!***** Eta model....jsk 8/00 +! + use kftable_mod + IMPLICIT NONE + +! include 'include_kftable' +!----------------------------------------------------------- + INTEGER, INTENT(IN ) :: ids,ide, jds,jde, kds,kde, & + ims,ime, jms,jme, kms,kme, & + its,ite, jts,jte, kts,kte, & + I,J,NTST + ! ,P_QI,P_QS,P_FIRST_SCALAR + + LOGICAL, INTENT(IN ) :: F_QI, F_QS + + LOGICAL, INTENT(IN ) :: warm_rain +! + REAL, DIMENSION( kts:kte ), & + INTENT(IN ) :: U0, & + V0, & + T0, & + QV0, & + P0, & + rhoe, & + DZQ, & + W0AVG1D +! + REAL, INTENT(IN ) :: DT,DX,DXSQ +! + + REAL, INTENT(IN ) :: XLV0,XLV1,XLS0,XLS1,CP,R,G + REAL, INTENT(IN ) :: EP2,SVP1,SVP2,SVP3,SVPT0 + +! + REAL, DIMENSION( kts:kte ):: & + DQDT, & + DQIDT, & + DQCDT, & + DQRDT, & + DQSDT, & + DTDT + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(INOUT) :: NCA + + REAL, DIMENSION( ims:ime , jms:jme ) :: RAINCV + + REAL, DIMENSION( ims:ime , jms:jme ), & + INTENT(OUT) :: CUBOT, & + CUTOP +! +!...DEFINE LOCAL VARIABLES... +! + REAL, DIMENSION( kts:kte ) :: & + Q0,Z0,TV0,TU,TVU,QU,TZ,TVD, & + QD,QES,THTES,TG,TVG,QG,WU,WD,W0,EMS,EMSD, & + UMF,UER,UDR,DMF,DER,DDR,UMF2,UER2, & + UDR2,DMF2,DER2,DDR2,DZA,THTA0,THETEE, & + THTAU,THETEU,THTAD,THETED,QLIQ,QICE, & + QLQOUT,QICOUT,PPTLIQ,PPTICE,DETLQ,DETIC, & + DETLQ2,DETIC2,RATIO,RATIO2 + + + REAL, DIMENSION( kts:kte ) :: & + DOMGDP,EXN,TVQU,DP,RH,EQFRC,WSPD, & + QDT,FXM,THTAG,THPA,THFXOUT, & + THFXIN,QPA,QFXOUT,QFXIN,QLPA,QLFXIN, & + QLFXOUT,QIPA,QIFXIN,QIFXOUT,QRPA, & + QRFXIN,QRFXOUT,QSPA,QSFXIN,QSFXOUT, & + QL0,QLG,QI0,QIG,QR0,QRG,QS0,QSG + + + REAL, DIMENSION( kts:kte+1 ) :: OMG + REAL, DIMENSION( kts:kte ) :: RAINFB,SNOWFB + REAL, DIMENSION( kts:kte ) :: & + CLDHGT,QSD,DILFRC,DDILFRC,TKE,TGU,QGU,THTEEG + +! LOCAL VARS + + REAL :: P00,T00,RLF,RHIC,RHBC,PIE, & + TTFRZ,TBFRZ,C5,RATE + REAL :: GDRY,ROCP,ALIQ,BLIQ, & + CLIQ,DLIQ + REAL :: FBFRC,P300,DPTHMX,THMIX,QMIX,ZMIX,PMIX, & + ROCPQ,TMIX,EMIX,TLOG,TDPT,TLCL,TVLCL, & + CPORQ,PLCL,ES,DLP,TENV,QENV,TVEN,TVBAR, & + ZLCL,WKL,WABS,TRPPT,WSIGNE,DTLCL,GDT,WLCL,& + TVAVG,QESE,WTW,RHOLCL,AU0,VMFLCL,UPOLD, & + UPNEW,ABE,WKLCL,TTEMP,FRC1, & + QNEWIC,RL,R1,QNWFRZ,EFFQ,BE,BOTERM,ENTERM,& + DZZ,UDLBE,REI,EE2,UD2,TTMP,F1,F2, & + THTTMP,QTMP,TMPLIQ,TMPICE,TU95,TU10,EE1, & + UD1,DPTT,QNEWLQ,DUMFDP,EE,TSAT, & + THTA,VCONV,TIMEC,SHSIGN,VWS,PEF, & + CBH,RCBH,PEFCBH,PEFF,PEFF2,TDER,THTMIN, & + DTMLTD,QS,TADVEC,DPDD,FRC,DPT,RDD,A1, & + DSSDT,DTMP,T1RH,QSRH,PPTFLX,CPR,CNDTNF, & + UPDINC,AINCM2,DEVDMF,PPR,RCED,DPPTDF, & + DMFLFS,DMFLFS2,RCED2,DDINC,AINCMX,AINCM1, & + AINC,TDER2,PPTFL2,FABE,STAB,DTT,DTT1, & + DTIME,TMA,TMB,TMM,BCOEFF,ACOEFF,QVDIFF, & + TOPOMG,CPM,DQ,ABEG,DABE,DFDA,FRC2,DR, & + UDFRC,TUC,QGS,RH0,RHG,QINIT,QFNL,ERR2, & + RELERR,RLC,RLS,RNC,FABEOLD,AINCOLD,UEFRC, & + DDFRC,TDC,DEFRC,RHBAR,DMFFRC,DPMIN,DILBE + REAL :: ASTRT,TP,VALUE,AINTRP,TKEMAX,QFRZ,& + QSS,PPTMLT,DTMELT,RHH,EVAC,BINC +! + INTEGER :: INDLU,NU,NUCHM,NNN,KLFS + REAL :: CHMIN,PM15,CHMAX,DTRH,RAD,DPPP + REAL :: TVDIFF,DTTOT,ABSOMG,ABSOMGTC,FRDP + + INTEGER :: KX,K,KL +! + INTEGER :: NCHECK + INTEGER, DIMENSION (kts:kte) :: KCHECK + + INTEGER :: ISTOP,ML,L5,KMIX,LOW, & + LC,MXLAYR,LLFC,NLAYRS,NK, & + KPBL,KLCL,LCL,LET,IFLAG, & + NK1,LTOP,NJ,LTOP1, & + LTOPM1,LVF,KSTART,KMIN,LFS, & + ND,NIC,LDB,LDT,ND1,NDK, & + NM,LMAX,NCOUNT,NOITR, & + NSTEP,NTC,NCHM,ISHALL,NSHALL + LOGICAL :: IPRNT + CHARACTER*1024 message +! + DATA P00,T00/1.E5,273.16/ + DATA RLF/3.339E5/ + DATA RHIC,RHBC/1.,0.90/ + DATA PIE,TTFRZ,TBFRZ,C5/3.141592654,268.16,248.16,1.0723E-3/ + DATA RATE/0.03/ +!----------------------------------------------------------- + IPRNT=.FALSE. + GDRY=-G/CP + ROCP=R/CP + NSHALL = 0 + KL=kte + KX=kte +! +! ALIQ = 613.3 +! BLIQ = 17.502 +! CLIQ = 4780.8 +! DLIQ = 32.19 + ALIQ = SVP1*1000. + BLIQ = SVP2 + CLIQ = SVP2*SVPT0 + DLIQ = SVP3 +! +! +!**************************************************************************** +! ! PPT FB MODS +!...OPTION TO FEED CONVECTIVELY GENERATED RAINWATER ! PPT FB MODS +!...INTO GRID-RESOLVED RAINWATER (OR SNOW/GRAUPEL) ! PPT FB MODS +!...FIELD. "FBFRC" IS THE FRACTION OF AVAILABLE ! PPT FB MODS +!...PRECIPITATION TO BE FED BACK (0.0 - 1.0)... ! PPT FB MODS + FBFRC=0.0 ! PPT FB MODS +!...mods to allow shallow convection... + NCHM = 0 + ISHALL = 0 + DPMIN = 5.E3 +!... + P300=P0(1)-30000. +! +!...PRESSURE PERTURBATION TERM IS ONLY DEFINED AT MID-POINT OF +!...VERTICAL LAYERS...SINCE TOTAL PRESSURE IS NEEDED AT THE TOP AND +!...BOTTOM OF LAYERS BELOW, DO AN INTERPOLATION... +! +!...INPUT A VERTICAL SOUNDING ... NOTE THAT MODEL LAYERS ARE NUMBERED +!...FROM BOTTOM-UP IN THE KF SCHEME... +! + ML=0 +!SUE tmprpsb=1./PSB(I,J) +!SUE CELL=PTOP*tmprpsb +! + DO K=1,KX +! +!...IF Q0 IS ABOVE SATURATION VALUE, REDUCE IT TO SATURATION LEVEL... +! + ES=ALIQ*EXP((BLIQ*T0(K)-CLIQ)/(T0(K)-DLIQ)) + QES(K)=0.622*ES/(P0(K)-ES) + Q0(K)=AMIN1(QES(K),QV0(K)) + Q0(K)=AMAX1(0.000001,Q0(K)) + QL0(K)=0. + QI0(K)=0. + QR0(K)=0. + QS0(K)=0. + RH(K) = Q0(K)/QES(K) + DILFRC(K) = 1. + TV0(K)=T0(K)*(1.+0.608*Q0(K)) +! RHOE(K)=P0(K)/(R*TV0(K)) +! DP IS THE PRESSURE INTERVAL BETWEEN FULL SIGMA LEVELS... + DP(K)=rhoe(k)*g*DZQ(k) +! IF Turbulent Kinetic Energy (TKE) is available from turbulent mixing scheme +! use it for shallow convection...For now, assume it is not available.... +! TKE(K) = Q2(I,J,NK) + TKE(K) = 0. + CLDHGT(K) = 0. +! IF(P0(K).GE.500E2)L5=K + IF(P0(K).GE.0.5*P0(1))L5=K + IF(P0(K).GE.P300)LLFC=K + IF(T0(K).GT.T00)ML=K + ENDDO +! +!...DZQ IS DZ BETWEEN SIGMA SURFACES, DZA IS DZ BETWEEN MODEL HALF LEVEL + Z0(1)=.5*DZQ(1) +!cdir novector + DO K=2,KL + Z0(K)=Z0(K-1)+.5*(DZQ(K)+DZQ(K-1)) + DZA(K-1)=Z0(K)-Z0(K-1) + ENDDO + DZA(KL)=0. +! +! +! To save time, specify a pressure interval to move up in sequential +! check of different ~50 mb deep groups of adjacent model layers in +! the process of identifying updraft source layer (USL). Note that +! this search is terminated as soon as a buoyant parcel is found and +! this parcel can produce a cloud greater than specifed minimum depth +! (CHMIN)...For now, set interval at 15 mb... +! + NCHECK = 1 + KCHECK(NCHECK)=1 + PM15 = P0(1)-15.E2 + DO K=2,LLFC + IF(P0(K).LT.PM15)THEN + NCHECK = NCHECK+1 + KCHECK(NCHECK) = K + PM15 = PM15-15.E2 + ENDIF + ENDDO +! + NU=0 + NUCHM=0 +usl: DO + NU = NU+1 +!! write(*,*)'NU=',NU + IF(NU.GT.NCHECK)THEN + IF(ISHALL.EQ.1)THEN + CHMAX = 0. + NCHM = 0 + DO NK = 1,NCHECK + NNN=KCHECK(NK) + IF(CLDHGT(NNN).GT.CHMAX)THEN + NCHM = NNN + NUCHM = NK + CHMAX = CLDHGT(NNN) + ENDIF + ENDDO + NU = NUCHM-1 + FBFRC=1. + CYCLE usl + ELSE + RETURN + ENDIF + ENDIF + KMIX = KCHECK(NU) + LOW=KMIX +!... + LC = LOW +! +!...ASSUME THAT IN ORDER TO SUPPORT A DEEP UPDRAFT YOU NEED A LAYER OF +!...UNSTABLE AIR AT LEAST 50 mb DEEP...TO APPROXIMATE THIS, ISOLATE A +!...GROUP OF ADJACENT INDIVIDUAL MODEL LAYERS, WITH THE BASE AT LEVEL +!...LC, SUCH THAT THE COMBINED DEPTH OF THESE LAYERS IS AT LEAST 50 mb.. +! + NLAYRS=0 + DPTHMX=0. + NK=LC-1 + IF ( NK+1 .LT. KTS ) THEN + WRITE(message,*)'WOULD GO OFF BOTTOM: KF_ETA_PARA I,J,NK',I,J,NK +!! CALL wrf_message (TRIM(message)) + ELSE + DO + NK=NK+1 + IF ( NK .GT. KTE ) THEN + WRITE(message,*)'WOULD GO OFF TOP: KF_ETA_PARA I,J,DPTHMX,DPMIN',I,J,DPTHMX,DPMIN +!! CALL wrf_message (TRIM(message)) + EXIT + ENDIF + DPTHMX=DPTHMX+DP(NK) + NLAYRS=NLAYRS+1 + IF(DPTHMX.GT.DPMIN)THEN + EXIT + ENDIF + END DO + ENDIF + IF(DPTHMX.LT.DPMIN)THEN + RETURN + ENDIF + KPBL=LC+NLAYRS-1 +! +!...******************************************************** +!...for computational simplicity without much loss in accuracy, +!...mix temperature instead of theta for evaluating convective +!...initiation (triggering) potential... +! THMIX=0. + TMIX=0. + QMIX=0. + ZMIX=0. + PMIX=0. +! +!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY +!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL +!...LAYERS... +! +!cdir novector + DO NK=LC,KPBL + TMIX=TMIX+DP(NK)*T0(NK) + QMIX=QMIX+DP(NK)*Q0(NK) + ZMIX=ZMIX+DP(NK)*Z0(NK) + PMIX=PMIX+DP(NK)*P0(NK) + ENDDO +! THMIX=THMIX/DPTHMX + TMIX=TMIX/DPTHMX + QMIX=QMIX/DPTHMX + ZMIX=ZMIX/DPTHMX + PMIX=PMIX/DPTHMX + EMIX=QMIX*PMIX/(0.622+QMIX) +! +!...FIND THE TEMPERATURE OF THE MIXTURE AT ITS LCL... +! +! TLOG=ALOG(EMIX/ALIQ) +! ...calculate dewpoint using lookup table... +! + astrt=1.e-3 + ainc=0.075 + a1=emix/aliq + tp=(a1-astrt)/ainc + indlu=int(tp)+1 + value=(indlu-1)*ainc+astrt + aintrp=(a1-value)/ainc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) + TLCL=AMIN1(TLCL,TMIX) + TVLCL=TLCL*(1.+0.608*QMIX) + ZLCL = ZMIX+(TLCL-TMIX)/GDRY + NK = LC-1 + DO + NK = NK+1 + KLCL=NK + IF(ZLCL.LE.Z0(NK) .or. NK.GT.KL)THEN + EXIT + ENDIF + ENDDO + IF(NK.GT.KL)THEN + RETURN + ENDIF + K=KLCL-1 + DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=T0(K)+(T0(KLCL)-T0(K))*DLP + QENV=Q0(K)+(Q0(KLCL)-Q0(K))*DLP + TVEN=TENV*(1.+0.608*QENV) +! +!...CHECK TO SEE IF CLOUD IS BUOYANT USING FRITSCH-CHAPPELL TRIGGER +!...FUNCTION DESCRIBED IN KAIN AND FRITSCH (1992)...W0 IS AN +!...APROXIMATE VALUE FOR THE RUNNING-MEAN GRID-SCALE VERTICAL +!...VELOCITY, WHICH GIVES SMOOTHER FIELDS OF CONVECTIVE INITIATION +!...THAN THE INSTANTANEOUS VALUE...FORMULA RELATING TEMPERATURE +!...PERTURBATION TO VERTICAL VELOCITY HAS BEEN USED WITH THE MOST +!...SUCCESS AT GRID LENGTHS NEAR 25 km. FOR DIFFERENT GRID-LENGTHS, +!...ADJUST VERTICAL VELOCITY TO EQUIVALENT VALUE FOR 25 KM GRID +!...LENGTH, ASSUMING LINEAR DEPENDENCE OF W ON GRID LENGTH... +! + IF(ZLCL.LT.2.E3)THEN + WKLCL=0.02*ZLCL/2.E3 + ELSE + WKLCL=0.02 + ENDIF + WKL=(W0AVG1D(K)+(W0AVG1D(KLCL)-W0AVG1D(K))*DLP)*DX/25.E3-WKLCL + IF(WKL.LT.0.0001)THEN + DTLCL=0. + ELSE + DTLCL=4.64*WKL**0.33 + ENDIF +! +!...for ETA model, give parcel an extra temperature perturbation based +!...the threshold RH for condensation (U00)... +! +!...for now, just assume U00=0.75... +!...!!!!!! for MM5, SET DTRH = 0. !!!!!!!! +! U00 = 0.75 +! IF(U00.lt.1.)THEN +! QSLCL=QES(K)+(QES(KLCL)-QES(K))*DLP +! RHLCL = QENV/QSLCL +! DQSSDT = QMIX*(CLIQ-BLIQ*DLIQ)/((TLCL-DLIQ)*(TLCL-DLIQ)) +! IF(RHLCL.ge.0.75 .and. RHLCL.le.0.95)then +! DTRH = 0.25*(RHLCL-0.75)*QMIX/DQSSDT +! ELSEIF(RHLCL.GT.0.95)THEN +! DTRH = (1./RHLCL-1.)*QMIX/DQSSDT +! ELSE + DTRH = 0. +! ENDIF +! ENDIF +! IF(ISHALL.EQ.1)IPRNT=.TRUE. +! IPRNT=.TRUE. +! IF(TLCL+DTLCL.GT.TENV)GOTO 45 +! +trigger: IF(TLCL+DTLCL+DTRH.LT.TENV)THEN +! +! Parcel not buoyant, CYCLE back to start of trigger and evaluate next potential USL... +! + CYCLE usl +! + ELSE ! Parcel is buoyant, determine updraft +! +!...CONVECTIVE TRIGGERING CRITERIA HAS BEEN SATISFIED...COMPUTE +!...EQUIVALENT POTENTIAL TEMPERATURE +!...(THETEU) AND VERTICAL VELOCITY OF THE RISING PARCEL AT THE LCL... +! + CALL ENVIRTHT(PMIX,TMIX,QMIX,THETEU(K),ALIQ,BLIQ,CLIQ,DLIQ) +! +!...modify calculation of initial parcel vertical velocity...jsk 11/26/97 +! + DTTOT = DTLCL+DTRH + IF(DTTOT.GT.1.E-4)THEN + GDT=2.*G*DTTOT*500./TVEN + WLCL=1.+0.5*SQRT(GDT) + WLCL = AMIN1(WLCL,3.) + ELSE + WLCL=1. + ENDIF + PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP + WTW=WLCL*WLCL +! + TVLCL=TLCL*(1.+0.608*QMIX) + RHOLCL=PLCL/(R*TVLCL) +! + LCL=KLCL + LET=LCL +! make RAD a function of background vertical velocity... + IF(WKL.LT.0.)THEN + RAD = 1000. + ELSEIF(WKL.GT.0.1)THEN + RAD = 2000. + ELSE + RAD = 1000.+1000*WKL/0.1 + ENDIF +! +!******************************************************************* +! * +! COMPUTE UPDRAFT PROPERTIES * +! * +!******************************************************************* +! +! +!... +!...ESTIMATE INITIAL UPDRAFT MASS FLUX (UMF(K))... +! + WU(K)=WLCL + AU0=0.01*DXSQ + UMF(K)=RHOLCL*AU0 + VMFLCL=UMF(K) + UPOLD=VMFLCL + UPNEW=UPOLD +! +!...RATIO2 IS THE DEGREE OF GLACIATION IN THE CLOUD (0 TO 1), +!...UER IS THE ENVIR ENTRAINMENT RATE, ABE IS AVAILABLE +!...BUOYANT ENERGY, TRPPT IS THE TOTAL RATE OF PRECIPITATION +!...PRODUCTION... +! + RATIO2(K)=0. + UER(K)=0. + ABE=0. + TRPPT=0. + TU(K)=TLCL + TVU(K)=TVLCL + QU(K)=QMIX + EQFRC(K)=1. + QLIQ(K)=0. + QICE(K)=0. + QLQOUT(K)=0. + QICOUT(K)=0. + DETLQ(K)=0. + DETIC(K)=0. + PPTLIQ(K)=0. + PPTICE(K)=0. + IFLAG=0 +! +!...TTEMP IS USED DURING CALCULATION OF THE LINEAR GLACIATION +!...PROCESS; IT IS INITIALLY SET TO THE TEMPERATURE AT WHICH +!...FREEZING IS SPECIFIED TO BEGIN. WITHIN THE GLACIATION +!...INTERVAL, IT IS SET EQUAL TO THE UPDRAFT TEMP AT THE +!...PREVIOUS MODEL LEVEL... +! + TTEMP=TTFRZ +! +!...ENTER THE LOOP FOR UPDRAFT CALCULATIONS...CALCULATE UPDRAFT TEMP, +!...MIXING RATIO, VERTICAL MASS FLUX, LATERAL DETRAINMENT OF MASS AND +!...MOISTURE, PRECIPITATION RATES AT EACH MODEL LEVEL... +! +! + EE1=1. + UD1=0. + REI = 0. + DILBE = 0. +updraft: DO NK=K,KL-1 + NK1=NK+1 + RATIO2(NK1)=RATIO2(NK) + FRC1=0. + TU(NK1)=T0(NK1) + THETEU(NK1)=THETEU(NK) + QU(NK1)=QU(NK) + QLIQ(NK1)=QLIQ(NK) + QICE(NK1)=QICE(NK) + call tpmix2(p0(nk1),theteu(nk1),tu(nk1),qu(nk1),qliq(nk1), & + qice(nk1),qnewlq,qnewic,XLV1,XLV0) +! +! +!...CHECK TO SEE IF UPDRAFT TEMP IS ABOVE THE TEMPERATURE AT WHICH +!...GLACIATION IS ASSUMED TO INITIATE; IF IT IS, CALCULATE THE +!...FRACTION OF REMAINING LIQUID WATER TO FREEZE...TTFRZ IS THE +!...TEMP AT WHICH FREEZING BEGINS, TBFRZ THE TEMP BELOW WHICH ALL +!...LIQUID WATER IS FROZEN AT EACH LEVEL... +! + IF(TU(NK1).LE.TTFRZ)THEN + IF(TU(NK1).GT.TBFRZ)THEN + IF(TTEMP.GT.TTFRZ)TTEMP=TTFRZ + FRC1=(TTEMP-TU(NK1))/(TTEMP-TBFRZ) + ELSE + FRC1=1. + IFLAG=1 + ENDIF + TTEMP=TU(NK1) +! +! DETERMINE THE EFFECTS OF LIQUID WATER FREEZING WHEN TEMPERATURE +!...IS BELOW TTFRZ... +! + QFRZ = (QLIQ(NK1)+QNEWLQ)*FRC1 + QNEWIC=QNEWIC+QNEWLQ*FRC1 + QNEWLQ=QNEWLQ-QNEWLQ*FRC1 + QICE(NK1) = QICE(NK1)+QLIQ(NK1)*FRC1 + QLIQ(NK1) = QLIQ(NK1)-QLIQ(NK1)*FRC1 + CALL DTFRZNEW(TU(NK1),P0(NK1),THETEU(NK1),QU(NK1),QFRZ, & + QICE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) + ENDIF + TVU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)) +! +! CALCULATE UPDRAFT VERTICAL VELOCITY AND PRECIPITATION FALLOUT... +! + IF(NK.EQ.K)THEN + BE=(TVLCL+TVU(NK1))/(TVEN+TV0(NK1))-1. + BOTERM=2.*(Z0(NK1)-ZLCL)*G*BE/1.5 + DZZ=Z0(NK1)-ZLCL + ELSE + BE=(TVU(NK)+TVU(NK1))/(TV0(NK)+TV0(NK1))-1. + BOTERM=2.*DZA(NK)*G*BE/1.5 + DZZ=DZA(NK) + ENDIF + ENTERM=2.*REI*WTW/UPOLD + + CALL CONDLOAD(QLIQ(NK1),QICE(NK1),WTW,DZZ,BOTERM,ENTERM, & + RATE,QNEWLQ,QNEWIC,QLQOUT(NK1),QICOUT(NK1),G) +! +!...IF VERT VELOCITY IS LESS THAN ZERO, EXIT THE UPDRAFT LOOP AND, +!...IF CLOUD IS TALL ENOUGH, FINALIZE UPDRAFT CALCULATIONS... +! + IF(WTW.LT.1.E-3)THEN + EXIT + ELSE + WU(NK1)=SQRT(WTW) + ENDIF +!...Calculate value of THETA-E in environment to entrain into updraft... +! + CALL ENVIRTHT(P0(NK1),T0(NK1),Q0(NK1),THETEE(NK1),ALIQ,BLIQ,CLIQ,DLIQ) +! +!...REI IS THE RATE OF ENVIRONMENTAL INFLOW... +! + REI=VMFLCL*DP(NK1)*0.03/RAD + TVQU(NK1)=TU(NK1)*(1.+0.608*QU(NK1)-QLIQ(NK1)-QICE(NK1)) + IF(NK.EQ.K)THEN + DILBE=((TVLCL+TVQU(NK1))/(TVEN+TV0(NK1))-1.)*DZZ + ELSE + DILBE=((TVQU(NK)+TVQU(NK1))/(TV0(NK)+TV0(NK1))-1.)*DZZ + ENDIF + IF(DILBE.GT.0.)ABE=ABE+DILBE*G +! +!...IF CLOUD PARCELS ARE VIRTUALLY COLDER THAN THE ENVIRONMENT, MINIMAL +!...ENTRAINMENT (0.5*REI) IS IMPOSED... +! + IF(TVQU(NK1).LE.TV0(NK1))THEN ! Entrain/Detrain IF BLOCK + EE2=0.5 + UD2=1. + EQFRC(NK1)=0. + ELSE + LET=NK1 + TTMP=TVQU(NK1) +! +!...DETERMINE THE CRITICAL MIXED FRACTION OF UPDRAFT AND ENVIRONMENTAL AIR... +! + F1=0.95 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & + qnewlq,qnewic,XLV1,XLV0) + TU95=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + IF(TU95.GT.TV0(NK1))THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + ELSE + F1=0.10 + F2=1.-F1 + THTTMP=F1*THETEE(NK1)+F2*THETEU(NK1) + QTMP=F1*Q0(NK1)+F2*QU(NK1) + TMPLIQ=F2*QLIQ(NK1) + TMPICE=F2*QICE(NK1) + call tpmix2(p0(nk1),thttmp,ttmp,qtmp,tmpliq,tmpice, & + qnewlq,qnewic,XLV1,XLV0) + TU10=TTMP*(1.+0.608*QTMP-TMPLIQ-TMPICE) + TVDIFF = ABS(TU10-TVQU(NK1)) + IF(TVDIFF.LT.1.e-3)THEN + EE2=1. + UD2=0. + EQFRC(NK1)=1.0 + ELSE + EQFRC(NK1)=(TV0(NK1)-TVQU(NK1))*F1/(TU10-TVQU(NK1)) + EQFRC(NK1)=AMAX1(0.0,EQFRC(NK1)) + EQFRC(NK1)=AMIN1(1.0,EQFRC(NK1)) + IF(EQFRC(NK1).EQ.1)THEN + EE2=1. + UD2=0. + ELSEIF(EQFRC(NK1).EQ.0.)THEN + EE2=0. + UD2=1. + ELSE +! +!...SUBROUTINE PROF5 INTEGRATES OVER THE GAUSSIAN DIST TO DETERMINE THE +! FRACTIONAL ENTRAINMENT AND DETRAINMENT RATES... +! + CALL PROF5(EQFRC(NK1),EE2,UD2) + ENDIF + ENDIF + ENDIF + ENDIF ! End of Entrain/Detrain IF BLOCK +! +! +!...NET ENTRAINMENT AND DETRAINMENT RATES ARE GIVEN BY THE AVERAGE FRACTIONAL +! VALUES IN THE LAYER... +! + EE2 = AMAX1(EE2,0.5) + UD2 = 1.5*UD2 + UER(NK1)=0.5*REI*(EE1+EE2) + UDR(NK1)=0.5*REI*(UD1+UD2) +! +!...IF THE CALCULATED UPDRAFT DETRAINMENT RATE IS GREATER THAN THE TOTAL +! UPDRAFT MASS FLUX, ALL CLOUD MASS DETRAINS, EXIT UPDRAFT CALCULATIONS... +! + IF(UMF(NK)-UDR(NK1).LT.10.)THEN +! +!...IF THE CALCULATED DETRAINED MASS FLUX IS GREATER THAN THE TOTAL UPD MASS +! FLUX, IMPOSE TOTAL DETRAINMENT OF UPDRAFT MASS AT THE PREVIOUS MODEL LVL.. +! First, correct ABE calculation if needed... +! + IF(DILBE.GT.0.)THEN + ABE=ABE-DILBE*G + ENDIF + LET=NK +! WRITE(98,1015)P0(NK1)/100. + EXIT + ELSE + EE1=EE2 + UD1=UD2 + UPOLD=UMF(NK)-UDR(NK1) + UPNEW=UPOLD+UER(NK1) + UMF(NK1)=UPNEW + DILFRC(NK1) = UPNEW/UPOLD +! +!...DETLQ AND DETIC ARE THE RATES OF DETRAINMENT OF LIQUID AND +!...ICE IN THE DETRAINING UPDRAFT MASS... +! + DETLQ(NK1)=QLIQ(NK1)*UDR(NK1) + DETIC(NK1)=QICE(NK1)*UDR(NK1) + QDT(NK1)=QU(NK1) + QU(NK1)=(UPOLD*QU(NK1)+UER(NK1)*Q0(NK1))/UPNEW + THETEU(NK1)=(THETEU(NK1)*UPOLD+THETEE(NK1)*UER(NK1))/UPNEW + QLIQ(NK1)=QLIQ(NK1)*UPOLD/UPNEW + QICE(NK1)=QICE(NK1)*UPOLD/UPNEW +! +!...PPTLIQ IS THE RATE OF GENERATION (FALLOUT) OF +!...LIQUID PRECIP AT A GIVEN MODEL LVL, PPTICE THE SAME FOR ICE, +!...TRPPT IS THE TOTAL RATE OF PRODUCTION OF PRECIP UP TO THE +!...CURRENT MODEL LEVEL... +! + PPTLIQ(NK1)=QLQOUT(NK1)*UMF(NK) + PPTICE(NK1)=QICOUT(NK1)*UMF(NK) +! + TRPPT=TRPPT+PPTLIQ(NK1)+PPTICE(NK1) + IF(NK1.LE.KPBL)UER(NK1)=UER(NK1)+VMFLCL*DP(NK1)/DPTHMX + ENDIF +! + END DO updraft +! +!...CHECK CLOUD DEPTH...IF CLOUD IS TALL ENOUGH, ESTIMATE THE EQUILIBRIU +! TEMPERATURE LEVEL (LET) AND ADJUST MASS FLUX PROFILE AT CLOUD TOP SO +! THAT MASS FLUX DECREASES TO ZERO AS A LINEAR FUNCTION OF PRESSURE BE +! THE LET AND CLOUD TOP... +! +!...LTOP IS THE MODEL LEVEL JUST BELOW THE LEVEL AT WHICH VERTICAL VELOC +! FIRST BECOMES NEGATIVE... +! + LTOP=NK + CLDHGT(LC)=Z0(LTOP)-ZLCL +! +!...Instead of using the same minimum cloud height (for deep convection) +!...everywhere, try specifying minimum cloud depth as a function of TLCL... +! +! +! + IF(TLCL.GT.293.)THEN + CHMIN = 4.E3 + ELSEIF(TLCL.LE.293. .and. TLCL.GE.273)THEN + CHMIN = 2.E3 + 100.*(TLCL-273.) + ELSEIF(TLCL.LT.273.)THEN + CHMIN = 2.E3 + ENDIF + +! +!...If cloud top height is less than the specified minimum for deep +!...convection, save value to consider this level as source for +!...shallow convection, go back up to check next level... +! +!...Try specifying minimum cloud depth as a function of TLCL... +! +! +!...DO NOT ALLOW ANY CLOUD FROM THIS LAYER IF: +! +!... 1.) if there is no CAPE, or +!... 2.) cloud top is at model level just above LCL, or +!... 3.) cloud top is within updraft source layer, or +!... 4.) cloud-top detrainment layer begins within +!... updraft source layer. +! + IF(LTOP.LE.KLCL .or. LTOP.LE.KPBL .or. LET+1.LE.KPBL)THEN ! No Convection Allowed + CLDHGT(LC)=0. + DO NK=K,LTOP + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + ENDDO +! + ELSEIF(CLDHGT(LC).GT.CHMIN .and. ABE.GT.1)THEN ! Deep Convection allowed + ISHALL=0 + EXIT usl + ELSE +! +!...TO DISALLOW SHALLOW CONVECTION, COMMENT OUT NEXT LINE !!!!!!!! + ISHALL = 1 + IF(NU.EQ.NUCHM)THEN + EXIT usl ! Shallow Convection from this layer + ELSE +! Remember this layer (by virtue of non-zero CLDHGT) as potential shallow-cloud layer + DO NK=K,LTOP + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + ENDDO + ENDIF + ENDIF + ENDIF trigger + END DO usl + IF(ISHALL.EQ.1)THEN + KSTART=MAX0(KPBL,KLCL) + LET=KSTART + endif +! +!...IF THE LET AND LTOP ARE THE SAME, DETRAIN ALL OF THE UPDRAFT MASS FL +! THIS LEVEL... +! + IF(LET.EQ.LTOP)THEN + UDR(LTOP)=UMF(LTOP)+UDR(LTOP)-UER(LTOP) + DETLQ(LTOP)=QLIQ(LTOP)*UDR(LTOP)*UPNEW/UPOLD + DETIC(LTOP)=QICE(LTOP)*UDR(LTOP)*UPNEW/UPOLD + UER(LTOP)=0. + UMF(LTOP)=0. + ELSE +! +! BEGIN TOTAL DETRAINMENT AT THE LEVEL ABOVE THE LET... +! + DPTT=0. + DO NJ=LET+1,LTOP + DPTT=DPTT+DP(NJ) + ENDDO + DUMFDP=UMF(LET)/DPTT +! +!...ADJUST MASS FLUX PROFILES, DETRAINMENT RATES, AND PRECIPITATION FALL +! RATES TO REFLECT THE LINEAR DECREASE IN MASS FLX BETWEEN THE LET AND +! + DO NK=LET+1,LTOP +! +!...entrainment is allowed at every level except for LTOP, so disallow +!...entrainment at LTOP and adjust entrainment rates between LET and LTOP +!...so the the dilution factor due to entyrianment is not changed but +!...the actual entrainment rate will change due due forced total +!...detrainment in this layer... +! + IF(NK.EQ.LTOP)THEN + UDR(NK) = UMF(NK-1) + UER(NK) = 0. + DETLQ(NK) = UDR(NK)*QLIQ(NK)*DILFRC(NK) + DETIC(NK) = UDR(NK)*QICE(NK)*DILFRC(NK) + ELSE + UMF(NK)=UMF(NK-1)-DP(NK)*DUMFDP + UER(NK)=UMF(NK)*(1.-1./DILFRC(NK)) + UDR(NK)=UMF(NK-1)-UMF(NK)+UER(NK) + DETLQ(NK)=UDR(NK)*QLIQ(NK)*DILFRC(NK) + DETIC(NK)=UDR(NK)*QICE(NK)*DILFRC(NK) + ENDIF + IF(NK.GE.LET+2)THEN + TRPPT=TRPPT-PPTLIQ(NK)-PPTICE(NK) + PPTLIQ(NK)=UMF(NK-1)*QLQOUT(NK) + PPTICE(NK)=UMF(NK-1)*QICOUT(NK) + TRPPT=TRPPT+PPTLIQ(NK)+PPTICE(NK) + ENDIF + ENDDO + ENDIF +! +! Initialize some arrays below cloud base and above cloud top... +! + DO NK=1,K + IF(NK.GE.LC)THEN + IF(NK.EQ.LC)THEN + UMF(NK)=VMFLCL*DP(NK)/DPTHMX + UER(NK)=VMFLCL*DP(NK)/DPTHMX + ELSEIF(NK.LE.KPBL)THEN + UER(NK)=VMFLCL*DP(NK)/DPTHMX + UMF(NK)=UMF(NK-1)+UER(NK) + ELSE + UMF(NK)=VMFLCL + UER(NK)=0. + ENDIF + TU(NK)=TMIX+(Z0(NK)-ZMIX)*GDRY + QU(NK)=QMIX + WU(NK)=WLCL + ELSE + TU(NK)=0. + QU(NK)=0. + UMF(NK)=0. + WU(NK)=0. + UER(NK)=0. + ENDIF + UDR(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + RATIO2(NK)=0. + CALL ENVIRTHT(P0(NK),T0(NK),Q0(NK),THETEE(NK),ALIQ,BLIQ,CLIQ,DLIQ) + EQFRC(NK)=1.0 + ENDDO +! + LTOP1=LTOP+1 + LTOPM1=LTOP-1 +! +!...DEFINE VARIABLES ABOVE CLOUD TOP... +! + DO NK=LTOP1,KX + UMF(NK)=0. + UDR(NK)=0. + UER(NK)=0. + QDT(NK)=0. + QLIQ(NK)=0. + QICE(NK)=0. + QLQOUT(NK)=0. + QICOUT(NK)=0. + DETLQ(NK)=0. + DETIC(NK)=0. + PPTLIQ(NK)=0. + PPTICE(NK)=0. + IF(NK.GT.LTOP1)THEN + TU(NK)=0. + QU(NK)=0. + WU(NK)=0. + ENDIF + THTA0(NK)=0. + THTAU(NK)=0. + EMS(NK)=0. + EMSD(NK)=0. + TG(NK)=T0(NK) + QG(NK)=Q0(NK) + QLG(NK)=0. + QIG(NK)=0. + QRG(NK)=0. + QSG(NK)=0. + OMG(NK)=0. + ENDDO + OMG(KX+1)=0. + DO NK=1,LTOP + EMS(NK)=DP(NK)*DXSQ/G + EMSD(NK)=1./EMS(NK) +! +!...INITIALIZE SOME VARIABLES TO BE USED LATER IN THE VERT ADVECTION SCH +! + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QDT(NK))) + THTAU(NK)=TU(NK)*EXN(NK) + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*Q0(NK))) + THTA0(NK)=T0(NK)*EXN(NK) + DDILFRC(NK) = 1./DILFRC(NK) + OMG(NK)=0. + ENDDO +! IF (XTIME.LT.10.)THEN +! WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, +! * TMIX-T00,PMIX,QMIX,ABE +! WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., +! * WLCL,CLDHGT +! ENDIF +! +!...COMPUTE CONVECTIVE TIME SCALE(TIMEC). THE MEAN WIND AT THE LCL +!...AND MIDTROPOSPHERE IS USED. +! + WSPD(KLCL)=SQRT(U0(KLCL)*U0(KLCL)+V0(KLCL)*V0(KLCL)) + WSPD(L5)=SQRT(U0(L5)*U0(L5)+V0(L5)*V0(L5)) + WSPD(LTOP)=SQRT(U0(LTOP)*U0(LTOP)+V0(LTOP)*V0(LTOP)) + VCONV=.5*(WSPD(KLCL)+WSPD(L5)) +!...for ETA model, DX is a function of location... +! TIMEC=DX(I,J)/VCONV + TIMEC=DX/VCONV + TADVEC=TIMEC + TIMEC=AMAX1(1800.,TIMEC) + TIMEC=AMIN1(3600.,TIMEC) + IF(ISHALL.EQ.1)TIMEC=2400. + NIC=NINT(TIMEC/DT) + TIMEC=FLOAT(NIC)*DT +! +!...COMPUTE WIND SHEAR AND PRECIPITATION EFFICIENCY. +! + IF(WSPD(LTOP).GT.WSPD(KLCL))THEN + SHSIGN=1. + ELSE + SHSIGN=-1. + ENDIF + VWS=(U0(LTOP)-U0(KLCL))*(U0(LTOP)-U0(KLCL))+(V0(LTOP)-V0(KLCL))* & + (V0(LTOP)-V0(KLCL)) + VWS=1.E3*SHSIGN*SQRT(VWS)/(Z0(LTOP)-Z0(LCL)) + PEF=1.591+VWS*(-.639+VWS*(9.53E-2-VWS*4.96E-3)) + PEF=AMAX1(PEF,.2) + PEF=AMIN1(PEF,.9) +! +!...PRECIPITATION EFFICIENCY IS A FUNCTION OF THE HEIGHT OF CLOUD BASE. +! + CBH=(ZLCL-Z0(1))*3.281E-3 + IF(CBH.LT.3.)THEN + RCBH=.02 + ELSE + RCBH=.96729352+CBH*(-.70034167+CBH*(.162179896+CBH*(- & + 1.2569798E-2+CBH*(4.2772E-4-CBH*5.44E-6)))) + ENDIF + IF(CBH.GT.25)RCBH=2.4 + PEFCBH=1./(1.+RCBH) + PEFCBH=AMIN1(PEFCBH,.9) +! +!... MEAN PEF. IS USED TO COMPUTE RAINFALL. +! + PEFF=.5*(PEF+PEFCBH) + PEFF2 = PEFF ! JSK MODS + IF(IPRNT)THEN + WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS +! call flush(98) + endif +! WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS +!***************************************************************** +! * +! COMPUTE DOWNDRAFT PROPERTIES * +! * +!***************************************************************** +! +! + TDER=0. + devap:IF(ISHALL.EQ.1)THEN + LFS = 1 + ELSE +! +!...start downdraft about 150 mb above cloud base... +! +! KSTART=MAX0(KPBL,KLCL) +! KSTART=KPBL ! Changed 7/23/99 + KSTART=KPBL+1 ! Changed 7/23/99 + KLFS = LET-1 + DO NK = KSTART+1,KL + DPPP = P0(KSTART)-P0(NK) +! IF(DPPP.GT.200.E2)THEN + IF(DPPP.GT.150.E2)THEN + KLFS = NK + EXIT + ENDIF + ENDDO + KLFS = MIN0(KLFS,LET-1) + LFS = KLFS +! +!...if LFS is not at least 50 mb above cloud base (implying that the +!...level of equil temp, LET, is just above cloud base) do not allow a +!...downdraft... +! + IF((P0(KSTART)-P0(LFS)).GT.50.E2)THEN + THETED(LFS) = THETEE(LFS) + QD(LFS) = Q0(LFS) +! +!...call tpmix2dd to find wet-bulb temp, qv... +! + call tpmix2dd(p0(lfs),theted(lfs),tz(lfs),qss,i,j) + THTAD(LFS)=TZ(LFS)*(P00/P0(LFS))**(0.2854*(1.-0.28*QSS)) +! +!...TAKE A FIRST GUESS AT THE INITIAL DOWNDRAFT MASS FLUX... +! + TVD(LFS)=TZ(LFS)*(1.+0.608*QSS) + RDD=P0(LFS)/(R*TVD(LFS)) + A1=(1.-PEFF)*AU0 + DMF(LFS)=-A1*RDD + DER(LFS)=DMF(LFS) + DDR(LFS)=0. + RHBAR = RH(LFS)*DP(LFS) + DPTT = DP(LFS) + DO ND = LFS-1,KSTART,-1 + ND1 = ND+1 + DER(ND)=DER(LFS)*EMS(ND)/EMS(LFS) + DDR(ND)=0. + DMF(ND)=DMF(ND1)+DER(ND) + THETED(ND)=(THETED(ND1)*DMF(ND1)+THETEE(ND)*DER(ND))/DMF(ND) + QD(ND)=(QD(ND1)*DMF(ND1)+Q0(ND)*DER(ND))/DMF(ND) + DPTT = DPTT+DP(ND) + RHBAR = RHBAR+RH(ND)*DP(ND) + ENDDO + RHBAR = RHBAR/DPTT + DMFFRC = 2.*(1.-RHBAR) + DPDD = 0. +!...Calculate melting effect +!... first, compute total frozen precipitation generated... +! + pptmlt = 0. + DO NK = KLCL,LTOP + PPTMLT = PPTMLT+PPTICE(NK) + ENDDO + if(lc.lt.ml)then +!...For now, calculate melting effect as if DMF = -UMF at KLCL, i.e., as +!...if DMFFRC=1. Otherwise, for small DMFFRC, DTMELT gets too large! +!...12/14/98 jsk... + DTMELT = RLF*PPTMLT/(CP*UMF(KLCL)) + else + DTMELT = 0. + endif + LDT = MIN0(LFS-1,KSTART-1) +! + call tpmix2dd(p0(kstart),theted(kstart),tz(kstart),qss,i,j) +! + tz(kstart) = tz(kstart)-dtmelt + ES=ALIQ*EXP((BLIQ*TZ(KSTART)-CLIQ)/(TZ(KSTART)-DLIQ)) + QSS=0.622*ES/(P0(KSTART)-ES) + THETED(KSTART)=TZ(KSTART)*(1.E5/P0(KSTART))**(0.2854*(1.-0.28*QSS))* & + EXP((3374.6525/TZ(KSTART)-2.5403)*QSS*(1.+0.81*QSS)) +!.... + LDT = MIN0(LFS-1,KSTART-1) + DO ND = LDT,1,-1 + DPDD = DPDD+DP(ND) + THETED(ND) = THETED(KSTART) + QD(ND) = QD(KSTART) +! +!...call tpmix2dd to find wet bulb temp, saturation mixing ratio... +! + call tpmix2dd(p0(nd),theted(nd),tz(nd),qss,i,j) + qsd(nd) = qss +! +!...specify RH decrease of 20%/km in downdraft... +! + RHH = 1.-0.2/1000.*(Z0(KSTART)-Z0(ND)) +! +!...adjust downdraft TEMP, Q to specified RH: +! + IF(RHH.LT.1.)THEN + DSSDT=(CLIQ-BLIQ*DLIQ)/((TZ(ND)-DLIQ)*(TZ(ND)-DLIQ)) + RL=XLV0-XLV1*TZ(ND) + DTMP=RL*QSS*(1.-RHH)/(CP+RL*RHH*QSS*DSSDT) + T1RH=TZ(ND)+DTMP + ES=RHH*ALIQ*EXP((BLIQ*T1RH-CLIQ)/(T1RH-DLIQ)) + QSRH=0.622*ES/(P0(ND)-ES) +! +!...CHECK TO SEE IF MIXING RATIO AT SPECIFIED RH IS LESS THAN ACTUAL +!...MIXING RATIO...IF SO, ADJUST TO GIVE ZERO EVAPORATION... +! + IF(QSRH.LT.QD(ND))THEN + QSRH=QD(ND) + T1RH=TZ(ND)+(QSS-QSRH)*RL/CP + ENDIF + TZ(ND)=T1RH + QSS=QSRH + QSD(ND) = QSS + ENDIF + TVD(nd) = tz(nd)*(1.+0.608*qsd(nd)) + IF(TVD(ND).GT.TV0(ND).OR.ND.EQ.1)THEN + LDB=ND + EXIT + ENDIF + ENDDO + IF((P0(LDB)-P0(LFS)) .gt. 50.E2)THEN ! minimum Downdraft depth! + DO ND=LDT,LDB,-1 + ND1 = ND+1 + DDR(ND) = -DMF(KSTART)*DP(ND)/DPDD + DER(ND) = 0. + DMF(ND) = DMF(ND1)+DDR(ND) + TDER=TDER+(QSD(nd)-QD(ND))*DDR(ND) + QD(ND)=QSD(nd) + THTAD(ND)=TZ(ND)*(P00/P0(ND))**(0.2854*(1.-0.28*QD(ND))) + ENDDO + ENDIF + ENDIF + ENDIF devap +! +!...IF DOWNDRAFT DOES NOT EVAPORATE ANY WATER FOR SPECIFIED RELATIVE +!...HUMIDITY, NO DOWNDRAFT IS ALLOWED... +! +d_mf: IF(TDER.LT.1.)THEN +! WRITE(98,3004)I,J +!3004 FORMAT(' ','No Downdraft!; I=',I3,2X,'J=',I3,'ISHALL =',I2) + PPTFLX=TRPPT + CPR=TRPPT + TDER=0. + CNDTNF=0. + UPDINC=1. + LDB=LFS + DO NDK=1,LTOP + DMF(NDK)=0. + DER(NDK)=0. + DDR(NDK)=0. + THTAD(NDK)=0. + WD(NDK)=0. + TZ(NDK)=0. + QD(NDK)=0. + ENDDO + AINCM2=100. + ELSE + DDINC = -DMFFRC*UMF(KLCL)/DMF(KSTART) + UPDINC=1. + IF(TDER*DDINC.GT.TRPPT)THEN + DDINC = TRPPT/TDER + ENDIF + TDER = TDER*DDINC + DO NK=LDB,LFS + DMF(NK)=DMF(NK)*DDINC + DER(NK)=DER(NK)*DDINC + DDR(NK)=DDR(NK)*DDINC + ENDDO + CPR=TRPPT + PPTFLX = TRPPT-TDER + PEFF=PPTFLX/TRPPT + IF(IPRNT)THEN + write(98,*)'PRECIP EFFICIENCY =',PEFF +! call flush(98) + ENDIF +! +! +!...ADJUST UPDRAFT MASS FLUX, MASS DETRAINMENT RATE, AND LIQUID WATER AN +! DETRAINMENT RATES TO BE CONSISTENT WITH THE TRANSFER OF THE ESTIMATE +! FROM THE UPDRAFT TO THE DOWNDRAFT AT THE LFS... +! +! DO NK=LC,LFS +! UMF(NK)=UMF(NK)*UPDINC +! UDR(NK)=UDR(NK)*UPDINC +! UER(NK)=UER(NK)*UPDINC +! PPTLIQ(NK)=PPTLIQ(NK)*UPDINC +! PPTICE(NK)=PPTICE(NK)*UPDINC +! DETLQ(NK)=DETLQ(NK)*UPDINC +! DETIC(NK)=DETIC(NK)*UPDINC +! ENDDO +! +!...ZERO OUT THE ARRAYS FOR DOWNDRAFT DATA AT LEVELS ABOVE AND BELOW THE +!...DOWNDRAFT... +! + IF(LDB.GT.1)THEN + DO NK=1,LDB-1 + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + ENDIF + DO NK=LFS+1,KX + DMF(NK)=0. + DER(NK)=0. + DDR(NK)=0. + WD(NK)=0. + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + DO NK=LDT+1,LFS-1 + TZ(NK)=0. + QD(NK)=0. + THTAD(NK)=0. + ENDDO + ENDIF d_mf +! +!...SET LIMITS ON THE UPDRAFT AND DOWNDRAFT MASS FLUXES SO THAT THE INFL +! INTO CONVECTIVE DRAFTS FROM A GIVEN LAYER IS NO MORE THAN IS AVAILAB +! IN THAT LAYER INITIALLY... +! + AINCMX=1000. + LMAX=MAX0(KLCL,LFS) + DO NK=LC,LMAX + IF((UER(NK)-DER(NK)).GT.1.e-3)THEN + AINCM1=EMS(NK)/((UER(NK)-DER(NK))*TIMEC) + AINCMX=AMIN1(AINCMX,AINCM1) + ENDIF + ENDDO + AINC=1. + IF(AINCMX.LT.AINC)AINC=AINCMX +! +!...SAVE THE RELEVENT VARIABLES FOR A UNIT UPDRAFT AND DOWNDRAFT...THEY WILL +!...BE ITERATIVELY ADJUSTED BY THE FACTOR AINC TO SATISFY THE STABILIZATION +!...CLOSURE... +! + TDER2=TDER + PPTFL2=PPTFLX + DO NK=1,LTOP + DETLQ2(NK)=DETLQ(NK) + DETIC2(NK)=DETIC(NK) + UDR2(NK)=UDR(NK) + UER2(NK)=UER(NK) + DDR2(NK)=DDR(NK) + DER2(NK)=DER(NK) + UMF2(NK)=UMF(NK) + DMF2(NK)=DMF(NK) + ENDDO + FABE=1. + STAB=0.95 + NOITR=0 + ISTOP=0 +! + IF(ISHALL.EQ.1)THEN ! First for shallow convection +! +! No iteration for shallow convection; if turbulent kinetic energy (TKE) is available +! from a turbulence parameterization, scale cloud-base updraft mass flux as a function +! of TKE, but for now, just specify shallow-cloud mass flux using TKEMAX = 5... +! +!...find the maximum TKE value between LC and KLCL... +! TKEMAX = 0. + TKEMAX = 5. +! DO 173 K = LC,KLCL +! NK = KX-K+1 +! TKEMAX = AMAX1(TKEMAX,Q2(I,J,NK)) +! 173 CONTINUE +! TKEMAX = AMIN1(TKEMAX,10.) +! TKEMAX = AMAX1(TKEMAX,5.) +!c TKEMAX = 10. +!c...3_24_99...DPMIN was changed for shallow convection so that it is the +!c... the same as for deep convection (5.E3). Since this doubles +!c... (roughly) the value of DPTHMX, add a factor of 0.5 to calcu- +!c... lation of EVAC... +!c EVAC = TKEMAX*0.1 + EVAC = 0.5*TKEMAX*0.1 +! AINC = 0.1*DPTHMX*DXIJ*DXIJ/(VMFLCL*G*TIMEC) +! AINC = EVAC*DPTHMX*DX(I,J)*DX(I,J)/(VMFLCL*G*TIMEC) + AINC = EVAC*DPTHMX*DXSQ/(VMFLCL*G*TIMEC) + TDER=TDER2*AINC + PPTFLX=PPTFL2*AINC + DO NK=1,LTOP + UMF(NK)=UMF2(NK)*AINC + DMF(NK)=DMF2(NK)*AINC + DETLQ(NK)=DETLQ2(NK)*AINC + DETIC(NK)=DETIC2(NK)*AINC + UDR(NK)=UDR2(NK)*AINC + UER(NK)=UER2(NK)*AINC + DER(NK)=DER2(NK)*AINC + DDR(NK)=DDR2(NK)*AINC + ENDDO + ENDIF ! Otherwise for deep convection +! use iterative procedure to find mass fluxes... +iter: DO NCOUNT=1,10 +! +!***************************************************************** +! * +! COMPUTE PROPERTIES FOR COMPENSATIONAL SUBSIDENCE * +! * +!***************************************************************** +! +!...DETERMINE OMEGA VALUE NECESSARY AT TOP AND BOTTOM OF EACH LAYER TO +!...SATISFY MASS CONTINUITY... +! + DTT=TIMEC + DO NK=1,LTOP + DOMGDP(NK)=-(UER(NK)-DER(NK)-UDR(NK)-DDR(NK))*EMSD(NK) + IF(NK.GT.1)THEN + OMG(NK)=OMG(NK-1)-DP(NK-1)*DOMGDP(NK-1) + ABSOMG = ABS(OMG(NK)) + ABSOMGTC = ABSOMG*TIMEC + FRDP = 0.75*DP(NK-1) + IF(ABSOMGTC.GT.FRDP)THEN + DTT1 = FRDP/ABSOMG + DTT=AMIN1(DTT,DTT1) + ENDIF + ENDIF + ENDDO + DO NK=1,LTOP + THPA(NK)=THTA0(NK) + QPA(NK)=Q0(NK) + NSTEP=NINT(TIMEC/DTT+1) + DTIME=TIMEC/FLOAT(NSTEP) + FXM(NK)=OMG(NK)*DXSQ/G + ENDDO +! +!...DO AN UPSTREAM/FORWARD-IN-TIME ADVECTION OF THETA, QV... +! + DO NTC=1,NSTEP +! +!...ASSIGN THETA AND Q VALUES AT THE TOP AND BOTTOM OF EACH LAYER BASED +!...SIGN OF OMEGA... +! + DO NK=1,LTOP + THFXIN(NK)=0. + THFXOUT(NK)=0. + QFXIN(NK)=0. + QFXOUT(NK)=0. + ENDDO + DO NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + THFXIN(NK)=-FXM(NK)*THPA(NK-1) + QFXIN(NK)=-FXM(NK)*QPA(NK-1) + THFXOUT(NK-1)=THFXOUT(NK-1)+THFXIN(NK) + QFXOUT(NK-1)=QFXOUT(NK-1)+QFXIN(NK) + ELSE + THFXOUT(NK)=FXM(NK)*THPA(NK) + QFXOUT(NK)=FXM(NK)*QPA(NK) + THFXIN(NK-1)=THFXIN(NK-1)+THFXOUT(NK) + QFXIN(NK-1)=QFXIN(NK-1)+QFXOUT(NK) + ENDIF + ENDDO +! +!...UPDATE THE THETA AND QV VALUES AT EACH LEVEL... +! + DO NK=1,LTOP + THPA(NK)=THPA(NK)+(THFXIN(NK)+UDR(NK)*THTAU(NK)+DDR(NK)* & + THTAD(NK)-THFXOUT(NK)-(UER(NK)-DER(NK))*THTA0(NK))* & + DTIME*EMSD(NK) + QPA(NK)=QPA(NK)+(QFXIN(NK)+UDR(NK)*QDT(NK)+DDR(NK)*QD(NK)- & + QFXOUT(NK)-(UER(NK)-DER(NK))*Q0(NK))*DTIME*EMSD(NK) + ENDDO + ENDDO + DO NK=1,LTOP + THTAG(NK)=THPA(NK) + QG(NK)=QPA(NK) + ENDDO +! +!...CHECK TO SEE IF MIXING RATIO DIPS BELOW ZERO ANYWHERE; IF SO, BORRO +!...MOISTURE FROM ADJACENT LAYERS TO BRING IT BACK UP ABOVE ZERO... +! + DO NK=1,LTOP + IF(QG(NK).LT.0.)THEN + IF(NK.EQ.1)THEN ! JSK MODS +! PRINT *,' PROBLEM WITH KF SCHEME: ' ! JSK MODS +! PRINT *,'QG = 0 AT THE SURFACE!!!!!!!' ! JSK MODS +!! CALL wrf_error_fatal ( 'QG, QG(NK).LT.0') ! JSK MODS + ENDIF ! JSK MODS + NK1=NK+1 + IF(NK.EQ.LTOP)THEN + NK1=KLCL + ENDIF + TMA=QG(NK1)*EMS(NK1) + TMB=QG(NK-1)*EMS(NK-1) + TMM=(QG(NK)-1.E-9)*EMS(NK ) + BCOEFF=-TMM/((TMA*TMA)/TMB+TMB) + ACOEFF=BCOEFF*TMA/TMB + TMB=TMB*(1.-BCOEFF) + TMA=TMA*(1.-ACOEFF) + IF(NK.EQ.LTOP)THEN + QVDIFF=(QG(NK1)-TMA*EMSD(NK1))*100./QG(NK1) +! IF(ABS(QVDIFF).GT.1.)THEN +! PRINT *,'!!!WARNING!!! CLOUD BASE WATER VAPOR CHANGES BY ', & +! QVDIFF, & +! '% WHEN MOISTURE IS BORROWED TO PREVENT NEGATIVE ', & +! 'VALUES IN KAIN-FRITSCH' +! ENDIF + ENDIF + QG(NK)=1.E-9 + QG(NK1)=TMA*EMSD(NK1) + QG(NK-1)=TMB*EMSD(NK-1) + ENDIF + ENDDO + TOPOMG=(UDR(LTOP)-UER(LTOP))*DP(LTOP)*EMSD(LTOP) + IF(ABS(TOPOMG-OMG(LTOP)).GT.1.E-3)THEN +! WRITE(99,*)'ERROR: MASS DOES NOT BALANCE IN KF SCHEME; & +! TOPOMG, OMG =',TOPOMG,OMG(LTOP) +! TOPOMG, OMG =',TOPOMG,OMG(LTOP) + ISTOP=1 + IPRNT=.TRUE. + EXIT iter + ENDIF +! +!...CONVERT THETA TO T... +! + DO NK=1,LTOP + EXN(NK)=(P00/P0(NK))**(0.2854*(1.-0.28*QG(NK))) + TG(NK)=THTAG(NK)/EXN(NK) + TVG(NK)=TG(NK)*(1.+0.608*QG(NK)) + ENDDO + IF(ISHALL.EQ.1)THEN + EXIT iter + ENDIF +! +!******************************************************************* +! * +! COMPUTE NEW CLOUD AND CHANGE IN AVAILABLE BUOYANT ENERGY. * +! * +!******************************************************************* +! +!...THE FOLLOWING COMPUTATIONS ARE SIMILAR TO THAT FOR UPDRAFT +! +! THMIX=0. + TMIX=0. + QMIX=0. +! +!...FIND THE THERMODYNAMIC CHARACTERISTICS OF THE LAYER BY +!...MASS-WEIGHTING THE CHARACTERISTICS OF THE INDIVIDUAL MODEL +!...LAYERS... +! + DO NK=LC,KPBL + TMIX=TMIX+DP(NK)*TG(NK) + QMIX=QMIX+DP(NK)*QG(NK) + ENDDO + TMIX=TMIX/DPTHMX + QMIX=QMIX/DPTHMX + ES=ALIQ*EXP((TMIX*BLIQ-CLIQ)/(TMIX-DLIQ)) + QSS=0.622*ES/(PMIX-ES) +! +!...REMOVE SUPERSATURATION FOR DIAGNOSTIC PURPOSES, IF NECESSARY... +! + IF(QMIX.GT.QSS)THEN + RL=XLV0-XLV1*TMIX + CPM=CP*(1.+0.887*QMIX) + DSSDT=QSS*(CLIQ-BLIQ*DLIQ)/((TMIX-DLIQ)*(TMIX-DLIQ)) + DQ=(QMIX-QSS)/(1.+RL*DSSDT/CPM) + TMIX=TMIX+RL/CP*DQ + QMIX=QMIX-DQ + TLCL=TMIX + ELSE + QMIX=AMAX1(QMIX,0.) + EMIX=QMIX*PMIX/(0.622+QMIX) + astrt=1.e-3 + binc=0.075 + a1=emix/aliq + tp=(a1-astrt)/binc + indlu=int(tp)+1 + value=(indlu-1)*binc+astrt + aintrp=(a1-value)/binc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TLCL=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(TMIX-T00))*(TMIX-TDPT) + TLCL=AMIN1(TLCL,TMIX) + ENDIF + TVLCL=TLCL*(1.+0.608*QMIX) + ZLCL = ZMIX+(TLCL-TMIX)/GDRY + DO NK = LC,KL + KLCL=NK + IF(ZLCL.LE.Z0(NK))THEN + EXIT + ENDIF + ENDDO + K=KLCL-1 + DLP=(ZLCL-Z0(K))/(Z0(KLCL)-Z0(K)) +! +!...ESTIMATE ENVIRONMENTAL TEMPERATURE AND MIXING RATIO AT THE LCL... +! + TENV=TG(K)+(TG(KLCL)-TG(K))*DLP + QENV=QG(K)+(QG(KLCL)-QG(K))*DLP + TVEN=TENV*(1.+0.608*QENV) + PLCL=P0(K)+(P0(KLCL)-P0(K))*DLP + THETEU(K)=TMIX*(1.E5/PMIX)**(0.2854*(1.-0.28*QMIX))* & + EXP((3374.6525/TLCL-2.5403)*QMIX*(1.+0.81*QMIX)) +! +!...COMPUTE ADJUSTED ABE(ABEG). +! + ABEG=0. + DO NK=K,LTOPM1 + NK1=NK+1 + THETEU(NK1) = THETEU(NK) +! + call tpmix2dd(p0(nk1),theteu(nk1),tgu(nk1),qgu(nk1),i,j) +! + TVQU(NK1)=TGU(NK1)*(1.+0.608*QGU(NK1)-QLIQ(NK1)-QICE(NK1)) + IF(NK.EQ.K)THEN + DZZ=Z0(KLCL)-ZLCL + DILBE=((TVLCL+TVQU(NK1))/(TVEN+TVG(NK1))-1.)*DZZ + ELSE + DZZ=DZA(NK) + DILBE=((TVQU(NK)+TVQU(NK1))/(TVG(NK)+TVG(NK1))-1.)*DZZ + ENDIF + IF(DILBE.GT.0.)ABEG=ABEG+DILBE*G +! +!...DILUTE BY ENTRAINMENT BY THE RATE AS ORIGINAL UPDRAFT... +! + CALL ENVIRTHT(P0(NK1),TG(NK1),QG(NK1),THTEEG(NK1),ALIQ,BLIQ,CLIQ,DLIQ) + THETEU(NK1)=THETEU(NK1)*DDILFRC(NK1)+THTEEG(NK1)*(1.-DDILFRC(NK1)) + ENDDO +! +!...ASSUME AT LEAST 90% OF CAPE (ABE) IS REMOVED BY CONVECTION DURING +!...THE PERIOD TIMEC... +! + IF(NOITR.EQ.1)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1060)FABE +! GOTO 265 + EXIT iter + ENDIF + DABE=AMAX1(ABE-ABEG,0.1*ABE) + FABE=ABEG/ABE + IF(FABE.GT.1. .and. ISHALL.EQ.0)THEN +! WRITE(98,*)'UPDRAFT/DOWNDRAFT COUPLET INCREASES CAPE AT THIS +! *GRID POINT; NO CONVECTION ALLOWED!' + RETURN + ENDIF + IF(NCOUNT.NE.1)THEN + IF(ABS(AINC-AINCOLD).LT.0.0001)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ENDIF + DFDA=(FABE-FABEOLD)/(AINC-AINCOLD) + IF(DFDA.GT.0.)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ENDIF + ENDIF + AINCOLD=AINC + FABEOLD=FABE + IF(AINC/AINCMX.GT.0.999.AND.FABE.GT.1.05-STAB)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1055)FABE +! GOTO 265 + EXIT + ENDIF + IF((FABE.LE.1.05-STAB.AND.FABE.GE.0.95-STAB) .or. NCOUNT.EQ.10)THEN + EXIT iter + ELSE + IF(NCOUNT.GT.10)THEN +! write(98,*)' ' +! write(98,*)'TAU, I, J, =',NTSD,I,J +! WRITE(98,1060)FABE +! GOTO 265 + EXIT + ENDIF +! +!...IF MORE THAN 10% OF THE ORIGINAL CAPE REMAINS, INCREASE THE CONVECTI +!...MASS FLUX BY THE FACTOR AINC: +! + IF(FABE.EQ.0.)THEN + AINC=AINC*0.5 + ELSE + IF(DABE.LT.1.e-4)THEN + NOITR=1 + AINC=AINCOLD + CYCLE iter + ELSE + AINC=AINC*STAB*ABE/DABE + ENDIF + ENDIF +! AINC=AMIN1(AINCMX,AINC) + AINC=AMIN1(AINCMX,AINC) +!...IF AINC BECOMES VERY SMALL, EFFECTS OF CONVECTION ! JSK MODS +!...WILL BE MINIMAL SO JUST IGNORE IT... ! JSK MODS + IF(AINC.LT.0.05)then + RETURN ! JSK MODS + ENDIF +! AINC=AMAX1(AINC,0.05) ! JSK MODS + TDER=TDER2*AINC + PPTFLX=PPTFL2*AINC +! IF (XTIME.LT.10.)THEN +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT, +! * FABEOLD,AINCOLD +! ENDIF + DO NK=1,LTOP + UMF(NK)=UMF2(NK)*AINC + DMF(NK)=DMF2(NK)*AINC + DETLQ(NK)=DETLQ2(NK)*AINC + DETIC(NK)=DETIC2(NK)*AINC + UDR(NK)=UDR2(NK)*AINC + UER(NK)=UER2(NK)*AINC + DER(NK)=DER2(NK)*AINC + DDR(NK)=DDR2(NK)*AINC + ENDDO +! +!...GO BACK UP FOR ANOTHER ITERATION... +! + ENDIF + ENDDO iter +! +!...COMPUTE HYDROMETEOR TENDENCIES AS IS DONE FOR T, QV... +! +!...FRC2 IS THE FRACTION OF TOTAL CONDENSATE ! PPT FB MODS +!...GENERATED THAT GOES INTO PRECIPITIATION ! PPT FB MODS +! +! Redistribute hydormeteors according to the final mass-flux values: +! + IF(CPR.GT.0.)THEN + FRC2=PPTFLX/(CPR*AINC) ! PPT FB MODS + ELSE + FRC2=0. + ENDIF + DO NK=1,LTOP + QLPA(NK)=QL0(NK) + QIPA(NK)=QI0(NK) + QRPA(NK)=QR0(NK) + QSPA(NK)=QS0(NK) + RAINFB(NK)=PPTLIQ(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS + SNOWFB(NK)=PPTICE(NK)*AINC*FBFRC*FRC2 ! PPT FB MODS + ENDDO + DO NTC=1,NSTEP +! +!...ASSIGN HYDROMETEORS CONCENTRATIONS AT THE TOP AND BOTTOM OF EACH LAY +!...BASED ON THE SIGN OF OMEGA... +! + DO NK=1,LTOP + QLFXIN(NK)=0. + QLFXOUT(NK)=0. + QIFXIN(NK)=0. + QIFXOUT(NK)=0. + QRFXIN(NK)=0. + QRFXOUT(NK)=0. + QSFXIN(NK)=0. + QSFXOUT(NK)=0. + ENDDO + DO NK=2,LTOP + IF(OMG(NK).LE.0.)THEN + QLFXIN(NK)=-FXM(NK)*QLPA(NK-1) + QIFXIN(NK)=-FXM(NK)*QIPA(NK-1) + QRFXIN(NK)=-FXM(NK)*QRPA(NK-1) + QSFXIN(NK)=-FXM(NK)*QSPA(NK-1) + QLFXOUT(NK-1)=QLFXOUT(NK-1)+QLFXIN(NK) + QIFXOUT(NK-1)=QIFXOUT(NK-1)+QIFXIN(NK) + QRFXOUT(NK-1)=QRFXOUT(NK-1)+QRFXIN(NK) + QSFXOUT(NK-1)=QSFXOUT(NK-1)+QSFXIN(NK) + ELSE + QLFXOUT(NK)=FXM(NK)*QLPA(NK) + QIFXOUT(NK)=FXM(NK)*QIPA(NK) + QRFXOUT(NK)=FXM(NK)*QRPA(NK) + QSFXOUT(NK)=FXM(NK)*QSPA(NK) + QLFXIN(NK-1)=QLFXIN(NK-1)+QLFXOUT(NK) + QIFXIN(NK-1)=QIFXIN(NK-1)+QIFXOUT(NK) + QRFXIN(NK-1)=QRFXIN(NK-1)+QRFXOUT(NK) + QSFXIN(NK-1)=QSFXIN(NK-1)+QSFXOUT(NK) + ENDIF + ENDDO +! +!...UPDATE THE HYDROMETEOR CONCENTRATION VALUES AT EACH LEVEL... +! + DO NK=1,LTOP + QLPA(NK)=QLPA(NK)+(QLFXIN(NK)+DETLQ(NK)-QLFXOUT(NK))*DTIME*EMSD(NK) + QIPA(NK)=QIPA(NK)+(QIFXIN(NK)+DETIC(NK)-QIFXOUT(NK))*DTIME*EMSD(NK) + QRPA(NK)=QRPA(NK)+(QRFXIN(NK)-QRFXOUT(NK)+RAINFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS + QSPA(NK)=QSPA(NK)+(QSFXIN(NK)-QSFXOUT(NK)+SNOWFB(NK))*DTIME*EMSD(NK) ! PPT FB MODS + ENDDO + ENDDO + DO NK=1,LTOP + QLG(NK)=QLPA(NK) + QIG(NK)=QIPA(NK) + QRG(NK)=QRPA(NK) + QSG(NK)=QSPA(NK) + ENDDO +! +!...CLEAN THINGS UP, CALCULATE CONVECTIVE FEEDBACK TENDENCIES FOR THIS +!...GRID POINT... +! +! IF (XTIME.LT.10.)THEN +! WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! ENDIF + IF(IPRNT)THEN + WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! call flush(98) + endif +! +!...SEND FINAL PARAMETERIZED VALUES TO OUTPUT FILES... +! +!297 IF(IPRNT)then + IF(IPRNT)then +! if(I.eq.16 .and. J.eq.41)then +! IF(ISTOP.EQ.1)THEN + write(98,*) +! write(98,*)'At t(h), I, J =',float(NTSD)*72./3600.,I,J + write(98,*)'P(LC), DTP, WKL, WKLCL =',p0(LC)/100., & + TLCL+DTLCL+dtrh-TENV,WKL,WKLCL + write(98,*)'TLCL, DTLCL, DTRH, TENV =',TLCL,DTLCL, & + DTRH,TENV + WRITE(98,1025)KLCL,ZLCL,DTLCL,LTOP,P0(LTOP),IFLAG, & + TMIX-T00,PMIX,QMIX,ABE + WRITE(98,1030)P0(LET)/100.,P0(LTOP)/100.,VMFLCL,PLCL/100., & + WLCL,CLDHGT(LC) + WRITE(98,1035)PEF,PEFCBH,LC,LET,WKL,VWS + write(98,*)'PRECIP EFFICIENCY =',PEFF + WRITE(98,1080)LFS,LDB,LDT,TIMEC,TADVEC,NSTEP,NCOUNT,FABE,AINC +! ENDIF +!!!!! HERE !!!!!!! + WRITE(98,1070)' P ',' DP ',' DT K/D ',' DR K/D ',' OMG ', & + ' DOMGDP ',' UMF ',' UER ',' UDR ',' DMF ',' DER ' & + ,' DDR ',' EMS ',' W0 ',' DETLQ ',' DETIC ' + write(98,*)'just before DO 300...' +! call flush(98) + DO NK=1,LTOP + K=LTOP-NK+1 + DTT=(TG(K)-T0(K))*86400./TIMEC + RL=XLV0-XLV1*TG(K) + DR=-(QG(K)-Q0(K))*RL*86400./(TIMEC*CP) + UDFRC=UDR(K)*TIMEC*EMSD(K) + UEFRC=UER(K)*TIMEC*EMSD(K) + DDFRC=DDR(K)*TIMEC*EMSD(K) + DEFRC=-DER(K)*TIMEC*EMSD(K) + WRITE(98,1075)P0(K)/100.,DP(K)/100.,DTT,DR,OMG(K),DOMGDP(K)*1.E4, & + UMF(K)/1.E6,UEFRC,UDFRC,DMF(K)/1.E6,DEFRC,DDFRC,EMS(K)/1.E11, & + W0AVG1D(K)*1.E2,DETLQ(K)*TIMEC*EMSD(K)*1.E3,DETIC(K)* & + TIMEC*EMSD(K)*1.E3 + ENDDO + WRITE(98,1085)'K','P','Z','T0','TG','DT','TU','TD','Q0','QG', & + 'DQ','QU','QD','QLG','QIG','QRG','QSG','RH0','RHG' + DO NK=1,KL + K=KX-NK+1 + DTT=TG(K)-T0(K) + TUC=TU(K)-T00 + IF(K.LT.LC.OR.K.GT.LTOP)TUC=0. + TDC=TZ(K)-T00 + IF((K.LT.LDB.OR.K.GT.LDT).AND.K.NE.LFS)TDC=0. + IF(T0(K).LT.T00)THEN + ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) + ELSE + ES=ALIQ*EXP((BLIQ*TG(K)-CLIQ)/(TG(K)-DLIQ)) + ENDIF + QGS=ES*0.622/(P0(K)-ES) + RH0=Q0(K)/QES(K) + RHG=QG(K)/QGS + WRITE(98,1090)K,P0(K)/100.,Z0(K),T0(K)-T00,TG(K)-T00,DTT,TUC, & + TDC,Q0(K)*1000.,QG(K)*1000.,(QG(K)-Q0(K))*1000.,QU(K)* & + 1000.,QD(K)*1000.,QLG(K)*1000.,QIG(K)*1000.,QRG(K)*1000., & + QSG(K)*1000.,RH0,RHG + ENDDO +! +!...IF CALCULATIONS ABOVE SHOW AN ERROR IN THE MASS BUDGET, PRINT OUT A +!...TO BE USED LATER FOR DIAGNOSTIC PURPOSES, THEN ABORT RUN... +! +! IF(ISTOP.EQ.1 .or. ISHALL.EQ.1)THEN + +! IF(ISHALL.NE.1)THEN +! write(98,4421)i,j,iyr,imo,idy,ihr,imn +! write(98)i,j,iyr,imo,idy,ihr,imn,kl +! 4421 format(7i4) +! write(98,4422)kl +! 4422 format(i6) + DO 310 NK = 1,KL + k = kl - nk + 1 + write(98,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & + u0(k),v0(k),W0AVG1D(K),dp(k),tke(k) +! write(98) p0,t0,q0,u0,v0,w0,dp,tke +! WRITE(98,1115)Z0(K),P0(K)/100.,T0(K)-273.16,Q0(K)*1000., +! * U0(K),V0(K),DP(K)/100.,W0AVG(I,J,K) + 310 CONTINUE + IF(ISTOP.EQ.1)THEN +!! CALL wrf_error_fatal ( 'KAIN-FRITSCH, istop=1, diags' ) + ENDIF +! ENDIF + 4455 format(8f11.3) + ENDIF + CNDTNF=(1.-EQFRC(LFS))*(QLIQ(LFS)+QICE(LFS))*DMF(LFS) + RAINCV(I,J)=DT*PPTFLX*(1.-FBFRC)/DXSQ ! PPT FB MODS +! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS +! RNC=0.1*TIMEC*PPTFLX/DXSQ + RNC=RAINCV(I,J)*NIC + IF(ISHALL.EQ.0.AND.IPRNT)write (98,909)I,J,RNC + +! WRITE(98,1095)CPR*AINC,TDER+PPTFLX+CNDTNF +! +! EVALUATE MOISTURE BUDGET... +! + + QINIT=0. + QFNL=0. + DPT=0. + DO 315 NK=1,LTOP + DPT=DPT+DP(NK) + QINIT=QINIT+Q0(NK)*EMS(NK) + QFNL=QFNL+QG(NK)*EMS(NK) + QFNL=QFNL+(QLG(NK)+QIG(NK)+QRG(NK)+QSG(NK))*EMS(NK) + 315 CONTINUE + QFNL=QFNL+PPTFLX*TIMEC*(1.-FBFRC) ! PPT FB MODS +! QFNL=QFNL+PPTFLX*TIMEC ! PPT FB MODS + ERR2=(QFNL-QINIT)*100./QINIT + IF(IPRNT)WRITE(98,1110)QINIT,QFNL,ERR2 + IF(ABS(ERR2).GT.0.05 .AND. ISTOP.EQ.0)THEN +! write(99,*)'!!!!!!!! MOISTURE BUDGET ERROR IN KFPARA !!!' +! WRITE(99,1110)QINIT,QFNL,ERR2 + IPRNT=.TRUE. + ISTOP=1 + write(98,4422)kl + 4422 format(i6) + DO 311 NK = 1,KL + k = kl - nk + 1 +! write(99,4455) p0(k)/100.,t0(k)-273.16,q0(k)*1000., & +! u0(k),v0(k),W0AVG1D(K),dp(k) +! write(98) p0,t0,q0,u0,v0,w0,dp,tke +! WRITE(98,1115)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & +! U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) + WRITE(98,4456)P0(K)/100.,T0(K)-273.16,Q0(K)*1000., & + U0(K),V0(K),W0AVG1D(K),dp(k)/100.,tke(k) + 311 CONTINUE +! call flush(98) + +! GOTO 297 +! STOP 'QVERR' + ENDIF + 1115 FORMAT (2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) + 4456 format(8f12.3) + IF(PPTFLX.GT.0.)THEN + RELERR=ERR2*QINIT/(PPTFLX*TIMEC) + ELSE + RELERR=0. + ENDIF + IF(IPRNT)THEN + WRITE(98,1120)RELERR + WRITE(98,*)'TDER, CPR, TRPPT =', & + TDER,CPR*AINC,TRPPT*AINC + ENDIF +! +!...FEEDBACK TO RESOLVABLE SCALE TENDENCIES. +! +!...IF THE ADVECTIVE TIME PERIOD (TADVEC) IS LESS THAN SPECIFIED MINIMUM +!...TIMEC, ALLOW FEEDBACK TO OCCUR ONLY DURING TADVEC... +! + IF(TADVEC.LT.TIMEC)NIC=NINT(TADVEC/DT) + NCA(I,J)=FLOAT(NIC) + IF(ISHALL.EQ.1)THEN + TIMEC = 2400. + NCA(I,J) = FLOAT(NTST) + NSHALL = NSHALL+1 + ENDIF + DO K=1,KX +! IF(IMOIST(INEST).NE.2)THEN +! +!...IF HYDROMETEORS ARE NOT ALLOWED, THEY MUST BE EVAPORATED OR SUBLIMAT +!...AND FED BACK AS VAPOR, ALONG WITH ASSOCIATED CHANGES IN TEMPERATURE. +!...NOTE: THIS WILL INTRODUCE CHANGES IN THE CONVECTIVE TEMPERATURE AND +!...WATER VAPOR FEEDBACK TENDENCIES AND MAY LEAD TO SUPERSATURATED VALUE +!...OF QG... +! +! RLC=XLV0-XLV1*TG(K) +! RLS=XLS0-XLS1*TG(K) +! CPM=CP*(1.+0.887*QG(K)) +! TG(K)=TG(K)-(RLC*(QLG(K)+QRG(K))+RLS*(QIG(K)+QSG(K)))/CPM +! QG(K)=QG(K)+(QLG(K)+QRG(K)+QIG(K)+QSG(K)) +! DQLDT(I,J,NK)=0. +! DQIDT(I,J,NK)=0. +! DQRDT(I,J,NK)=0. +! DQSDT(I,J,NK)=0. +! ELSE +! +!...IF ICE PHASE IS NOT ALLOWED, MELT ALL FROZEN HYDROMETEORS... +! + IF(.NOT. F_QI .and. warm_rain )THEN + + CPM=CP*(1.+0.887*QG(K)) + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(.NOT. F_QI .and. .not. warm_rain)THEN +! +!...IF ICE PHASE IS ALLOWED, BUT MIXED PHASE IS NOT, MELT FROZEN HYDROME +!...BELOW THE MELTING LEVEL, FREEZE LIQUID WATER ABOVE THE MELTING LEVEL +! + CPM=CP*(1.+0.887*QG(K)) + IF(K.LE.ML)THEN + TG(K)=TG(K)-(QIG(K)+QSG(K))*RLF/CPM + ELSEIF(K.GT.ML)THEN + TG(K)=TG(K)+(QLG(K)+QRG(K))*RLF/CPM + ENDIF + DQCDT(K)=(QLG(K)+QIG(K)-QL0(K)-QI0(K))/TIMEC + DQIDT(K)=0. + DQRDT(K)=(QRG(K)+QSG(K)-QR0(K)-QS0(K))/TIMEC + DQSDT(K)=0. + ELSEIF(F_QI) THEN +! +!...IF MIXED PHASE HYDROMETEORS ARE ALLOWED, FEED BACK CONVECTIVE TENDEN +!...OF HYDROMETEORS DIRECTLY... +! + DQCDT(K)=(QLG(K)-QL0(K))/TIMEC + DQIDT(K)=(QIG(K)-QI0(K))/TIMEC + DQRDT(K)=(QRG(K)-QR0(K))/TIMEC + IF (F_QS) THEN + DQSDT(K)=(QSG(K)-QS0(K))/TIMEC + ELSE + DQIDT(K)=DQIDT(K)+(QSG(K)-QS0(K))/TIMEC + ENDIF + ELSE + PRINT *,'THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED!' +!! CALL wrf_error_fatal ( 'KAIN-FRITSCH, THIS COMBINATION OF IMOIST, IEXICE, IICE NOT ALLOWED' ) + ENDIF + DTDT(K)=(TG(K)-T0(K))/TIMEC + DQDT(K)=(QG(K)-Q0(K))/TIMEC + ENDDO + RAINCV(I,J)=DT*PPTFLX*(1.-FBFRC)/DXSQ ! PPT FB MODS +! RAINCV(I,J)=.1*.5*DT*PPTFLX/DXSQ ! PPT FB MODS +! RNC=0.1*TIMEC*PPTFLX/DXSQ + RNC=RAINCV(I,J)*NIC + 909 FORMAT('AT I, J =',i3,1x,i3,' CONVECTIVE RAINFALL =',F8.4,' mm') +! write (98,909)I,J,RNC +! write (6,909)I,J,RNC +! WRITE(98,*)'at NTSD =',NTSD,',No. of KF points activated =', +! * NCCNT +! call flush(98) +1000 FORMAT(' ',10A8) +1005 FORMAT(' ',F6.0,2X,F6.4,2X,F7.3,1X,F6.4,2X,4(F6.3,2X),2(F7.3,1X)) +1010 FORMAT(' ',' VERTICAL VELOCITY IS NEGATIVE AT ',F4.0,' MB') +1015 FORMAT(' ','ALL REMAINING MASS DETRAINS BELOW ',F4.0,' MB') +1025 FORMAT(5X,' KLCL=',I2,' ZLCL=',F7.1,'M', & + ' DTLCL=',F5.2,' LTOP=',I2,' P0(LTOP)=',-2PF5.1,'MB FRZ LV=', & + I2,' TMIX=',0PF4.1,1X,'PMIX=',-2PF6.1,' QMIX=',3PF5.1, & + ' CAPE=',0PF7.1) +1030 FORMAT(' ',' P0(LET) = ',F6.1,' P0(LTOP) = ',F6.1,' VMFLCL =', & + E12.3,' PLCL =',F6.1,' WLCL =',F6.3,' CLDHGT =', & + F8.1) +1035 FORMAT(1X,'PEF(WS)=',F4.2,'(CB)=',F4.2,'LC,LET=',2I3,'WKL=' & + ,F6.3,'VWS=',F5.2) +!1055 FORMAT('*** DEGREE OF STABILIZATION =',F5.3, & +! ', NO MORE MASS FLUX IS ALLOWED!') +!1060 FORMAT(' ITERATION DOES NOT CONVERGE TO GIVE THE SPECIFIED & +! &DEGREE OF STABILIZATION! FABE= ',F6.4) + 1070 FORMAT (16A8) + 1075 FORMAT (F8.2,3(F8.2),2(F8.3),F8.2,2F8.3,F8.2,6F8.3) + 1080 FORMAT(2X,'LFS,LDB,LDT =',3I3,' TIMEC, TADVEC, NSTEP=', & + 2(1X,F5.0),I3,'NCOUNT, FABE, AINC=',I2,1X,F5.3,F6.2) + 1085 FORMAT (A3,16A7,2A8) + 1090 FORMAT (I3,F7.2,F7.0,10F7.2,4F7.3,2F8.3) + 1095 FORMAT(' ',' PPT PRODUCTION RATE= ',F10.0,' TOTAL EVAP+PPT= ',F10.0) +1105 FORMAT(' ','NET LATENT HEAT RELEASE =',E12.5,' ACTUAL HEATING =',& + E12.5,' J/KG-S, DIFFERENCE = ',F9.3,'%') +1110 FORMAT(' ','INITIAL WATER =',E12.5,' FINAL WATER =',E12.5, & + ' TOTAL WATER CHANGE =',F8.2,'%') +! 1115 FORMAT (2X,F6.0,2X,F7.2,2X,F5.1,2X,F6.3,2(2X,F5.1),2X,F7.2,2X,F7.4) +1120 FORMAT(' ','MOISTURE ERROR AS FUNCTION OF TOTAL PPT =',F9.3,'%') +! +!----------------------------------------------------------------------- +!--------------SAVE CLOUD TOP AND BOTTOM FOR RADIATION------------------ +!----------------------------------------------------------------------- +! + CUTOP(I,J)=REAL(LTOP) + CUBOT(I,J)=REAL(LCL) + UMF(LTOP)=0.0 +! +!----------------------------------------------------------------------- + END SUBROUTINE KF_eta_PARA +!******************************************************************** +! *********************************************************************** + SUBROUTINE TPMIX2(p,thes,tu,qu,qliq,qice,qnewlq,qnewic,XLV1,XLV0) +! +! Lookup table variables: +! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables: + + +!----------------------------------------------------------------------- + use kftable_mod + + IMPLICIT NONE + +! include 'include_kftable' +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,THES,XLV1,XLV0 + REAL, INTENT(OUT ) :: QNEWLQ,QNEWIC + REAL, INTENT(INOUT) :: TU,QU,QLIQ,QICE + REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11, & + TEMP,QS,QNEW,DQ,QTOT,RLL,CPP + INTEGER :: IPTB,ITHTB +!----------------------------------------------------------------------- + +!c******** LOOKUP TABLE VARIABLES... **************************** +! parameter(kfnt=250,kfnp=220) +!c +! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), +! * alu(200),rdpr,rdthk,plutop +!C*************************************************************** +!c +!c*********************************************************************** +!c scaling pressure and tt table index +!c*********************************************************************** +!c + tp=(p-plutop)*rdpr + qq=tp-aint(tp) + iptb=int(tp)+1 + +! +!*********************************************************************** +! base and scaling factor for the +!*********************************************************************** +! +! scaling the and tt table index + bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) + tth=(thes-bth)*rdthk + pp =tth-aint(tth) + ithtb=int(tth)+1 + IF(IPTB.GE.220 .OR. IPTB.LE.1 .OR. ITHTB.GE.250 .OR. ITHTB.LE.1)THEN + write(98,*)'**** OUT OF BOUNDS *********' +! call flush(98) + ENDIF +! + t00=ttab(ithtb ,iptb ) + t10=ttab(ithtb+1,iptb ) + t01=ttab(ithtb ,iptb+1) + t11=ttab(ithtb+1,iptb+1) +! + q00=qstab(ithtb ,iptb ) + q10=qstab(ithtb+1,iptb ) + q01=qstab(ithtb ,iptb+1) + q11=qstab(ithtb+1,iptb+1) +! +!*********************************************************************** +! parcel temperature +!*********************************************************************** +! + temp=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) +! + qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) +! + DQ=QS-QU + IF(DQ.LE.0.)THEN + QNEW=QU-QS + QU=QS + ELSE +! +! IF THE PARCEL IS SUBSATURATED, TEMPERATURE AND MIXING RATIO MUST BE +! ADJUSTED...IF LIQUID WATER IS PRESENT, IT IS ALLOWED TO EVAPORATE +! + QNEW=0. + QTOT=QLIQ+QICE +! +! IF THERE IS ENOUGH LIQUID OR ICE TO SATURATE THE PARCEL, TEMP STAYS AT ITS +! WET BULB VALUE, VAPOR MIXING RATIO IS AT SATURATED LEVEL, AND THE MIXING +! RATIOS OF LIQUID AND ICE ARE ADJUSTED TO MAKE UP THE ORIGINAL SATURATION +! DEFICIT... OTHERWISE, ANY AVAILABLE LIQ OR ICE VAPORIZES AND APPROPRIATE +! ADJUSTMENTS TO PARCEL TEMP; VAPOR, LIQUID, AND ICE MIXING RATIOS ARE MADE. +! +!...subsaturated values only occur in calculations involving various mixtures of +!...updraft and environmental air for estimation of entrainment and detrainment. +!...For these purposes, assume that reasonable estimates can be given using +!...liquid water saturation calculations only - i.e., ignore the effect of the +!...ice phase in this process only...will not affect conservative properties... +! + IF(QTOT.GE.DQ)THEN + qliq=qliq-dq*qliq/(qtot+1.e-10) + qice=qice-dq*qice/(qtot+1.e-10) + QU=QS + ELSE + RLL=XLV0-XLV1*TEMP + CPP=1004.5*(1.+0.89*QU) + IF(QTOT.LT.1.E-10)THEN +! +!...IF NO LIQUID WATER OR ICE IS AVAILABLE, TEMPERATURE IS GIVEN BY: + TEMP=TEMP+RLL*(DQ/(1.+DQ))/CPP + ELSE +! +!...IF SOME LIQ WATER/ICE IS AVAILABLE, BUT NOT ENOUGH TO ACHIEVE SATURATION, +! THE TEMPERATURE IS GIVEN BY: +! + TEMP=TEMP+RLL*((DQ-QTOT)/(1+DQ-QTOT))/CPP + QU=QU+QTOT + QTOT=0. + QLIQ=0. + QICE=0. + ENDIF + ENDIF + ENDIF + TU=TEMP + qnewlq=qnew + qnewic=0. +! + END SUBROUTINE TPMIX2 +!****************************************************************************** + SUBROUTINE DTFRZNEW(TU,P,THTEU,QU,QFRZ,QICE,ALIQ,BLIQ,CLIQ,DLIQ) +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,QFRZ,ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(INOUT) :: TU,THTEU,QU,QICE + REAL :: RLC,RLS,RLF,CPP,A,DTFRZ,ES,QS,DQEVAP,PII +!----------------------------------------------------------------------- +! +!...ALLOW THE FREEZING OF LIQUID WATER IN THE UPDRAFT TO PROCEED AS AN +!...APPROXIMATELY LINEAR FUNCTION OF TEMPERATURE IN THE TEMPERATURE RANGE +!...TTFRZ TO TBFRZ... +!...FOR COLDER TERMPERATURES, FREEZE ALL LIQUID WATER... +!...THERMODYNAMIC PROPERTIES ARE STILL CALCULATED WITH RESPECT TO LIQUID WATER +!...TO ALLOW THE USE OF LOOKUP TABLE TO EXTRACT TMP FROM THETAE... +! + RLC=2.5E6-2369.276*(TU-273.16) + RLS=2833922.-259.532*(TU-273.16) + RLF=RLS-RLC + CPP=1004.5*(1.+0.89*QU) +! +! A = D(es)/DT IS THAT CALCULATED FROM BUCK (1981) EMPERICAL FORMULAS +! FOR SATURATION VAPOR PRESSURE... +! + A=(CLIQ-BLIQ*DLIQ)/((TU-DLIQ)*(TU-DLIQ)) + DTFRZ = RLF*QFRZ/(CPP+RLS*QU*A) + TU = TU+DTFRZ + + ES = ALIQ*EXP((BLIQ*TU-CLIQ)/(TU-DLIQ)) + QS = ES*0.622/(P-ES) +! +!...FREEZING WARMS THE AIR AND IT BECOMES UNSATURATED...ASSUME THAT SOME OF THE +!...LIQUID WATER THAT IS AVAILABLE FOR FREEZING EVAPORATES TO MAINTAIN SATURA- +!...TION...SINCE THIS WATER HAS ALREADY BEEN TRANSFERRED TO THE ICE CATEGORY, +!...SUBTRACT IT FROM ICE CONCENTRATION, THEN SET UPDRAFT MIXING RATIO AT THE NEW +!...TEMPERATURE TO THE SATURATION VALUE... +! + DQEVAP = QS-QU + QICE = QICE-DQEVAP + QU = QU+DQEVAP + PII=(1.E5/P)**(0.2854*(1.-0.28*QU)) + THTEU=TU*PII*EXP((3374.6525/TU-2.5403)*QU*(1.+0.81*QU)) +! + END SUBROUTINE DTFRZNEW +! -------------------------------------------------------------------------------- + + SUBROUTINE CONDLOAD(QLIQ,QICE,WTW,DZ,BOTERM,ENTERM,RATE,QNEWLQ, & + QNEWIC,QLQOUT,QICOUT,G) + +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- +! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US +! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- +! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- +! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL +! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). + + REAL, INTENT(IN ) :: G + REAL, INTENT(IN ) :: DZ,BOTERM,ENTERM,RATE + REAL, INTENT(INOUT) :: QLQOUT,QICOUT,WTW,QLIQ,QICE,QNEWLQ,QNEWIC + REAL :: QTOT,QNEW,QEST,G1,WAVG,CONV,RATIO3,OLDQ,RATIO4,DQ,PPTDRG + +! +! 9/18/88...THIS PRECIPITATION FALLOUT SCHEME IS BASED ON THE SCHEME US +! BY OGURA AND CHO (1973). LIQUID WATER FALLOUT FROM A PARCEL IS CAL- +! CULATED USING THE EQUATION DQ=-RATE*Q*DT, BUT TO SIMULATE A QUASI- +! CONTINUOUS PROCESS, AND TO ELIMINATE A DEPENDENCY ON VERTICAL +! RESOLUTION THIS IS EXPRESSED AS Q=Q*EXP(-RATE*DZ). + QTOT=QLIQ+QICE + QNEW=QNEWLQ+QNEWIC +! +! ESTIMATE THE VERTICAL VELOCITY SO THAT AN AVERAGE VERTICAL VELOCITY +! BE CALCULATED TO ESTIMATE THE TIME REQUIRED FOR ASCENT BETWEEN MODEL +! LEVELS... +! + QEST=0.5*(QTOT+QNEW) + G1=WTW+BOTERM-ENTERM-2.*G*DZ*QEST/1.5 + IF(G1.LT.0.0)G1=0. + WAVG=0.5*(SQRT(WTW)+SQRT(G1)) + CONV=RATE*DZ/WAVG +! +! RATIO3 IS THE FRACTION OF LIQUID WATER IN FRESH CONDENSATE, RATIO4 IS +! THE FRACTION OF LIQUID WATER IN THE TOTAL AMOUNT OF CONDENSATE INVOLV +! IN THE PRECIPITATION PROCESS - NOTE THAT ONLY 60% OF THE FRESH CONDEN +! SATE IS IS ALLOWED TO PARTICIPATE IN THE CONVERSION PROCESS... +! + RATIO3=QNEWLQ/(QNEW+1.E-8) +! OLDQ=QTOT + QTOT=QTOT+0.6*QNEW + OLDQ=QTOT + RATIO4=(0.6*QNEWLQ+QLIQ)/(QTOT+1.E-8) + QTOT=QTOT*EXP(-CONV) +! +! DETERMINE THE AMOUNT OF PRECIPITATION THAT FALLS OUT OF THE UPDRAFT +! PARCEL AT THIS LEVEL... +! + DQ=OLDQ-QTOT + QLQOUT=RATIO4*DQ + QICOUT=(1.-RATIO4)*DQ +! +! ESTIMATE THE MEAN LOAD OF CONDENSATE ON THE UPDRAFT IN THE LAYER, CAL +! LATE VERTICAL VELOCITY +! + PPTDRG=0.5*(OLDQ+QTOT-0.2*QNEW) + WTW=WTW+BOTERM-ENTERM-2.*G*DZ*PPTDRG/1.5 + IF(ABS(WTW).LT.1.E-4)WTW=1.E-4 +! +! DETERMINE THE NEW LIQUID WATER AND ICE CONCENTRATIONS INCLUDING LOSSE +! DUE TO PRECIPITATION AND GAINS FROM CONDENSATION... +! + QLIQ=RATIO4*QTOT+RATIO3*0.4*QNEW + QICE=(1.-RATIO4)*QTOT+(1.-RATIO3)*0.4*QNEW + QNEWLQ=0. + QNEWIC=0. + + END SUBROUTINE CONDLOAD + +! ---------------------------------------------------------------------- + SUBROUTINE PROF5(EQ,EE,UD) +! +!*********************************************************************** +!***** GAUSSIAN TYPE MIXING PROFILE....****************************** +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +! THIS SUBROUTINE INTEGRATES THE AREA UNDER THE CURVE IN THE GAUSSIAN +! DISTRIBUTION...THE NUMERICAL APPROXIMATION TO THE INTEGRAL IS TAKEN FROM +! "HANDBOOK OF MATHEMATICAL FUNCTIONS WITH FORMULAS, GRAPHS AND MATHEMATICS TABLES" +! ED. BY ABRAMOWITZ AND STEGUN, NATL BUREAU OF STANDARDS APPLIED +! MATHEMATICS SERIES. JUNE, 1964., MAY, 1968. +! JACK KAIN +! 7/6/89 +!CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC +!----------------------------------------------------------------------- + IMPLICIT NONE +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: EQ + REAL, INTENT(INOUT) :: EE,UD + REAL :: SQRT2P,A1,A2,A3,P,SIGMA,FE,X,Y,EY,E45,T1,T2,C1,C2 + + DATA SQRT2P,A1,A2,A3,P,SIGMA,FE/2.506628,0.4361836,-0.1201676, & + 0.9372980,0.33267,0.166666667,0.202765151/ + X=(EQ-0.5)/SIGMA + Y=6.*EQ-3. + EY=EXP(Y*Y/(-2)) + E45=EXP(-4.5) + T2=1./(1.+P*ABS(Y)) + T1=0.500498 + C1=A1*T1+A2*T1*T1+A3*T1*T1*T1 + C2=A1*T2+A2*T2*T2+A3*T2*T2*T2 + IF(Y.GE.0.)THEN + EE=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*(0.5+EQ*EQ/2.- & + EQ) + ELSE + EE=SIGMA*(0.5*(EY*C2-E45*C1)+SIGMA*(E45-EY))-E45*EQ*EQ/2. + UD=SIGMA*(0.5*(SQRT2P-E45*C1-EY*C2)+SIGMA*(E45-EY))-E45*(0.5+EQ* & + EQ/2.-EQ) + ENDIF + EE=EE/FE + UD=UD/FE + + END SUBROUTINE PROF5 + +! ------------------------------------------------------------------------ + SUBROUTINE TPMIX2DD(p,thes,ts,qs,i,j) +! +! Lookup table variables: +! INTEGER, PARAMETER :: (KFNT=250,KFNP=220) +! REAL, SAVE, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB +! REAL, SAVE, DIMENSION(1:KFNP) :: THE0K +! REAL, SAVE, DIMENSION(1:200) :: ALU +! REAL, SAVE :: RDPR,RDTHK,PLUTOP +! End of Lookup table variables: +!----------------------------------------------------------------------- + use kftable_mod + + IMPLICIT NONE +! include 'include_kftable' + +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P,THES + REAL, INTENT(INOUT) :: TS,QS + INTEGER, INTENT(IN ) :: i,j ! avail for debugging + REAL :: TP,QQ,BTH,TTH,PP,T00,T10,T01,T11,Q00,Q10,Q01,Q11 + INTEGER :: IPTB,ITHTB + CHARACTER*256 :: MESS +!----------------------------------------------------------------------- + +! +!******** LOOKUP TABLE VARIABLES (F77 format)... **************************** +! parameter(kfnt=250,kfnp=220) +! +! COMMON/KFLUT/ ttab(kfnt,kfnp),qstab(kfnt,kfnp),the0k(kfnp), & +! alu(200),rdpr,rdthk,plutop +!*************************************************************** +! +!*********************************************************************** +! scaling pressure and tt table index +!*********************************************************************** +! + tp=(p-plutop)*rdpr + qq=tp-aint(tp) + iptb=int(tp)+1 +! +!*********************************************************************** +! base and scaling factor for the +!*********************************************************************** +! +! scaling the and tt table index + bth=(the0k(iptb+1)-the0k(iptb))*qq+the0k(iptb) + tth=(thes-bth)*rdthk + pp =tth-aint(tth) + ithtb=int(tth)+1 +! + t00=ttab(ithtb ,iptb ) + t10=ttab(ithtb+1,iptb ) + t01=ttab(ithtb ,iptb+1) + t11=ttab(ithtb+1,iptb+1) +! + q00=qstab(ithtb ,iptb ) + q10=qstab(ithtb+1,iptb ) + q01=qstab(ithtb ,iptb+1) + q11=qstab(ithtb+1,iptb+1) +! +!*********************************************************************** +! parcel temperature and saturation mixing ratio +!*********************************************************************** +! + ts=(t00+(t10-t00)*pp+(t01-t00)*qq+(t00-t10-t01+t11)*pp*qq) +! + qs=(q00+(q10-q00)*pp+(q01-q00)*qq+(q00-q10-q01+q11)*pp*qq) +! + END SUBROUTINE TPMIX2DD + +! ----------------------------------------------------------------------- + SUBROUTINE ENVIRTHT(P1,T1,Q1,THT1,ALIQ,BLIQ,CLIQ,DLIQ) +! +!----------------------------------------------------------------------- + use kftable_mod + IMPLICIT NONE +! include 'include_kftable' + +!----------------------------------------------------------------------- + REAL, INTENT(IN ) :: P1,T1,Q1,ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(INOUT) :: THT1 + REAL :: EE,TLOG,ASTRT,AINC,A1,TP,VALUE,AINTRP,TDPT,TSAT,THT, & + T00,P00,C1,C2,C3,C4,C5 + INTEGER :: INDLU +!----------------------------------------------------------------------- + DATA T00,P00,C1,C2,C3,C4,C5/273.16,1.E5,3374.6525,2.5403,3114.834, & + 0.278296,1.0723E-3/ +! +! CALCULATE ENVIRONMENTAL EQUIVALENT POTENTIAL TEMPERATURE... +! +! NOTE: Calculations for mixed/ice phase no longer used...jsk 8/00 +! + EE=Q1*P1/(0.622+Q1) +! TLOG=ALOG(EE/ALIQ) +! ...calculate LOG term using lookup table... +! + astrt=1.e-3 + ainc=0.075 + a1=ee/aliq + tp=(a1-astrt)/ainc + indlu=int(tp)+1 + value=(indlu-1)*ainc+astrt + aintrp=(a1-value)/ainc + tlog=aintrp*alu(indlu+1)+(1-aintrp)*alu(indlu) +! + TDPT=(CLIQ-DLIQ*TLOG)/(BLIQ-TLOG) + TSAT=TDPT-(.212+1.571E-3*(TDPT-T00)-4.36E-4*(T1-T00))*(T1-TDPT) + THT=T1*(P00/P1)**(0.2854*(1.-0.28*Q1)) + THT1=THT*EXP((C1/TSAT-C2)*Q1*(1.+0.81*Q1)) +! + END SUBROUTINE ENVIRTHT +! *********************************************************************** +!==================================================================== + SUBROUTINE kf_eta_init(RTHCUTEN,RQVCUTEN,RQCCUTEN,RQRCUTEN, & + RQICUTEN,RQSCUTEN,NCA,W0AVG,P_QI,P_QS, & + SVP1,SVP2,SVP3,SVPT0, & + P_FIRST_SCALAR,restart,allowed_to_read, & + ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte ) +!-------------------------------------------------------------------- + IMPLICIT NONE +!-------------------------------------------------------------------- + LOGICAL , INTENT(IN) :: restart,allowed_to_read + INTEGER , INTENT(IN) :: ids, ide, jds, jde, kds, kde, & + ims, ime, jms, jme, kms, kme, & + its, ite, jts, jte, kts, kte + INTEGER , INTENT(IN) :: P_QI,P_QS,P_FIRST_SCALAR + + REAL, DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: & + RTHCUTEN, & + RQVCUTEN, & + RQCCUTEN, & + RQRCUTEN, & + RQICUTEN, & + RQSCUTEN + + REAL , DIMENSION( ims:ime , kms:kme , jms:jme ) , INTENT(OUT) :: W0AVG + + REAL, DIMENSION( ims:ime , jms:jme ), INTENT(INOUT):: NCA + + INTEGER :: i, j, k, itf, jtf, ktf + REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 + + jtf=min0(jte,jde-1) + ktf=min0(kte,kde-1) + itf=min0(ite,ide-1) + + IF(.not.restart)THEN + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RTHCUTEN(i,k,j)=0. + RQVCUTEN(i,k,j)=0. + RQCCUTEN(i,k,j)=0. + RQRCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + IF (P_QI .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQICUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + IF (P_QS .ge. P_FIRST_SCALAR) THEN + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + RQSCUTEN(i,k,j)=0. + ENDDO + ENDDO + ENDDO + ENDIF + + DO j=jts,jtf + DO i=its,itf + NCA(i,j)=-100. + ENDDO + ENDDO + + DO j=jts,jtf + DO k=kts,ktf + DO i=its,itf + W0AVG(i,k,j)=0. + ENDDO + ENDDO + ENDDO + + endif + + CALL KF_LUTAB(SVP1,SVP2,SVP3,SVPT0) + + END SUBROUTINE kf_eta_init + +!------------------------------------------------------- + + subroutine kf_lutab(SVP1,SVP2,SVP3,SVPT0) +! +! This subroutine is a lookup table. +! Given a series of series of saturation equivalent potential +! temperatures, the temperature is calculated. +! +!-------------------------------------------------------------------- + use kftable_mod + IMPLICIT NONE +! include 'include_kftable' + + INTEGER :: KP,IT,ITCNT,I + REAL :: DTH,TMIN,TOLER,PBOT,DPR, & + TEMP,P,ES,QS,PI,THES,TGUES,THGUES,F0,T1,T0,THGS,F1,DT, & + ASTRT,AINC,A1,THTGS +! REAL :: ALIQ,BLIQ,CLIQ,DLIQ,SVP1,SVP2,SVP3,SVPT0 + REAL :: ALIQ,BLIQ,CLIQ,DLIQ + REAL, INTENT(IN) :: SVP1,SVP2,SVP3,SVPT0 +! +! equivalent potential temperature increment + data dth/1./ +! minimum starting temp + data tmin/150./ +! tolerance for accuracy of temperature + data toler/0.001/ +! top pressure (pascals) + plutop=5000.0 +! bottom pressure (pascals) + pbot=110000.0 + + ALIQ = SVP1*1000. + BLIQ = SVP2 + CLIQ = SVP2*SVPT0 + DLIQ = SVP3 + +! +! compute parameters +! +! 1._over_(sat. equiv. theta increment) + rdthk=1./dth +! pressure increment +! + DPR=(PBOT-PLUTOP)/REAL(KFNP-1) +! dpr=(pbot-plutop)/REAL(kfnp-1) +! 1._over_(pressure increment) + rdpr=1./dpr +! compute the spread of thes +! thespd=dth*(kfnt-1) +! +! calculate the starting sat. equiv. theta +! + temp=tmin + p=plutop-dpr + do kp=1,kfnp + p=p+dpr + es=aliq*exp((bliq*temp-cliq)/(temp-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + the0k(kp)=temp*pi*exp((3374.6525/temp-2.5403)*qs* & + (1.+0.81*qs)) + enddo +! +! compute temperatures for each sat. equiv. potential temp. +! + p=plutop-dpr + do kp=1,kfnp + thes=the0k(kp)-dth + p=p+dpr + do it=1,kfnt +! define sat. equiv. pot. temp. + thes=thes+dth +! iterate to find temperature +! find initial guess + if(it.eq.1) then + tgues=tmin + else + tgues=ttab(it-1,kp) + endif + es=aliq*exp((bliq*tgues-cliq)/(tgues-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + thgues=tgues*pi*exp((3374.6525/tgues-2.5403)*qs* & + (1.+0.81*qs)) + f0=thgues-thes + t1=tgues-0.5*f0 + t0=tgues + itcnt=0 +! iteration loop + do itcnt=1,11 + es=aliq*exp((bliq*t1-cliq)/(t1-dliq)) + qs=0.622*es/(p-es) + pi=(1.e5/p)**(0.2854*(1.-0.28*qs)) + thtgs=t1*pi*exp((3374.6525/t1-2.5403)*qs*(1.+0.81*qs)) + f1=thtgs-thes + if(abs(f1).lt.toler)then + exit + endif +! itcnt=itcnt+1 + dt=f1*(t1-t0)/(f1-f0) + t0=t1 + f0=f1 + t1=t1-dt + enddo + ttab(it,kp)=t1 + qstab(it,kp)=qs + enddo + enddo +! +! lookup table for tlog(emix/aliq) +! +! set up intial values for lookup tables +! + astrt=1.e-3 + ainc=0.075 +! + a1=astrt-ainc + do i=1,200 + a1=a1+ainc + alu(i)=alog(a1) + enddo +! + END SUBROUTINE KF_LUTAB + diff --git a/src_flexwrf_v3.1/convmix.f90 b/src_flexwrf_v3.1/convmix.f90 new file mode 100644 index 0000000000000000000000000000000000000000..38a2bde3d7fc19ca57e527e1edb9988ab782b572 --- /dev/null +++ b/src_flexwrf_v3.1/convmix.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!*********************************************************************** + 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,stat + integer :: jy, kpart, ktop, ngrid,kz +! integer :: igrid(maxpart), ipoint(maxpart), igridn(maxpart,maxnests) + integer,allocatable, dimension (:) :: igrid,ipoint + integer,allocatable, dimension (:,:) :: igridn + + ! 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 + + real :: duma, dumz(nuvzmax+1) + + write(*,'(//a,a//)') & + '*** Stopping in subr. convmix ***', & + ' This is not implemented for FLEXPART_WRF' + stop + + allocate(igrid(maxpart) ,stat=stat) + allocate(ipoint(maxpart) ,stat=stat) + allocate(igridn(maxpart,maxnests) ,stat=stat) + + + return + end subroutine convmix diff --git a/src_flexwrf_v3.1/convmix_kfeta.f90 b/src_flexwrf_v3.1/convmix_kfeta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..aa91978bab091170649feb881db773f7fec6551b --- /dev/null +++ b/src_flexwrf_v3.1/convmix_kfeta.f90 @@ -0,0 +1,627 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine convmix_kfeta(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 + +! CHANGED on 10.10.2007 save convective mass fluxes, update them every dt_conv + +! CHANGED by Weiguo WANG 13 Aug, 2007, use KFeta CU convection scheme +! +! Changes by J. Brioude: particles sorting is much more efficient. +! +! input for kftea cumulus scheme +! u1d - 1-d u wind velocity profile +! v1d - 1-d v wind velocity profile +! t1d - 1-D temperture (K) +! qv1d- 1-D water vapor mixin gratio (kg/kg) +! p1d - 1-D pressure profile (pa) +! rho1d-1-D density profile (kg/m3) +! w0avg1d - 1-D vertical velocity (m/s) +! all above are defined at T-point or P-poit +! dz1d - dz between full levels +! delx - grid size of column (m) +! dt - integraiton time step (s) +! cudt - cumulus activation time interval (min) +! kts - starting point in z for convection calculation +! kte - ending point + +! output +! umf - updraft mass flux +! uer - updraft entrainment flux +! udr - updraft detrainment flux +! dmf - downdraft mass flux +! der - downdraft entrainemnt flux +! ddr - downdraft detrainment flux +! cu_top1 -- top of cumulus cloud (index? for height) +! cu_bot1 -- bottom of cumulus cloud (index) + +!************************************************************** + + 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,kzp,a + 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,warm_rain + real :: x, y, xtn,ytn, ztold, delt + real :: dt1,dt2,dtt,dummy + real :: duma, dumz(nuvzmax+1) + integer :: mind1,mind2 + ! dt1,dt2,dtt,mind1,mind2 variables used for time interpolation + integer :: itage,nage,duminc + real,parameter :: eps=nxmax/3.e5 + + integer :: i,k,numberp(maxpart) +!-- for KFeta + real, dimension(nuvzmax):: u1d,v1d,t1d,dz1d,qv1d,p1d, & + rho1d,w0avg1d,umf,uer,udr, & + dmf,der,ddr,zh + real :: cudt,delx,dt,cu_bot1,cu_top1,zp,fmix + real, dimension(nuvzmax+1):: umfzf,dmfzf,zf + integer :: kts,kte,if_update +! + +! monitoring variables + real :: sumconv,sumall,sumpart + integer :: sumpartgrid(1000000) + +! print *, "IN convmix_kfeta" +! write(*,'(//a,a//)') +! & '*** Stopping in subr. convmix ***', +! & ' This is not implemented for FLEXPART_WRF' +! stop + + +! Calculate auxiliary variables for time interpolation +!***************************************************** + + delt=real(abs(lsynctime)) + +! dt_conv is given from input namelist +! dt_conv=3600.0 + if_update=0 + if ( mod(real(itime),dt_conv) .eq. 0 ) if_update=1 +! print*,'conv itime',itime,dt_conv,if_update + +! delt=dt_conv + + + dt1=real(itime-memtime(1)) + dt2=real(memtime(2)-itime) + dtt=1./(dt1+dt2) + mind1=memind(1) + mind2=memind(2) + + lconv = .false. + +! for KFeta +! warm_rain=.true. ! depends on mp_physics in WRF, may add an option in the future + cudt = 10.0 ! cumulus para is called every 10 min in a time step, if dt < cudt, call once + + kts=1 + kte=nuvz-1 + +! 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 +!************************************************************************ +! print*,'step1' + do ipart=1,numpart + igrid(ipart)=-1 + do j=numbnests,1,-1 + igridn(ipart,j)=-1 + enddo + 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 + + sumpart = 0. + sumconv = 0. + +! print*,'step2' + +!************************************************************************************** +! 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. +!************************************************************************************** + delx = dx + +! sort particles according to horizontal position and calculate index vector IPOINT + + call sort2(numpart,igrid,ipoint) +! print*,'step2 after sort',minval(igrid),maxval(igrid),numpart + +! count particle # in each column +! do 40 i=abs(minval(igrid)),maxval(igrid) +! sumpart=0. +! do 41 k=1,numpart +! if(igrid(k) .eq. i) then +! sumpart=sumpart+1 +! endif +!41 continue +! do 42 k=1,numparc Changes by J. Brioude: the sort of particles is much more efficient.t +!42 if(igrid(k) .eq. i) numberp(k)=int(sumpart) +!40 continue +! JB + if (maxval(igrid).gt.1000000) then + print*,'too much x and y grid. modify convmix_kfeta.f' + stop + endif + do k=1,1000000 + sumpartgrid(k)=0 + enddo + do k=1,numpart + if (igrid(k).gt.0) sumpartgrid(igrid(k))=sumpartgrid(igrid(k))+1 + enddo + do k=1,numpart + if (igrid(k).gt.0) then + numberp(k)=sumpartgrid(igrid(k)) + else + numberp(k)=0 + endif + enddo + +! print*,'step3',numpart + +! Now visit all grid columns where particles are present +! by going through the sorted particles + + igrold = -1 + a=0 + do kpart=1,numpart + igr = igrid(kpart) + if (igr .eq. -1 .or. numberp(kpart).le.20 & +! if (igr .eq. -1 + ) goto 50 + ipart = ipoint(kpart) + +! sumall = sumall + 1 +!c For one column, we only need to compute 1D met once + + if (igr .ne. igrold) then + sumconv=sumconv+1 +! we are in a new grid column + jy = (igr-1)/nx + ix = igr - jy*nx - 1 + a=a+1 +! print*,'a',a +! Interpolate all meteorological data needed for the convection scheme + + do kz=1,nuvz-1 ! nconvlev+1 +! FLEXPART_WRF - used add_sfc_level for the shifting +! for W, it is not shifted, make sure w is 'true' vertical velocity! + + kzp = kz + add_sfc_level + u1d(kz)=(u_wrf(ix,jy,kzp,mind1)*dt2+ & + u_wrf(ix,jy,kzp,mind2)*dt1)*dtt + v1d(kz)=(v_wrf(ix,jy,kzp,mind1)*dt2+ & + v_wrf(ix,jy,kzp,mind2)*dt1)*dtt + t1d(kz)=(tth(ix,jy,kzp,mind1)*dt2+ & + tth(ix,jy,kzp,mind2)*dt1)*dtt + qv1d(kz)=(qvh(ix,jy,kzp,mind1)*dt2+ & + qvh(ix,jy,kzp,mind2)*dt1)*dtt + p1d(kz)=(pph(ix,jy,kzp,mind1)*dt2+ & + pph(ix,jy,kzp,mind2)*dt1)*dtt + dz1d(kz)=(zzh(ix,jy,kzp+1,mind1)*dt2+ & + zzh(ix,jy,kzp+1,mind2)*dt1)*dtt- & + (zzh(ix,jy,kzp,mind1)*dt2+ & + zzh(ix,jy,kzp,mind2)*dt1)*dtt + w0avg1d(kz)=(w_wrf(ix,jy,kz,mind1)*dt2+ & + w_wrf(ix,jy,kz,mind2)*dt1)*dtt+ & + (w_wrf(ix,jy,kz+1,mind1)*dt2+ & + w_wrf(ix,jy,kz+1,mind2)*dt1)*dtt + w0avg1d(kz)=0.5*w0avg1d(kz) + rho1d(kz)=p1d(kz)/ & + (t1d(kz)*(1.0+0.608*qv1d(kz))) & + /287.0 + +! write(*,'(1x,I10,10F10.2)')kz,u1d(kz),v1d(kz),w0avg1d(kz), +! & t1d(kz),qv1d(kz),p1d(kz)/100,dz1d(kz) + + + enddo + +! -- old convective mass fluxes + do k=kts,kte + umf(k)=umf3(ix,jy,k) + uer(k)=uer3(ix,jy,k) + udr(k)=udr3(ix,jy,k) + dmf(k)=dmf3(ix,jy,k) + der(k)=der3(ix,jy,k) + ddr(k)=ddr3(ix,jy,k) + enddo + cu_top1=cu_top(ix,jy) + cu_bot1=cu_bot(ix,jy) + + +! write(*,*)'1-D wind' + +! Calculate convection flux, updrought flux, entrainment, detrainment flux +! downdraft flux, entrainment ,detrainment flux + warm_rain=.false. + if (mp_physics .eq. 1) warm_rain = .true. +! -- Update fluxes + if (if_update .eq. 1 ) then !! if_update +! write(*,*)'update convective fluxes, itime=',itime/3600. +! print*,u1d(4:8),v1d(4:8),t1d(4:8),dz1d(4:8),qv1d(4:8) +! print*,p1d(4:8),rho1d(4:8),w0avg1d(4:8) +! print*,cudt,delx,dt_conv,warm_rain +! print*,'attend' +! pause + CALL KF_ETA(nuvzmax,u1d,v1d,t1d,dz1d,qv1d,p1d, & ! IN + rho1d,w0avg1d,cudt,delx,dt_conv,warm_rain,kts,kte, & ! IN + umf,uer,udr,dmf,der,ddr,cu_bot1,cu_top1) ! OUT + dummy=0. + do k=kts,kte + umf3(ix,jy,k)=umf(k) + uer3(ix,jy,k)=uer(k) + udr3(ix,jy,k)=udr(k) + dmf3(ix,jy,k)=dmf(k) + der3(ix,jy,k)=der(k) + ddr3(ix,jy,k)=ddr(k) + dummy=dummy+umf(k)+uer(k)+udr(k) + enddo + if (dummy.gt.0.) then +! print*,'dummy',dummy + duminc=1 + else + duminc=0 + endif + cu_top(ix,jy)=cu_top1 + cu_bot(ix,jy)=cu_bot1 +! if (cu_top1.gt.1.) print*,'cu h',cu_bot1,cu_top1 + endif !! if_update +! if (a.gt.2000) then +! print*,'after kf_eta',a +! a=0 +! endif + +! write(*,*)'ix,jy=',ix,jy,itime +! write(*,*)'previous column part#=',sumpart +! write(*,*)'FLUX,k,umf,uer,udr,dmf,der,ddr' +! write(*,*)'cu_bot1,cu_top1=',cu_bot1,cu_top1 +! if (cu_top1 .lt. cu_bot1) write(*,*)'umf=', umf(1),umf(10) + +! do kz=kts,kte +! write(*,'(1x,I10,10E10.2)')kz,umf(kz),uer(kz),udr(kz),dmf(kz) +! & ,der(kz),ddr(kz),p1d(kz)/100 + +! enddo + + sumpart=0 + IF (cu_top1 .gt. cu_bot1+1 ) then ! lconv +! write(250+lconvection,*)'-1',itime,ix,jy + lconv = .true. + +! Prepare data for redistributing particle + + CALL pre_redist_kf(nuvzmax,nuvz,umf,dmf,dz1d,p1d,delx,delt, & ! IN + cu_bot1,cu_top1, & ! IN + zf,zh, & ! OUT + umfzf,dmfzf,fmix) ! OUT + + else + lconv= .false. + + ENDIF ! lconv + + + igrold = igr + ktop = 0 + endif + + sumpart=sumpart+1 +! treat particle only if column has convection + if (lconv .eqv. .true.) then +! assign new vertical position to particle +! ztold=ztra1(ipart) + zp=ztra1(ipart) +!C write(*,*)'befrore convection zp= ',zp + +! write(*,*)'part No =',sumpart + CALL redist_kf(lconvection,ldirect,delt,delx, & ! IN + dz1d,nzmax, nz,umf,uer,udr,dmf, & ! IN + der,ddr,rho1d, & ! IN + zf,zh, & ! IN + umfzf,dmfzf,fmix, & ! IN + zp) ! IN/OUT + + if (zp .lt. 0.0) zp=-1.0*zp + if (zp .gt. height(nz)-0.5) & + zp = height(nz)-0.5 +! if (abs(zp-ztra1(ipart)) .ge. 1e-5) +! &write(250+lconvection,*)ztra1(ipart),zp,zp-ztra1(ipart) +! if (duminc.eq.1) +! + print*,'true conv',dummy,zp-ztra1(ipart),cu_top1-cu_bot1 + + ztra1(ipart) = zp +!C write(*,*)'after convection, zp=',zp + +!C OLD 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 + enddo + 37 continue +! print*,'step 4' + + if (nage.le.nageclass) & + call calcfluxes(nage,ipart,real(xtra1(ipart)), & + real(ytra1(ipart)),ztold) + endif + + endif !(lconv .eqv. .true) + enddo + 50 continue + +! write(*,*)'total convective columns=',sumconv, +! & 'time=', 1.0*itime/3600 + +!*********************************************************************************** +! 2. Nested domains +!*********************************************************************************** + +! sort particles according to horizontal position and calculate index vector IPOINT + + do inest=1,numbnests + delx = dxn(inest) + if (delx .le. 10000.0) goto 70 ! for small grid size, no need to do convection + do ipart=1,numpart + ipoint(ipart)=ipart + igrid(ipart) = igridn(ipart,inest) + enddo + call sort2(numpart,igrid,ipoint) + +! print*,'step in nest' +! 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 + +! Interpolate all meteorological data needed for the convection scheme + + do kz=1,nuvz ! nconvlev+1 +! FLEXPART_WRF - used add_sfc_level for the shifting +! for W, it is not shifted, make sure w is 'true' vertical velocity! + + kzp = kz + add_sfc_level + u1d(kz)=(un_wrf(ix,jy,kzp,mind1,inest)*dt2+ & + un_wrf(ix,jy,kzp,mind2,inest)*dt1)*dtt + v1d(kz)=(vn_wrf(ix,jy,kzp,mind1,inest)*dt2+ & + vn_wrf(ix,jy,kzp,mind2,inest)*dt1)*dtt + t1d(kz)=(tthn(ix,jy,kzp,mind1,inest)*dt2+ & + tthn(ix,jy,kzp,mind2,inest)*dt1)*dtt + qv1d(kz)=(qvhn(ix,jy,kzp,mind1,inest)*dt2+ & + qvhn(ix,jy,kzp,mind2,inest)*dt1)*dtt + p1d(kz)=(pphn(ix,jy,kzp,mind1,inest)*dt2+ & + pphn(ix,jy,kzp,mind2,inest)*dt1)*dtt + dz1d(kz)=(zzhn(ix,jy,kzp+1,mind1,inest)*dt2+ & + zzhn(ix,jy,kzp+1,mind2,inest)*dt1)*dtt- & + (zzhn(ix,jy,kzp,mind1,inest)*dt2+ & + zzhn(ix,jy,kzp,mind2,inest)*dt1)*dtt + w0avg1d(kz)=(wn_wrf(ix,jy,kz,mind1,inest)*dt2+ & + wn_wrf(ix,jy,kz,mind2,inest)*dt1)*dtt+ & + (wn_wrf(ix,jy,kz+1,mind1,inest)*dt2+ & + wn_wrf(ix,jy,kz+1,mind2,inest)*dt1)*dtt + w0avg1d(kz)=0.5*w0avg1d(kz) + rho1d(kz)=p1d(kz)/ & + (t1d(kz)*(1.0+0.608*qv1d(kz))) & + /287.0 + + enddo + +!C Old convective mass fluxes + do k=kts,kte + umf(k)=umf3n(ix,jy,k,inest) + uer(k)=uer3n(ix,jy,k,inest) + udr(k)=udr3n(ix,jy,k,inest) + dmf(k)=dmf3n(ix,jy,k,inest) + der(k)=der3n(ix,jy,k,inest) + ddr(k)=ddr3n(ix,jy,k,inest) + enddo + cu_top1=cu_topn(ix,jy,inest) + cu_bot1=cu_botn(ix,jy,inest) + + + +!alculate convection flux, updrought flux, entrainment, detrainment flux +! downdraft flux, entrainment ,detrainment flux + warm_rain = .false. + if (mp_physicsn(inest) .eq. 1 ) warm_rain = .true. + + if (if_update .eq. 1 ) then !!! update + CALL KF_ETA(nuvzmax,u1d,v1d,t1d,dz1d,qv1d,p1d, & ! IN + rho1d,w0avg1d,cudt,delx,dt_conv,warm_rain,kts,kte, & ! IN + umf,uer,udr,dmf,der,ddr,cu_bot1,cu_top1) ! OUT + do k=kts,kte + umf3n(ix,jy,k,inest)=umf(k) + uer3n(ix,jy,k,inest)=uer(k) + udr3n(ix,jy,k,inest)=udr(k) + dmf3n(ix,jy,k,inest)=dmf(k) + der3n(ix,jy,k,inest)=der(k) + ddr3n(ix,jy,k,inest)=ddr(k) + enddo + cu_topn(ix,jy,inest)=cu_top1 + cu_botn(ix,jy,inest)=cu_bot1 + endif !!! update + + + + IF (cu_top1 .gt. cu_bot1) then ! lconv + + lconv = .true. + +! Prepare data for redistributing particle + + CALL pre_redist_kf(nuvzmax,nuvz,umf,dmf,dz1d,p1d,delx,delt, & ! IN + cu_bot1,cu_top1, & ! IN + zf,zh, & ! OUT + umfzf,dmfzf,fmix) ! OUT + + else + lconv = .false. + ENDIF ! lconv + + + 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) + zp=ztra1(ipart) + + CALL redist_kf(lconvection,ldirect,delt,delx, & ! IN + dz1d,nzmax, nz,umf,uer,udr,dmf, & ! IN + der,ddr,rho1d, & ! IN + zf,zh, & ! IN + umfzf,dmfzf, & ! IN + zp) ! IN/OUT + + if (zp .lt. 0.0) zp=-1.0*zp + if (zp .gt. height(nz)-0.5) & + zp = height(nz)-0.5 + ztra1(ipart) = zp + +! 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 + enddo + 47 continue + + if (nage.le.nageclass) & + call calcfluxes(nage,ipart,real(xtra1(ipart)), & + real(ytra1(ipart)),ztold) + endif + + endif !(lconv .eqv. .true.) + + enddo + 60 continue + enddo + 70 continue !inest - loop +! print*,'end of convmix' +!-------------------------------------------------------------------------- +! 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_kfeta diff --git a/src_flexwrf_v3.1/coordtrafo.f90 b/src_flexwrf_v3.1/coordtrafo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4cd21fb77cced04b68a52ec758afc0086caf7bdf --- /dev/null +++ b/src_flexwrf_v3.1/coordtrafo.f90 @@ -0,0 +1,122 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine coordtrafo +!********************************************************************** +! * +! Note: This is the FLEXPART_WRF version of subroutine coordtrafo. * +! * +! FLEXPART MODEL SUBROUTINE COORDTRAFO * +! * +!********************************************************************** +! * +! AUTHOR: G. WOTAWA * +! DATE: 1994-02-07 * +! LAST UPDATE: 1996-05-18 A. STOHL * +! * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables* +! July 2012, J Brioude: modification following flexpart 9 * +!********************************************************************** +! * +! 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)-xmet0)/dx + xpoint2(i)=(xpoint2(i)-xmet0)/dx + ypoint1(i)=(ypoint1(i)-ymet0)/dy + ypoint2(i)=(ypoint2(i)-ymet0)/dy + end do + +15 continue + + +! CHECK IF RELEASE POINTS ARE WITHIN DOMAIN +!****************************************** + + do i=1,numpoint + + 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.(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 + +! 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 ... ' +! write(*,*) ' COMMENT: ',compoint(i) + + 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.2000) compoint(j-1)=compoint(j) + do k=1,nspec + xmass(j-1,k)=xmass(j,k) + end do + + enddo + 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 + diff --git a/src_flexwrf_v3.1/copyright.txt b/src_flexwrf_v3.1/copyright.txt new file mode 100644 index 0000000000000000000000000000000000000000..2d151ea1de2177c3a726e0992635f7edd95d9621 --- /dev/null +++ b/src_flexwrf_v3.1/copyright.txt @@ -0,0 +1,18 @@ +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * + +This file is part of FLEXPART-WRF +FLEXPART-WRF is free software: you can redistribute it and/or modify +it under the terms of the 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. + +The GNU General Public License is available at http://www.gnu.org/licenses diff --git a/src_flexwrf_v3.1/data/IGBP_int1.dat b/src_flexwrf_v3.1/data/IGBP_int1.dat new file mode 100755 index 0000000000000000000000000000000000000000..089a3dd57efec5ae30eddb9b2eae8c8498df0279 Binary files /dev/null and b/src_flexwrf_v3.1/data/IGBP_int1.dat differ diff --git a/src_flexwrf_v3.1/data/OH_7lev_agl.dat b/src_flexwrf_v3.1/data/OH_7lev_agl.dat new file mode 100755 index 0000000000000000000000000000000000000000..d5c6e11ad191900eaa314e0fa0bfe3dfc864db25 Binary files /dev/null and b/src_flexwrf_v3.1/data/OH_7lev_agl.dat differ diff --git a/src_flexwrf_v3.1/data/surfdata.t b/src_flexwrf_v3.1/data/surfdata.t new file mode 100644 index 0000000000000000000000000000000000000000..95a38fb7217129dd58f4d9794c8f94704e0d28c8 --- /dev/null +++ b/src_flexwrf_v3.1/data/surfdata.t @@ -0,0 +1,17 @@ +13 landuse categories are related roughness length +-------------------------------------------------------- +landuse comment z0 +-------------------------------------------------------- + 1 Urban land 0.7 + 2 Agricultural land 0.1 + 3 Range land 0.1 + 4 Deciduous forest 1. + 5 Coniferous forest 1. + 6 Mixed forest including wetland 0.7 + 7 water, both salt and fresh 0.001 + 8 barren land mostly desert 0.01 + 9 nonforested wetland 0.1 +10 mixed agricultural and range land 0.1 +11 rocky open areas with low grow shrubs 0.05 +12 snow and ice 0.001 +13 rainforest 1. diff --git a/src_flexwrf_v3.1/data/surfdepo.t b/src_flexwrf_v3.1/data/surfdepo.t new file mode 100644 index 0000000000000000000000000000000000000000..1171b672ea773a57c6eb90cc03091caf1a08ce92 --- /dev/null +++ b/src_flexwrf_v3.1/data/surfdepo.t @@ -0,0 +1,57 @@ +============================================================================== +INPUT RESISTANCES (s/m) FOR THE COMPUTATION OF SURFACE RESISTANCES TO +DRY DEPOSITION +============================================================================== +AFTER WESELY, 1989 +============================================================================== +1 to 11: Landuse types after Wesely; 12 .. snow, 13 .. rainforest +============================================================================== +Values are tabulated for 5 seasonal categories: +1 Midsummer with lush vegetation +2 Autumn with unharvested cropland +3 Late autumn after frost, no snow +4 Winter, snow on ground and subfreezing +5 Transitional spring with partially green short annuals +============================================================================== + 1 2 3 4 5 6 7 8 9 10 11 12 13 +________________________________________________________________________________________________________________ +ri 9999. 60. 120. 70. 130. 100. 9999. 9999. 80. 100. 150. 9999. 200. 1 +rlu 9999. 2000. 2000. 2000. 2000. 2000. 9999. 9999. 2500. 2000. 4000. 9999. 1000. +rac 100. 200. 100. 2000. 2000. 2000. 0. 0. 300. 150. 200. 0. 2000. +rgss 400. 150. 350. 500. 500. 100. 0. 1000. 0. 220. 400. 100. 200. +rgso 300. 150. 200. 200. 200. 300. 2000. 400. 1000. 180. 200. 10000. 200. +rcls 9999. 2000. 2000. 2000. 2000. 2000. 9999. 9999. 2500. 2000. 4000. 9999. 9999. +rclo 9999. 1000. 1000. 1000. 1000. 1000. 9999. 9999. 1000. 1000. 1000. 9999. 9999. +_________________________________________________________________________________________________________________ +ri 9999. 9999. 9999. 9999. 250. 500. 9999. 9999. 9999. 9999. 9999. 9999. 200. 2 +rlu 9999. 9000. 9000. 9000. 4000. 8000. 9999. 9999. 9000. 9000. 9000. 9999. 1000. +rac 100. 150. 100. 1500. 2000. 1700. 0. 0. 200. 120. 140. 0. 2000. +rgss 400. 200. 350. 500. 500. 100. 0. 1000. 0. 300. 400. 100. 200. +rgso 300. 150. 200. 200. 200. 300. 2000. 400. 800. 180. 200. 10000. 200. +rcls 9999. 9000. 9000. 9000. 2000. 4000. 9999. 9999. 9000. 9000. 9000. 9999. 9999. +rclo 9999. 400. 400. 400. 1000. 600. 9999. 9999. 400. 400. 400. 9999. 9999. +_________________________________________________________________________________________________________________ +ri 9999. 9999. 9999. 9999. 250. 500. 9999. 9999. 9999. 9999. 9999. 9999. 200. 3 +rlu 9999. 9999. 9000. 9000. 4000. 8000. 9999. 9999. 9000. 9000. 9000. 9999. 1000. +rac 100. 10. 100. 1000. 2000. 1500. 0. 0. 100. 50. 120. 0. 2000. +rgss 400. 150. 350. 500. 500. 200. 0. 1000. 0. 200. 400. 100. 200. +rgso 300. 150. 200. 200. 200. 300. 2000. 400. 1000. 180. 200. 10000. 200. +rcls 9999. 9999. 9000. 9000. 3000. 6000. 9999. 9999. 9000. 9000. 9000. 9999. 9999. +rclo 9999. 1000. 400. 400. 1000. 600. 9999. 9999. 800. 600. 600. 9999. 9999. +_________________________________________________________________________________________________________________ +ri 9999. 9999. 9999. 9999. 400. 800. 9999. 9999. 9999. 9999. 9999. 9999. 200. 4 +rlu 9999. 9999. 9999. 9999. 6000. 9000. 9999. 9999. 9000. 9000. 9000. 9999. 1000. +rac 100. 10. 10. 1000. 2000. 1500. 0. 0. 50. 10. 50. 0. 2000. +rgss 100. 100. 100. 100. 100. 100. 0. 1000. 100. 100. 50. 100. 200. +rgso 600. 3500. 3500. 3500. 3500. 3500. 2000. 400. 3500. 3500. 3500. 10000. 200. +rcls 9999. 9999. 9999. 9000. 200. 400. 9999. 9999. 9000. 9999. 9000. 9999. 9999. +rclo 9999. 1000. 1000. 400. 1500. 600. 9999. 9999. 800. 1000. 800. 9999. 9999. +_________________________________________________________________________________________________________________ +ri 9999. 120. 240. 140. 250. 190. 9999. 9999. 160. 200. 300. 9999. 200. 5 +rlu 9999. 4000. 4000. 4000. 2000. 3000. 9999. 9999. 4000. 4000. 8000. 9999. 1000. +rac 100. 50. 80. 1200. 2000. 1500. 0. 0. 200. 60. 120. 0. 2000. +rgss 500. 150. 350. 500 500. 200. 0. 1000. 0. 250. 400. 100. 200. +rgso 300. 150. 200. 200. 200. 300. 2000. 400. 1000. 180. 200. 10000. 200. +rcls 9999. 4000. 4000. 4000. 2000. 3000. 9999. 9999. 4000. 4000. 8000. 9999. 9999. +rclo 9999. 1000. 500. 500. 1500. 700. 9999. 9999. 600. 800. 800. 9999. 9999. +_________________________________________________________________________________________________________________ diff --git a/src_flexwrf_v3.1/drydepokernel.f90 b/src_flexwrf_v3.1/drydepokernel.f90 new file mode 100644 index 0000000000000000000000000000000000000000..34b577abf5a64994c4816a65a581763e252bf0b3 --- /dev/null +++ b/src_flexwrf_v3.1/drydepokernel.f90 @@ -0,0 +1,160 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** +subroutine drydepokernel(nunc,deposit,x,y,itage,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 * + ! + ! D. Arnold: modification to skip the kernel the first 3 hours. + ! then, modification to a regular lat-lon. + ! + ! * + !***************************************************************************** + ! * + ! 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 +! CDA new declarations + real :: rhoprof(2),rhoi,xlon,ylat,xl2,yl2 + integer :: itage +! CDA + +!JB + if (outgrid_option.eq.0) then +! CDA + xl=(x*dx+xoutshift)/dxout + yl=(y*dy+youtshift)/dyout + elseif (outgrid_option.eq.1) then +! CDA new code: + xl2=x*dx+xmet0 + yl2=y*dy+ymet0 + call xymeter_to_ll_wrf(xl2,yl2,xlon,ylat) + xl=(xlon-outlon0)/dxoutl + yl=(ylat-outlat0)/dyoutl + endif + + + ix=int(xl) + jy=int(yl) + +! CDA skip kernel + if (itage.lt.7200) then ! no kernel, direct attribution to grid cell + do ks=1,nspec + if ((abs(deposit(ks)).gt.0).and.DRYDEPSPEC(ks)) then +!$OMP CRITICAL + if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. & + (jy.le.numygrid-1)) & + drygridunc2(ix,jy,ks,kp,nunc,nage)= & + drygridunc2(ix,jy,ks,kp,nunc,nage)+deposit(ks) +!$OMP END CRITICAL + endif + enddo + 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 + !********************************************** + 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 +!$OMP CRITICAL + drygridunc2(ix,jy,ks,kp,nunc,nage)= & + drygridunc2(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w +!$OMP END CRITICAL + 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) +!$OMP CRITICAL + drygridunc2(ixp,jyp,ks,kp,nunc,nage)= & + drygridunc2(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w +!$OMP END CRITICAL + endif + + if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. & + (jy.le.numygrid-1)) then + w=(1.-wx)*wy +!$OMP CRITICAL + drygridunc2(ixp,jy,ks,kp,nunc,nage)= & + drygridunc2(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w +!$OMP END CRITICAL + endif + + if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. & + (jyp.le.numygrid-1)) then + w=wx*(1.-wy) +!$OMP CRITICAL + drygridunc2(ix,jyp,ks,kp,nunc,nage)= & + drygridunc2(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w +!$OMP END CRITICAL + endif + + endif + + end do + + endif !kernel +end subroutine drydepokernel diff --git a/src_flexwrf_v3.1/drydepokernel_nest.f90 b/src_flexwrf_v3.1/drydepokernel_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d6c8c647f561a33d64fbe9607a14ad812a4b9da0 --- /dev/null +++ b/src_flexwrf_v3.1/drydepokernel_nest.f90 @@ -0,0 +1,159 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** +subroutine drydepokernel_nest(nunc,deposit,x,y,itage,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 +! CDA new declarations + real :: rhoprof(2),rhoi,xlon,ylat,xl2,yl2 + integer :: itage +! CDA + + +!JB + if (outgrid_option.eq.0) then +! CDA + xl=(x*dx+xoutshiftn)/dxoutn + yl=(y*dy+youtshiftn)/dyoutn + elseif (outgrid_option.eq.1) then +! CDA new code: + xl2=x*dx+xmet0 + yl2=y*dy+ymet0 + call xymeter_to_ll_wrf(xl2,yl2,xlon,ylat) + xl=(xlon-outlon0n)/dxoutln + yl=(ylat-outlat0n)/dyoutln + endif + + ix=int(xl) + jy=int(yl) + +! CDA skip kernel + if (itage.lt.7200) then ! no kernel, direct attribution to grid cell + do ks=1,nspec + if ((abs(deposit(ks)).gt.0).and.DRYDEPSPEC(ks)) then +!$OMP CRITICAL + if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. & + (jy.le.numygridn-1)) & + drygriduncn2(ix,jy,ks,kp,nunc,nage)= & + drygriduncn2(ix,jy,ks,kp,nunc,nage)+deposit(ks) +!$OMP END CRITICAL + endif + enddo + 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 + !********************************************** + 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 +!$OMP CRITICAL + drygriduncn2(ix,jy,ks,kp,nunc,nage)= & + drygriduncn2(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w +!$OMP END CRITICAL + 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) +!$OMP CRITICAL + drygriduncn2(ixp,jyp,ks,kp,nunc,nage)= & + drygriduncn2(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w +!$OMP END CRITICAL + endif + + if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. & + (jy.le.numygridn-1)) then + w=(1.-wx)*wy +!$OMP CRITICAL + drygriduncn2(ixp,jy,ks,kp,nunc,nage)= & + drygriduncn2(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w +!$OMP END CRITICAL + endif + + if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. & + (jyp.le.numygridn-1)) then + w=wx*(1.-wy) +!$OMP CRITICAL + drygriduncn2(ix,jyp,ks,kp,nunc,nage)= & + drygriduncn2(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w +!$OMP END CRITICAL + endif + + endif + + end do + endif !kernel + +end subroutine drydepokernel_nest diff --git a/src_flexwrf_v3.1/dynamic_viscosity.f90 b/src_flexwrf_v3.1/dynamic_viscosity.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0ef1bcb92f05c145cfbdbff55a9fbaa686618843 --- /dev/null +++ b/src_flexwrf_v3.1/dynamic_viscosity.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +! 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 diff --git a/src_flexwrf_v3.1/erf.f b/src_flexwrf_v3.1/erf.f new file mode 100644 index 0000000000000000000000000000000000000000..b1d9a482f8edeadf7b2f64b2326beea3c7b88539 --- /dev/null +++ b/src_flexwrf_v3.1/erf.f @@ -0,0 +1,159 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Jerome Fast, +!* Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa * +!* Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** +! +! J. Brioude: the version in fortran 9 gives some error. better use f77 +! +c To be used, if the non-standard Fortran function erf does not exist on +c your machine +C +C aus: Numerical Recipes (FORTRAN) / Chapter 6. +C +C 6.1 FUNCTION GAMMLN +C 6.2 FUNCTION GAMMP <6.2:GSER/6.2:GCF/6.1:GAMMLN> +C 6.2 FUNCTION GAMMQ <6.2:GSER/6.2:GCF/6.1:GAMMLN> +C 6.2 SUBROUTINE GSER <6.1:GAMMLN> +C 6.2 SUBROUTINE GCF <6.1:GAMMLN> +C 6.2 FUNCTION ERF <6.2:GAMMP/6.2:GSER/6.2:GCF/6.1:GAMMLN> +C 6.2 FUNCTION ERFC <6.2.:GAMMP/6.2:GAMMQ/6.2:GSER/ +C 6.2:GCF/6.1:GAMMLN> +C 6.2 FUNCTION ERFCC +C + FUNCTION GAMMLN(XX) + REAL*8 COF(6),STP,HALF,ONE,FPF,X,TMP,SER + DATA COF,STP/76.18009173D0,-86.50532033D0,24.01409822D0, + * -1.231739516D0,.120858003D-2,-.536382D-5,2.50662827465D0/ + DATA HALF,ONE,FPF/0.5D0,1.0D0,5.5D0/ + X=XX-ONE + TMP=X+FPF + TMP=(X+HALF)*LOG(TMP)-TMP + SER=ONE + DO 11 J=1,6 + X=X+ONE + SER=SER+COF(J)/X +11 CONTINUE + GAMMLN=TMP+LOG(STP*SER) + RETURN + END +C + FUNCTION GAMMP(A,X) + IF(X.LT.0..OR.A.LE.0.) STOP 'GAMMP' + 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 + RETURN + END +C + FUNCTION GAMMQ(A,X) + IF(X.LT.0..OR.A.LE.0.) STOP 'GAMMQ' + 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 + RETURN + END +C + SUBROUTINE GSER(GAMSER,A,X,GLN) + PARAMETER (ITMAX=100,EPS=3.E-7) + GLN=GAMMLN(A) + IF(X.LE.0.)THEN +! IF(X.LT.0.) PAUSE 'GSER' + GAMSER=0. + RETURN + ENDIF + AP=A + SUM=1./A + DEL=SUM + DO 11 N=1,ITMAX + AP=AP+1. + DEL=DEL*X/AP + SUM=SUM+DEL + IF(ABS(DEL).LT.ABS(SUM)*EPS)GO TO 1 +11 CONTINUE + STOP 'GSER: A too large, ITMAX too small' +1 GAMSER=SUM*EXP(-X+A*LOG(X)-GLN) + RETURN + END +C + SUBROUTINE GCF(GAMMCF,A,X,GLN) + PARAMETER (ITMAX=100,EPS=3.E-7) + GLN=GAMMLN(A) + GOLD=0. + A0=1. + A1=X + B0=0. + B1=1. + FAC=1. + DO 11 N=1,ITMAX + AN=FLOAT(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 +11 CONTINUE + STOP 'GCF: A too large, ITMAX too small' +1 GAMMCF=EXP(-X+A*ALOG(X)-GLN)*G + RETURN + END +C + FUNCTION erf(X) + IF(X.LT.0.)THEN + erf=-GAMMP(.5,X**2) + ELSE + erf=GAMMP(.5,X**2) + ENDIF + RETURN + END +C + FUNCTION ERFC(X) + IF(X.LT.0.)THEN + ERFC=1.+GAMMP(.5,X**2) + ELSE + ERFC=GAMMQ(.5,X**2) + ENDIF + RETURN + END +C + FUNCTION ERFCC(X) + 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 + RETURN + END +C diff --git a/src_flexwrf_v3.1/ew.f90 b/src_flexwrf_v3.1/ew.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0d44e82cf9f345b4955f373ba4f4fcd3f95cd4c3 --- /dev/null +++ b/src_flexwrf_v3.1/ew.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/examples/AVAILABLE2 b/src_flexwrf_v3.1/examples/AVAILABLE2 new file mode 100644 index 0000000000000000000000000000000000000000..d98eaa02d50b1fefce7760a1fd3913c1dda7a35c --- /dev/null +++ b/src_flexwrf_v3.1/examples/AVAILABLE2 @@ -0,0 +1,27 @@ +XXXXXX EMPTY LINES XXXXXXXXX +XXXXXX EMPTY LINES XXXXXXXX +YYYYMMDD HHMMSS name of the file(up to 80 characters) +20100518 000000 'wrfout_d02_2010-05-18_00.nc' ' ' +20100518 003000 'wrfout_d02_2010-05-18_00.nc' ' ' +20100518 010000 'wrfout_d02_2010-05-18_00.nc' ' ' +20100518 013000 'wrfout_d02_2010-05-18_00.nc' ' ' +20100518 020000 'wrfout_d02_2010-05-18_00.nc' ' ' +20100518 023000 'wrfout_d02_2010-05-18_00.nc' ' ' +20100518 030000 'wrfout_d02_2010-05-18_03.nc' ' ' +20100518 033000 'wrfout_d02_2010-05-18_03.nc' ' ' +20100518 040000 'wrfout_d02_2010-05-18_03.nc' ' ' +20100518 043000 'wrfout_d02_2010-05-18_03.nc' ' ' +20100518 050000 'wrfout_d02_2010-05-18_03.nc' ' ' +20100518 053000 'wrfout_d02_2010-05-18_03.nc' ' ' +20100518 060000 'wrfout_d02_2010-05-18_06.nc' ' ' +20100518 063000 'wrfout_d02_2010-05-18_06.nc' ' ' +20100518 070000 'wrfout_d02_2010-05-18_06.nc' ' ' +20100518 073000 'wrfout_d02_2010-05-18_06.nc' ' ' +20100518 080000 'wrfout_d02_2010-05-18_06.nc' ' ' +20100518 083000 'wrfout_d02_2010-05-18_06.nc' ' ' +20100518 090000 'wrfout_d02_2010-05-18_09.nc' ' ' +20100518 093000 'wrfout_d02_2010-05-18_09.nc' ' ' +20100518 100000 'wrfout_d02_2010-05-18_09.nc' ' ' +20100518 103000 'wrfout_d02_2010-05-18_09.nc' ' ' +20100518 110000 'wrfout_d02_2010-05-18_09.nc' ' ' +20100518 113000 'wrfout_d02_2010-05-18_09.nc' ' ' diff --git a/src_flexwrf_v3.1/examples/AVAILABLE3 b/src_flexwrf_v3.1/examples/AVAILABLE3 new file mode 100644 index 0000000000000000000000000000000000000000..071b138d27c7f3862705cdc5715aacc204dfe07a --- /dev/null +++ b/src_flexwrf_v3.1/examples/AVAILABLE3 @@ -0,0 +1,27 @@ +XXXXXX EMPTY LINES XXXXXXXXX +XXXXXX EMPTY LINES XXXXXXXX +YYYYMMDD HHMMSS name of the file(up to 80 characters) +20100518 000000 'wrfout_d03_2010-05-18_00.nc' ' ' +20100518 003000 'wrfout_d03_2010-05-18_00.nc' ' ' +20100518 010000 'wrfout_d03_2010-05-18_00.nc' ' ' +20100518 013000 'wrfout_d03_2010-05-18_00.nc' ' ' +20100518 020000 'wrfout_d03_2010-05-18_00.nc' ' ' +20100518 023000 'wrfout_d03_2010-05-18_00.nc' ' ' +20100518 030000 'wrfout_d03_2010-05-18_03.nc' ' ' +20100518 033000 'wrfout_d03_2010-05-18_03.nc' ' ' +20100518 040000 'wrfout_d03_2010-05-18_03.nc' ' ' +20100518 043000 'wrfout_d03_2010-05-18_03.nc' ' ' +20100518 050000 'wrfout_d03_2010-05-18_03.nc' ' ' +20100518 053000 'wrfout_d03_2010-05-18_03.nc' ' ' +20100518 060000 'wrfout_d03_2010-05-18_06.nc' ' ' +20100518 063000 'wrfout_d03_2010-05-18_06.nc' ' ' +20100518 070000 'wrfout_d03_2010-05-18_06.nc' ' ' +20100518 073000 'wrfout_d03_2010-05-18_06.nc' ' ' +20100518 080000 'wrfout_d03_2010-05-18_06.nc' ' ' +20100518 083000 'wrfout_d03_2010-05-18_06.nc' ' ' +20100518 090000 'wrfout_d03_2010-05-18_09.nc' ' ' +20100518 093000 'wrfout_d03_2010-05-18_09.nc' ' ' +20100518 100000 'wrfout_d03_2010-05-18_09.nc' ' ' +20100518 103000 'wrfout_d03_2010-05-18_09.nc' ' ' +20100518 110000 'wrfout_d03_2010-05-18_09.nc' ' ' +20100518 113000 'wrfout_d03_2010-05-18_09.nc' ' ' diff --git a/src_flexwrf_v3.1/examples/README_FIRST.txt b/src_flexwrf_v3.1/examples/README_FIRST.txt new file mode 100644 index 0000000000000000000000000000000000000000..69780c65a125bb5074a7271707b17e96c77a1b6c --- /dev/null +++ b/src_flexwrf_v3.1/examples/README_FIRST.txt @@ -0,0 +1,49 @@ +Those test cases can be run by copying a compiled binary and the flexwrf.input file of a test case in a directory. In addition, data from the directory src_flexwrf_v3.0/data are required for calculating dry deposition for the Cesium species. +The three test cases cover most of the format the input file should have if 2 output grid nests, ageclasses, several species with hourly emission variations are used. + +an example of AVAILABLE file with the proper format is given for 2 different domains, assuming that each WRF output has 6 time frames with a time interval output of 30 minutes. +################################# +file flexwrf.input.forward1: +- This case is a forward run (using LDIRECT=1) +- The output gives the concentration and deposition from the total release of the 2 release location by using IOUTPUTFOREACHREL=0 +- a passive airtracer and Cesium particles are released (NSPEC=2), without any hourly emission variation (EMITVAR=0) +- 2 output grid are defined. They are defined using latitude/longitude coordinates, the number of grid cells and the grid spacing +- 2 ageclasses are asked by using LAGESPECTRA=1 +- The NetCDF output format is selected, with 3 time frames per file. + +Because the species #1 is a passive tracer, the dry and wet deposition fields +are empty. The wet and dry deposition fields exist for species #2 + +This test case can be run by typing +./flexwrf30_pgi_omp flexwrf.input.forward1 +if, for instance, an OpenMP is compiled. +################################# +file flexwrf.input.forward2: +- This case is a forward run (using LDIRECT=1) +- The output gives the concentration and deposition from each release location by using IOUTPUTFOREACHREL=1 +- a passive airtracer and Cesium particles are released (NSPEC=2), with hourly and daily emission variation (EMITVAR=1) +- 1 output grid is defined. It is defined base on metric coordinates of the WRF output +- No ageclass is used because LAGESPECTRA=0 +- The NetCDF output format is selected, with 1 time frame per file. because IOUTPUTFOREACHREL=1, an additional dimension is used in the netcdf file compared to the case flexwrf.input.forward1 + +This test case can be run by typing +./flexwrf30_pgi_omp flexwrf.input.forward2 +if, for instance, an OpenMP is compiled. +################################# +file flexwrf.input.backward1: +- This case is a backward run (using LDIRECT=-1) +- Only one species is emitted, the passive airtracer. +- The output gives the source-receptor relationship of the 3 release locations over Los Angeles Basin. Their vertical location is defined based on pressure +- 1 output grid is defined. +- No ageclass is used because LAGESPECTRA=0 +- The binary format is selected. The header file (binary format), latlon*.txt files (ascii format) and grid_time* (binary format) files are generated. + +This test case can be run by typing +./flexwrf30_pgi_omp flexwrf.input.backward1 +if, for instance, an OpenMP is compiled. + +################################# +file flexwrf.input.backward2: +Identical to flexwrf.input.backward1 except that 2 WRF nested output are read. (The nested WRF output files is not available on http://www.flexpart.eu) +In such case, the OUTPUT grid can be defined in WRF coordinates but relative to the outer WRF domain. + diff --git a/src_flexwrf_v3.1/examples/flexwrf.input.backward1 b/src_flexwrf_v3.1/examples/flexwrf.input.backward1 new file mode 100644 index 0000000000000000000000000000000000000000..8e24283a0436aee443f877fd2fc14085f3f62293 --- /dev/null +++ b/src_flexwrf_v3.1/examples/flexwrf.input.backward1 @@ -0,0 +1,103 @@ +=====================FORMER PATHNAMES FILE=================== +/scratch2/portfolios/BMC/stela/jbrioude/flexwrf_backward1/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/AVAILABLE2 +============================================================= +=====================FORMER COMMAND FILE===================== + -1 LDIRECT: 1 for forward simulation, -1 for backward simulation + 20100518 000000 YYYYMMDD HHMISS beginning date of simulation + 20100518 110000 YYYYMMDD HHMISS ending date of simulation + 3600 SSSSS (int) output every SSSSS seconds + 3600 SSSSS (int) time average of output (in SSSSS seconds) + 180 SSSSS (int) sampling rate of output (in SSSSS seconds) + 999999999 SSSSS (int) time constant for particle splitting (in seconds) + 180 SSSSS (int) synchronisation interval of flexpart (in seconds) + 10. CTL (real) factor by which time step must be smaller than tl + 10 IFINE (int) decrease of time step for vertical motion by factor ifine + 1 IOUT 1 concentration, 2 mixing ratio, 3 both, 4 plume traject, 5=1+4 + 0 IPOUT particle dump: 0 no, 1 every output interval, 2 only at end + 0 LSUBGRID subgrid terrain effect parameterization: 1 yes, 0 no + 0 LCONVECTION convection: 3 yes, 0 no + 3600. DT_CONV (real) time interval to call convection, seconds + 0 LAGESPECTRA age spectra: 1 yes, 0 no + 0 IPIN continue simulation with dumped particle data: 1 yes, 0 no + 0 IFLUX calculate fluxes: 1 yes, 0 no + 1 IOUTPUTFOREACHREL CREATE AN OUPUT FILE FOR EACH RELEASE LOCATION: 1 YES, 0 NO + 0 MDOMAINFILL domain-filling trajectory option: 1 yes, 0 no, 2 strat. o3 tracer + 1 IND_SOURCE 1=mass unit , 2=mass mixing ratio unit + 2 IND_RECEPTOR 1=mass unit , 2=mass mixing ratio unit + 0 NESTED_OUTPUT shall nested output be used? 1 yes, 0 no + 0 LINIT_COND INITIAL COND. FOR BW RUNS: 0=NO,1=MASS UNIT,2=MASS MIXING RATIO UNIT + 1 TURB_OPTION 0=no turbulence; 1=diagnosed as in flexpart_ecmwf; 2 and 3=from tke. + 1 CBL SCHEME 0=no, 1=yes. works if TURB_OPTION=1 + 1 SFC_OPTION 0=default computation of u*, hflux, pblh, 1=from wrf + -1 WIND_OPTION 0=snapshot winds, 1=mean winds,2=snapshot eta-dot,-1=w based on divergence + 0 TIME_OPTION 1=correction of time validity for time-average wind, 0=no need + 0 OUTGRID_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 1 RELEASE_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 0 IOUTTYPE 0=default binary, 1=ascii (for particle dump only),2=netcdf + 3 NCTIMEREC (int) Time frames per output file, only used for netcdf + 0 VERBOSE VERBOSE MODE,0=minimum, 100=maximum +=====================FORMER AGECLASESS FILE================== + 2 NAGECLASS number of age classes + 7200 SSSSSS (int) age class in SSSSS seconds + 999999 SSSSSS (int) age class in SSSSS seconds +=====================FORMER OUTGRID FILE===================== + 0. OUTLONLEFT geograhical longitude of lower left corner of output grid + 0. OUTLATLOWER geographical latitude of lower left corner of output grid + 100 NUMXGRID number of grid points in x direction (= # of cells ) + 120 NUMYGRID number of grid points in y direction (= # of cells ) + 1 OUTGRIDDEF outgrid defined 0=using grid distance, 1=upperright corner coordinate + 1200000. DXOUTLON grid distance in x direction or upper right corner of output grid + 1440000. DYOUTLON grid distance in y direction or upper right corner of output grid + 2 NUMZGRID number of vertical levels + 100.0 LEVEL height of level (upper boundary) + 20000.0 LEVEL height of level (upper boundary) +=====================FORMER RECEPTOR FILE==================== + 0 NUMRECEPTOR number of receptors +=====================FORMER SPECIES FILE===================== + 2 NUMTABLE number of variable properties. The following lines are fixed format +XXXX|NAME |decaytime |wetscava |wetsb|drydif|dryhenry|drya|partrho |parmean|partsig|dryvelo|weight | + AIRTRACER -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 29.00 + Cs-137 -999.9 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 +=====================FORMER RELEEASES FILE=================== + 1 NSPEC total number of species emitted + 0 EMITVAR 1 for emission variation + 1 LINK index of species in file SPECIES +3 NUMPOINT number of releases +20100518 110000 ID1, IT1 beginning date and time of release +20100518 110000 ID2, IT2 ending date and time of release +-117.6152 XPOINT1 (real) longitude [deg] of lower left corner + 34.0450 YPOINT1 (real) latitude [deg] of lower left corner +-117.5952 XPOINT2 (real) longitude [deg] of upper right corner + 34.0650 YPOINT2 (real) latitude [DEG] of upper right corner + 3 KINDZ (int) 1 for m above ground, 2 for m above sea level, 3 pressure + 984.3800 ZPOINT1 (real) lower z-level + 972.5500 ZPOINT2 (real) upper z-level + 10000 NPART (int) total number of particles to be released +.1000E+01 XMASS (real) total mass emitted +release1 NAME OF RELEASE LOCATION +20100518 110000 +20100518 110000 +-118.0229 + 34.1349 +-117.9913 + 34.1356 + 3 + 932.270 + 922.270 + 10000 +.1000E+01 +release2 +20100518 110000 +20100518 110000 +-116.9502 + 33.7114 +-116.9183 + 33.7341 + 3 + 687.110 + 677.110 + 10000 +.1000E+01 +release3 diff --git a/src_flexwrf_v3.1/examples/flexwrf.input.backward2 b/src_flexwrf_v3.1/examples/flexwrf.input.backward2 new file mode 100644 index 0000000000000000000000000000000000000000..c13a76c855af3f7ec99b0fc45a46d230a27a23ce --- /dev/null +++ b/src_flexwrf_v3.1/examples/flexwrf.input.backward2 @@ -0,0 +1,105 @@ +=====================FORMER PATHNAMES FILE=================== +/scratch2/portfolios/BMC/stela/jbrioude/flexwrf_backward2/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/AVAILABLE2 +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/AVAILABLE3 +============================================================= +=====================FORMER COMMAND FILE===================== + -1 LDIRECT: 1 for forward simulation, -1 for backward simulation + 20100518 000000 YYYYMMDD HHMISS beginning date of simulation + 20100518 110000 YYYYMMDD HHMISS ending date of simulation + 3600 SSSSS (int) output every SSSSS seconds + 3600 SSSSS (int) time average of output (in SSSSS seconds) + 180 SSSSS (int) sampling rate of output (in SSSSS seconds) + 999999999 SSSSS (int) time constant for particle splitting (in seconds) + 180 SSSSS (int) synchronisation interval of flexpart (in seconds) + 10. CTL (real) factor by which time step must be smaller than tl + 10 IFINE (int) decrease of time step for vertical motion by factor ifine + 1 IOUT 1 concentration, 2 mixing ratio, 3 both, 4 plume traject, 5=1+4 + 0 IPOUT particle dump: 0 no, 1 every output interval, 2 only at end + 0 LSUBGRID subgrid terrain effect parameterization: 1 yes, 0 no + 0 LCONVECTION convection: 3 yes, 0 no + 3600. DT_CONV (real) time interval to call convection, seconds + 0 LAGESPECTRA age spectra: 1 yes, 0 no + 0 IPIN continue simulation with dumped particle data: 1 yes, 0 no + 0 IFLUX calculate fluxes: 1 yes, 0 no + 1 IOUTPUTFOREACHREL CREATE AN OUPUT FILE FOR EACH RELEASE LOCATION: 1 YES, 0 NO + 0 MDOMAINFILL domain-filling trajectory option: 1 yes, 0 no, 2 strat. o3 tracer + 1 IND_SOURCE 1=mass unit , 2=mass mixing ratio unit + 2 IND_RECEPTOR 1=mass unit , 2=mass mixing ratio unit + 0 NESTED_OUTPUT shall nested output be used? 1 yes, 0 no + 0 LINIT_COND INITIAL COND. FOR BW RUNS: 0=NO,1=MASS UNIT,2=MASS MIXING RATIO UNIT + 1 TURB_OPTION 0=no turbulence; 1=diagnosed as in flexpart_ecmwf; 2 and 3=from tke. + 1 CBL SCHEME 0=no, 1=yes. works if TURB_OPTION=1 + 1 SFC_OPTION 0=default computation of u*, hflux, pblh, 1=from wrf + -1 WIND_OPTION 0=snapshot winds, 1=mean winds,2=snapshot eta-dot,-1=w based on divergence + 0 TIME_OPTION 1=correction of time validity for time-average wind, 0=no need + 0 OUTGRID_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 1 RELEASE_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 0 IOUTTYPE 0=default binary, 1=ascii (for particle dump only),2=netcdf + 3 NCTIMEREC (int) Time frames per output file, only used for netcdf + 0 VERBOSE VERBOSE MODE,0=minimum, 100=maximum +=====================FORMER AGECLASESS FILE================== + 2 NAGECLASS number of age classes + 7200 SSSSSS (int) age class in SSSSS seconds + 999999 SSSSSS (int) age class in SSSSS seconds +=====================FORMER OUTGRID FILE===================== + 0. OUTLONLEFT geograhical longitude of lower left corner of output grid + 0. OUTLATLOWER geographical latitude of lower left corner of output grid + 100 NUMXGRID number of grid points in x direction (= # of cells ) + 120 NUMYGRID number of grid points in y direction (= # of cells ) + 1 OUTGRIDDEF outgrid defined 0=using grid distance, 1=upperright corner coordinate + 1200000. DXOUTLON grid distance in x direction or upper right corner of output grid + 1440000. DYOUTLON grid distance in y direction or upper right corner of output grid + 2 NUMZGRID number of vertical levels + 100.0 LEVEL height of level (upper boundary) + 20000.0 LEVEL height of level (upper boundary) +=====================FORMER RECEPTOR FILE==================== + 0 NUMRECEPTOR number of receptors +=====================FORMER SPECIES FILE===================== + 2 NUMTABLE number of variable properties. The following lines are fixed format +XXXX|NAME |decaytime |wetscava |wetsb|drydif|dryhenry|drya|partrho |parmean|partsig|dryvelo|weight | + AIRTRACER -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 29.00 + Cs-137 -999.9 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 +=====================FORMER RELEEASES FILE=================== + 1 NSPEC total number of species emitted + 0 EMITVAR 1 for emission variation + 1 LINK index of species in file SPECIES +3 NUMPOINT number of releases +20100518 110000 ID1, IT1 beginning date and time of release +20100518 110000 ID2, IT2 ending date and time of release +-117.6152 XPOINT1 (real) longitude [deg] of lower left corner + 34.0450 YPOINT1 (real) latitude [deg] of lower left corner +-117.5952 XPOINT2 (real) longitude [deg] of upper right corner + 34.0650 YPOINT2 (real) latitude [DEG] of upper right corner + 3 KINDZ (int) 1 for m above ground, 2 for m above sea level, 3 pressure + 984.3800 ZPOINT1 (real) lower z-level + 972.5500 ZPOINT2 (real) upper z-level + 10000 NPART (int) total number of particles to be released +.1000E+01 XMASS (real) total mass emitted +release1 NAME OF RELEASE LOCATION +20100518 110000 +20100518 110000 +-118.0229 + 34.1349 +-117.9913 + 34.1356 + 3 + 932.270 + 922.270 + 10000 +.1000E+01 +release2 +20100518 110000 +20100518 110000 +-116.9502 + 33.7114 +-116.9183 + 33.7341 + 3 + 687.110 + 677.110 + 10000 +.1000E+01 +release3 diff --git a/src_flexwrf_v3.1/examples/flexwrf.input.forward1 b/src_flexwrf_v3.1/examples/flexwrf.input.forward1 new file mode 100644 index 0000000000000000000000000000000000000000..487edfea3d10022276d89910be4158231e0f96f9 --- /dev/null +++ b/src_flexwrf_v3.1/examples/flexwrf.input.forward1 @@ -0,0 +1,103 @@ +=====================FORMER PATHNAMES FILE=================== +/scratch2/portfolios/BMC/stela/jbrioude/test_depo1/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/AVAILABLE2 +============================================================= +=====================FORMER COMMAND FILE===================== + 1 LDIRECT: 1 for forward simulation, -1 for backward simulation + 20100518 000000 YYYYMMDD HHMISS beginning date of simulation + 20100518 110000 YYYYMMDD HHMISS ending date of simulation + 3600 SSSSS (int) output every SSSSS seconds + 3600 SSSSS (int) time average of output (in SSSSS seconds) + 180 SSSSS (int) sampling rate of output (in SSSSS seconds) + 999999999 SSSSS (int) time constant for particle splitting (in seconds) + 180 SSSSS (int) synchronisation interval of flexpart (in seconds) + 10. CTL (real) factor by which time step must be smaller than tl + 10 IFINE (int) decrease of time step for vertical motion by factor ifine + 1 IOUT 1 concentration, 2 mixing ratio, 3 both, 4 plume traject, 5=1+4 + 0 IPOUT particle dump: 0 no, 1 every output interval, 2 only at end + 0 LSUBGRID subgrid terrain effect parameterization: 1 yes, 0 no + 0 LCONVECTION convection: 3 yes, 0 no + 3600. DT_CONV (real) time interval to call convection, seconds + 1 LAGESPECTRA age spectra: 1 yes, 0 no + 0 IPIN continue simulation with dumped particle data: 1 yes, 0 no + 0 IFLUX calculate fluxes: 1 yes, 0 no + 0 IOUTPUTFOREACHREL CREATE AN OUPUT FILE FOR EACH RELEASE LOCATION: 1 YES, 0 NO + 0 MDOMAINFILL domain-filling trajectory option: 1 yes, 0 no, 2 strat. o3 tracer + 1 IND_SOURCE 1=mass unit , 2=mass mixing ratio unit + 2 IND_RECEPTOR 1=mass unit , 2=mass mixing ratio unit + 1 NESTED_OUTPUT shall nested output be used? 1 yes, 0 no + 0 LINIT_COND INITIAL COND. FOR BW RUNS: 0=NO,1=MASS UNIT,2=MASS MIXING RATIO UNIT + 1 TURB_OPTION 0=no turbulence; 1=diagnosed as in flexpart_ecmwf; 2 and 3=from tke. + 0 CBL SCHEME 0=no, 1=yes. works if TURB_OPTION=1 + 1 SFC_OPTION 0=default computation of u*, hflux, pblh, 1=from wrf + 1 WIND_OPTION 0=snapshot winds, 1=mean winds,2=snapshot eta-dot,-1=w based on divergence + 1 TIME_OPTION 1=correction of time validity for time-average wind, 0=no need + 1 OUTGRID_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 1 RELEASE_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 2 IOUTTYPE 0=default binary, 1=ascii (for particle dump only),2=netcdf + 3 NCTIMEREC (int) Time frames per output file, only used for netcdf + 0 VERBOSE VERBOSE MODE,0=minimum, 100=maximum +=====================FORMER AGECLASESS FILE================== + 2 NAGECLASS number of age classes + 7200 SSSSSS (int) age class in SSSSS seconds + 999999 SSSSSS (int) age class in SSSSS seconds +=====================FORMER OUTGRID FILE===================== + -123.00 OUTLONLEFT geograhical longitude of lower left corner of output grid + 38.0 OUTLATLOWER geographical latitude of lower left corner of output grid + 24 NUMXGRID number of grid points in x direction (= # of cells ) + 28 NUMYGRID number of grid points in y direction (= # of cells ) + 0 OUTGRIDDEF outgrid defined 0=using grid distance, 1=upperright corner coordinate + 0.1250 DXOUTLON grid distance in x direction or upper right corner of output grid + 0.1250 DYOUTLON grid distance in y direction or upper right corner of output grid + 3 NUMZGRID number of vertical levels + 100.0 LEVEL height of level (upper boundary) + 1000.0 LEVEL height of level (upper boundary) + 20000.0 LEVEL height of level (upper boundary) +================OUTGRID_NEST========================== + -123. OUTLONLEFT geograhical longitude of lower left corner of output grid + 38.00 OUTLATLOWER geographical latitude of lower left corner of output grid + 24 NUMXGRID number of grid points in x direction (= # of cells ) + 28 NUMYGRID number of grid points in y direction (= # of cells ) + 0 OUTGRIDDEF outgrid defined 0=using grid distance, 1=upperright corner coordinate + 0.125 DXOUTLON grid distance in x direction or upper right corner of output grid + 0.125 DYOUTLON grid distance in y direction or upper right corner of output grid +=====================FORMER RECEPTOR FILE==================== + 0 NUMRECEPTOR number of receptors +=====================FORMER SPECIES FILE===================== + 2 NUMTABLE number of variable properties. The following lines are fixed format +XXXX|NAME |decaytime |wetscava |wetsb|drydif|dryhenry|drya|partrho |parmean|partsig|dryvelo|weight | + AIRTRACER -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 29.00 + Cs-137 -999.9 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 +=====================FORMER RELEEASES FILE=================== + 2 NSPEC total number of species emitted + 0 EMITVAR 1 for emission variation + 1 LINK index of species in file SPECIES + 2 LINK index of species in file SPECIES +2 NUMPOINT number of releases +20100518 000000 ID1, IT1 beginning date and time of release +20100518 110000 ID2, IT2 ending date and time of release +-123.0000 XPOINT1 (real) longitude [deg] of lower left corner + 40.3000 YPOINT1 (real) latitude [deg] of lower left corner +-122.6000 XPOINT2 (real) longitude [deg] of upper right corner + 40.6000 YPOINT2 (real) latitude [DEG] of upper right corner + 1 KINDZ (int) 1 for m above ground, 2 for m above sea level, 3 pressure + 100.000 ZPOINT1 (real) lower z-level + 1000.000 ZPOINT2 (real) upper z-level + 50000 NPART (int) total number of particles to be released +.1000E+04 XMASS (real) total mass emitted +.1000E+04 XMASS (real) total mass emitted +box1 NAME OF RELEASE LOCATION +20100518 000000 +20100518 110000 +-122.0000 + 38.3000 +-121.6000 + 38.6000 + 1 + 100.000 + 1000.000 + 50000 +.5000E+04 +.1000E+04 +box2 diff --git a/src_flexwrf_v3.1/examples/flexwrf.input.forward2 b/src_flexwrf_v3.1/examples/flexwrf.input.forward2 new file mode 100644 index 0000000000000000000000000000000000000000..db66d3016057027cd4d80c8f553e2dd949efcfa6 --- /dev/null +++ b/src_flexwrf_v3.1/examples/flexwrf.input.forward2 @@ -0,0 +1,157 @@ +=====================FORMER PATHNAMES FILE=================== +/scratch2/portfolios/BMC/stela/jbrioude/flexwrf_forward2/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/AVAILABLE2 +============================================================= +=====================FORMER COMMAND FILE===================== + 1 LDIRECT: 1 for forward simulation, -1 for backward simulation + 20100518 000000 YYYYMMDD HHMISS beginning date of simulation + 20100518 110000 YYYYMMDD HHMISS ending date of simulation + 3600 SSSSS (int) output every SSSSS seconds + 3600 SSSSS (int) time average of output (in SSSSS seconds) + 180 SSSSS (int) sampling rate of output (in SSSSS seconds) + 999999999 SSSSS (int) time constant for particle splitting (in seconds) + 180 SSSSS (int) synchronisation interval of flexpart (in seconds) + 10. CTL (real) factor by which time step must be smaller than tl + 10 IFINE (int) decrease of time step for vertical motion by factor ifine + 1 IOUT 1 concentration, 2 mixing ratio, 3 both, 4 plume traject, 5=1+4 + 0 IPOUT particle dump: 0 no, 1 every output interval, 2 only at end + 0 LSUBGRID subgrid terrain effect parameterization: 1 yes, 0 no + 0 LCONVECTION convection: 3 yes, 0 no + 3600. DT_CONV (real) time interval to call convection, seconds + 0 LAGESPECTRA age spectra: 1 yes, 0 no + 0 IPIN continue simulation with dumped particle data: 1 yes, 0 no + 0 IFLUX calculate fluxes: 1 yes, 0 no + 1 IOUTPUTFOREACHREL CREATE AN OUPUT FILE FOR EACH RELEASE LOCATION: 1 YES, 0 NO + 0 MDOMAINFILL domain-filling trajectory option: 1 yes, 0 no, 2 strat. o3 tracer + 1 IND_SOURCE 1=mass unit , 2=mass mixing ratio unit + 1 IND_RECEPTOR 1=mass unit , 2=mass mixing ratio unit + 0 NESTED_OUTPUT shall nested output be used? 1 yes, 0 no + 0 LINIT_COND INITIAL COND. FOR BW RUNS: 0=NO,1=MASS UNIT,2=MASS MIXING RATIO UNIT + 1 TURB_OPTION 0=no turbulence; 1=diagnosed as in flexpart_ecmwf; 2 and 3=from tke. + 1 CBL SCHEME 0=no, 1=yes. works if TURB_OPTION=1 + 1 SFC_OPTION 0=default computation of u*, hflux, pblh, 1=from wrf + 0 WIND_OPTION 0=snapshot winds, 1=mean winds,2=snapshot eta-dot,-1=w based on divergence + 0 TIME_OPTION 1=correction of time validity for time-average wind, 0=no need + 0 OUTGRID_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 1 RELEASE_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 2 IOUTTYPE 0=default binary, 1=ascii (for particle dump only),2=netcdf + 1 NCTIMEREC (int) Time frames per output file, only used for netcdf + 0 VERBOSE VERBOSE MODE,0=minimum, 100=maximum +=====================FORMER AGECLASESS FILE================== + 2 NAGECLASS number of age classes + 7200 SSSSSS (int) age class in SSSSS seconds + 999999 SSSSSS (int) age class in SSSSS seconds +=====================FORMER OUTGRID FILE===================== + 0. OUTLONLEFT geograhical longitude of lower left corner of output grid + 0. OUTLATLOWER geographical latitude of lower left corner of output grid + 100 NUMXGRID number of grid points in x direction (= # of cells ) + 120 NUMYGRID number of grid points in y direction (= # of cells ) + 1 OUTGRIDDEF outgrid defined 0=using grid distance, 1=upperright corner coordinate + 1200000. DXOUTLON grid distance in x direction or upper right corner of output grid + 1440000. DYOUTLON grid distance in y direction or upper right corner of output grid + 3 NUMZGRID number of vertical levels + 100.0 LEVEL height of level (upper boundary) + 1000.0 LEVEL height of level (upper boundary) + 20000.0 LEVEL height of level (upper boundary) +=====================FORMER RECEPTOR FILE==================== + 0 NUMRECEPTOR number of receptors +=====================FORMER SPECIES FILE===================== + 2 NUMTABLE number of variable properties. The following lines are fixed format +XXXX|NAME |decaytime |wetscava |wetsb|drydif|dryhenry|drya|partrho |parmean|partsig|dryvelo|weight | + AIRTRACER -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 29.00 + Cs-137 -999.9 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 +=====================FORMER RELEEASES FILE=================== + 2 NSPEC total number of species emitted + 1 EMITVAR 1 for emission variation + 1 LINK index of species in file SPECIES + 0 0.487 0.932 0-1 local time + 1 0.273 0.931 1-2 local time + 2 0.169 0.927 + 3 0.138 0.926 + 4 0.212 0.928 + 5 0.492 0.936 + 6 0.993 0.952 + 7 1.386 0.975 + 8 1.493 1.046 + 9 1.299 1.055 + 10 1.218 1.061 + 11 1.204 1.064 + 12 1.228 1.067 + 13 1.273 1.068 + 14 1.334 1.069 + 15 1.475 1.068 + 16 1.570 1.024 + 17 1.645 1.017 + 18 1.590 1.008 + 19 1.312 1.007 + 20 1.021 1.004 + 21 0.854 0.996 + 22 0.753 0.981 + 23 0.580 0.958 23-24 local time + 1 1.000 1.000 Monday + 2 1.000 1.000 Tuesday + 3 1.000 1.000 Wednesday + 4 1.000 1.000 Thursday + 5 1.000 1.000 Friday + 6 1.000 1.000 Saturday + 7 1.000 1.000 Sunday + 2 LINK index of species in file SPECIES + 0 0.487 0.932 0-1 local time + 1 0.273 0.931 1-2 local time + 2 0.169 0.927 + 3 0.138 0.926 + 4 0.212 0.928 + 5 0.492 0.936 + 6 0.993 0.952 + 7 1.386 0.975 + 8 1.493 1.046 + 9 1.299 1.055 + 10 1.218 1.061 + 11 1.204 1.064 + 12 1.228 1.067 + 13 1.273 1.068 + 14 1.334 1.069 + 15 1.475 1.068 + 16 1.570 1.024 + 17 1.645 1.017 + 18 1.590 1.008 + 19 1.312 1.007 + 20 1.021 1.004 + 21 0.854 0.996 + 22 0.753 0.981 + 23 0.580 0.958 23-24 local time + 1 1.000 1.000 Monday + 2 1.000 1.000 Tuesday + 3 1.000 1.000 Wednesday + 4 1.000 1.000 Thursday + 5 1.000 1.000 Friday + 6 1.000 1.000 Saturday + 7 1.000 1.000 Sunday +2 NUMPOINT number of releases +20100518 000000 ID1, IT1 beginning date and time of release +20100518 110000 ID2, IT2 ending date and time of release +-123.0000 XPOINT1 (real) longitude [deg] of lower left corner + 40.3000 YPOINT1 (real) latitude [deg] of lower left corner +-122.6000 XPOINT2 (real) longitude [deg] of upper right corner + 40.6000 YPOINT2 (real) latitude [DEG] of upper right corner + 1 KINDZ (int) 1 for m above ground, 2 for m above sea level, 3 pressure + 100.000 ZPOINT1 (real) lower z-level + 1000.000 ZPOINT2 (real) upper z-level + 50000 NPART (int) total number of particles to be released +.1000E+04 XMASS (real) total mass emitted +.1000E+04 XMASS (real) total mass emitted +release_1 NAME OF RELEASE LOCATION +20100518 000000 +20100518 110000 +-122.0000 + 38.3000 +-121.6000 + 38.6000 + 1 + 100.000 + 1000.000 + 50000 +.5000E+04 +.1000E+04 +release_2 diff --git a/src_flexwrf_v3.1/f_get_coeff.f90 b/src_flexwrf_v3.1/f_get_coeff.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d1a6d4423fc51ac8db97a90e1c1c8d622ea8a27b --- /dev/null +++ b/src_flexwrf_v3.1/f_get_coeff.f90 @@ -0,0 +1,93 @@ +subroutine f_get_coeff(nn,mm,rr,ww,avec,nj,id,pp,np) +!=============================================================================== +! Compute MT jump ahead polynomial coefficients +! uses GF(2)[x] computation +!=============================================================================== + use mt_kind_defs + use gf2xe + implicit none + integer(INT32), intent(in) :: nn,mm,rr,ww,avec,nj,id + integer(INT32), intent(inout) :: pp(0:nn-1),np + type(gf2x_obj) :: af,bf,ff,f1,f2 + type(gf2x_prime_obj) :: fp + integer(INT32) :: i,ib,nws + +!============================== +! MT characteristic polynomial +! ff : MT char poly. +!============================== + call set_coef(af,nn) + call set_coef(af,mm) ! af = x^nn + x^mm + call set_coef(bf,nn-1) + call set_coef(bf,mm-1) ! bf = x^(nn-1) + x^(mm-1) + + call pow(f1,af,ww-rr) ! f1 = af^(ww-rr) + call pow(f2,bf,rr) ! f2 = bf^(rr) + call mult(ff,f1,f2) ! ff = f1*f2 + do i=0,rr-1 + ib = mod(i,ww) + if (BTEST(avec,ib)) then + call pow(f2,bf,rr-1-i) + call mult_assign(f2,f1) + call add_assign(ff,f2) + endif + enddo + do i=rr,ww-1 + ib = mod(i,ww) + if (BTEST(avec,ib)) then + call pow(f1,af,ww-1-i) + call add_assign(ff,f1) + endif + enddo + +!#ifdef _DEBUG_ +! write(*,'("@",$)') +! call print_hex(ff) +!#endif + + call delete(af) + call delete(bf) + call delete(f1) + call delete(f2) + +!============================== +! set ff for Barrett reduction +!============================== + call set_prime(fp,ff) ! fp = ff + call delete(ff) + call delete(f1) + call delete(f2) + +!=============== +! jump ahead +! long jump +!=============== + call gf2x_pow_pow_2(f1,nj,fp) ! f1 = x**(2**nj) mod fp + +!#ifdef _DEBUG_ +! write(*,'("@",$)') +! call print_hex(f1) +!#endif + +!=============== +! short jump +!=============== + call pow(ff,f1,id,fp) ! ff = f1**id mod fp + +!#ifdef _DEBUG_ +! write(*,'("@",$)') +! call print_hex(ff) +!#endif + + pp(:) = 0 + np = get_deg(ff)+1 + nws = CEILING(real(np,kind=KIND(1.0d0))/32) + pp(0:nws-1) = ff%c(0:nws-1) + + call delete(f1) + call delete(f2) + call delete(ff) + call delete(fp) + + return +end subroutine diff --git a/src_flexwrf_v3.1/flexwrf.f90 b/src_flexwrf_v3.1/flexwrf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b05fc654c6d5014d7bd2ccb5f2f368b31ec6e5ea --- /dev/null +++ b/src_flexwrf_v3.1/flexwrf.f90 @@ -0,0 +1,287 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + program flexwrf +!******************************************************************************* +! * +! This is the Lagrangian Particle Dispersion Model FLEXPART_WRF. * +! * +! FLEXPART uses met. files from the ECMWF model (in grib format), * +! and its internal computational grid is latitude-longitude. * +! * +! FLEXPART_WRF uses met. files from the WRF model (in NetCDF format), * +! and its internal computational grid is the WRF x-y grid. * +! * +! 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 * +! * +! Nov 2005, R. Easter - Added the above comments and changed * +! the program name to "flexpart_wrf" * +! * +! Feb 2012, J Brioude- modify the name of the pilt_wrf model from PNLL * +! to flexwrf. +! start doing versions * +! input information should be put in flexwr.input * +! Mar 2012, J Brioude: Hybrid parallelization of v74. everything converted * +! in fortran 90, based on version 90.1 of the main stream * +! version of FLEXPART. * +! Jun 2012, J Brioude: Add tests on arguments to the flexwrf input file. * +!******************************************************************************* +! * +! Variables: * +! * +! Constants: * +! * +!******************************************************************************* + + + use point_mod + use par_mod + use com_mod + use conv_mod + + use luxury + use mt_stream + + implicit none + +! include 'mpif.h' + + integer :: i,j,ix,jy,inest,ii +! ,MPI_COMM_WORLD + integer :: idummy = -320 + integer :: inext,inextp,ma(55),iff +! integer, dimension(MPI_STATUS_SIZE) :: status + integer :: myid,ntasks,islave +! integer, parameter :: master=0, mstgtag1=11, msgtag2=12 + integer :: ierr + + real, external :: ran3 ! added by mc to use RAN3 using the original JB random number system + integer, allocatable :: seed(:) ! here and below further variable used by the MT generator + integer(4) :: iseed = 73519232 + integer :: id + type (mt_state) :: mts (0: MAX_STREAM) + character :: nummpi_id*2 !for test on pc + +! if (myid.eq.0) then +!let's comment the line above to let each node reading and making the same +!thing. + +! save inext,inextp,ma,iff + iff=0 +! call MPI_INIT( ierr ) +! call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) +! call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) + + if (command_argument_count().eq.0) then + print*,'the input file used is flexwrf.input in the ' // & + 'local folder of the executable' + inputname='flexwrf.input' + endif + if (command_argument_count().gt.0) then + call get_command_argument(1,inputname,len2,ierr) + print*,'the input file used is ' // inputname + endif + + +! Generate a large number of random numbers +!****************************************** + if (newrandomgen.eq.0) then +! idummy = -320-(myid*4049) + idummy = -320 + do j=1,maxomp + do i=1,maxrand-1,2 + ii=i+(j-1)*maxrand + call gasdev1(idummy,rannumb(ii),rannumb(ii+1),inext,inextp,ma,iff) + enddo + enddo + ii=maxrand*maxomp + call gasdev1(idummy,rannumb(ii),rannumb(ii-1),inext,inextp,ma,iff) +! print*,'rand',myid +! print*,rannumb(1:5) +! call ranlux(uniform_rannumb,maxrandomp) ! this generate a uniform +! distribution + else + idummy=254 !+myid*443 !different seed for different mpi processes are produced so indepedent stream for any mpi process suing RANLUX are certain + call RLUXGO(3,idummy,0,0) ! this set the luxury level to 3 and initalize the generator for any myid + do i=1,maxrand-1,2 + call gasdevlux2R(rannumb(i),rannumb(i+1)) !this will generate a guassian distribution + end do + call gasdevlux2R(rannumb(maxrand),rannumb(maxrand-1)) + ! Generate a stream of uniform deviate random numbers to be used for CBL + call ranlux(uniform_rannumb,maxrand) ! this generate a uniform distribution + +!----- comment by MC: now initialize the mersenne twister generator for a number +!max_stream of possible streams +!----- to be called subsequently by any openmp process activated. note RANLUX +!above is suppose to be the best generator +!----- but it is slower than mersenne twister and moreover it would require some +!adaptation for workiong with openmp processes + !do this on any mpi_process taht will have a copy of all the MT generator + !initialization + ! set parameters + + call set_mt19937 + + ! initialize MT state type + call new (mts(0)) + + call init (mts(0),iseed) !iseed unique and defined above. note that the lenght of the period of the master stream is about 2^19000 + + ! initialize additional streams from the master. this is done jumping + ! between different points in the stream any child stream has period + ! 2^256 + do id=1, MAX_STREAM + call create_stream (mts(0),mts(id),id) + end do + end if + + +! Read the unified input file - jdf +!*************************** + + call readinput + + if ( DRYDEP ) then +! Read the landuse inventory +!*************************** + + call readlanduse + +! Assign fractional cover of landuse classes to each ECMWF grid point +!******************************************************************** + + call assignland + +! Read and compute surface resistances to dry deposition of gases +!**************************************************************** + + call readdepo + endif + +! 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 +! enddo + +! 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 +!*************************************************************** +! if (myid.eq.0) then + if (outgrid_option.eq.0) then + call outgrid_init_irreg + if (nested_output.eq.1) call outgrid_init_nest_irreg !need to be fixed + elseif (outgrid_option.eq.1) then + call outgrid_init_reg + if (nested_output.eq.1) call outgrid_init_nest_reg !need to be fixed + endif +! endif + + + ! 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 +!****************************************************************** + +! if (myid.eq.0) then + if (iouttype.eq.0 .or. iouttype.eq.1) then ! binary or ascii output + call writeheader + if (nested_output.eq.1) call writeheader_nest() !need to be fixed + else ! netcdf output + call write_ncheader(0,0) + if (nested_output.eq.1) call write_ncheader(0,1) + endif !iouttype +! open(unitdates,file=path(2)(1:length(2))//'dates') + open(unitdates,file=path(1)(1:length(1))//'dates') + call openreceptors + if ((iout.eq.4).or.(iout.eq.5)) call openouttraj + +! endif +! 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 + enddo + +! 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 +!******************************** +! endif !if condition on myid +! call MPI_BARRIER(MPI_COMM_WORLD,ierr) + + call timemanager(mts) + + + write(*,'(/a/)') 'CONGRATULATIONS: YOU HAVE SUCCESSFULLY ' // & + 'COMPLETED A FLEXPART_WRF MODEL RUN!' + +! call MPI_FINALIZE ( ierr ) + +end program flexwrf + diff --git a/src_flexwrf_v3.1/flexwrf.input.reference b/src_flexwrf_v3.1/flexwrf.input.reference new file mode 100644 index 0000000000000000000000000000000000000000..391372c75391628bb72f705ff98bd16163d66967 --- /dev/null +++ b/src_flexwrf_v3.1/flexwrf.input.reference @@ -0,0 +1,92 @@ +=====================FORMER PATHNAMES FILE=================== +/scratch2/portfolios/BMC/stela/jbrioude/flexwrf_forward1/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/ +/scratch2/portfolios/BMC/stela/jbrioude/wrfnomodif2/AVAILABLE2 +============================================================= +=====================FORMER COMMAND FILE===================== + 1 LDIRECT: 1 for forward simulation, -1 for backward simulation + 20100518 000000 YYYYMMDD HHMISS beginning date of simulation + 20100518 110000 YYYYMMDD HHMISS ending date of simulation + 3600 SSSSS (int) output every SSSSS seconds + 3600 SSSSS (int) time average of output (in SSSSS seconds) + 180 SSSSS (int) sampling rate of output (in SSSSS seconds) + 999999999 SSSSS (int) time constant for particle splitting (in seconds) + 180 SSSSS (int) synchronisation interval of flexpart (in seconds) + 10. CTL (real) factor by which time step must be smaller than tl + 10 IFINE (int) decrease of time step for vertical motion by factor ifine + 1 IOUT 1 concentration, 2 mixing ratio, 3 both, 4 plume traject, 5=1+4 + 0 IPOUT particle dump: 0 no, 1 every output interval, 2 only at end + 0 LSUBGRID subgrid terrain effect parameterization: 1 yes, 0 no + 0 LCONVECTION convection: 3 yes, 0 no + 3600. DT_CONV (real) time interval to call convection, seconds + 1 LAGESPECTRA age spectra: 1 yes, 0 no + 0 IPIN continue simulation with dumped particle data: 1 yes, 0 no + 0 IFLUX calculate fluxes: 1 yes, 0 no + 0 IOUTPUTFOREACHREL CREATE AN OUPUT FILE FOR EACH RELEASE LOCATION: 1 YES, 0 NO + 0 MDOMAINFILL domain-filling trajectory option: 1 yes, 0 no, 2 strat. o3 tracer + 1 IND_SOURCE 1=mass unit , 2=mass mixing ratio unit + 2 IND_RECEPTOR 1=mass unit , 2=mass mixing ratio unit + 0 NESTED_OUTPUT shall nested output be used? 1 yes, 0 no + 0 LINIT_COND INITIAL COND. FOR BW RUNS: 0=NO,1=MASS UNIT,2=MASS MIXING RATIO UNIT + 1 TURB_OPTION 0=no turbulence; 1=diagnosed as in flexpart_ecmwf; 2 and 3=from tke. + 0 CBL SCHEME 0=no, 1=yes. works if TURB_OPTION=1 + 1 SFC_OPTION 0=default computation of u*, hflux, pblh, 1=from wrf + 1 WIND_OPTION 0=snapshot winds, 1=mean winds,2=snapshot eta-dot,-1=w based on divergence + 1 TIME_OPTION 1=correction of time validity for time-average wind, 0=no need + 1 OUTGRID_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 1 RELEASE_COORD 0=wrf grid(meters), 1=regular lat/lon grid + 2 IOUTTYPE 0=default binary, 1=ascii (for particle dump only),2=netcdf + 3 NCTIMEREC (int) Time frames per output file, only used for netcdf + 0 VERBOSE VERBOSE MODE,0=minimum, 100=maximum +=====================FORMER AGECLASESS FILE================== + 2 NAGECLASS number of age classes + 7200 SSSSSS (int) age class in SSSSS seconds + 999999 SSSSSS (int) age class in SSSSS seconds +=====================FORMER OUTGRID FILE===================== + -123.00 OUTLONLEFT geograhical longitude of lower left corner of output grid + 38.0 OUTLATLOWER geographical latitude of lower left corner of output grid + 24 NUMXGRID number of grid points in x direction (= # of cells ) + 28 NUMYGRID number of grid points in y direction (= # of cells ) + 0 OUTGRIDDEF outgrid defined 0=using grid distance, 1=upperright corner coordinate + 0.1250 DXOUTLON grid distance in x direction or upper right corner of output grid + 0.1250 DYOUTLON grid distance in y direction or upper right corner of output grid + 3 NUMZGRID number of vertical levels + 100.0 LEVEL height of level (upper boundary) + 1000.0 LEVEL height of level (upper boundary) + 20000.0 LEVEL height of level (upper boundary) +=====================FORMER RECEPTOR FILE==================== + 0 NUMRECEPTOR number of receptors +=====================FORMER SPECIES FILE===================== + 2 NUMTABLE number of variable properties. The following lines are fixed format +XXXX|NAME |decaytime |wetscava |wetsb|drydif|dryhenry|drya|partrho |parmean|partsig|dryvelo|weight | + AIRTRACER -999.9 -9.9E-09 -9.9 -9.9E09 -9.99 29.00 + Cs-137 -999.9 1.0E-04 0.80 -9.9 2.5E03 6.0E-7 3.0E-1 -9.99 -9.99 +=====================FORMER RELEEASES FILE=================== + 1 NSPEC total number of species emitted + 0 EMITVAR 1 for emission variation + 1 LINK index of species in file SPECIES +2 NUMPOINT number of releases +20100518 120000 ID1, IT1 beginning date and time of release +20100518 220000 ID2, IT2 ending date and time of release +-123.0000 XPOINT1 (real) longitude [deg] of lower left corner + 40.3000 YPOINT1 (real) latitude [deg] of lower left corner +-122.6000 XPOINT2 (real) longitude [deg] of upper right corner + 40.6000 YPOINT2 (real) latitude [DEG] of upper right corner + 1 KINDZ (int) 1 for m above ground, 2 for m above sea level, 3 pressure + 100.000 ZPOINT1 (real) lower z-level + 1000.000 ZPOINT2 (real) upper z-level + 50000 NPART (int) total number of particles to be released +.1000E+04 XMASS (real) total mass emitted, species 1 +box1 NAME OF RELEASE LOCATION +20100518 120000 +20100518 130000 +-122.0000 + 38.3000 +-121.6000 + 38.6000 + 1 + 100.000 + 1000.000 + 50000 +.5000E+04 +box2 diff --git a/src_flexwrf_v3.1/flexwrf_mpi.f90 b/src_flexwrf_v3.1/flexwrf_mpi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..963a80952f121fe64a02a8a418a2332e0bee7323 --- /dev/null +++ b/src_flexwrf_v3.1/flexwrf_mpi.f90 @@ -0,0 +1,309 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + program flexwrf_mpi +! +!******************************************************************************* +! * +! This is the Lagrangian Particle Dispersion Model FLEXPART_WRF. * +! * +! FLEXPART uses met. files from the ECMWF model (in grib format), * +! and its internal computational grid is latitude-longitude. * +! * +! FLEXPART_WRF uses met. files from the WRF model (in NetCDF format), * +! and its internal computational grid is the WRF x-y grid. * +! * +! 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 * +! * +! Nov 2005, R. Easter - Added the above comments and changed * +! the program name to "flexpart_wrf" * +! * +! Feb 2012, J Brioude- modify the name of the pilt_wrf model from PNLL * +! to flexwrf. +! start doing versions * +! input information should be put in flexwr.input * +! Mar 2012, J Brioude: Hybrid parallelization of v74. everything converted * +! in fortran 90, based on version 90.1 of the main stream * +! version of FLEXPART. * +! Jun 2012, J Brioude: Add tests on arguments to the flexwrf input file. * +!******************************************************************************* +! * +! Variables: * +! * +! Constants: * +! * +!******************************************************************************* + + + use point_mod + use par_mod + use com_mod + use conv_mod + + !-- modules below added by mc for parallel random generaiton using teh RANLUX + !and Mersenne-Twister generator + use luxury + use mt_stream + implicit none + + include 'mpif.h' + + integer :: i,j,ix,jy,inest,ii +! integer :: MPI_COMM_WORLD + integer :: idummy + integer :: inext,inextp,ma(55),iff + integer, dimension(MPI_STATUS_SIZE) :: status + integer :: myid,ntasks,ierr,islave +! ,len2 +! character(len=200) :: inputname + real, external :: ran3 ! added by mc to use RAN3 using the original JB random number system + integer, allocatable :: seed(:) ! here and below further variable used by the MT generator + integer(4) :: iseed = 73519232 + integer :: id + type (mt_state) :: mts (0: MAX_STREAM) + character :: nummpi_id*2 !for test on pc + +! integer, parameter :: master=0, mstgtag1=11, msgtag2=12 + + +! if (myid.eq.0) then +!let's comment the line above to let each node reading and making the same +!thing. + +! save inext,inextp,ma,iff + iff=0 +! print*,'before 1' + call MPI_INIT( ierr ) + call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) + call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) + +! print*,'after 1' + + print*,'MPI id',myid +! Generate a large number of random numbers +! write(*,9100) 'degrees longitude,latitude', +! + 'degrees longitude,latitude' +! else +! write(*,9100) 'grid-meters', 'grid-meters' +! endif +!9100 format( ' x,y coordinates in input files must be in ', a / +! + ' x,y coordinates in output files will be in ', a / ) + + + if (command_argument_count().eq.0) then + print*,'the input file used is flexwrf.input in the ' // & + 'local folder of the executable' + inputname='flexwrf.input' + endif + if (command_argument_count().gt.0) then + call get_command_argument(1,inputname,len2,ierr) + print*,'the input file used is ' // inputname + endif +! Generate a large number of random numbers +!****************************************** + if (newrandomgen.eq.0) then + idummy = -320-(myid*4049) +! idummy = -320 + do j=1,maxomp + do i=1,maxrand-1,2 + ii=i+(j-1)*maxrand + call gasdev1(idummy,rannumb(ii),rannumb(ii+1),inext,inextp,ma,iff) + enddo + enddo + ii=maxrand*maxomp + call gasdev1(idummy,rannumb(ii),rannumb(ii-1),inext,inextp,ma,iff) +! print*,'rand',myid +! print*,rannumb(1:5) +! call ranlux(uniform_rannumb,maxrandomp) ! this generate a uniform distribution + else + idummy=254+myid*443 !different seed for different mpi processes are produced so indepedent stream for any mpi process suing RANLUX are certain + call RLUXGO(3,idummy,0,0) ! this set the luxury level to 3 and initalize the generator for any myid + do i=1,maxrand-1,2 + call gasdevlux2R(rannumb(i),rannumb(i+1)) !this will generate a guassian distribution + end do + call gasdevlux2R(rannumb(maxrand),rannumb(maxrand-1)) + ! Generate a stream of uniform deviate random numbers to be used for CBL + call ranlux(uniform_rannumb,maxrand) ! this generate a uniform distribution + +!----- comment by MC: now initialize the mersenne twister generator for a number +!max_stream of possible streams +!----- to be called subsequently by any openmp process activated. note RANLUX +!above is suppose to be the best generator +!----- but it is slower than mersenne twister and moreover it would require some +!adaptation for workiong with openmp processes + !do this on any mpi_process taht will have a copy of all the MT generator + !initialization + ! set parameters + + call set_mt19937 + + ! initialize MT state type + call new (mts(0)) + + call init (mts(0),iseed) !iseed unique and defined above. note that the lenght of the period of the master stream is about 2^19000 + + ! initialize additional streams from the master. this is done jumping + ! between different points in the stream any child stream has period + ! 2^256 + do id=1, MAX_STREAM + call create_stream (mts(0),mts(id),id) + end do + end if + +! Read the unified input file - jdf +!*************************** + + call readinput + + if ( DRYDEP ) then + +! Read the landuse inventory +!*************************** + + call readlanduse + +! Assign fractional cover of landuse classes to each ECMWF grid point +!******************************************************************** + + call assignland + + +! Read and compute surface resistances to dry deposition of gases +!**************************************************************** + + call readdepo + endif +! 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 +! enddo + +! 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 +!*************************************************************** +! if (myid.eq.0) then + if (outgrid_option.eq.0) then + call outgrid_init_irreg + if (nested_output.eq.1) call outgrid_init_nest_irreg() !need to be fixed + elseif (outgrid_option.eq.1) then + call outgrid_init_reg + if (nested_output.eq.1) call outgrid_init_nest_reg() !need to be fixed + endif +! endif +! if (nested_output.eq.1) call outgrid_init_nest() !need to be fixed + + + ! 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 +!****************************************************************** + + if (myid.eq.0) then + if (iouttype.eq.0 .or. iouttype.eq.1) then ! binary or ascii output + call writeheader + if (nested_output.eq.1) call writeheader_nest() !need to be fixed + else ! netcdf output + call write_ncheader(0,0) + if (nested_output.eq.1) call write_ncheader(0,1) +! if (nested_output.eq.1) then +! write(*,*) 'netcdf nested output not finished yet! aborting' +! stop +! endif + endif !iouttype +! open(unitdates,file=path(2)(1:length(2))//'dates') + open(unitdates,file=path(1)(1:length(1))//'dates') + call openreceptors + if ((iout.eq.4).or.(iout.eq.5)) call openouttraj + + endif +! 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 + enddo + +! 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 +!******************************** +! endif !if condition on myid + call MPI_BARRIER(MPI_COMM_WORLD,ierr) + + +! print*,'entering timemanager' + call timemanager_mpi(mts) + + + write(*,'(/a/)') 'CONGRATULATIONS: YOU HAVE SUCCESSFULLY ' // & + 'COMPLETED A FLEXPART_WRF MODEL RUN!' + + call MPI_FINALIZE ( ierr ) + +end program flexwrf_mpi + diff --git a/src_flexwrf_v3.1/flux_mod.f90 b/src_flexwrf_v3.1/flux_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..220dd4f57d94fac2f3cdb8e165f35f098506afa7 --- /dev/null +++ b/src_flexwrf_v3.1/flux_mod.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/fluxoutput.f90 b/src_flexwrf_v3.1/fluxoutput.f90 new file mode 100644 index 0000000000000000000000000000000000000000..95faaf80f1047677a732a2cb75d362a15fbaea93 --- /dev/null +++ b/src_flexwrf_v3.1/fluxoutput.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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(1)(1:length(1))//'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 diff --git a/src_flexwrf_v3.1/gasdevlux.f90 b/src_flexwrf_v3.1/gasdevlux.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e422d52a12cd16f277d6a9f3dc2ce2f8df6836af --- /dev/null +++ b/src_flexwrf_v3.1/gasdevlux.f90 @@ -0,0 +1,73 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + !C--- adapted from press et al. 1992 numerial recipes in Fortran by Massimo Cassiani to jse RANLUX as uniform random number generator + FUNCTION gasdevlux() + USE luxury + INTEGER idum + REAL gasdevlux + INTEGER iset + REAL fac,gset,rsq,v1,v2,RTEST(2) + SAVE iset,gset + DATA iset/0/ + if (iset.eq.0) then +1 call RANLUX(RTEST,2) + + v1=2.*RTEST(1)-1. + v2=2.*RTEST(2)-1. + rsq=v1**2+v2**2 + if(rsq.ge.1..or.rsq.eq.0.)goto 1 + fac=sqrt(-2.*log(rsq)/rsq) + gset=v1*fac + gasdevlux=v2*fac + iset=1 + else + gasdevlux=gset + iset=0 + endif + return + END + + subroutine gasdevlux2R(random1,random2) + USE luxury + INTEGER idum + REAL random1,random2 + INTEGER iset + REAL fac,gset,rsq,v1,v2,RTEST(2) + +1 call RANLUX(RTEST,2) + + v1=2.*RTEST(1)-1. + v2=2.*RTEST(2)-1. + rsq=v1**2+v2**2 + if(rsq.ge.1..or.rsq.eq.0.)goto 1 + fac=sqrt(-2.*log(rsq)/rsq) + random1=v1*fac + random2=v2*fac + ! Limit the random numbers to lie within the interval -4 and +4 + !************************************************************** + if (random1.lt.-4.) random1=-4. + if (random2.lt.-4.) random2=-4. + if (random1.gt.4.) random1=4. + if (random2.gt.4.) random2=4. + return + END + diff --git a/src_flexwrf_v3.1/get_settling.f90 b/src_flexwrf_v3.1/get_settling.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2287ac59c43ceb1f63d4b8964c4f0080266b6506 --- /dev/null +++ b/src_flexwrf_v3.1/get_settling.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 + !**************************************************************** +! print*,'indice',indz,xt,yt,zt + 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)) +! print*,'cun',dquer(nsp),density(nsp),cunningham(nsp) + 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 diff --git a/src_flexwrf_v3.1/getfields.f90 b/src_flexwrf_v3.1/getfields.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4dfeed170e4e212cd6b26252c91490efa5080338 --- /dev/null +++ b/src_flexwrf_v3.1/getfields.f90 @@ -0,0 +1,228 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine 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|<itime, i.e. the absolute value of 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. * +! * +! Dec 2005, R. Easter - * +! When "memtime(2) = itime = wftime(numbwf)", do not read a new file. * +! This allows the ending date/time of the flexpart run to match * +! the date/time of the last met. file. * +! * +!******************************************************************************* +! * +! 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 calculation * +! 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(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) + real(kind=4) :: divh(0:nxmax-1,0:nymax-1,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 :: wwh(0:nxmax-1,0:nymax-1,nwzmax) + real(kind=4) :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) + real :: start, finish + + integer :: indmin = 1 + + + real(kind=4) :: divhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + character(len=28) :: name2 + character(len=8) :: chartime + integer :: ix,jy,kz + + + +! 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 + +! FLEXPART_WRF - following change allows the ending date/time +! of the flexpart run to match that of the last met. file + else if ( (ldirect*memtime(1).lt.ldirect*itime).and. & + (memtime(2).eq.itime) .and. (wftime(numbwf).eq.itime) ) then + + 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 cpu_time(start) + if ((time_option.eq.1).and.(wind_option.eq.1)) & + call readwind_timeav(indj+1,memind(2),uuh,vvh,wwh) + call readwind(indj+1,memind(2),uuh,vvh,wwh,divh) + if ((time_option.eq.1).and.(wind_option.eq.1)) & + call readwind_nests_timeav(indj+1,memind(2),uuhn,vvhn,wwhn) + call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn,divhn) + if (option_verbose.gt.1) then + call cpu_time(finish) + print*,'readwind',finish-start + call cpu_time(start) + endif + call calcpar(memind(2),uuh,vvh,pvh) + call calcpar_nests(memind(2),uuhn,vvhn,pvhn) + if (option_verbose.gt.1) then + call cpu_time(finish) + print*,'calcpar',finish-start + call cpu_time(start) + endif + call verttransform(memind(2),uuh,vvh,wwh,pvh,divh) + call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn,divhn) + if (option_verbose.gt.1) then + call cpu_time(finish) + print*,'verttran',finish-start + endif + memtime(2)=wftime(indj+1) + nstop = 1 + goto 40 + endif + enddo + 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 + if ((time_option.eq.1).and.(wind_option.eq.1)) & + call readwind_timeav(indj,memind(1),uuh,vvh,wwh) + call readwind(indj,memind(1),uuh,vvh,wwh,divh) + if ((time_option.eq.1).and.(wind_option.eq.1)) & + call readwind_nests_timeav(indj,memind(1),uuhn,vvhn,wwhn) + call readwind_nests(indj,memind(1),uuhn,vvhn,wwhn,divhn) + call calcpar(memind(1),uuh,vvh,pvh) + call calcpar_nests(memind(1),uuhn,vvhn,pvhn) + call verttransform(memind(1),uuh,vvh,wwh,pvh,divh) + call verttransform_nests(memind(1),uuhn,vvhn,wwhn,pvhn,divhn) + memtime(1)=wftime(indj) + memind(2)=2 + if ((time_option.eq.1).and.(wind_option.eq.1)) & + call readwind_timeav(indj+1,memind(2),uuh,vvh,wwh) + call readwind(indj+1,memind(2),uuh,vvh,wwh,divh) + if ((time_option.eq.1).and.(wind_option.eq.1)) & + call readwind_nests_timeav(indj+1,memind(2),uuhn,vvhn,wwhn) + call readwind_nests(indj+1,memind(2),uuhn,vvhn,wwhn,divhn) + call calcpar(memind(2),uuh,vvh,pvh) + call calcpar_nests(memind(2),uuhn,vvhn,pvhn) + call verttransform(memind(2),uuh,vvh,wwh,pvh,divh) + call verttransform_nests(memind(2),uuhn,vvhn,wwhn,pvhn,divhn) + 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 diff --git a/src_flexwrf_v3.1/getrb.f90 b/src_flexwrf_v3.1/getrb.f90 new file mode 100644 index 0000000000000000000000000000000000000000..82e58d623296404529dcf27999c00ac8b4fbcd7c --- /dev/null +++ b/src_flexwrf_v3.1/getrb.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/getrc.f90 b/src_flexwrf_v3.1/getrc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..05bbbe2d4d6ac1f83949d51596f97c30eb143709 --- /dev/null +++ b/src_flexwrf_v3.1/getrc.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/getvdep.f90 b/src_flexwrf_v3.1/getvdep.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b13749023f1430ae80d32a33d376680af99a2662 --- /dev/null +++ b/src_flexwrf_v3.1/getvdep.f90 @@ -0,0 +1,205 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine getvdep(n,ix,jy,ust,temp,pa,L,gr,rh,rr,vdepo) + ! 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 + +!JB: assume no snow input from WRF + snow=0. + ! 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 diff --git a/src_flexwrf_v3.1/getvdep_nests.f90 b/src_flexwrf_v3.1/getvdep_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..15e9d869a1da181b5ac2edf64f05352f2982a195 --- /dev/null +++ b/src_flexwrf_v3.1/getvdep_nests.f90 @@ -0,0 +1,205 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine getvdep_nests(n,ix,jy,ust,temp,pa, & + L,gr,rh,rr,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 + + snow=0. + ! 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 diff --git a/src_flexwrf_v3.1/gf2xe.f90 b/src_flexwrf_v3.1/gf2xe.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6e15b563bea1e511637078a6407fbd51231237d0 --- /dev/null +++ b/src_flexwrf_v3.1/gf2xe.f90 @@ -0,0 +1,1146 @@ +module gf2xe +!=============================================================================== +! Fortran 90/95 Module for GF(2)[x] computation +!=============================================================================== + use mt_kind_defs + implicit none + private + public :: gf2x_obj + public :: gf2x_prime_obj + public :: new,delete + public :: print_bit,print_hex + public :: get_deg + public :: set_coef, set_prime + public :: assign + public :: add, add_assign + public :: mult, mult_assign + public :: pow, square + public :: div, rem, divrem + public :: mult_by_x, div_by_x, mod_by_x + public :: shift + public :: deg_i32, mult_i32, square_i32, shift_i32 + public :: mult_i32_old + public :: gf2x_pow_pow_2 + + integer(INT32), parameter :: MAX_KARA = 64 + + type gf2x_obj + integer(INT32), pointer :: c(:) => NULL() + integer(INT32) :: deg = -1 + integer(INT32) :: size = -1 + end type + + type gf2x_prime_obj + type(gf2x_obj) :: prime_poly + type(gf2x_obj) :: barrett_poly + integer(INT32) :: deg + end type + + interface new + module procedure gf2x_new + module procedure gf2x_delete_prime + end interface + + interface delete + module procedure gf2x_delete + module procedure gf2x_delete_prime + end interface + + interface print_bit + module procedure gf2x_print_bit + end interface + + interface print_hex + module procedure gf2x_print_hex + end interface + + interface set_coef + module procedure gf2x_set_coef + end interface + + interface set_prime + module procedure gf2x_set_prime + end interface + + interface assign + module procedure gf2x_assign + end interface + + interface add + module procedure gf2x_add + end interface + + interface add_assign + module procedure gf2x_add_assign + end interface + + interface mult + module procedure gf2x_mult_kara + end interface + + interface mult_assign + module procedure gf2x_mult_assign_kara + end interface + + interface pow + module procedure gf2x_pow + module procedure gf2x_pow_mod + end interface + + interface square + module procedure gf2x_square + end interface + + interface mult_by_x + module procedure gf2x_mult_by_x + end interface + + interface mod_by_x + module procedure gf2x_mod_by_x + end interface + + interface div_by_x + module procedure gf2x_div_by_x + end interface + + interface div + module procedure gf2x_div + end interface + + interface rem + module procedure gf2x_rem + module procedure gf2x_rem_barrett + end interface + + interface divrem + module procedure gf2x_divrem + end interface + + interface shift + module procedure gf2x_shift + end interface + +contains + +!!DEC$ ATTRIBUTES FORCEINLINE :: get_size +function get_size(deg) result(size) + integer(INT32) :: deg,size + size = CEILING(real(deg+1,kind=REAL64)/32.0_REAL64) + return +end function + +subroutine gf2x_new(this,deg) + type(gf2x_obj), intent(inout) :: this + integer(INT32), intent(in) :: deg + integer(INT32) :: isize + intrinsic :: SIZE + if (deg < 0) then + this%deg = -1 + this%size = -1 + return + endif + isize = get_size(deg) + this%size = isize + this%deg = deg + if (.not.associated(this%c)) then + allocate(this%c(0:isize-1)) + else + if (SIZE(this%c) < this%size) then + deallocate(this%c) + NULLIFY(this%c) + allocate(this%c(0:isize-1)) + endif + endif + this%c(:) = 0 + return +end subroutine + +subroutine gf2x_delete(this) + type(gf2x_obj), intent(inout) :: this + integer(INT32) :: ierr + if (associated(this%c)) then + deallocate(this%c,STAT=ierr) + endif + NULLIFY(this%c) + this%deg = -1 + this%size = -1 + return +end subroutine + +subroutine gf2x_print_bit(this) + type(gf2x_obj), intent(in) :: this + integer(INT32) :: i,ib,iw,deg + deg = get_deg(this) + if (deg < 0) then + write(*,'("0")') + return + endif + do i=deg,0,-1 + ib = mod(i,32) + iw = i/32 + if (BTEST(this%c(iw),ib)) then + write(*,'("1",$)') + else + write(*,'("0",$)') + endif + enddo + write(*,'("")') + return +end subroutine + +subroutine gf2x_print_hex(this) + type(gf2x_obj), intent(in) :: this + integer(INT32) :: i,ib,iw,isize + character(9) :: str + if (is_zero(this)) then + write(*,'("0")') + return + endif + isize = get_size(this%deg) + i = isize-1 + write(str,'(Z8)')this%c(i) + write(*,'(A,$)')TRIM(ADJUSTL(str)) + do i=isize-2,0,-1 + write(*,'(Z8.8,$)')this%c(i) + enddo + write(*,'("")') + return +end subroutine + +subroutine gf2x_assign(c,a) + type(gf2x_obj), intent(inout) :: c ! c := a + type(gf2x_obj), intent(in) :: a + integer(INT32) :: ia,isa,i + + call delete(c) + if (is_zero(a)) then + return + endif + + ia = get_deg(a) + isa = get_size(ia) + call new(c,ia) + do i=0,isa-1 + c%c(i) = a%c(i) + enddo + + return +end subroutine + +function is_zero(a) result(is) + type(gf2x_obj), intent(in) :: a + logical :: is + integer(INT32) :: deg + deg = get_deg(a) + if (deg==-1) then + is = .true. + else + is = .false. + endif + return +end function + +!!DEC$ ATTRIBUTES FORCEINLINE :: get_deg +function get_deg(a) result(deg) + type(gf2x_obj), intent(in) :: a + integer(INT32) :: deg + integer(INT32) :: isize,i,top_deg + intrinsic :: SIZE + deg=-1 + if (.not.associated(a%c)) return + isize = SIZE(a%c) + do i=isize-1,0,-1 + if (a%c(i) /= 0) then + top_deg = deg_i32(a%c(i)) + deg = 32*i + top_deg + return + endif + enddo + return +end function + +subroutine gf2x_set_coef(a,i) + type(gf2x_obj), intent(inout) :: a + integer(INT32), intent(in) :: i + type(gf2x_obj), pointer :: w + integer(INT32) :: ib,iw + NULLIFY(w) + if (is_zero(a)) then + call new(a,i) + endif + allocate(w) + call new(w,i) + iw = i/32 + ib = mod(i,32) + w%c(iw) = ibset(w%c(iw),ib) + call add_assign(w,a) ! w := w + a + call assign(a,w) ! a := w + call delete(w) + deallocate(w) + NULLIFY(w) + a%deg = get_deg(a) + return +end subroutine + +subroutine gf2x_add_assign(c,a) + type(gf2x_obj), intent(inout) :: c ! c := c + a + type(gf2x_obj), intent(in) :: a + type(gf2x_obj), pointer :: w + integer(INT32) :: ia,ic + integer(INT32) :: isa,isc,i + if (is_zero(a)) then + return + endif + if (is_zero(c)) then + call assign(c,a) + return + endif + ia = a%deg + ic = c%deg + isa = a%size + isc = c%size + if (isc < isa) then + NULLIFY(w) + allocate(w) + call new(w,MAX(ia,ic)) + do i=0,isc-1 + w%c(i) = IEOR(c%c(i),a%c(i)) + enddo + do i=isc,isa-1 + w%c(i) = a%c(i) + enddo + call assign(c,w) + call delete(w) + deallocate(w) + NULLIFY(w) + else + do i=0,isa-1 + c%c(i) = IEOR(c%c(i),a%c(i)) + enddo + c%deg = get_deg(c) + c%size = get_size(c%deg) + endif + return +end subroutine + +subroutine gf2x_add(c,a,b) + type(gf2x_obj), intent(inout) :: c ! c := a + b + type(gf2x_obj), intent(in) :: a,b + integer(INT32) :: ia,ib,ic + integer(INT32) :: isa,isb,isc,i + if (is_zero(a) .and. is_zero(b)) then + return + endif + if (is_zero(a)) then + call assign(c,b) + return + endif + if (is_zero(b)) then + call assign(c,a) + return + endif + ia = get_deg(a) + ib = get_deg(b) + isa = get_size(ia) + isb = get_size(ib) + if (c%deg < MAX(ia,ib)) call new(c,MAX(ia,ib)) + if (isa < isb) then + do i=0,isa-1 + c%c(i) = IEOR(a%c(i),b%c(i)) + enddo + do i=isa,isb-1 + c%c(i) = b%c(i) + enddo + else + do i=0,isb-1 + c%c(i) = IEOR(a%c(i),b%c(i)) + enddo + do i=isb,isa-1 + c%c(i) = a%c(i) + enddo + endif + c%deg = get_deg(c) + c%size = get_size(c%deg) + return +end subroutine + +subroutine gf2x_pow(c,a,e) + type(gf2x_obj), intent(inout) :: c ! c = a**e + type(gf2x_obj), intent(in) :: a + integer(INT32), intent(in) :: e + type(gf2x_obj), pointer :: w + integer(INT32) :: ch,cl + integer(INT32) :: i,deg + NULLIFY(w) + call delete(c) + if (e==1) then + call assign(c,a) + return + endif + if (e==0) then + call set_coef(c,0) + return + endif + if (e<0) then + write(*,*)"pow: c = a^e : exponent should be e>=0." + stop + endif + if (is_zero(a)) return + + deg = deg_i32(e) + + allocate(w) + call set_coef(c,0) + do i=deg,0,-1 + call square(w,c) ! w := c**2 + if (BTEST(e,i)) then + call mult(c,w,a) ! c := w * a + else + call assign(c,w) ! c := w + endif + enddo + call delete(w) + deallocate(w) + NULLIFY(w) + + return +end subroutine + +subroutine gf2x_square(c,a) + type(gf2x_obj), intent(inout) :: c ! c := a**2 + type(gf2x_obj), intent(in) :: a + integer(INT32) :: ch,cl + integer(INT32) :: i,deg + call delete(c) + if (is_zero(a)) return + deg = a%deg*2 + call new(c,deg) + do i=0,a%size-1 + if (a%c(i) == 0) cycle + call square_i32(a%c(i),ch,cl) + if (cl /= 0) c%c(2*i) = IEOR(c%c(2*i), cl) + if (ch /= 0) c%c(2*i+1) = IEOR(c%c(2*i+1),ch) + enddo + c%deg = get_deg(c) + c%size = get_size(c%deg) + return +end subroutine + +recursive subroutine gf2x_mult_kara(c,a,b) +! +! multiply 2 polyomials using Karatsuba algorithm +! + type(gf2x_obj), intent(inout) :: c ! c := a * b + type(gf2x_obj), intent(in) :: a,b + type(gf2x_obj), pointer :: ah,al,bh,bl,ahbh,albl,ahl,bhl,ahlbhl + integer(INT32) :: isa,isb,isc + integer(INT32) :: i,j,deg + + NULLIFY(ah,al,bh,bl,ahbh,albl,ahl,bhl,ahlbhl) + call delete(c) + if (is_zero(a)) return + if (is_zero(b)) return + + isa = a%size + isb = b%size + isc = MAX(isa,isb) + if (isc < MAX_KARA) then + call gf2x_mult_normal(c,a,b) + return + endif + + if (mod(isc,2)/=0) then + isc = isc + 1 + endif + + allocate(ah,al,bh,bl,ahbh,albl,ahl,bhl,ahlbhl) + deg = 32*(isc/2)-1 + call new(al,deg) + call new(bl,deg) + call new(ah,deg) + call new(bh,deg) + + do i=0,MIN(isc/2-1,isa-1) + al%c(i) = a%c(i) + enddo + do i=0,MIN(isc/2-1,isb-1) + bl%c(i) = b%c(i) + enddo + do i=isc/2,isa-1 + ah%c(i-isc/2) = a%c(i) + enddo + do i=isc/2,isb-1 + bh%c(i-isc/2) = b%c(i) + enddo + ah%deg = get_deg(ah) + al%deg = get_deg(al) + bh%deg = get_deg(bh) + bl%deg = get_deg(bl) + ah%size = get_size(ah%deg) + al%size = get_size(al%deg) + bh%size = get_size(bh%deg) + bl%size = get_size(bl%deg) + +!=================================== + + call add(ahl,ah,al) + call add(bhl,bh,bl) + call gf2x_mult_kara(ahlbhl,ahl,bhl) + call delete(ahl) + call delete(bhl) + deallocate(ahl,bhl) + +!=================================== + + call gf2x_mult_kara(ahbh,ah,bh) + call delete(ah) + call delete(bh) + deallocate(ah,bh) + + call add_assign(ahlbhl,ahbh) + +!=================================== + + call gf2x_mult_kara(albl,al,bl) + call delete(al) + call delete(bl) + deallocate(al,bl) + + call add_assign(ahlbhl,albl) + +!=================================== + deg = a%deg + b%deg + call new(c,deg) + + do i=0,MIN(c%size,albl%size)-1 + c%c(i) = albl%c(i) + enddo + call delete(albl) + + if (.not. is_zero(ahlbhl)) then + do i=isc/2,MIN(c%size,isc/2+ahlbhl%size)-1 + c%c(i) = IEOR(c%c(i),ahlbhl%c(i-isc/2)) + enddo + endif + call delete(ahlbhl) + + if (.not. is_zero(ahbh)) then + do i=isc,MIN(c%size,isc+ahbh%size)-1 + c%c(i) = IEOR(c%c(i),ahbh%c(i-isc)) + enddo + endif + call delete(ahbh) + deallocate(ahbh,albl,ahlbhl) + NULLIFY(ah,al,bh,bl,ahbh,albl,ahl,bhl,ahlbhl) + c%deg = get_deg(c) + c%size = get_size(c%deg) + return +end subroutine + +subroutine gf2x_mult_assign_kara(a,b) + type(gf2x_obj), intent(inout) :: a ! a := a * b + type(gf2x_obj), intent(in) :: b + type(gf2x_obj), pointer :: w + NULLIFY(w) + if (is_zero(a)) then + call delete(a) + return + endif + if (is_zero(b)) then + call delete(a) + return + endif + allocate(w) + call gf2x_mult_kara(w,a,b) + call assign(a,w) + call delete(w) + deallocate(w) + NULLIFY(w) + return +end subroutine + +subroutine gf2x_mult_assign_normal(a,b) + type(gf2x_obj), intent(inout) :: a ! a := a * b + type(gf2x_obj), intent(in) :: b + type(gf2x_obj), pointer :: w + integer(INT32) :: ch,cl + integer(INT32) :: i,j,deg + NULLIFY(w) + allocate(w) + deg = a%deg + b%deg + call new(w,deg) + call gf2x_mult_normal(w,a,b) + call assign(a,w) ! a := w + call delete(w) + deallocate(w) + NULLIFY(w) + return +end subroutine + +subroutine gf2x_mult_normal(c,a,b) + type(gf2x_obj), intent(inout) :: c ! c := a * b + type(gf2x_obj), intent(in) :: a,b + integer(INT32) :: ch,cl + integer(INT32) :: i,j,ij,deg,kk,mm + integer(INT32), allocatable :: hi(:,:),lo(:,:) + + call delete(c) + if (is_zero(a) .or. is_zero(b) ) then + return + endif + + deg = a%deg + b%deg + call new(c,deg) + +!#define _NEW_ +!#undef _NEW_ +!#ifdef _NEW_ +! do j=0,c%size-2 +! kk = MIN(j, a%size-1) +! mm = MAX(0,j-b%size+1) +! do i=mm,kk +! call mult_i32(a%c(i),b%c(j-i),ch,cl) +! c%c(j) = IEOR(c%c(j), cl) +! c%c(j+1) = IEOR(c%c(j+1),ch) +! enddo +! enddo +! j=c%size-1 +! kk = a%size-1 +! mm = c%size-b%size +! do i=mm,kk +! call mult_i32(a%c(i),b%c(j-i),ch,cl) +! c%c(j) = IEOR(c%c(j), cl) +! enddo +! +!#else + do j=0,b%size-1 + if (b%c(j) == 0) cycle + do i=0,a%size-1 + if (a%c(i) == 0) cycle + + ij = i + j + call mult_i32(a%c(i),b%c(j),ch,cl) + c%c(ij) = IEOR(c%c(ij), cl) + if (ij+1<c%size) c%c(ij+1) = IEOR(c%c(ij+1),ch) + + enddo + enddo +!#endif + + c%deg = get_deg(c) + c%size = get_size(c%deg) + + return +end subroutine + +subroutine gf2x_shift(c,a,i) + type(gf2x_obj), intent(inout) :: c ! c := shift(a,i) + type(gf2x_obj), intent(in) :: a + integer(INT32), intent(in) :: i + integer(INT32) :: j,isn,iw,ib,ida,isa,ch,cm,cl + if (i==0) then + call assign(c,a) + return + endif + ida = get_deg(a) + isa = get_size(ida) + if (ida + i < 0) then + call delete(c) + return + endif + iw = abs(i)/32 + ib = mod(abs(i),32) + call delete(c) + call new(c,ida+i) + if (i > 0) then + do j=0,isa-1 + call shift_i32(a%c(j),+ib,ch,cm,cl) + if (ch /= 0) c%c(j+iw+1) = IEOR(c%c(j+iw+1),ch) + if (cm /= 0) c%c(j+iw) = IEOR(c%c(j+iw) ,cm) + enddo + else + call shift_i32(a%c(iw),-ib,ch,cm,cl) + if (cm /= 0) c%c(0) = IEOR(c%c(0),cm) + do j=iw+1,isa-1 + call shift_i32(a%c(j),-ib,ch,cm,cl) + if (cm /= 0) c%c(j-iw) = IEOR(c%c(j-iw) ,cm) + if (cl /= 0) c%c(j-iw-1) = IEOR(c%c(j-iw-1),cl) + enddo + endif + c%deg = get_deg(c) + c%size = get_size(c%deg) + return +end subroutine + +subroutine gf2x_divrem(q,r,a,b) + ! a =: q * b + r + type(gf2x_obj), intent(inout) :: q ! q := a div b + type(gf2x_obj), intent(inout) :: r ! r := a mod b + type(gf2x_obj), intent(in) :: a,b + type(gf2x_obj), pointer :: w,t,s + integer(INT32) :: ida,idb,idw + call delete(q) + call delete(r) + ida = a%deg + idb = b%deg + if (ida < idb) then + call assign(r,a) + return + endif + NULLIFY(w,t,s) + allocate(w,t,s) + call assign(w,a) + idw = w%deg + do + call mult_by_x(t,b,idw-idb) ! t := b * x^(deg(w)-deg(b)) + call set_coef(s,idw-idb) ! s := s + x^(deg(w)-deg(b)) + call add_assign(w,t) ! w := w + t + call delete(t) + idw = w%deg + if (idw < idb) exit + enddo + call assign(r,w) + call delete(w) + call assign(q,s) + call delete(s) + deallocate(w,t,s) + NULLIFY(w,t,s) + return +end subroutine + +subroutine gf2x_div(q,a,b) + ! a =: q * b + r + type(gf2x_obj), intent(inout) :: q ! q := a div b + type(gf2x_obj), intent(in) :: a,b + type(gf2x_obj), pointer :: w,t,s + integer(INT32) :: ida,idb,idw + call delete(q) + ida = a%deg + idb = b%deg + if (ida < idb) then + return + endif + NULLIFY(w,t,s) + allocate(w,t,s) + call assign(w,a) + idw = w%deg + do + call mult_by_x(t,b,idw-idb) ! t := b * x^(deg(w)-deg(b)) + call set_coef(s,idw-idb) ! s := s + x^(deg(w)-deg(b)) + call add_assign(w,t) ! w := w + t + call delete(t) + idw = w%deg + if (idw < idb) exit + enddo + call delete(w) + call assign(q,s) + call delete(s) + deallocate(w,t,s) + NULLIFY(w,t,s) + return +end subroutine + +subroutine gf2x_rem(r,a,b) + type(gf2x_obj), intent(inout) :: r ! r := a mod b + type(gf2x_obj), intent(in) :: a,b + type(gf2x_obj), pointer :: w,t + integer(INT32) :: ida,idb,idw + call delete(r) + ida = a%deg + idb = b%deg + if (ida < idb) then + call assign(r,a) + return + endif + NULLIFY(w,t) + allocate(w,t) + call assign(w,a) + idw = w%deg + do + call mult_by_x(t,b,idw-idb) ! t := b * x^(deg(w)-deg(b)) + call add_assign(w,t) ! w := w + t + call delete(t) + idw = w%deg + if (idw < idb) exit + enddo + call assign(r,w) + call delete(w) + deallocate(w,t) + NULLIFY(w,t) + return +end subroutine + +subroutine gf2x_set_prime(mp,m) +! +! Set a primitive polynomial to the cotainer. +! the container contains the prime poly and precomputed polynomial for Barrett reduciont. +! This routine does not check the primitivity. +! mp : container +! m : primitive polynomial +! + type(gf2x_prime_obj), intent(inout) :: mp + type(gf2x_obj), intent(in) :: m + type(gf2x_obj), pointer :: xx + integer(INT32) :: deg + call delete(mp) + call assign(mp%prime_poly,m) + deg = get_deg(m) + mp%deg = deg + NULLIFY(xx) + allocate(xx) + call set_coef(xx,2*deg) + call div(mp%barrett_poly,xx,m) + call delete(xx) + deallocate(xx) + NULLIFY(xx) + return +end subroutine + +subroutine gf2x_delete_prime(mp) + type(gf2x_prime_obj), intent(inout) :: mp + call delete(mp%prime_poly) + call delete(mp%barrett_poly) + return +end subroutine + +subroutine gf2x_rem_barrett(r,a,m) +! +! compute r := a mod m using Barrett algorithm +! + type(gf2x_obj), intent(inout) :: r ! r := a mod m + type(gf2x_obj), intent(in) :: a + type(gf2x_prime_obj), intent(in) :: m ! precomputed polynomial for Barrett algorithm + type(gf2x_obj), pointer :: q,p + integer(INT32) :: deg + + call delete(r) + deg = m%deg + if (a%deg < deg) then + call assign(r,a) + return + endif + + NULLIFY(q,p) + allocate(q,p) + + call div_by_x(q,a,deg) ! q = a / x**deg + call mod_by_x(r,a,deg) ! r = a mod x**deg + + call mult_assign(q,m%barrett_poly) ! q = q * mu + call div_by_x(p,q,deg) ! p = q / x**deg + + call mult_assign(p,m%prime_poly) ! p = p * m + call mod_by_x(q,p,deg) ! q = p mod x**deg + + call add_assign(r,q) ! r = r + q + + call delete(p) + call delete(q) + + deallocate(p,q) + NULLIFY(p,q) + + return +end subroutine + +subroutine gf2x_mod_by_x(c,a,i) + type(gf2x_obj), intent(inout) :: c ! c := a mod x^i + type(gf2x_obj), intent(in) :: a + integer(INT32), intent(in) :: i + type(gf2x_obj), pointer :: w + integer(INT32) :: iw,ib,j + call delete(c) + if (a%deg < i) then + call assign(c,a) + return + endif + if (i == 0) then + call delete(c) + return + endif + if (i < 0) then + write(*,'("mod_by_x: error, negative i:",I10)')i + stop + endif + iw = i/32 + ib = mod(i,32) + NULLIFY(w) + allocate(w) + call new(w,i) + do j=0,w%size-1 + w%c(j) = a%c(j) + enddo + w%c(w%size-1) = IAND(w%c(w%size-1),2**ib-1) + call assign(c,w) + call delete(w) + deallocate(w) + NULLIFY(w) + return +end subroutine + +subroutine gf2x_mult_by_x(c,a,i) + type(gf2x_obj), intent(inout) :: c ! c := a * x^i + type(gf2x_obj), intent(in) :: a + integer(INT32), intent(in) :: i + if (i < 0) then + write(*,'("mult_by_x: error, negative i:",I10)')i + stop + endif + if (i == 0) then + call assign(c,a) + return + endif + call shift(c,a,i) + return +end subroutine + +subroutine gf2x_div_by_x(c,a,i) + type(gf2x_obj), intent(inout) :: c ! c := a div x^i + type(gf2x_obj), intent(in) :: a + integer(INT32), intent(in) :: i + if (i < 0) then + write(*,'("div_by_x: error, negative i:",I10)')i + stop + endif + if (i == 0) then + call assign(c,a) + return + endif + call shift(c,a,-i) + return +end subroutine + + +subroutine gf2x_pow_pow_2(c,e,m) + type(gf2x_obj), intent(inout) :: c ! c := x**(2**e) mod m + integer(INT32), intent(in) :: e + type(gf2x_prime_obj), intent(in) :: m ! precomputed polynomial for Barrett algorithm + integer(INT32) :: i,ee + type(gf2x_obj), pointer :: w,s + + ee = CEILING(log(REAL(m%deg))/log(2.0)) + call delete(c) + if (ee > e) then + call set_coef(c,2**e) + return + endif + + NULLIFY(w,s) + allocate(w,s) + call set_coef(w,2**ee) + call rem(s,w,m) ! s = w mod m + do i=ee+1,e + call square(w,s) ! w = s**2 + call rem(s,w,m) ! s = w mod m + enddo + call assign(c,s) + call delete(w) + call delete(s) + deallocate(w,s) + NULLIFY(w,s) + return +end subroutine + +subroutine gf2x_pow_mod(c,a,e,m) + type(gf2x_obj), intent(inout) :: c ! c := a**e mod m + type(gf2x_obj), intent(in) :: a + integer(INT32), intent(in) :: e + type(gf2x_prime_obj), intent(in) :: m ! precomputed polynomial for Barrett algorithm + type(gf2x_obj), pointer :: w + integer(INT32) :: i,deg + NULLIFY(w) + call delete(c) + if (e==1) then + if (a%deg >= m%deg) then + call rem(c,a,m) + return + else + call assign(c,a) + return + endif + endif + if (e==0) then + call set_coef(c,0) + return + endif + if (e<0) then + write(*,*)"pow: c = a^e mod m : exponent should be e>=0." + stop + endif + if (is_zero(a)) return + + deg = deg_i32(e) + + allocate(w) + call set_coef(c,0) + do i=deg,0,-1 + call square(w,c) ! c := c**2 mod m + call rem(c,w,m) + if (BTEST(e,i)) then + call mult(w,c,a) ! c := c * a mod m + call rem(c,w,m) + endif + enddo + call delete(w) + deallocate(w) + NULLIFY(w) + return +end subroutine + +!======================================================================== +function deg_i32(a) result(d) + integer(INT32) :: a,d,i + d=-1 + do i=31,0,-1 + if (BTEST(a,i)) then + d=i + exit + endif + enddo + return +end function + +function deg_i64(a) result(d) + integer(INT64) :: a + integer(INT32) :: d,i + do i=63,0,-1 + if (BTEST(a,i)) then + d=i + exit + endif + enddo + return +end function + +subroutine square_i32(a,ch,cl) + integer(INT32), intent(in) :: a + integer(INT32), intent(out) :: ch,cl ! (ch,cl) = a**2 + integer(INT32) :: ia,i + integer(INT64) :: da,dc + da = a + if (da < 0) da = da + 2_8**32 ! convert to unsigned + dc = Z'0' + ia = deg_i32(a) + do i = 0,ia + if (BTEST(a,i)) then + dc = ibset(dc,i*2) + endif + enddo + ch = ISHFT(dc,-32) + cl = dc + return +end subroutine + +!DEC$ ATTRIBUTES FORCEINLINE :: mult_i32 +subroutine mult_i32(a,b,ch,cl) + integer(INT32), intent(in) :: a,b + integer(INT32), intent(out) :: ch,cl ! (ch,cl) = a*b + integer(INT32) :: tmp,u(0:3) + integer(INT32), parameter :: ZE = Z'eeeeeeee' + integer(INT32), parameter :: ZC = Z'cccccccc' + integer(INT32), parameter :: Z8 = Z'88888888' + + if (a==0 .or. b ==0) then + ch = 0 + cl = 0 + return + endif + + u(0) = 0 + u(1) = a + u(2) = ISHFT(u(1),+1) + u(3) = IEOR(u(2),a) + + cl = IEOR(ISHFT(u( ISHFT(b,-30) ),2),u(IAND(ISHFT(b,-28),3))) + ch = ISHFT(cl,-28) + cl = IEOR(ISHFT(cl,4),IEOR(ISHFT(u(IAND(ISHFT(b,-26),3)),2),u(IAND(ISHFT(b,-24),3)))) + ch = IOR(ISHFT(ch,4),ISHFT(cl,-28)) + cl = IEOR(ISHFT(cl,4),IEOR(ISHFT(u(IAND(ISHFT(b,-22),3)),2),u(IAND(ISHFT(b,-20),3)))) + ch = IOR(ISHFT(ch,4),ISHFT(cl,-28)) + cl = IEOR(ISHFT(cl,4),IEOR(ISHFT(u(IAND(ISHFT(b,-18),3)),2),u(IAND(ISHFT(b,-16),3)))) + ch = IOR(ISHFT(ch,4),ISHFT(cl,-28)) + cl = IEOR(ISHFT(cl,4),IEOR(ISHFT(u(IAND(ISHFT(b,-14),3)),2),u(IAND(ISHFT(b,-12),3)))) + ch = IOR(ISHFT(ch,4),ISHFT(cl,-28)) + cl = IEOR(ISHFT(cl,4),IEOR(ISHFT(u(IAND(ISHFT(b,-10),3)),2),u(IAND(ISHFT(b, -8),3)))) + ch = IOR(ISHFT(ch,4),ISHFT(cl,-28)) + cl = IEOR(ISHFT(cl,4),IEOR(ISHFT(u(IAND(ISHFT(b, -6),3)),2),u(IAND(ISHFT(b, -4),3)))) + ch = IOR(ISHFT(ch,4),ISHFT(cl,-28)) + cl = IEOR(ISHFT(cl,4),IEOR(ISHFT(u(IAND(ISHFT(b, -2),3)),2),u(IAND( b ,3)))) + + tmp = -IAND(ISHFT(a,-31),1) + tmp = IAND(tmp,ISHFT(IAND(b,ZE),-1)) + ch = IEOR(ch,tmp) + + tmp = -IAND(ISHFT(a,-30),1) + tmp = IAND(tmp,ISHFT(IAND(b,ZC),-2)) + ch = IEOR(ch,tmp) + + tmp = -IAND(ISHFT(a,-29),1) + tmp = IAND(tmp,ISHFT(IAND(b,Z8),-3)) + ch = IEOR(ch,tmp) + + return +end subroutine + + +subroutine mult_i32_old(a,b,ch,cl) + integer(INT32), intent(in) :: a,b + integer(INT32), intent(out) :: ch,cl ! (ch,cl) = a*b + integer(INT32) :: ia,ib,i + integer(INT64) :: da,db,dc + da = a + db = b + if (da < 0) da = da + 2_8**32 ! convert to unsigned + if (db < 0) db = db + 2_8**32 ! convert to unsigned + ia = deg_i32(a) + ib = deg_i32(b) + dc = Z'0' + do i = 0,ia + if (BTEST(a,i)) then + dc = IEOR(dc,db) + endif + dc = ISHFTC(dc,-1) + enddo + dc = ISHFTC(dc,ia+1) + ch = ISHFT(dc,-32) + cl = dc +! write(*,'(B64.64)')dc +! write(*,'(B32.32)')ch +! write(*,'(B64.64)')cl + return +end subroutine + +subroutine shift_i32(a,i,ch,cm,cl) + integer(INT32), intent(in) :: a + integer(INT32), intent(in) :: i + integer(INT32), intent(out) :: ch,cm,cl ! (ch,cm,cl) = shift(a,i) + integer(INT64) :: dc + if (abs(i) >= 32) then + write(*,*)"shift_int32: error i=",i + stop + endif + select case (i) + case (0) + ch = 0; cm = a; cl = 0 + return + case (1:31) + dc = a + if (dc < 0) dc = dc + 2_8**32 ! convert to unsigned + dc = ISHFT(dc,i) + ch = ISHFT(dc,-32) + cm = dc + cl = 0 + return + case (-31:-1) + dc = a + if (dc < 0) dc = dc + 2_8**32 ! convert to unsigned + dc = ISHFT(dc,i+32) + ch = 0 + cm = ISHFT(dc,-32) + cl = dc + return + end select + return +end subroutine + +end module diff --git a/src_flexwrf_v3.1/gridcheck.f90 b/src_flexwrf_v3.1/gridcheck.f90 new file mode 100644 index 0000000000000000000000000000000000000000..87588358ddea2585a1fdae9e784ce27440d84b87 --- /dev/null +++ b/src_flexwrf_v3.1/gridcheck.f90 @@ -0,0 +1,677 @@ + subroutine gridcheck +!********************************************************************** +! * +! TRAJECTORY MODEL SUBROUTINE GRIDCHECK * +! FLEXPART VERSION -> DO NOT USE IN FLEXTRA, PRAEPRO * +! * +!********************************************************************** +! * +! AUTHOR: R. Easter & J. Fast, PNNL * +! DATE: 2005-autumn-?? * +! * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables* +! * +!********************************************************************** +! * +! DESCRIPTION: * +! * +! Note: This is the FLEXPART_WRF version of subroutine gridcheck. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! There are many differences from the FLEXPART version. * +! * +! This subroutine determines the grid specifications * +! of the WRF model run from the first met. input file. * +! (longitudes & latitudes, number of grid points, grid distance, * +! vertical discretization) * +! The consistancy of met. input files is checked in the routine * +! "readwind" each call. (Grid info must not change.) * +! * +! * +! XMET0,YMET0 -- x,y coordinates (in m) of the lower left * +! "T-grid" point * +! NOTE: These replace XLON0,YLAT0 of FLEXPART (ECMWF), * +! which uses longitude,longitude (degrees) as coordinates. * +! * +! NX number of grid points x-direction * +! NY number of grid points y-direction * +! DX grid distance x-direction (in m) * +! DY grid distance y-direction (in m) * +! NUVZ number of grid points for horizontal wind * +! components in z direction * +! NWZ number of grid points for vertical wind * +! component in z direction * +! * +! For WRF, the "W" grid has NWZ == "bottom_top_stag" levels * +! For WRF, the "U", "V", and "T" grids have * +! NWZ-1 == "bottom_top" levels. * +! In the ecmwf FLEXPART, the "U", "V", and "T" grids are * +! "augmented" with an additional "surface" layer, * +! and thus have NUVZ==NWZ levels * +! Because of the high vertical resolution often used in WRF, * +! it may be desirable to eliminate this "surface layer". * +! * +! * +! UVHEIGHT(1)- heights of gridpoints where u and v are * +! UVHEIGHT(NUVZ) given * +! WHEIGHT(1)- heights of gridpoints where w is given * +! WHEIGHT(NWZ) * +! * +!********************************************************************** +! +! include 'includepar' +! include 'includecom' +! include 'includeconv' +! use grib_api + use par_mod + use com_mod + use conv_mod + use cmapf_mod, only: stlmbr,stcm2p + + integer,parameter :: ndims_max=4 + integer :: i, idiagaa, ierr, ifn, itime, ix + integer :: jy + integer :: kz + integer :: lendim(ndims_max), lendim_exp(ndims_max), & + lendim_max(ndims_max) + integer :: ndims, ndims_exp, & + ext_scalar,pbl_physics,mp_physics_dum + integer :: n_west_east, n_south_north, n_bottom_top + + real :: dx_met, dy_met + real :: duma, dumb, dumc + real :: dump1, dump2, dumdz + real :: pint,m + + character(len=160) :: fnamenc, varname,fnamenc2 + + real(kind=4) :: m_u(0:nxmax-1,0:nymax-1,1) + real(kind=4) :: m_v(0:nxmax-1,0:nymax-1,1) + + + +! +! get grid info from the wrf netcdf file +! +! write(*,'(//a)') 'gridcheck output' + + if(ideltas.gt.0) then + ifn=1 + else + ifn=numbwf + endif + fnamenc = path(2)(1:length(2))//wfname(ifn) + idiagaa = 0 + + call read_ncwrfout_gridinfo( ierr, idiagaa, fnamenc, & + n_west_east, n_south_north, n_bottom_top, & + dx_met, dy_met, & + m_grid_id(0), m_parent_grid_id(0), m_parent_grid_ratio(0), & + i_parent_start(0), j_parent_start(0), & + map_proj_id, map_stdlon, map_truelat1, map_truelat2, & + ext_scalar,pbl_physics,mp_physics_dum ) + + mp_physics=mp_physics_dum + + if (ierr.ne.0) goto 999 + +! +! set grid dimension and size variables +! + nx = n_west_east + nxfield = nx + ny = n_south_north + + nxmin1=nx-1 + nymin1=ny-1 +! print*,'nxo',nxmin1,nymin1 + nuvz = n_bottom_top + nwz = n_bottom_top + 1 + nlev_ec = n_bottom_top + +! for FLEXPART_WRF, x & y coords are in meters, and +! we define lower-left corner of outermost (mother) grid == (0.0,0.0) + xmet0 = 0.0 + ymet0 = 0.0 + + dx = dx_met + dy = dy_met + + dxconst = 1.0/dx + dyconst = 1.0/dy + + l_parent_nest_id(0) = -1 + + xglobal=.false. + if (nxshift.ne.0) stop & + 'nxshift (par_mod) must be zero for non-global domain' + + sglobal=.false. + switchsouthg=999999. + + nglobal=.false. + switchnorthg=999999. + + if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative' + if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large' + +! +! check that grid dimensions are not too big +! +! FLEXPART_WRF 07-nov-2005 - require (nx+1 .le. nxmax) and (ny+1 .le. nymax) +! because u,v in met. files are on staggered grid +! if (nx.gt.nxmax) then + if (nx+1 .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+1, nxmax =', nx,nxmax + stop + endif + +! if (ny.gt.nymax) then + if (ny+1 .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+1, nymax =', 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 + +! +! read latitude and longitude +! read oro, lsm, and excessoro + + varname = 'MAPFAC_MX' + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + ndims_exp = 3 + itime=1 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_x(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + varname = 'MAPFAC_M' + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_x(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + endif + if (ierr .ne. 0) then + print*,'error doing MAP X' + varname = 'MAPFAC_UX' + lendim_exp(1) = nx+1 + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_u(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + do j = 0, nymin1 + do i = 0, nxmin1 + m_x(i,j,1)=(m_u(i,j,1)+m_u(i+1,j,1))*0.5 + enddo + enddo + if (ierr .ne. 0) then + print*,'error doing MAP U' + print*,'NO MAP FACTOR IS GOING TO BE USED.' + print*,'LARGE UNCERTAINTIES TO BE EXPECTED' + do j = 0, nymin1 + do i = 0, nxmin1 + m_x(i,j,1)=1. + enddo + enddo + end if + end if +! do j = 0, nymin1 +! do i = 0, nxmin1 +! m_x(i,j,1)=1. +! enddo +! enddo + + varname = 'MAPFAC_MY' + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_y(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + varname = 'MAPFAC_M' + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_y(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + endif + if (ierr .ne. 0) then + print*,'error doing MAP Y' + varname = 'MAPFAC_VY' + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny+1 + lendim_max(2) = nymax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_v(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + do j = 0, nymin1 + do i = 0, nxmin1 + m_y(i,j,1)=(m_v(i,j,1)+m_v(i,j+1,1))*0.5 + enddo + enddo + if (ierr .ne. 0) then + print*,'ERROR doing MAP V' + print*,'NO MAP FACTOR IS GOING TO BE USED.' + print*,'LARGE UNCERTAINTIES TO BE EXPECTED' + do j = 0, nymin1 + do i = 0, nxmin1 + m_y(i,j,1)=1. + enddo + enddo + end if + end if + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax +! do j = 0, nymin1 +! do i = 0, nxmin1 +! m_y(i,j,1)=1. +! enddo +! enddo + +! + idiagaa = 0 + + varname = 'XLAT' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + itime = 1 + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + ndims_exp = 3 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, ylat2d, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of XLAT' + stop + end if +! print*,'values',ylat2d(309,101),ylat2d(300,101),ylat2d(250,101) +! print*,'values',ylat2d(309,101),ylat2d(300,101),ylat2d(250,101) + varname = 'XLONG' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, xlon2d, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of XLONG' + stop + end if + + varname = 'HGT' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, oro, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of HGT' + stop + end if + +! lsm = landsea mask == land fraction (or non-ocean fraction) +! for now, set lsm=1.0 which means land + do jy=0,ny-1 + do ix=0,nxfield-1 +! lsm(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1) + lsm(ix,jy)=1.0 + end do + end do + +! for now, set excessoro=0.0 + do jy=0,ny-1 + do ix=0,nxfield-1 + excessoro(ix,jy)=0.0 + end do + end do + do jy=1,ny-2 + do ix=1,nxfield-2 + m=4.*oro(ix,jy)+oro(ix-1,jy)+oro(ix+1,jy)+oro(ix,jy-1)+oro(ix,jy+1) + m=m/8. + excessoro(ix,jy)=4.*(oro(ix,jy)-m)**2.+(oro(ix-1,jy)-m)**2. & + +(oro(ix+1,jy)-m)**2.+(oro(ix,jy-1)-m)**2.+(oro(ix,jy+1)-m)**2. + excessoro(ix,jy)=(excessoro(ix,jy)/8.)**0.5 + end do + end do + + +! check that the map projection routines are working + call test_xyindex_to_ll_wrf( 0 ) + + +! 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 + + +! CALCULATE VERTICAL DISCRETIZATION OF WRF MODEL +! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM + +! read eta_w_wrf, eta_u_wrf, and p_top_wrf from the netcdf wrfout file + itime = 1 + + varname = 'ZNW' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nwz + lendim_max(1) = nwzmax + ndims_exp = 2 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, eta_w_wrf, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + fnamenc2='wrfout_d03_zn.nc' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc2, & + varname, eta_w_wrf, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of ZNW' +! stop + end if + end if + + varname = 'ZNU' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nwz-1 + lendim_max(1) = nwzmax + ndims_exp = 2 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, eta_u_wrf, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + fnamenc2='wrfout_d03_zn.nc' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc2, & + varname, eta_u_wrf, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of ZNU' + stop + end if + end if + + varname = 'P_TOP' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = 1 + lendim_max(1) = 6 + ndims_exp = 2 + if (ext_scalar .lt. 0) ndims_exp = 1 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, p_top_wrf, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of P_TOP' + stop + end if + +! diagnostics for testing + if (idiagaa .gt. 0) then + write(*,*) + write(*,*) 'k, eta_w_wrf, eta_u_wrf =' + write(*,'(i3,2f11.6)') & + (kz, eta_w_wrf(kz), eta_u_wrf(kz), kz=1,nwz-1) + kz = nwz + write(*,'(i3,2f11.6)') kz, eta_w_wrf(kz) + write(*,*) + write(*,*) 'p_top_wrf =', p_top_wrf + write(*,*) + + duma = 0.0 + dumb = 1.0e30 + dumc = -1.0e30 + do jy = 0, ny-1 + do ix = 0, nx-1 + duma = duma + oro(ix,jy) + dumb = min( dumb, oro(ix,jy) ) + dumc = max( dumc, oro(ix,jy) ) + end do + end do + duma = duma/(nx*ny) + write(*,*) 'oro avg, min, max =', duma, dumb, dumc + write(*,*) + end if + + +! +! the wrf eta vertical grid at layer boundaries (w grid) and +! layer centers (u grid) is defined by +! eta_w_wrf(kz) = (pdh_w(kz) - p_top_wrf)/(pdh_surface - p_top_wrf) +! eta_u_wrf(kz) = (pdh_u(kz) - p_top_wrf)/(pdh_surface - p_top_wrf) +! where "pdh_" refers to the dry hydrostatic component of the pressure +! +! so +! pdh_w(kz) = ((1.0 - eta_w_wrf(kz))*p_top_wrf) + eta_w_wrf(kz)*pdh_surface +! pdh_u(kz) = ((1.0 - eta_u_wrf(kz))*p_top_wrf) + eta_u_wrf(kz)*pdh_surface +! +! the ecmwf eta vertical grid is defined by +! p_w(kz) = akm(kz) + bkm(kz)*p_surface +! p_u(kz) = akz(kz) + bkz(kz)*p_surface +! +! the following definitions of akm, bkm, akz, bkz for wrf would be roughly +! consistent those for ecmwf EXCEPT that for wrf, they involve the +! dry hydrostatic component of the pressure +! do kz = 1, nwz +! akm(kz) = (1.0 - eta_w_wrf(kz))*p_top_wrf +! bkm(kz) = eta_w_wrf(kz) +! end do +! do kz = 1, nuvz +! akz(kz) = (1.0 - eta_u_wrf(kz))*p_top_wrf +! bkz(kz) = eta_u_wrf(kz) +! end do +! +! *** in FLEXPART_WRF we decided to used pressure from the met. files +! and drop the akz/bkz/akm/bkm entirely *** +! + + +! in FLEXPART_ECMWF, the U, V, & T-grid levels are always shifted up by 1, +! and an extra near-surface level is defined at kz=1 +! which is loaded with the 10 m winds and 2 m temperature & humidity +! for FLEXPART_WRF, this is optional, and is done when add_sfc_level=1 +! (Note -- it will take a lot of effort to get rid of this augmented +! level because many of the surface & boundary layer routines +! are expecting it. so for now, always augment.) + + dump1 = (101325.0-p_top_wrf)*eta_w_wrf(1) + p_top_wrf + dump2 = (101325.0-p_top_wrf)*eta_w_wrf(2) + p_top_wrf + dumdz = log(dump1/dump2)*8.4e3 + write(*,*) +! write(*,*) 'add_sfc_level =', add_sfc_level +! write(*,*) 'WRF layer 1 approx. thickness =', dumdz + + if (add_sfc_level .eq. 1) then + nuvz = nuvz + 1 + else + write(*,'(/a/a/)') '*** gridcheck fatal error ***', & + ' add_sfc_level=0 is not yet implemented' +! stop + end if + + +!******************************************************************************* +! following comments are from FLEXPART_ECMWF. This options for doubled vertical +! resolution has not been tried in FLEXPART_WRF, but it probably could be done +! with little effort. +! ------------------------------------------------------------------------------ +! 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 100 i=1,nuvz +! aknew(i)=akz(i) +!100 bknew(i)=bkz(i) + +! 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) +! +! FLEXPART_WRF - use approx. pressures to set nconvlev, and limit it to nuvz-2 +!******************************************************************************* + + do i=1,nuvz-2 +! do i=1,nuvz-1 +! pint=akz(i)+bkz(i)*101325. + pint = (101325.0-p_top_wrf)*eta_u_wrf(i) + p_top_wrf + if (pint.lt.5000.0) goto 96 + enddo +96 nconvlev=i + nconvlev = min( nconvlev, nuvz-2 ) + if (nconvlev.gt.nconvlevmax-1) then + nconvlev=nconvlevmax-1 + pint = (101325.0-p_top_wrf)*eta_u_wrf(nconvlev) + p_top_wrf + write(*,*) 'Attention, convection only calculated up to ', & + pint*0.01, ' hPa' + endif + + +! Output of grid info +!******************** + + write(*,*) + write(*,*) + write(*,'(a/a,2i7/a,2i7//a,3i7/a,2i7/a,4i7)') & + '# of vertical levels in WRF data', & + ' n_bottom_top & "true" nuvz:', n_bottom_top, & + (nuvz-add_sfc_level), & + ' nwz & "augmented" nuvz:', nwz, nuvz, & + ' nwzmax, nuvzmax, nzmax :', nwzmax, nuvzmax, nzmax, & + ' nconvlevmax, nconvlev :', nconvlevmax, nconvlev, & + ' nx, ny, nxmax, nymax :', nx, ny, nxmax, nymax + write(*,*) + write(*,'(a)') 'Mother domain:' + write(*,'(a,f10.1,a1,f10.1,a,f10.1)') ' east-west range: ', & + xmet0,' to ',xmet0+(nx-1)*dx,' Grid distance: ',dx + write(*,'(a,f10.1,a1,f10.1,a,f10.1)') ' south-north range: ', & + ymet0,' to ',ymet0+(ny-1)*dy,' Grid distance: ',dy + write(*,*) + + +! +! all done +! + return + + +! file open error +999 write(*,*) + write(*,*) ' ###########################################'// & + '###### ' + write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:' + write(*,*) ' CAN NOT OPEN INPUT DATA FILE = ' + write(*,*) wfname(ifn) + write(*,*) ' ###########################################'// & + '###### ' + write(*,*) + stop + +end subroutine gridcheck + + + diff --git a/src_flexwrf_v3.1/gridcheck_nests.f90 b/src_flexwrf_v3.1/gridcheck_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..54bd52ec8cff1122a5d499ab1649108b655c651b --- /dev/null +++ b/src_flexwrf_v3.1/gridcheck_nests.f90 @@ -0,0 +1,636 @@ + 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. * +! * +! Note: This is the FLEXPART_WRF version of subroutine gridcheck. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! There are many differences from the FLEXPART version. * +! * +! Authors: A. Stohl, G. Wotawa * +! 8 February 1999 * +! * +! Nov 2005 - R. Easter - MAJOR revisions for FLEXPART_WRF * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! * +!******************************************************************************* + +! use grib_api + use par_mod + use com_mod + + + integer,parameter :: ndims_max=4 + integer :: i, ierr, ifn, itime, ix + integer :: idiagaa, idiagaa_1, idiagaa_2, idiagbb + integer :: iduma, idumb + integer :: jy + integer :: k + integer :: l, lp + integer :: lendim(ndims_max), lendim_exp(ndims_max), & + lendim_max(ndims_max) + integer :: m + integer :: map_proj_id_dum + integer :: ndims, ndims_exp, & + ext_scalar,pbl_physics,mp_physics_dum + integer :: n_west_east, n_south_north, n_bottom_top + integer :: nuvzn, nwzn + + real :: dx_met, dy_met + real :: duma, dumb, dumc, dumx, dumy + real :: dump1, dump2, dumdz + real :: eta_w_wrf_nest(nwzmax), eta_u_wrf_nest(nwzmax) + real :: map_stdlon_dum, map_truelat1_dum, map_truelat2_dum + real :: pint, p_top_wrf_nest + real :: xaux1, xaux2, yaux1, yaux2 + + character(len=160) :: fnamenc, varname + + real(kind=4) :: m_un(0:nxmaxn-1,0:nymaxn-1,1,maxnests) + real(kind=4) :: m_vn(0:nxmaxn-1,0:nymaxn-1,1,maxnests) + +! Loop about all nesting levels +!****************************** +! idiagaa_1 = 1 + idiagaa_1 = 0 + idiagaa_2 = 0 +! idiagbb = 10 + idiagbb = 0 + + do l=1,numbnests + + write(*,'(//a,i3)') 'gridcheck_nests output for grid #', l + +! +! get grid info from the wrf netcdf file +! + if(ideltas.gt.0) then + ifn=1 + else + ifn=numbwf + endif + m = numpath+2*(l-1)+1 + fnamenc = path(m)(1:length(m)) // wfnamen(l,ifn) + + idiagaa = idiagaa_1 + + call read_ncwrfout_gridinfo( ierr, idiagaa, fnamenc, & + n_west_east, n_south_north, n_bottom_top, & + dx_met, dy_met, & + m_grid_id(l), m_parent_grid_id(l), m_parent_grid_ratio(l), & + i_parent_start(l), j_parent_start(l), & + map_proj_id_dum, map_stdlon_dum, & + map_truelat1_dum, map_truelat2_dum, & + ext_scalar,pbl_physics,mp_physics_dum ) + if (ierr .ne. 0) goto 999 + + + mp_physicsn(l)=mp_physics_dum + +! subtract 1 because i & j indexing in flexpart always starts at 0 + i_parent_start(l) = i_parent_start(l)-1 + j_parent_start(l) = j_parent_start(l)-1 + +! +! set grid dimension and size variables +! + nxn(l) = n_west_east + nyn(l) = n_south_north + + nuvzn = n_bottom_top + nwzn = n_bottom_top + 1 + +! for FLEXPART_WRF, x & y coords are in meters + dxn(l) = dx_met + dyn(l) = dy_met + + +! +! check that grid dimensions are not too big +! +! flexpart_wrf 07-nov-2005 - require (nxn+1 .le. nxmaxn) and (nyn+1 .le. nymaxn) +! because u,v in met. files are on staggered grid + if (nxn(l)+1 .gt. nxmaxn) then + write(*,*) 'FLEXPART gridcheck_nests error: ' // & + 'Too many grid points in x direction.' + write(*,*) 'Change parameter settings in file par_mod.' + write(*,*) 'l, nxn(l)+1, nxmaxn =', l, nxn(l), nxmaxn + stop + endif + + if (nyn(l)+1 .gt. nymaxn) then + write(*,*) 'FLEXPART gridcheck_nests error: ' // & + 'Too many grid points in y direction.' + write(*,*) 'Change parameter settings in file par_mod.' + write(*,*) 'l, nyn(l)+1, nymaxn =', l, nyn(l), nymaxn + stop + endif + + nuvzn = nuvzn+add_sfc_level + if (nuvzn .ne. nuvz) then + write(*,*) 'FLEXPART gridcheck_nests error: ' // & + 'nuvzn and nuvz differ' + write(*,*) 'l, nuvzn, nuvz =', l, nuvzn, nuvz + stop + endif + + if (nwzn .ne. nwz) then + write(*,*) 'FLEXPART gridcheck_nests error: ' // & + 'nwzn and nwz differ' + write(*,*) 'l, nwzn, nwz =', l, nwzn, nwz + stop + endif + +! check that map projection info matches parent + duma = 3.0e-7*max( abs(map_stdlon), 1.0e-30 ) + dumb = 3.0e-7*max( abs(map_truelat1), 1.0e-30 ) + dumc = 3.0e-7*max( abs(map_truelat2), 1.0e-30 ) + iduma = 0 + if (map_proj_id .ne. map_proj_id_dum) iduma = 1 + if (abs(map_stdlon-map_stdlon_dum) .gt. duma) iduma = 2 + if (abs(map_truelat1-map_truelat1_dum) .gt. dumb) iduma = 3 + if (abs(map_truelat2-map_truelat2_dum) .gt. dumc) iduma = 4 + if (iduma .ne. 0) then + write(*,*) 'FLEXPART gridcheck_nests error: ' // & + 'map projection parameters differ' + write(*,*) 'l, map param #=', l, iduma + stop + end if + + varname = 'MAPFAC_MX' + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + ndims_exp = 3 + itime=1 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_xn(0,0,1,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + varname = 'MAPFAC_M' + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_xn(0,0,1,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + endif + if (ierr .ne. 0) then + print*,'error doing MAP X' + varname = 'MAPFAC_UX' + lendim_exp(1) = nxn(l)+1 + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_un(0,0,1,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + m_xn(i,j,1,l)=(m_un(i,j,1,l)+m_un(i+1,j,1,l))*0.5 + enddo + enddo + if (ierr .ne. 0) then + print*,'error doing MAP U' + print*,'NO MAP FACTOR IS GOING TO BE USED.' + print*,'LARGE UNCERTAINTIES TO BE EXPECTED' + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + m_xn(i,j,1,l)=1. + enddo + enddo + end if + end if + + varname = 'MAPFAC_MY' + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_yn(0,0,1,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + varname = 'MAPFAC_M' + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_yn(0,0,1,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + endif + if (ierr .ne. 0) then + print*,'error doing MAP Y' + varname = 'MAPFAC_VY' + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l)+1 + lendim_max(2) = nymaxn + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, m_vn(0,0,1,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + m_yn(i,j,1,l)=(m_vn(i,j,1,l)+m_vn(i,j+1,1,l))*0.5 + enddo + enddo + if (ierr .ne. 0) then + print*,'ERROR doing MAP V' + print*,'NO MAP FACTOR IS GOING TO BE USED.' + print*,'LARGE UNCERTAINTIES TO BE EXPECTED' + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + m_yn(i,j,1,l)=1. + enddo + enddo + end if + end if + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + +! +! read latitude and longitude +! read oro, lsm, and excessoro +! + + idiagaa = idiagaa_2 + + varname = 'XLAT' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + itime = 1 + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + ndims_exp = 3 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, ylat2dn(0,0,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of XLAT' + stop + end if + + varname = 'XLONG' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, xlon2dn(0,0,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of XLONG' + stop + end if + + varname = 'HGT' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, oron(0,0,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of HGT' + stop + end if + +! lsm = landsea mask == land fraction (or non-ocean fraction) +! for now, set lsm=1.0 which means land + do jy=0,nyn(l)-1 + do ix=0,nxn(l)-1 + lsmn(ix,jy,l)=1.0 + end do + end do + +! for now, set excessoro=0.0 + do jy=0,nyn(l)-1 + do ix=0,nxn(l)-1 + excessoron(ix,jy,l)=0.0 + end do + end do + do jy=1,nyn(l)-2 + do ix=1,nxn(l)-2 + m=oron(ix,jy,l)+oron(ix-1,jy,l)+oron(ix+1,jy,l)+ & + oron(ix,jy-1,l)+oron(ix,jy+1,l) + m=m/5. + excessoron(ix,jy,l)=(oron(ix,jy,l)-m)**2.+(oron(ix-1,jy,l)-m)**2. & + +(oron(ix+1,jy,l)-m)**2.+(oron(ix,jy-1,l)-m)**2.+(oron(ix,jy+1,l)-m)**2. + excessoron(ix,jy,l)=(excessoron(ix,jy,l)/5.)**0.5 + end do + end do + + +! +! identify the parent grid (which is probably "l-1", so this code +! may be more complicated that necessary) +! set xmet0n, ymet0n, which are the x,y coords of lower-left corner +! of a nested grid (in meters on the mother grid) +! +! note on dumc: +! the lower-left corner of the nested cell (0,0) coincides with the +! lower-left corner of the parent cell (i_parent_start,j_parent_start) +! this being the case, the center of nested cell (0,0) is shifted +! by (-dumc*parent_gridsize) relative to the center of the parent cell +! (for m_parent_grid_ratio = 2, 3, 4, 5; dumc = 1/4, 1/3, 3/8, 2/5) +! + l_parent_nest_id(l) = -1 + if (m_parent_grid_id(l) .gt. 0) then + do lp = 0, l-1 + if ( (l_parent_nest_id(l) .eq. -1) .and. & + (m_parent_grid_id(l) .eq. m_grid_id(lp)) ) then + + l_parent_nest_id(l) = lp + m = m_parent_grid_ratio(l) + dumc = real(m-1)/real(m*2) + if (lp .eq. 0) then + xmet0n(l) = xmet0 + dx*(i_parent_start(l)-dumc) + ymet0n(l) = ymet0 + dy*(j_parent_start(l)-dumc) + else + xmet0n(l) = xmet0n(lp) + dxn(lp)*(i_parent_start(l)-dumc) + ymet0n(l) = ymet0n(lp) + dyn(lp)*(j_parent_start(l)-dumc) + end if + end if + end do + end if + if (idiagbb .gt. 0) write(*,'(/a,3i8)') & + 'l, m_grid_id(l), m_parent_grid_id(l)', & + l, m_grid_id(l), m_parent_grid_id(l) + + if (l_parent_nest_id(l) .eq. -1) then + write(*,'(/a,i3/)') & + 'gridcheck_nests fatal error -- ' // & + 'parent grid not found for l =', l + stop + end if + +! +! diagnostics for testing the nesting calculations +! (set idiagbb=0 to turn it off) +! + lp = l_parent_nest_id(l) + if (idiagbb .gt. 0) then + write(*,'(a,2i8)') 'l_parent, m_grid_id(l_parent) ', & + lp, m_grid_id(lp) + write(*,'(a,2i8)') 'm_parent_grid_ratio(l) ', & + m_parent_grid_ratio(l) + write(*,'(a,i8,f11.2)') & + 'i_parent_start(l), xi_... ', & + i_parent_start(l), i_parent_start(l)-dumc + write(*,'(a,i8,f11.2)') & + 'j_parent_start(l), yj_... ', & + j_parent_start(l), j_parent_start(l)-dumc + end if +!23456789012345678901234567890123456789012345678901234567890123456789012 + + if (idiagbb .gt. 0) then + write(*,*) + do jy = j_parent_start(l)-1, j_parent_start(l) + do ix = i_parent_start(l)-1, i_parent_start(l) + if (lp .eq. 0) then + write(*,'(a,2i7,2f11.4)') 'parent i,j,lon,lat', & + ix, jy, xlon2d(ix,jy), ylat2d(ix,jy) + else + write(*,'(a,2i7,2f11.4)') 'parent i,j,lon,lat', & + ix, jy, xlon2dn(ix,jy,lp), ylat2dn(ix,jy,lp) + end if + end do + end do + + dumc = real( (m_parent_grid_ratio(l)-1) )/ & + real( (m_parent_grid_ratio(l)*2) ) + dumx = i_parent_start(l) - dumc + dumy = j_parent_start(l) - dumc + call xyindex_to_ll_wrf( lp, dumx, dumy, xaux1, yaux1 ) + write(*,'(a,2f7.2,2f11.4)') 'par. xi,yj,lon,lat', & + dumx, dumy, xaux1, yaux1 + + write(*,*) + write(*,'(a,2i7,2f11.4)') 'nest i,j,lon,lat', & + 0, 0, xlon2dn(0,0,l), ylat2dn(0,0,l) + write(*,*) + + dumx = (xmet0n(l) - xmet0)/dx + dumy = (ymet0n(l) - ymet0)/dy + call xyindex_to_ll_wrf( 0, dumx, dumy, xaux1, yaux1 ) + write(*,'(a,2f7.2,2f11.4)') 'mot. xi,yj,lon,lat', & + dumx, dumy, xaux1, yaux1 + + iduma = max( 0, ifix(dumx) ) + idumb = max( 0, ifix(dumy) ) + do jy = idumb, idumb+1 + do ix = iduma, iduma+1 + write(*,'(a,2i7,2f11.4)') 'mother i,j,lon,lat', & + ix, jy, xlon2d(ix,jy), ylat2d(ix,jy) + end do + end do + end if + + + +! Output of grid info +!******************** + + write(*,'(/a,i2)') & + 'gridcheck_nests -- nested domain #: ',l + write(*,'(a,f12.1,a1,f12.1,a,f10.1)') & + ' X coordinate range: ', & + xmet0n(l),' to ',xmet0n(l)+(nxn(l)-1)*dxn(l), & + ' Grid distance: ',dxn(l) + write(*,'(a,f12.1,a1,f12.1,a,f10.1)') & + ' Y coordinate range: ', & + ymet0n(l),' to ',ymet0n(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=xmet0n(l) + xaux2=xmet0n(l)+real(nxn(l)-1)*dxn(l) + yaux1=ymet0n(l) + yaux2=ymet0n(l)+real(nyn(l)-1)*dyn(l) + + xln(l)=(xaux1-xmet0)/dx + xrn(l)=(xaux2-xmet0)/dx + yln(l)=(yaux1-ymet0)/dy + yrn(l)=(yaux2-ymet0)/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(*,*) 'gridcheck_nests error' + write(*,*) 'Nested domain does not fit into mother domain' + write(*,*) 'Execution is terminated.' + stop + endif + + +! check that the map projection routines are working + call test_xyindex_to_ll_wrf( l ) + + +! 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. +!************************************************************* + +! first read eta_w_wrf_nest, eta_u_wrf_nest, and p_top_wrf_nest +! from the netcdf wrfout file + itime = 1 + + varname = 'ZNW' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nwz + lendim_max(1) = nwzmax + ndims_exp = 2 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, eta_w_wrf_nest, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of ZNW' + stop + end if + + varname = 'ZNU' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nwz-1 + lendim_max(1) = nwzmax + ndims_exp = 2 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, eta_u_wrf_nest, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of ZNU' + stop + end if + + varname = 'P_TOP' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = 1 + lendim_max(1) = 6 + ndims_exp = 2 + if (ext_scalar .lt. 0) ndims_exp=1 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, p_top_wrf_nest, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,*) '*** checkgrid -- error doing ncread of P_TOP' + stop + end if + + + do k = 1, nwz + duma = 3.0e-7*max( abs(eta_w_wrf(k)), 1.0e-30 ) + if (abs(eta_w_wrf(k)-eta_w_wrf_nest(k)) .gt. duma) then + write(*,*) & + 'FLEXPART gridcheck_nests error for nesting level',l + write(*,*) & + 'eta_w_wrf are not consistent with the mother domain' + write(*,*) 'k, eta_w_wrf(k), eta_w_wrf_nest(k) =', & + k, eta_w_wrf(k), eta_w_wrf_nest(k) + stop + endif + end do + + do k = 1, nwz-1 + duma = 3.0e-7*max( abs(eta_u_wrf(k)), 1.0e-30 ) + if (abs(eta_u_wrf(k)-eta_u_wrf_nest(k)) .gt. duma) then + write(*,*) & + 'FLEXPART gridcheck_nests error for nesting level',l + write(*,*) & + 'eta_u_wrf are not consistent with the mother domain' + write(*,*) 'k, eta_u_wrf(k), eta_u_wrf_nest(k) =', & + k, eta_u_wrf(k), eta_u_wrf_nest(k) + stop + endif + end do + + duma = 3.0e-7*max( abs(p_top_wrf), 1.0e-30 ) + if (abs(p_top_wrf-p_top_wrf_nest) .gt. duma) then + write(*,*) & + 'FLEXPART gridcheck_nests error for nesting level',l + write(*,*) & + 'p_top_wrf are not consistent with the mother domain' + write(*,*) 'p_top_wrf, p_top_wrf_nest', & + p_top_wrf, p_top_wrf_nest + stop + endif + + +! done with nest l + enddo + + return + + +999 write(*,*) + write(*,*) ' ###########################################'// & + '###### ' + write(*,*) ' FLEXPART_WRF subroutine gridcheck_nests: ' // & + 'nesting level ', l + write(*,*) ' can not open input data file ' + write(*,*) ' '//fnamenc + write(*,*) ' or, an error occured in subr. read_ncwrfout_gridinfo' + write(*,*) ' with ierr =', ierr + write(*,*) ' ###########################################'// & + '###### ' + stop + +end subroutine gridcheck_nests + + diff --git a/src_flexwrf_v3.1/hanna.f90 b/src_flexwrf_v3.1/hanna.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2c93715ddbd40eba397d4851787e18bae54fef86 --- /dev/null +++ b/src_flexwrf_v3.1/hanna.f90 @@ -0,0 +1,131 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine hanna(z, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + + ! 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 + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + + + + !********************** + ! 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 diff --git a/src_flexwrf_v3.1/hanna1.f90 b/src_flexwrf_v3.1/hanna1.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b052e7a2fd81d44681d49d0cf33e5a530262d1a0 --- /dev/null +++ b/src_flexwrf_v3.1/hanna1.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine hanna1(z, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + + ! 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 + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + + + + !********************** + ! 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 diff --git a/src_flexwrf_v3.1/hanna_mod.f90 b/src_flexwrf_v3.1/hanna_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..956b48e6b608399ba05b1b4c71092a41107431e7 --- /dev/null +++ b/src_flexwrf_v3.1/hanna_mod.f90 @@ -0,0 +1,30 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Jerome Fast, +!* Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa * +!* Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +module hanna_mod + + implicit none + + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + +end module hanna_mod diff --git a/src_flexwrf_v3.1/hanna_short.f90 b/src_flexwrf_v3.1/hanna_short.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8b31effb14b6b5433f2fd95c0d3c400763cc0d5d --- /dev/null +++ b/src_flexwrf_v3.1/hanna_short.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine hanna_short(z, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + + ! 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 + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + + + + !********************** + ! 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 diff --git a/src_flexwrf_v3.1/init_domainfill.f90 b/src_flexwrf_v3.1/init_domainfill.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dcac6fc3888026088c6ff46df36b01ac5003d7a7 --- /dev/null +++ b/src_flexwrf_v3.1/init_domainfill.f90 @@ -0,0 +1,451 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine init_domainfill +! +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine init_domainfill. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 * +! * +! 26 Oct 2005, R. Easter - changes for gridarea * +! associated with WRF horizontal grid. * +! Also calc. true ylat for pv stuff. * +! 11 Nov 2005, R. Easter - fixed error involving xy to latlon * +! * +! * +!******************************************************************************* +! * +! 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 +!,idummy + +! real gridarea(0:nymax-1),pp(nzmax),ylat,ylatp,ylatm,hzone,ran1 + real :: gridarea(0:nymax-1),pp(nzmax),ylat, ran1 +! real cosfactm,cosfactp,pih,deltacol,dz1,dz2,dz,pnew,fractus + real :: deltacol,dz1,dz2,dz,pnew,fractus + real :: xlon + + 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 +!10 gridarea(jy)=2.*pi*r_earth*hzone*dx/360. + +! for FLEXPART_WRF, dx & dy are in meters, and no cos(lat) is needed +! ??? should maybe include map factor here ??? + gridarea(jy)=dx*dy + enddo +! Do the same for the south pole + + if (sglobal) then + write(*,*) + write(*,*) '*** stopping in init_domainfill ***' + write(*,*) ' the s-pole code section should not be active' + write(*,*) +! 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 + write(*,*) + write(*,*) '*** stopping in init_domainfill ***' + write(*,*) ' the s-pole code section should not be active' + write(*,*) +! 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) + enddo + enddo + 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 + +! for FLEXPART_WRF, x & y coords are in meters. +! In the "do 30" loop, ylat is only needed for pv calcs. + call xyindex_to_ll_wrf( 0, real(ix), real(jy), xlon, ylat ) + + 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) + enddo + + 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 + enddo +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) + enddo + 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 +! if (((ztra1(numpart+jj).lt.8000.) +! + ).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 +! xmass1(numpart+jj,1)*60.*48./29./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 + enddo + + + + +! 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) + enddo +! 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(1)(1:length(1))//'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 + diff --git a/src_flexwrf_v3.1/initial_cond_calc.f90 b/src_flexwrf_v3.1/initial_cond_calc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b14a85fb0f8fd6f28f3dee1515485a7e4735bdf1 --- /dev/null +++ b/src_flexwrf_v3.1/initial_cond_calc.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/initial_cond_output.f90 b/src_flexwrf_v3.1/initial_cond_output.f90 new file mode 100644 index 0000000000000000000000000000000000000000..39fd209823e8a640da25de5ae2ad913ec72d098c --- /dev/null +++ b/src_flexwrf_v3.1/initial_cond_output.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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(1)(1:length(1))//'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 diff --git a/src_flexwrf_v3.1/initialize.f90 b/src_flexwrf_v3.1/initialize.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ff3722d66501963e53bef5a34967a2b57030465a --- /dev/null +++ b/src_flexwrf_v3.1/initialize.f90 @@ -0,0 +1,328 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine initialize(itime,ldt,up,vp,wp, & + usigold,vsigold,wsigold,xt,yt,zt,icbt, & + ngrid,depoindicator,indzindicator,cpt2,ompid,myid,n_threads,mts ) +! uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & +! rhoprof,rhogradprof, tkeprof,pttprof, & +! u,v,w,usig,vsig,wsig,pvi, & +!! p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & +! ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & +! indzindicator, & +! ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & +! sigw,dsigwdz,dsigw2dz,cpt,ompid) + +! 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 * +! * +!******************************************************************************* +! 12 JUNE 2007 W. Wang +! use WRF TKE option to compute turbulence +! Mar 2012: J. Brioude modification to handle openmp. * +! Jan 2013 M. Cassiani modification to use CBL scheme +!******************************************************************************* + use par_mod + use com_mod + use mt_stream + +! use interpol_mod +! use hanna_mod +! use ran_mod + implicit none + + integer :: itime + integer :: ldt,nrand,ompid +!OMP_GET_THREAD_NUM + 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 + + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(nzmax) + real :: u,v,w,usig,vsig,wsig,pvi,mu,mv + + real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2 + integer :: ix,jy,ixp,jyp,ngrid,indz,indzp,cpt2,maxrand2 + logical :: depoindicator(maxspec) + logical :: indzindicator(nzmax) + + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + + real :: dcas,dcas1,dcas2 !modified by by mc, random number needed in initialize_cbl_vel + integer :: myid,n_threads !added by mc for parallel random number generation + integer(4) :: rannum + real(4) :: real_rannum + type (mt_state) :: mts (0: MAX_STREAM) + + + idummy=7 + icbt=1 ! initialize particle to "no reflection" + + if (newrandomgen.eq.0) then + cpt2=cpt2+1 +! cpt=cpt+1000367 + cpt2=mod(cpt2,maxrand)+1; + +! nrand=int(ran3(idummy,inext,inextp,ma,iff)*real(maxrand-1))+1 +! nrand=int(ran3(idummy)*real(maxrand-1))+1 + nrand=cpt2+ompid*maxrand + maxrand2=maxrandomp + else +!mc +! rannum=genrand_int32(mts(ompid+1+(myid*n_threads))) !integer random +! number at 32 bit resolution + rannum=genrand_int32(mts(ompid+1)) !integer random number at 32 bit resolution + real_rannum = sngl(0.5_DP + 0.2328306e-9_DP * rannum) !conversion to single precision 32bit real between 0-1 + nrand=int(real_rannum*real(maxrand-1))+1 + maxrand2=maxrand + endif + +!****************************** +! 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))) + +! JB + 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, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,mu,mv) + + +! 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 +!**************************************** +! FLEXPART WRF +! write(*,*)'initial.f','turb_option=',turb_option +! write(*,*)'turb_option_mytke=',turb_option_mytke + if (turb_option .eq. turb_option_mytke) then +! write(*,*)'initial.f' + call tke_partition_my(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,uprof,vprof,tkeprof,pttprof,indz,indzp) + elseif (turb_option .eq. turb_option_tke) then + call tke_partition_hanna(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,uprof,vprof,tkeprof,pttprof,indz,indzp) + else + + if (turbswitch) then + call hanna(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + + else + call hanna1(zt, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + endif + endif + +! Determine the new diffusivity velocities +!***************************************** + + if (nrand+2.gt.maxrand2) nrand=1 + up=rannumb(nrand)*sigu + vp=rannumb(nrand+1)*sigv + wp=rannumb(nrand+2) + nrand=nrand+2 ! added by mc: it was missing previously a bug I think here and in original flexpart + + if (.not.turbswitch) then ! modified by mc + wp=wp*sigw + else if (cblflag.eq.1) then ! modified by mc + if (-h/ol.gt.5) then !unstable conditions from -h/ol >5 + !if (ol.lt.0.) then + !if (ol.gt.0.) then !by mc : gt.0 is only for test the correct is lt.0^M + dcas=uniform_rannumb(nrand) !uniform^M + dcas1=rannumb(nrand) !gaussian^M + nrand=nrand+3 + call initialize_cbl_vel(idummy,zt,ust,wst,h,sigw,wp,dcas,dcas1,ol) + else + wp=wp*sigw + end if + end if +! 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, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator,mu,mv) + + +! Compute everything for above the PBL + +! Assume constant turbulent perturbations +!**************************************** + + ldt=abs(lsynctime) + + if (nrand+1.gt.maxrand2) 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.maxrand2) nrand=1 + usigold=rannumb(nrand)*usig + vsigold=rannumb(nrand+1)*vsig + wsigold=rannumb(nrand+2)*wsig + +end subroutine initialize + diff --git a/src_flexwrf_v3.1/initialize_cbl_vel.f90 b/src_flexwrf_v3.1/initialize_cbl_vel.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a4ffbd6ce04806eda9162ee68dde03cff04105b8 --- /dev/null +++ b/src_flexwrf_v3.1/initialize_cbl_vel.f90 @@ -0,0 +1,119 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + + subroutine initialize_cbl_vel(idum,zp,ust,wst,h,sigmaw,wp,dcas,dcas1,ol) +! i/o i i i i i o i i i +! idum: for random number but not usednot used +! zp: particle psition +! ust: velocity scale, not used +! wst: ocnvective velcotiy scale +! sigmaW: standard deviaiton of vertical velocity +! wp: particle velocity +! dcas: for random number +! dcas1: for random number +! ol: Obukhov lenght +!=============== initilization of particle velcoity based on CBL skewed vertical profiles and formulation of LHH 1996 with profile of w3 from lHB 2000 ================== +!=============== by Massimo Cassiani ( mc ), NILU, 2012-2013, reference to Cassiani et al. 2013.. ================== +!================================================================================================================================================================================ + use par_mod, only:pi + use com_mod, only:ldirect +! use ieee_arithmetic + + implicit none + + + real :: usurad2,usurad2p,C0,costluar4,eps + parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=2,costluar4=0.66667,eps=0.000001) + + integer idum + real :: wp,zp,ust,wst,h,dens,ddens,sigmaw,dsigmawdz,tlw,dcas,dcas1,ran3,gasdev + real :: w3,w2 + real :: z, & + skew, & + skew2, & + radw2, & + fluarw,fluarw2, & + rluarw, & + xluarw, & + aluarw, & + bluarw, & + sigmawa, & + sigmawb, & + ath, & + bth, & + wb,wa + real timedir + real ol, transition + + !--------------------------------------------------------------------------- + !timedir=dble(ldirect) !direction of time forward (1) or backward(-1) + timedir=ldirect !time direction forward (1) or backward(-1) + z=zp/h !hn is the boundarylayer top + + transition=1. + if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5 !transtion from near neutral to unstable + + + !w2=(1.7*(z*(1.-0.7*z)*(1.-z))**(2./3.))*(wst**2) + w2=sigmaw*sigmaw + !w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3) *1.5 !the 1.5 is to test with increased skeweness see also cbl.f90 + w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3)*transition + skew=w3/(w2**1.5) + skew2=skew*skew + radw2=sqrt(w2) !sigmaw + + if (skew.ne.0) then + fluarw=costluar4*skew**0.333333333333333 + fluarw2=fluarw*fluarw + rluarw=(1.+fluarw2)**3.*skew2/((3.+fluarw2)**2.*fluarw2) !-> r + xluarw=rluarw**0.5 !(1.+fluarw2)**1.5*skew/((3.+fluarw2)*fluarw) !----> r^1/2 + else + fluarw=0. + fluarw2=0. + rluarw=0. + xluarw=0. + end if + + aluarw=0.5*(1.-xluarw/(4.+rluarw)**0.5) + bluarw=1.-aluarw + + sigmawa=radw2*(bluarw/(aluarw*(1.+fluarw2)))**0.5 + sigmawb=radw2*(aluarw/(bluarw*(1.+fluarw2)))**0.5 + + wa=(fluarw*sigmawa) + wb=(fluarw*sigmawb) + + !dcas=ran3(idum) !pass from outside + + if (dcas.le.aluarw) then + !dcas1=gasdev(idum) !pass from outside + wp=timedir*(dcas1*sigmawa+wa) + else + !dcas1=gasdev(idum) !pass from outside + wp=timedir*(dcas1*sigmawb-wb) + end if +! if (ieee_is_nan(wp)) print*,'PROBLEM INIT',wp,timedir, & +! dcas1,sigmawa,wa,sigmawb,wb,idum,zp,ust,wst,h,sigmaw,wp,dcas,dcas1,ol + return + end + diff --git a/src_flexwrf_v3.1/interpol_all.f90 b/src_flexwrf_v3.1/interpol_all.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dfb7f9a2163b62c46ca59d60a0b4ef20beee68bd --- /dev/null +++ b/src_flexwrf_v3.1/interpol_all.f90 @@ -0,0 +1,327 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine interpol_all(itime,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,mu,mv) + +! 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 * +! calculation 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 calculat* +! * +! Constants: * +! * +!******************************************************************************* +! 12 JUNE 2007, compute tkeprof, y4 +! 25 June 2007, compute pttprof, y5 +! compute tkeprof for all levels +!******************************************************************************* + 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),y4(2),y5(2) + real :: usl,vsl,wsl,usq,vsq,wsq,xaux + integer :: i,m,n,indexh,n2 + real :: tkeprof2 + + real,parameter ::eps=1.0e-30 + + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(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) + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz,mu,mv + + +!******************************************** +! 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 + mu =p1*m_x(ix ,jy ,1) & + + p2*m_x(ixp,jy ,1) & + + p3*m_x(ix ,jyp,1) & + + p4*m_x(ixp,jyp,1) + mv =p1*m_y(ix ,jy ,1) & + + p2*m_y(ixp,jy ,1) & + + p3*m_y(ix ,jyp,1) & + + p4*m_y(ixp,jyp,1) + +! 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) + + + enddo + 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 + + enddo + +! compute TKE for all levels, used for estimating turb length scale + tkeprof2=-999. +! tkeprof2=0. + do n=1,nz + do m=1,2 + indexh=memind(m) + y4(m) =p1*tke(ix ,jy ,n,indexh) & + +p2*tke(ixp,jy ,n,indexh) & + +p3*tke(ix ,jyp,n,indexh) & + +p4*tke(ixp,jyp,n,indexh) + y5(m) =p1*ptt(ix ,jy ,n,indexh) & + +p2*ptt(ixp,jy ,n,indexh) & + +p3*ptt(ix ,jyp,n,indexh) & + +p4*ptt(ixp,jyp,n,indexh) + enddo + tkeprof(n)=(y4(1)*dt2+y4(2)*dt1)*dtt + pttprof(n)=(y5(1)*dt2+y5(2)*dt1)*dtt +! if (tkeprof(n).gt.tkeprof2) then +! tkeprof2=tkeprof(n) +! n2=n +! endif +! if (n.lt.20) then +! tkeprof2=tkeprof2+tkeprof(n) +! n2=20 +! endif + enddo +! tkeprof(1)=0.33*tkeprof(1)+0.33*tkeprof(2)+0.33*tkeprof(3) +! write(*,*)'interpol_all,itime,xt,yt,zt',itime,xt,yt,zt +! write(*,*)(tkeprof(n),n=1,nz) + +end subroutine interpol_all + diff --git a/src_flexwrf_v3.1/interpol_all_nests.f90 b/src_flexwrf_v3.1/interpol_all_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0b542b453623483742de09573c4499d9202f1c3b --- /dev/null +++ b/src_flexwrf_v3.1/interpol_all_nests.f90 @@ -0,0 +1,293 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine interpol_all_nests(itime,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,mu,mv) + +! 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 * +! calculation 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 calculat* +! * +! Constants: * +! * +!******************************************************************************* +! 12 JUNE 2007 compute tkeprof, add a variable y4(2) +! 25 June 2007 compute pttprof, y5 +! compute tkeprof for all levels +!******************************************************************************* + 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),y4(2),y5(2) + real :: usl,vsl,wsl,usq,vsq,wsq,xaux + integer :: i,m,n,indexh + real,parameter :: eps=1.0e-30 + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(nzmax) + real :: u,v,w,usig,vsig,wsig,pvi,mu,mv + + 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) + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + + +!******************************************** +! 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 + mu =p1*m_xn(ix ,jy ,1,ngrid) & + + p2*m_xn(ixp,jy ,1,ngrid) & + + p3*m_xn(ix ,jyp,1,ngrid) & + + p4*m_xn(ixp,jyp,1,ngrid) + mv =p1*m_yn(ix ,jy ,1,ngrid) & + + p2*m_yn(ixp,jy ,1,ngrid) & + + p3*m_yn(ix ,jyp,1,ngrid) & + + p4*m_yn(ixp,jyp,1,ngrid) + + +! 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 + +! compute tke profile for all levels + + do n=1,nz + do m=1,2 + indexh=memind(m) + y4(m)=p1*tken(ix ,jy ,n,indexh,ngrid) & + +p2*tken(ixp,jy ,n,indexh,ngrid) & + +p3*tken(ix ,jyp,n,indexh,ngrid) & + +p4*tken(ixp,jyp,n,indexh,ngrid) + y5(m)=p1*pttn(ix ,jy ,n,indexh,ngrid) & + +p2*pttn(ixp,jy ,n,indexh,ngrid) & + +p3*pttn(ix ,jyp,n,indexh,ngrid) & + +p4*pttn(ixp,jyp,n,indexh,ngrid) + + enddo + tkeprof(n)=(y4(1)*dt2+y4(2)*dt1)*dtt + pttprof(n)=(y5(1)*dt2+y5(2)*dt1)*dtt + enddo + + + end subroutine interpol_all_nests + diff --git a/src_flexwrf_v3.1/interpol_hmix.f90 b/src_flexwrf_v3.1/interpol_hmix.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9f811d2c27d86eefd018bbd74646a2df2d883f48 --- /dev/null +++ b/src_flexwrf_v3.1/interpol_hmix.f90 @@ -0,0 +1,106 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Jerome Fast, +!* Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa * +!* Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann +!* M. Cassiani +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine interpol_hmix(itime,xt,yt,zt,haux, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp) + +! i i i i +!******************************************************************************* +! * +! This subroutine interpolates boundary layer top (h) * +! dispersion. * +! * +! Author:M. cassiani 2013 * +! * +! * +!******************************************************************************* + use par_mod + use com_mod +! use interpol_mod +! use hanna_mod + implicit none + + integer :: itime + real :: xt,yt,zt,h + +! Auxiliary variables needed for interpolation + + integer :: i,m,n,indexh,n2 + + real,parameter ::eps=1.0e-30 + + + real :: h1(2),haux + real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2 + integer :: ix,jy,ixp,jyp,ngrid,indz,indzp + logical :: indzindicator(nzmax) + + + +!******************************************** +! 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) + + + +!***************************************** + +! a) Bilinear horizontal interpolation + + do m=1,2 + indexh=memind(m) + + h1(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 + + +! b) Temporal interpolation + + haux=(h1(1)*dt2+h1(2)*dt1)*dtt + + +end subroutine interpol_hmix + diff --git a/src_flexwrf_v3.1/interpol_misslev.f90 b/src_flexwrf_v3.1/interpol_misslev.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cdb75167a0e53a1d07809248a108de4c5ea6d544 --- /dev/null +++ b/src_flexwrf_v3.1/interpol_misslev.f90 @@ -0,0 +1,217 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine interpol_misslev(n,xt,yt,zt,& + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + + +! 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 * +! calculation of standard deviation done in this * +! routine rather than subroutine call in order * +! to save computation time * +! * +!******************************************************************************* +! * +! Variables: * +! n level * +! * +! Constants: * +! * +!******************************************************************************* +! 12 JUNE 2007 by W Wang +! compute pttrof , add a variable y4 for interpolation * +!******************************************************************************* + + 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),y4(2) + real :: usl,vsl,wsl,usq,vsq,wsq,xaux + integer :: m,n,indexh + real,parameter :: eps=1.0e-30 + + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(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) + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + + real(kind=dp) :: xt,yt + real :: zt + +!******************************************** +! 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) +! y4(m) =p1*ptt(ix ,jy ,n,indexh) & +! +p2*ptt(ixp,jy ,n,indexh) & +! +p3*ptt(ix ,jyp,n,indexh) & +! +p4*ptt(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 +! pttprof(n)=(y4(1)*dt2+y4(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 + diff --git a/src_flexwrf_v3.1/interpol_misslev_nests.f90 b/src_flexwrf_v3.1/interpol_misslev_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5e3f1f556252a150814e58c53c002acbc26dcf3b --- /dev/null +++ b/src_flexwrf_v3.1/interpol_misslev_nests.f90 @@ -0,0 +1,182 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine interpol_misslev_nests(n,xt,yt,zt,& + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz) + +! i +!******************************************************************************* +! * +! This subroutine interpolates u,v,w, density and density gradients. * +! * +! Author: A. Stohl * +! * +! 16 December 1997 * +! * +!******************************************************************************* +! * +! Variables: * +! n level * +! * +! Constants: * +! * +!******************************************************************************* +! 12 JUNE 2007 W Wang +! compute pttprof, add a variable y4 for interpolation * +!******************************************************************************* + 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),y4(2) + real :: usl,vsl,wsl,usq,vsq,wsq,xaux + integer :: m,n,indexh + real,parameter :: eps=1.0e-30 + + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(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) + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + + real(kind=dp) :: xt,yt + real :: zt + +!******************************************** +! 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) +! y4(m)=p1*pttn(ix ,jy ,n,indexh,ngrid) & +! +p2*pttn(ixp,jy ,n,indexh,ngrid) & +! +p3*pttn(ix ,jyp,n,indexh,ngrid) & +! +p4*pttn(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 +! pttprof(n)=(y4(1)*dt2+y4(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 + diff --git a/src_flexwrf_v3.1/interpol_mod.f90 b/src_flexwrf_v3.1/interpol_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e75a98a5730d83740f08d82716922a58c775e822 --- /dev/null +++ b/src_flexwrf_v3.1/interpol_mod.f90 @@ -0,0 +1,43 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +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 :: tkeprof(nzmax),pttprof(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 + + diff --git a/src_flexwrf_v3.1/interpol_rain.f90 b/src_flexwrf_v3.1/interpol_rain.f90 new file mode 100644 index 0000000000000000000000000000000000000000..006980e23633c5762d467df6d1dcc0120ede3d83 --- /dev/null +++ b/src_flexwrf_v3.1/interpol_rain.f90 @@ -0,0 +1,249 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine interpol_rain(yy1,yy2,yy3,iy1,iy2,nxmax,nymax,nzmax,nx, & + ny,memind,xt,yt,level,itime1,itime2,itime,yint1,yint2,yint3, & + intiy1,intiy2,icmv) +! 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 * +! * +! 19-Oct-2007 WANG, W change cumulated rain to hourly rain +! yy1 is accumulated largescale precipitation (mm) +! yy2 is ''''''''''''convective ''''''''''''''''' +!**************************************************************************** + + implicit none + + integer :: nx,ny,nxmax,nymax,nzmax,memind(2),m,ix,jy,ixp,jyp +! integer :: itime,itime1,itime2,level,indexh,i1,i2 + integer :: itime,itime1,itime2,level,indexh,i1,i2,ip1,ip2,ip3,ip4 + integer :: intiy1,intiy2,ipsum,icmv + + 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) + + integer :: iy1(0:nxmax-1,0:nymax-1,2),iy2(0:nxmax-1,0:nymax-1,2) + +! real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2) + real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2),yi1(2),yi2(2) + +! real :: xt,yt,yint1,yint2,yint3,p1,p2,p3,p4 + real :: xt,yt,yint1,yint2,yint3,yint4,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 +!*********************** + +! y1 and y2 are accumulated rain, need change to hourly rain + + i1=memind(1) + i2=memind(2) +!! time interval between two fields, second to hour + dt=real(itime2-itime1)/3600.0 + + + yint1=p1*(yy1(ix ,jy ,level,i2)- & + yy1(ix ,jy ,level,i1)) & + + p2*(yy1(ixp,jy ,level,i2)- & + yy1(ixp,jy ,level,i1)) & + + p3*(yy1(ix ,jyp,level,i2)- & + yy1(ix ,jyp,level,i1)) & + + p4*(yy1(ixp,jyp,level,i2)- & + yy1(ixp,jyp,level,i1)) + yint1=yint1/dt + + yint2=p1*(yy2(ix ,jy ,level,i2)- & + yy2(ix ,jy ,level,i1)) & + + p2*(yy2(ixp,jy ,level,i2)- & + yy2(ixp,jy ,level,i1)) & + + p3*(yy2(ix ,jyp,level,i2)- & + yy2(ix ,jyp,level,i1)) & + + p4*(yy2(ixp,jyp,level,i2)- & + yy2(ixp,jyp,level,i1)) + yint2=yint2/dt + + +! Y3 is cloud fraction in an hour + do m=1,2 + indexh=memind(m) + 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) + enddo + + +! CDA new clouds + + do m=1,2 + indexh=memind(m) + + ip1=1 + ip2=1 + ip3=1 + ip4=1 + if (iy1(ix ,jy ,indexh) .eq. icmv) ip1=0 + if (iy1(ixp,jy ,indexh) .eq. icmv) ip2=0 + if (iy1(ix ,jyp,indexh) .eq. icmv) ip3=0 + if (iy1(ixp,jyp,indexh) .eq. icmv) ip4=0 + ipsum= ip1+ip2+ip3+ip4 + if (ipsum .eq. 0) then + yi1(m)=icmv + else + yi1(m)=(ip1*p1*iy1(ix ,jy ,indexh) & + + ip2*p2*iy1(ixp,jy ,indexh) & + + ip3*p3*iy1(ix ,jyp,indexh) & + + ip4*p4*iy1(ixp,jyp,indexh))/ipsum + endif + + ip1=1 + ip2=1 + ip3=1 + ip4=1 + if (iy2(ix ,jy ,indexh) .eq. icmv) ip1=0 + if (iy2(ixp,jy ,indexh) .eq. icmv) ip2=0 + if (iy2(ix ,jyp,indexh) .eq. icmv) ip3=0 + if (iy2(ixp,jyp,indexh) .eq. icmv) ip4=0 + ipsum= ip1+ip2+ip3+ip4 + if (ipsum .eq. 0) then + yi2(m)=icmv + else + yi2(m)=(ip1*p1*iy2(ix ,jy ,indexh) & + + ip2*p2*iy2(ixp,jy ,indexh) & + + ip3*p3*iy2(ix ,jyp,indexh) & + + ip4*p4*iy2(ixp,jyp,indexh))/ipsum + endif + enddo +!CPS end clouds + + +10 continue + + +!************************************ +! 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 + + +!CPS clouds: + intiy1=(yi1(1)*dt2 + yi1(2)*dt1)/dt + if (yi1(1) .eq. float(icmv)) intiy1=yi1(2) + if (yi1(2) .eq. float(icmv)) intiy1=yi1(1) + + intiy2=(yi2(1)*dt2 + yi2(2)*dt1)/dt + if (yi2(1) .eq. float(icmv)) intiy2=yi2(2) + if (yi2(2) .eq. float(icmv)) intiy2=yi2(1) + + if (intiy1 .ne. icmv .and. intiy2 .ne. icmv) then + intiy2 = intiy1 + intiy2 ! convert cloud thickness to cloud top + else + intiy1=icmv + intiy2=icmv + endif +!CPS end clouds + + + + + + end subroutine interpol_rain + diff --git a/src_flexwrf_v3.1/interpol_rain_nests.f90 b/src_flexwrf_v3.1/interpol_rain_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b6301f1f1ef434dc6026f15328b59fb8c96d3c45 --- /dev/null +++ b/src_flexwrf_v3.1/interpol_rain_nests.f90 @@ -0,0 +1,263 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine interpol_rain_nests(yy1,yy2,yy3,iy1,iy2,nxmaxn,nymaxn,nzmax, & + maxnests,ngrid,nxn,nyn,memind,xt,yt,level,itime1,itime2,itime, & + yint1,yint2,yint3,intiy1,intiy2,icmv) +! 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 * +! * +! Changed 10/22/2007 yy1,yy2 are accumulated rain (mm) +! convert them into hourly rain (mm/hr) +!**************************************************************************** + + 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,i1,i2 + integer :: ip1,ip2,ip3,ip4 + integer :: intiy1,intiy2,ipsum,icmv + 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) + integer :: iy1(0:nxmaxn-1,0:nymaxn-1,2,maxnests) + integer :: iy2(0:nxmaxn-1,0:nymaxn-1,2,maxnests) + real :: ddx,ddy,rddx,rddy,dt1,dt2,dt,y1(2),y2(2),y3(2),yi1(2),yi2(2) + real :: xt,yt,yint1,yint2,yint3,yint4,p1,p2,p3,p4 + + + +! If point at border of grid -> small displacement into grid +!*********************************************************** + + if (xt.ge.real(nxn(ngrid)-1)) xt=real(nxn(ngrid)-1)-0.00001 + if (yt.ge.real(nyn(ngrid)-1)) yt=real(nyn(ngrid)-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 +!*********************** + +! y1 and y2 are accumulated rain, need change to hourly rain + + i1=memind(1) + i2=memind(2) +! time interval between two fields, second to hour + dt=real(itime2-itime1)/3600.0 + + yint1=p1*(yy1(ix ,jy ,level,i2,ngrid)- & + yy1(ix ,jy ,level,i1,ngrid)) & + + p2*(yy1(ixp,jy ,level,i2,ngrid)- & + yy1(ixp,jy ,level,i1,ngrid)) & + + p3*(yy1(ix ,jyp,level,i2,ngrid)- & + yy1(ix ,jyp,level,i1,ngrid)) & + + p4*(yy1(ixp,jyp,level,i2,ngrid)- & + yy1(ixp,jyp,level,i1,ngrid)) + yint1=yint1/dt + + yint2=p1*(yy2(ix ,jy ,level,i2,ngrid)- & + yy2(ix ,jy ,level,i1,ngrid)) & + + p2*(yy2(ixp,jy ,level,i2,ngrid)- & + yy2(ixp,jy ,level,i1,ngrid)) & + + p3*(yy2(ix ,jyp,level,i2,ngrid)- & + yy2(ix ,jyp,level,i1,ngrid)) & + + p4*(yy2(ixp,jyp,level,i2,ngrid)- & + yy2(ixp,jyp,level,i1,ngrid)) + yint2=yint2/dt + + +! Y3 is cloud fraction in an hour + + + do m=1,2 + indexh=memind(m) + + 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) + enddo + + +! CDA new clouds + + do m=1,2 + indexh=memind(m) + + ip1=1 + ip2=1 + ip3=1 + ip4=1 + if (iy1(ix ,jy ,indexh,ngrid) .eq. icmv) ip1=0 + if (iy1(ixp,jy ,indexh,ngrid) .eq. icmv) ip2=0 + if (iy1(ix ,jyp,indexh,ngrid) .eq. icmv) ip3=0 + if (iy1(ixp,jyp,indexh,ngrid) .eq. icmv) ip4=0 + ipsum= ip1+ip2+ip3+ip4 + if (ipsum .eq. 0) then + yi1(m)=icmv + else + yi1(m)=(ip1*p1*iy1(ix ,jy ,indexh,ngrid) & + + ip2*p2*iy1(ixp,jy ,indexh,ngrid) & + + ip3*p3*iy1(ix ,jyp,indexh,ngrid) & + + ip4*p4*iy1(ixp,jyp,indexh,ngrid))/ipsum + endif + + ip1=1 + ip2=1 + ip3=1 + ip4=1 + if (iy2(ix ,jy ,indexh,ngrid) .eq. icmv) ip1=0 + if (iy2(ixp,jy ,indexh,ngrid) .eq. icmv) ip2=0 + if (iy2(ix ,jyp,indexh,ngrid) .eq. icmv) ip3=0 + if (iy2(ixp,jyp,indexh,ngrid) .eq. icmv) ip4=0 + ipsum= ip1+ip2+ip3+ip4 + if (ipsum .eq. 0) then + yi2(m)=icmv + else + yi2(m)=(ip1*p1*iy2(ix ,jy ,indexh,ngrid) & + + ip2*p2*iy2(ixp,jy ,indexh,ngrid) & + + ip3*p3*iy2(ix ,jyp,indexh,ngrid) & + + ip4*p4*iy2(ixp,jyp,indexh,ngrid))/ipsum + endif + ip1=1 + ip2=1 + ip3=1 + ip4=1 + if (iy2(ix ,jy ,indexh,ngrid) .eq. icmv) ip1=0 + if (iy2(ixp,jy ,indexh,ngrid) .eq. icmv) ip2=0 + if (iy2(ix ,jyp,indexh,ngrid) .eq. icmv) ip3=0 + if (iy2(ixp,jyp,indexh,ngrid) .eq. icmv) ip4=0 + ipsum= ip1+ip2+ip3+ip4 + if (ipsum .eq. 0) then + yi2(m)=icmv + else + yi2(m)=(ip1*p1*iy2(ix ,jy ,indexh,ngrid) & + + ip2*p2*iy2(ixp,jy ,indexh,ngrid) & + + ip3*p3*iy2(ix ,jyp,indexh,ngrid) & + + ip4*p4*iy2(ixp,jyp,indexh,ngrid))/ipsum + endif + enddo +!CPS end clouds + + +10 continue + + +!************************************ +! 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 + + +!CPS clouds: + intiy1=(yi1(1)*dt2 + yi1(2)*dt1)/dt + if (yi1(1) .eq. float(icmv)) intiy1=yi1(2) + if (yi1(2) .eq. float(icmv)) intiy1=yi1(1) + + intiy2=(yi2(1)*dt2 + yi2(2)*dt1)/dt + if (yi2(1) .eq. float(icmv)) intiy2=yi2(2) + if (yi2(2) .eq. float(icmv)) intiy2=yi2(1) + + if (intiy1 .ne. icmv .and. intiy2 .ne. icmv) then + intiy2 = intiy1 + intiy2 ! convert cloud thickness to cloud top + else + intiy1=icmv + intiy2=icmv + endif +!CPS end clouds + + +end subroutine interpol_rain_nests + diff --git a/src_flexwrf_v3.1/interpol_vdep.f90 b/src_flexwrf_v3.1/interpol_vdep.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6dd5c196a9648fa5386ba53fdc3eac0c614e4a80 --- /dev/null +++ b/src_flexwrf_v3.1/interpol_vdep.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine interpol_vdep(level,vdepo,ix,jy,ixp,jyp, & + p1,p2,p3,p4,dt1,dt2,dtt,depoindicator) + ! 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 + real :: p1,p2,p3,p4,dtt,dt1,dt2 + integer :: ix,jy,ixp,jyp + logical :: depoindicator(maxspec) + + ! 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 diff --git a/src_flexwrf_v3.1/interpol_vdep_nests.f90 b/src_flexwrf_v3.1/interpol_vdep_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..aebb6b1b1219191ecbba5f059d8ac95c24cbc8f1 --- /dev/null +++ b/src_flexwrf_v3.1/interpol_vdep_nests.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine interpol_vdep_nests(level,vdepo,ix,jy,ixp,jyp, & + p1,p2,p3,p4,dt1,dt2,dtt,depoindicator,ngrid) + ! 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 + real :: p1,p2,p3,p4,dtt,dt1,dt2 + integer :: ix,jy,ixp,jyp,ngrid + logical :: depoindicator(maxspec) + + ! 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 diff --git a/src_flexwrf_v3.1/interpol_wind.f90 b/src_flexwrf_v3.1/interpol_wind.f90 new file mode 100644 index 0000000000000000000000000000000000000000..42972df7f092a6c28ce0213ab9a26bdabf2a5d3f --- /dev/null +++ b/src_flexwrf_v3.1/interpol_wind.f90 @@ -0,0 +1,263 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine interpol_wind(itime,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator,mu,mv) + + ! 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 + + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(nzmax) + real :: u,v,w,usig,vsig,wsig,pvi,mu,mv + + 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) + + + !******************************************** + ! 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 + + + mu =p1*m_x(ix ,jy ,1) & + + p2*m_x(ixp,jy ,1) & + + p3*m_x(ix ,jyp,1) & + + p4*m_x(ixp,jyp,1) + mv =p1*m_y(ix ,jy ,1) & + + p2*m_y(ixp,jy ,1) & + + p3*m_y(ix ,jyp,1) & + + p4*m_y(ixp,jyp,1) + + ! 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 + if (usig.gt.1.e6) print*,'pb xaux',usq,usl + + 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 diff --git a/src_flexwrf_v3.1/interpol_wind_nests.f90 b/src_flexwrf_v3.1/interpol_wind_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b29d6a362f555e8c90c2095e1795a4b373886ce0 --- /dev/null +++ b/src_flexwrf_v3.1/interpol_wind_nests.f90 @@ -0,0 +1,245 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine interpol_wind_nests(itime,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator,mu,mv) + ! 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 + + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(nzmax) + real :: u,v,w,usig,vsig,wsig,pvi,mu,mv + + 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) + + + !******************************************** + ! 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 + + mu =p1*m_xn(ix ,jy ,1,ngrid) & + + p2*m_xn(ixp,jy ,1,ngrid) & + + p3*m_xn(ix ,jyp,1,ngrid) & + + p4*m_xn(ixp,jyp,1,ngrid) + mv =p1*m_yn(ix ,jy ,1,ngrid) & + + p2*m_yn(ixp,jy ,1,ngrid) & + + p3*m_yn(ix ,jyp,1,ngrid) & + + p4*m_yn(ixp,jyp,1,ngrid) + + + ! 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 diff --git a/src_flexwrf_v3.1/interpol_wind_short.f90 b/src_flexwrf_v3.1/interpol_wind_short.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2f40e223bc75103dc9a75c77e97ead915709bf64 --- /dev/null +++ b/src_flexwrf_v3.1/interpol_wind_short.f90 @@ -0,0 +1,185 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine interpol_wind_short(itime,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator) + + ! 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 + + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(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) + + + + !******************************************** + ! 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 +!!!$OMP CRITICAL + 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) +!!!$OMP END CRITICAL + else +!!!$OMP CRITICAL + 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) +!!!$OMP END CRITICAL + endif +!!!$OMP CRITICAL + 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) +!!!$OMP END CRITICAL + 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 diff --git a/src_flexwrf_v3.1/interpol_wind_short_nests.f90 b/src_flexwrf_v3.1/interpol_wind_short_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d74bf47a0de3618696484bd3c33a1c1c8488a64c --- /dev/null +++ b/src_flexwrf_v3.1/interpol_wind_short_nests.f90 @@ -0,0 +1,166 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine interpol_wind_short_nests(itime,xt,yt,zt, & + uprof,vprof,wprof, usigprof,vsigprof,wsigprof, & + rhoprof,rhogradprof, tkeprof,pttprof, & + u,v,w,usig,vsig,wsig,pvi, & + p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2, & + ix,jy,ixp,jyp,ngrid,indz,indzp, depoindicator, & + indzindicator) + ! 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 + + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(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) + + + !******************************************** + ! 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 diff --git a/src_flexwrf_v3.1/isnan_gfortran.f90 b/src_flexwrf_v3.1/isnan_gfortran.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a48e89dbe4a0908c2948e8e7cf4b759a2e3e99f1 --- /dev/null +++ b/src_flexwrf_v3.1/isnan_gfortran.f90 @@ -0,0 +1,11 @@ + + logical function isnan2(a) + real :: a + if (isnan(a)) then + isnan2 = .true. + else + isnan2 = .false. + end if + return + end + diff --git a/src_flexwrf_v3.1/isnan_other.f90 b/src_flexwrf_v3.1/isnan_other.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dd7e98bc493787adfe5e9179dc65f4cb7fce0ee2 --- /dev/null +++ b/src_flexwrf_v3.1/isnan_other.f90 @@ -0,0 +1,13 @@ + logical function isnan2(a) +! use ieee_arithmetic + real :: a +! if (ieee_is_nan(a)) then + if (a.ne.a) then + isnan2 = .true. + else + isnan2 = .false. + end if + return + end + + diff --git a/src_flexwrf_v3.1/juldate.f90 b/src_flexwrf_v3.1/juldate.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6d0303ef8a663b84a1272cf148a04a4071e500e0 --- /dev/null +++ b/src_flexwrf_v3.1/juldate.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/kftable_mod.f90 b/src_flexwrf_v3.1/kftable_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5b06ae018cc3535905dfa2b381baf0fa23740a21 --- /dev/null +++ b/src_flexwrf_v3.1/kftable_mod.f90 @@ -0,0 +1,31 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + module kftable_mod + INTEGER, PARAMETER :: KFNT=250,KFNP=220 + REAL, DIMENSION(1:KFNT,1:KFNP) :: TTAB,QSTAB + REAL, DIMENSION(1:KFNP) :: THE0K + REAL, DIMENSION(1:200) :: ALU + REAL rdpr,rdthk,plutop + + end module kftable_mod diff --git a/src_flexwrf_v3.1/makefile.mom b/src_flexwrf_v3.1/makefile.mom new file mode 100644 index 0000000000000000000000000000000000000000..3981a4ee630d4316375aeb46542c0dbf508bdf3a --- /dev/null +++ b/src_flexwrf_v3.1/makefile.mom @@ -0,0 +1,233 @@ +SHELL = /bin/bash +## name of the executable +EXECNAME = flexwrf31 +# +############## NETCDF library path ################# +#NETCDF = /wrk/d0/jbrioude/netcdf-3.6.2/lib +NETCDF = /usr/local + +# NetCDF library version 3 or 4. Version 4 is much better for compression +NETCDFVERSION=3 + +############### Specify the compiler you want +# COMPILER options --- gnu, pgi, intel +COMPILER = pgi + +######## Unless you want to change compiler options, you shouldn't have +######## to change anything in this section +################################################################ +GNU_FFLAGS = -m64 -mcmodel=medium -fconvert=little-endian -finit-local-zero -fno-range-check +GNU_LDFLAGS = -m64 -mcmodel=medium -fconvert=little-endian -finit-local-zero -lnetcdf -fno-range-check + +#PGI_FFLAGS = -fastsse -mcmodel=medium -traceback -Mbounds -Mchkfpstk -Mchkptr -Mchkstk +#PGI_FFLAGS = -fastsse -mcmodel=medium -tp=nehalem-64 + PGI_FFLAGS = -fastsse -mcmodel=medium +#PGI_LDFLAGS = -fastsse -mcmodel=medium -traceback -Mbounds -Mchkfpstk -Mchkptr -Mchkstk -lnetcdff -Kieee +#PGI_LDFLAGS = -fastsse -mcmodel=medium -traceback -Mbounds -Mchkfpstk -Mchkptr -Mchkstk -lnetcdff + PGI_LDFLAGS = -fastsse -mcmodel=medium -lnetcdf + +INTEL_FFLAGS = -mcmodel=medium -shared-intel -debug all +INTEL_LDFLAGS = -mcmodel=medium -shared-intel -lnetcdff -debug all +################################################################ + + +############## You shouldn't need to change anything below here +#+++++++++++++++++++++++++++++++++++++++++++++++++++++ + + + + +BASENAME=$(EXECNAME)_$(COMPILER) + +ifeq ($(COMPILER), pgi) + FCSER = pgf90 + FCOMP = pgf90 -mp + FCMPI = pgf90 -mp +# NETCDF = /apps/netcdf/4.1.3-pgi + + FFLAGS= -I${NETCDF}/include $(PGI_FFLAGS) + LDFLAGS= -L${NETCDF}/lib $(PGI_LDFLAGS) + ISNAN_OBJ = isnan_other.o +endif + + +ifeq ($(COMPILER), gnu) + FCSER = gfortran + FCOMP = gfortran -fopenmp + FCMPI = gfortran -fopenmp +# NETCDF = /apps/netcdf/4.1.3-pgi + + FFLAGS= -I${NETCDF}/include $(GNU_FFLAGS) + LDFLAGS= -L${NETCDF}/lib $(GNU_LDFLAGS) + ISNAN_OBJ = isnan_gfortran.o +endif + + +ifeq ($(COMPILER), intel) + FCSER = ifort + FCOMP = ifort -openmp + FCMPI = ifort -openmp +# NETCDF = /apps/netcdf/4.1.3-intel + + FFLAGS= -I${NETCDF}/include $(INTEL_FFLAGS) + LDFLAGS= -L${NETCDF}/lib $(INTEL_LDFLAGS) + ISNAN_OBJ = isnan_other.o +endif + + +NETCDF_OBJ = write_ncheader.o write_ncinfo.o \ + +ifeq ($(NETCDFVERSION), 3) + + NETCDF_OBJ = write_ncheader_v3.o write_ncinfo_v3.o \ + +endif + +ifeq ($(MAKECMDGOALS),serial) + FC=$(FCSER) + MAIN=$(BASENAME)_serial + FFLAGS2=$(FFLAGS) + LDFLAGS2=$(LDFLAGS) +endif +ifeq ($(MAKECMDGOALS),omp) + FC=$(FCOMP) + MAIN=$(BASENAME)_omp + FFLAGS2=$(FFLAGS) + LDFLAGS2=$(LDFLAGS) -lpthread +endif +ifeq ($(MAKECMDGOALS),mpi) + FC=$(FCMPI) + MAIN=$(BASENAME)_mpi + FFLAGS2=$(FFLAGS) -I${MPI_ROOT}/include + LDFLAGS2=$(LDFLAGS) -lpthread -L${MPI_ROOT}/lib -lmpi +endif + + + +#.SUFFIXES: .o .f90 +# +#.f90.o: +# $(FC) -c $(FCFLAGS) $*.f90 + +MODOBJS = \ +par_mod.o com_mod.o \ +conv_mod.o hanna_mod.o \ +interpol_mod.o cmapf_mod.o \ +unc_mod.o oh_mod.o \ +xmass_mod.o flux_mod.o \ +point_mod.o outg_mod.o \ +kftable_mod.o wrf_map_utils_mod.o \ +ran_mod.o mpi_mod.o \ +mt_kind_defs.o mt_stream.o +# +OBJECTS = assignland.o writeheader.o \ +calcpar.o part0.o \ +caldate.o partdep.o \ +coordtrafo.o psih.o \ + raerod.o \ +dynamic_viscosity.o random.o \ +initial_cond_output.o initial_cond_calc.o\ +outgrid_init_irreg.o outgrid_init_reg.o\ +releaseparticles_irreg.o releaseparticles_reg.o\ +conccalc_irreg.o conccalc_reg.o\ +erf.o \ +ew.o \ +advance.o readdepo.o \ +psim.o \ +readlanduse.o \ +getfields.o init_domainfill.o\ +interpol_wind.o \ +interpol_all.o ohreaction.o \ +getrb.o get_settling.o \ +getrc.o readohfield.o \ +getvdep.o getvdep_nests.o \ +interpol_misslev.o readwind.o \ +richardson.o \ +scalev.o \ +pbl_profile.o \ +juldate.o \ +interpol_vdep.o interpol_rain.o \ +verttransform.o partoutput.o \ +hanna.o wetdepokernel.o \ +mean.o wetdepo.o \ +hanna_short.o windalign.o \ +obukhov.o gridcheck.o \ +hanna1.o initialize.o \ +cmapf1.0.o \ + calcpar_nests.o \ +verttransform_nests.o interpol_all_nests.o \ +interpol_wind_nests.o interpol_misslev_nests.o \ +interpol_vdep_nests.o interpol_rain_nests.o \ +readpartpositions.o \ +calcfluxes.o fluxoutput.o \ +qvsat.o skplin.o \ +convmix.o calcmatrix.o \ +convect43c.o redist.o \ +sort2.o distance.o \ +centerofmass.o plumetraj.o \ +openouttraj.o calcpv.o \ +calcpv_nests.o distance2.o \ +clustering.o interpol_wind_short.o \ +interpol_wind_short_nests.o shift_field_0.o \ +shift_field.o \ +openreceptors.o boundcond_domainfill.o\ +gridcheck_nests.o \ +readwind_nests.o \ +outgrid_init_nest_reg.o outgrid_init_nest_irreg.o \ +outgrid_init_nest.o writeheader_nest.o \ +wetdepokernel_nest.o \ +drydepokernel_nest.o drydepokernel.o \ +concoutput_irreg.o concoutput_reg.o\ +concoutput_nest_irreg.o concoutput_nest_reg.o\ +read_ncwrfout.o map_proj_wrf.o \ +map_proj_wrf_subaa.o readinput.o \ +tke_partition_hanna.o tke_partition_my.o \ +redist_kf.o pre_redist_kf.o\ +convection_kfeta.o convmix_kfeta.o \ +readwind_timeav.o \ +readwind_nests_timeav.o \ +gf2xe.o f_get_coeff.o \ +ranlux.o \ +initialize_cbl_vel.o \ +gasdevlux.o \ +cbl.o re_initialize_particle.o \ +write_ncconc.o \ +check_ncerror.o + +MPI_ONLY_OBJS = sendreal_mpi.o senddouble_mpi.o \ + sendint_mpi.o sendint2_mpi.o \ + sendreal2d_mpi.o flexwrf_mpi.o \ + timemanager_mpi.o senddrydep_mpi.o \ + senddrydep_nest_mpi.o \ + +SERIAL_ONLY_OBJS = flexwrf.o timemanager_serial.o \ + +OMP_ONLY_OBJS = flexwrf.o timemanager.o \ + + +serial: $(MODOBJS) $(OBJECTS) $(SERIAL_ONLY_OBJS) $(ISNAN_OBJ) $(NETCDF_OBJ) +# echo 'Pure serial not supported - use omp' +# exit + $(FC) *.o -o $(MAIN) $(LDFLAGS2) + +omp: $(MODOBJS) $(OBJECTS) $(OMP_ONLY_OBJS) $(ISNAN_OBJ) $(NETCDF_OBJ) + $(FC) *.o -o $(MAIN) $(LDFLAGS2) + +mpi: $(MODOBJS) $(OBJECTS) $(MPI_ONLY_OBJS) $(ISNAN_OBJ) $(NETCDF_OBJ) + echo 'Compiling MPI' + $(FC) *.o -o $(MAIN) $(LDFLAGS2) + +$(OBJECTS): $(MODOBJS) +$(MPI_ONLY_OBJECTS): $(MODOBJS) +$(SERIAL_ONLY_OBJECTS): $(MODOBJS) + +%.o: %.f90 + $(FC) -c $(FFLAGS2) $< + +# This is here because of a single source file, erf.f +%.o: %.f + $(FC) -c $(FFLAGS2) $< + +clean: + rm *.o *.mod + diff --git a/src_flexwrf_v3.1/map_proj_wrf.f90 b/src_flexwrf_v3.1/map_proj_wrf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..096c8e20440c56c1401dc481772f50b67e577400 --- /dev/null +++ b/src_flexwrf_v3.1/map_proj_wrf.f90 @@ -0,0 +1,805 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** +!********************************************************************** +! FLEXPART_WRF SOURCE FILE MAP_PROJ_WRF - CONTAINS * +! subroutine xyindex_to_ll_wrf * +! subroutine xymeter_to_ll_wrf * +! subroutine ll_to_xyindex_wrf * +! subroutine ll_to_xymeter_wrf * +! subroutine test_xyindex_to_ll_wrf * +! * +!********************************************************************** +! * +! AUTHOR: R. Easter & J. Fast, PNNL * +! DATE: Dec 2005 * +! LAST UPDATE: same * +! * +!********************************************************************** +! * +! DESCRIPTION: * +! * +! Converts between "grid index" or "grid meter" coordinates * +! and latitude-longitude (degrees) * +! * +!********************************************************************** + + +!----------------------------------------------------------------------- +subroutine xyindex_to_ll_wrf( lgrid, x_i, y_j, x_lon, y_lat ) +! +! calculates longitude/latitude from xy "grid index" coordinates +! +! arguments +! lgrid - input - grid identifier +! x_i, y_j - input = "grid index" coordinates on grid "lgrid". +! x_i ranges from 0 to nx-1. y_j ranges from 0 to nj-1. +! x_lon, y_lat - output = longitude and latitude in degrees +! +! *** note *** +! if x_i is outside [-grace, +grace+nx] +! or y_j is outside [-grace, +grace+ny] +! the routine writes an error message and halts +! +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + +! arguments + implicit none + integer :: lgrid + real :: x_i, y_j, x_lon, y_lat + +! local variables + integer :: ia, ib, ja, jb + real :: dumxi, dumyj + real :: fx, fy + real,parameter :: grace=2.01 + + +! first check that x_i & y_j are "within bounds" + if (lgrid .le. 0) then + if ((x_i .lt. -grace) .or. (x_i .gt. grace+real(nx-1)) .or. & + (y_j .lt. -grace) .or. (y_j .gt. grace+real(ny-1))) then + write(*,'(/a/a,i4,1p,2e12.3)') & + '*** xyindex_to_ll_wrf error -- bad inputs', & + ' lgrid, x_i, y_j =', lgrid, x_i, y_j +! stop + end if + else + if ((x_i .lt. -grace ) .or. & + (x_i .gt. grace+real(nxn(lgrid)-1)) .or. & + (y_j .lt. -grace ) .or. & + (y_j .gt. grace+real(nyn(lgrid)-1))) then + write(*,'(/a/a,i4,1p,2e12.3)') & + '*** xyindex_to_ll_wrf error -- bad inputs', & + ' lgrid, x_i, y_j =', lgrid, x_i, y_j +! stop + end if + end if + + if (map_proj_method .gt. 0) then + if (map_proj_id .eq. 1) goto 2000 + if (map_proj_id .eq. 2) goto 2000 + if (map_proj_id .eq. 3) goto 2000 + if (map_proj_id .eq. 4) goto 2000 + end if + + if (lgrid .le. 0) then + goto 5000 + else + goto 6000 + end if + +! +! use map projection routines in map_proj_wrf_subaa.f +! +2000 continue + if (lgrid .le. 0) then + dumxi = 1.0 + x_i + dumyj = 1.0 + y_j + else + dumxi = 1.0 + (x_i/xresoln(lgrid)) + xln(lgrid) + dumyj = 1.0 + (y_j/yresoln(lgrid)) + yln(lgrid) + end if + call ij_to_latlon( dumxi, dumyj, y_lat, x_lon ) + return + + +! +! do interpolation using the outer grid xlon2d,ylat2d +! +5000 continue + if (x_i .le. 0.0) then + ia = 0 + else if (x_i .ge. real(nxmin1)) then + ia = nxmin1 + else + ia = ifix( x_i ) + end if + fx = x_i - ia + fx = max( -2.0, min( fx, 3.0 ) ) + ib = ia + 1 + + if (y_j .le. 0.0) then + ja = 0 + else if (y_j .ge. real(nymin1)) then + ja = nymin1 + else + ja = ifix( y_j ) + end if + fy = y_j - ja + fy = max( -2.0, min( fy, 3.0 ) ) + jb = ja + 1 + + x_lon = xlon2d(ia,ja)*(1.0-fx)*(1.0-fy) + & + xlon2d(ia,jb)*(1.0-fx)*fy + & + xlon2d(ib,ja)*fx*(1.0-fy) + & + xlon2d(ib,jb)*fx*fy + + + y_lat = ylat2d(ia,ja)*(1.0-fx)*(1.0-fy) + & + ylat2d(ia,jb)*(1.0-fx)*fy + & + ylat2d(ib,ja)*fx*(1.0-fy) + & + ylat2d(ib,jb)*fx*fy + + return + + +! +! do interpolation using the nested grid xlon2dn,ylat2dn +! +6000 continue + if (x_i .le. 0.0) then + ia = 0 + else if (x_i .ge. real(nxn(lgrid)-1)) then + ia = nxn(lgrid)-1 + else + ia = ifix( x_i ) + end if + fx = x_i - ia + fx = max( -2.0, min( fx, 3.0 ) ) + ib = ia + 1 + + if (y_j .le. 0.0) then + ja = 0 + else if (y_j .ge. real(nyn(lgrid)-1)) then + ja = nyn(lgrid)-1 + else + ja = ifix( y_j ) + end if + fy = y_j - ja + fy = max( -2.0, min( fy, 3.0 ) ) + jb = ja + 1 + + x_lon = xlon2dn(ia,ja,lgrid)*(1.0-fx)*(1.0-fy) + & + xlon2dn(ia,jb,lgrid)*(1.0-fx)*fy + & + xlon2dn(ib,ja,lgrid)*fx*(1.0-fy) + & + xlon2dn(ib,jb,lgrid)*fx*fy + + + y_lat = ylat2dn(ia,ja,lgrid)*(1.0-fx)*(1.0-fy) + & + ylat2dn(ia,jb,lgrid)*(1.0-fx)*fy + & + ylat2dn(ib,ja,lgrid)*fx*(1.0-fy) + & + ylat2dn(ib,jb,lgrid)*fx*fy + + return + + end subroutine xyindex_to_ll_wrf + + +!----------------------------------------------------------------------- + subroutine xyindex_to_ll_wrf_out(lgrid,x_i,y_j,x_lon,y_lat) +! +! calculates longitude/latitude from xy "grid index" coordinates +! +! arguments +! lgrid - input - grid identifier +! x_i, y_j - input = "grid index" coordinates on grid "lgrid". +! x_i ranges from 0 to nx-1. y_j ranges from 0 to nj-1. +! x_lon, y_lat - output = longitude and latitude in degrees +! +! *** note *** +! if x_i is outside [-grace, +grace+nx] +! or y_j is outside [-grace, +grace+ny] +! the routine writes an error message and halts +! +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + +! arguments + implicit none + integer :: lgrid + real :: x_i, y_j, x_lon, y_lat + +! local variables + integer :: ia, ib, ja, jb + real :: dumxi, dumyj + real :: fx, fy + real,parameter :: grace=2.01 + + +! first check that x_i & y_j are "within bounds" +! if (lgrid .le. 0) then +! if ((x_i .lt. -grace) .or. (x_i .gt. grace+real(nx-1)) .or. +! & (y_j .lt. -grace) .or. (y_j .gt. grace+real(ny-1))) then +! write(*,'(/a/a,i4,1p,2e12.3)') +! & '*** xyindex_to_ll_wrf error -- bad inputs', +! & ' lgrid, x_i, y_j =', lgrid, x_i, y_j +! stop +! end if +! else +! if ((x_i .lt. -grace ) .or. +! & (x_i .gt. grace+real(nxn(lgrid)-1)) .or. +! & (y_j .lt. -grace ) .or. +! & (y_j .gt. grace+real(nyn(lgrid)-1))) then +! write(*,'(/a/a,i4,1p,2e12.3)') +! & '*** xyindex_to_ll_wrf error -- bad inputs', +! & ' lgrid, x_i, y_j =', lgrid, x_i, y_j +! stop +! end if +! end if + + if (map_proj_method .gt. 0) then + if (map_proj_id .eq. 1) goto 2000 + if (map_proj_id .eq. 2) goto 2000 + if (map_proj_id .eq. 3) goto 2000 + if (map_proj_id .eq. 4) goto 2000 + end if + + if (lgrid .le. 0) then + goto 5000 + else + goto 6000 + end if + +! +! use map projection routines in map_proj_wrf_subaa.f +! +2000 continue + if (lgrid .le. 0) then + dumxi = 1.0 + x_i + dumyj = 1.0 + y_j + else + dumxi = 1.0 + (x_i/xresoln(lgrid)) + xln(lgrid) + dumyj = 1.0 + (y_j/yresoln(lgrid)) + yln(lgrid) + end if + call ij_to_latlon( dumxi, dumyj, y_lat, x_lon ) + return + + +! +! do interpolation using the outer grid xlon2d,ylat2d +! +5000 continue + if (x_i .le. 0.0) then + ia = 0 + else if (x_i .ge. real(nxmin1)) then + ia = nxmin1 + else + ia = ifix( x_i ) + end if + fx = x_i - ia + fx = max( -2.0, min( fx, 3.0 ) ) + ib = ia + 1 + + if (y_j .le. 0.0) then + ja = 0 + else if (y_j .ge. real(nymin1)) then + ja = nymin1 + else + ja = ifix( y_j ) + end if + fy = y_j - ja + fy = max( -2.0, min( fy, 3.0 ) ) + jb = ja + 1 + + x_lon = xlon2d(ia,ja)*(1.0-fx)*(1.0-fy) + & + xlon2d(ia,jb)*(1.0-fx)*fy + & + xlon2d(ib,ja)*fx*(1.0-fy) + & + xlon2d(ib,jb)*fx*fy + + + y_lat = ylat2d(ia,ja)*(1.0-fx)*(1.0-fy) + & + ylat2d(ia,jb)*(1.0-fx)*fy + & + ylat2d(ib,ja)*fx*(1.0-fy) + & + ylat2d(ib,jb)*fx*fy + + return + + +! +! do interpolation using the nested grid xlon2dn,ylat2dn +! +6000 continue + if (x_i .le. 0.0) then + ia = 0 + else if (x_i .ge. real(nxn(lgrid)-1)) then + ia = nxn(lgrid)-1 + else + ia = ifix( x_i ) + end if + fx = x_i - ia + fx = max( -2.0, min( fx, 3.0 ) ) + ib = ia + 1 + + if (y_j .le. 0.0) then + ja = 0 + else if (y_j .ge. real(nyn(lgrid)-1)) then + ja = nyn(lgrid)-1 + else + ja = ifix( y_j ) + end if + fy = y_j - ja + fy = max( -2.0, min( fy, 3.0 ) ) + jb = ja + 1 + + x_lon = xlon2dn(ia,ja,lgrid)*(1.0-fx)*(1.0-fy) + & + xlon2dn(ia,jb,lgrid)*(1.0-fx)*fy + & + xlon2dn(ib,ja,lgrid)*fx*(1.0-fy) + & + xlon2dn(ib,jb,lgrid)*fx*fy + + + y_lat = ylat2dn(ia,ja,lgrid)*(1.0-fx)*(1.0-fy) + & + ylat2dn(ia,jb,lgrid)*(1.0-fx)*fy + & + ylat2dn(ib,ja,lgrid)*fx*(1.0-fy) + & + ylat2dn(ib,jb,lgrid)*fx*fy + + return + + end subroutine xyindex_to_ll_wrf_out + + +!----------------------------------------------------------------------- + subroutine xymeter_to_ll_wrf( xmeter, ymeter, x_lon, y_lat ) +! +! calculates longitude/latitude from xy "grid meter" coordinates +! +! arguments +! xmeter, ymeter - input = "grid meter" coordinates on the mother grid. +! x_lon, y_lat - output = longitude and latitude in degrees +! +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + +! arguments + implicit none + real :: xmeter, ymeter, x_lon, y_lat + +! local variables + real :: x_i, y_j + + x_i = (xmeter - xmet0)/dx + y_j = (ymeter - ymet0)/dy + call xyindex_to_ll_wrf( 0, x_i, y_j, x_lon, y_lat ) + + return + end subroutine xymeter_to_ll_wrf + + subroutine xymeter_to_ll_wrf_out(xmeter,ymeter,x_lon,y_lat) +! +! calculates longitude/latitude from xy "grid meter" coordinates +! +! arguments +! xmeter, ymeter - input = "grid meter" coordinates on the mother grid. +! x_lon, y_lat - output = longitude and latitude in degrees +! +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + +! arguments + implicit none + real :: xmeter, ymeter, x_lon, y_lat + +! local variables + real :: x_i, y_j + + x_i = (xmeter - xmet0)/dx + y_j = (ymeter - ymet0)/dy + call xyindex_to_ll_wrf_out(0,x_i, y_j,x_lon,y_lat ) + + return + end subroutine xymeter_to_ll_wrf_out + +!----------------------------------------------------------------------- + subroutine ll_to_xyindex_wrf( x_lon, y_lat, x_i, y_j ) +! +! calculates xy "grid index" coordinates from longitude/latitude +! +! arguments +! x_lon, y_lat - input - longitude and latitude in degrees +! x_i, y_j - output = "grid index" coordinates on the mother grid. +! x_i ranges from 0 to nx-1. y_j ranges from 0 to nj-1. +! +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + implicit none + +! arguments + real :: x_i, y_j, x_lon, y_lat + +! local variables + integer :: i, ii, ia, ib, ip, ipass, iijjlohi + integer :: j, jj, ja, jb, jp + real :: dumcos, dumlat, dumlon + real :: dumr2, dumr2min + real :: dumxi, dumyj + real :: flo, fhi + real :: glo, ghi + real,parameter :: grace=2.01 + real :: xxcen, xxcenb, yycen, yycenb + real :: xxyydel, xxyydelmin + real :: x_lon_sv, y_lat_sv + + + + x_lon_sv = x_lon + y_lat_sv = y_lat + if (map_proj_method .gt. 0) then + if (map_proj_id .eq. 1) goto 2000 + if (map_proj_id .eq. 2) goto 2000 + if (map_proj_id .eq. 3) goto 2000 + if (map_proj_id .eq. 4) goto 2000 + end if + goto 5000 + +! +! use map projection routines in map_proj_wrf_subaa.f +! +2000 continue + + call latlon_to_ij( y_lat, x_lon, dumxi, dumyj ) + x_i = dumxi - 1.0 + y_j = dumyj - 1.0 + goto 8000 + + +! +! do it by search/minimization of distance, +! using the outer grid xlon2d/ylat2d values from WRF met file +! +5000 continue + +! +! first locate the i,j for which the lon,lat at +! i+0.5,j+0.5 are closest to x_lon, y_lat +! + dumr2min = 1.0e30 + dumcos = cos( y_lat ) + do j = 0, ny-1 + do i = 0, nx-1 + dumlat = 0.25*( ylat2d(i,j ) + ylat2d(i+1,j ) + & + ylat2d(i,j+1) + ylat2d(i+1,j+1) ) + dumlon = 0.25*( xlon2d(i,j ) + xlon2d(i+1,j ) + & + xlon2d(i,j+1) + xlon2d(i+1,j+1) ) + dumr2 = (y_lat-dumlat)**2 + ((x_lon-dumlon)*dumcos)**2 + if (dumr2 .lt. dumr2min) then + dumr2min = dumr2 + ib = i + jb = j + end if + end do + end do + i = ib + j = jb + ip = i+1 + jp = j+1 + +! +! next determine the position between i/i+1 & j/j+1 +! that is closest x_lon, y_lat +! + xxyydelmin = 5.0e-8*max( abs(x_lon), abs(y_lat) ) + xxyydel = 1.00 + xxcen = 0.5 + yycen = 0.5 + iijjlohi = 3 + ipass = 0 + +! write(*,9510) +! write(*,9520) 0, (i+xxcen), (j+yycen), x_lon, y_lat +9510 format( / 'll_to_xyindex' ) +9520 format( 'ipass, x_i, y_j, lon, lat', i3, 4f14.7 ) + +5200 ipass = ipass + 1 + dumr2min = 1.0e30 + do jj = -iijjlohi, iijjlohi + do ii = -iijjlohi, iijjlohi + fhi = xxcen + ii*xxyydel + ghi = yycen + jj*xxyydel + flo = 1.0 - fhi + glo = 1.0 - ghi + dumlat = glo*(flo*ylat2d(i,j ) + fhi*ylat2d(ip,j )) + & + ghi*(flo*ylat2d(i,jp) + fhi*ylat2d(ip,jp)) + dumlon = glo*(flo*xlon2d(i,j ) + fhi*xlon2d(ip,j )) + & + ghi*(flo*xlon2d(i,jp) + fhi*xlon2d(ip,jp)) + dumr2 = (y_lat-dumlat)**2 + ((x_lon-dumlon)*dumcos)**2 + if (dumr2 .lt. dumr2min) then + dumr2min = dumr2 + xxcenb = fhi + yycenb = ghi + end if + end do + end do + xxcen = xxcenb + yycen = yycenb +! write(*,9520) ipass, (i+xxcen), (j+yycen), dumlon, dumlat + if (xxyydel .gt. xxyydelmin) then + xxyydel = xxyydel*0.5 + if (ipass .eq. 4) iijjlohi = 2 + goto 5200 + end if +! write(*,9520) ipass, (i+xxcen), (j+yycen), dumlon, dumlat + + x_i = i + xxcen + y_j = j + yycen + + +! +! check for x_i, y_j in bounds before returning +! +8000 continue + if ((x_i .lt. -grace) .or. (x_i .gt. grace+real(nx-1)) .or. & + (y_j .lt. -grace) .or. (y_j .gt. grace+real(ny-1))) then + write(*,'(/a/a,1p,2e12.3/a,1p,2e12.3)') & + '*** ll_to_xyindex_wrf error -- x_i, y_j out of bounds', & + ' x_lon, y_lat =', x_lon_sv, y_lat_sv, & + ' x_i, y_j =', x_i, y_j +! pause +! ylat2d(5000,2000)=0. +! stop + end if + return + + end subroutine ll_to_xyindex_wrf + + +!----------------------------------------------------------------------- + subroutine ll_to_xymeter_wrf( x_lon, y_lat, xmeter, ymeter ) +! +! calculates xy "grid meter" coordinates from longitude/latitude +! +! arguments +! x_lon, y_lat - input - longitude and latitude in degrees +! xmeter, ymeter - output = "grid meter" coordinates on the mother grid. +! +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + implicit none + +! arguments + real :: xmeter, ymeter, x_lon, y_lat + +! local variables + real :: x_i, y_j + + call ll_to_xyindex_wrf( x_lon, y_lat, x_i, y_j ) + xmeter = xmet0 + dx*x_i + ymeter = ymet0 + dy*y_j + + return + end subroutine ll_to_xymeter_wrf + + +!----------------------------------------------------------------------- + subroutine test_xyindex_to_ll_wrf( lgrid ) +! +! tests the map projection routines by comparing +! lat,lon from projection routine against the +! lat,lon from the WRF met. files +! +! arguments +! lgrid - input - grid identifier +! +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + +! arguments + implicit none + integer :: lgrid +! local variables + integer :: idum, ix, jdum, jy + integer :: map_set_proj_code + real :: dumdx, dumxi, dumyj + real :: dumlat, dumlatb, dumlon, dumlonb + real :: err + real :: rmserr + + + +! +! check if map projection is lambert conformal or polar stereographic +! + if (map_proj_id .eq. 1) then + map_set_proj_code = 3 ! lambert conformal + else if (map_proj_id .eq. 2) then + map_set_proj_code = 5 ! polar stereographic + else if (map_proj_id .eq. 3) then + map_set_proj_code = 1 ! mercator + else if (map_proj_id .eq. 4) then + map_set_proj_code = 0 ! lat/lon + else + write(*,'(/ 10(a/) )') & + '************************************************************', & + '* *', & + '* WARNING - map projection is not polar sterographic *', & + '* or lambert conformal *', & + '* *', & + '* x,y <--> lat,lon conversions will be done *', & + '* by interpolation & searching, and will *', & + '* have limited accuracy near poles *', & + '* *', & + '************************************************************' + map_proj_method = 0 + return + end if + if (lgrid .gt. 0) goto 2000 + +! +! make call to map projection setup routine +! +! (The 0.999812 factor is due to different earth_radius +! values in wrfsi code (6370.0 vs 6371.2).) + dumdx = dx*0.999812 ! WA 2/11/10 is this right? +! dumdx = dx*0.9987242 ! WA 2/11/10 is this right? +! dumdx = dx*0.9979203 ! WA 2/11/10 is this right? + coefdx=0.999812 +! write(*,'(/2a,2i5)') & + ! 'test_xyindex_to_ll_wrf calling map_set -- ', & + ! 'map_proj_id, map_set_proj_code =', & + ! map_proj_id, map_set_proj_code + call map_set( map_set_proj_code, & + ylat2d(0,0), xlon2d(0,0), dumdx, & + map_stdlon, map_truelat1, map_truelat2, & + nx, ny ) + map_proj_method = 1 + +! +! compute lat,lon from xi,jy at 9 points (center, 4 corners, +! and 4 boundary midpoints) +! compare to lon,lat read from the WRF met. file and report rmserr +! +2000 continue + rmserr = 0.0 + do jdum = 0, 2 + do idum = 0, 2 + if (lgrid .le. 0) then + jy = nint( 0.5*real((ny-1)*jdum) ) + ix = nint( 0.5*real((nx-1)*idum) ) + dumyj = 1 + jy + dumxi = 1 + ix + dumlatb = ylat2d(ix,jy) + dumlonb = xlon2d(ix,jy) + else + jy = nint( 0.5*real((nyn(lgrid)-1)*jdum) ) + ix = nint( 0.5*real((nxn(lgrid)-1)*idum) ) + dumyj = 1.0 + (jy/yresoln(lgrid)) + yln(lgrid) + dumxi = 1.0 + (ix/xresoln(lgrid)) + xln(lgrid) + dumlatb = ylat2dn(ix,jy,lgrid) + dumlonb = xlon2dn(ix,jy,lgrid) + end if + call ij_to_latlon( dumxi, dumyj, dumlat, dumlon ) + err = (dumlat-dumlatb)**2 + & + ((dumlon-dumlonb)*cos(dumlatb))**2 +! print*,'err',idum,jdum,dumlat,dumlatb,dumlon,dumlonb + rmserr = rmserr + err +! print*,dumxi, dumyj, dumlat, dumlon,dumlatb,dumlonb + end do + end do + rmserr = 111.2*sqrt( rmserr/9.0 ) +! print*,'rmserr',rmserr + if (rmserr .le. 0.02*(1.0e-3*dumdx)) then + write(*,'(/a,i3,1pe10.2)') & + 'test_xyindex_to_ll_wrf -- lgrid, rmserr (km) =', lgrid, rmserr + endif +! +! if rms error exceeds 0.02*dx, something is wrong +! do not use the map projection routines in this case +! + if (rmserr .gt. 0.02*(1.0e-3*dumdx)) then +! print*,'pb with rmserr. try an other earth radius' + dumdx = dx ! try another earth radius + coefdx=1. + + write(*,'(/2a,2i5)') & + 'test_xyindex_to_ll_wrf calling map_set -- ', & + 'map_proj_id, map_set_proj_code =', & + map_proj_id, map_set_proj_code + call map_set( map_set_proj_code, & + ylat2d(0,0), xlon2d(0,0), dumdx, & + map_stdlon, map_truelat1, map_truelat2, & + nx, ny ) + map_proj_method = 1 + +! +! compute lat,lon from xi,jy at 9 points (center, 4 corners, +! and 4 boundary midpoints) +! compare to lon,lat read from the WRF met. file and report rmserr +! + rmserr = 0.0 + do jdum = 0, 2 + do idum = 0, 2 + if (lgrid .le. 0) then + jy = nint( 0.5*real((ny-1)*jdum) ) + ix = nint( 0.5*real((nx-1)*idum) ) + dumyj = 1 + jy + dumxi = 1 + ix + dumlatb = ylat2d(ix,jy) + dumlonb = xlon2d(ix,jy) + else + jy = nint( 0.5*real((nyn(lgrid)-1)*jdum) ) + ix = nint( 0.5*real((nxn(lgrid)-1)*idum) ) + dumyj = 1.0 + (jy/yresoln(lgrid)) + yln(lgrid) + dumxi = 1.0 + (ix/xresoln(lgrid)) + xln(lgrid) + dumlatb = ylat2dn(ix,jy,lgrid) + dumlonb = xlon2dn(ix,jy,lgrid) + end if + call ij_to_latlon( dumxi, dumyj, dumlat, dumlon ) + err = (dumlat-dumlatb)**2 + & + ((dumlon-dumlonb)*cos(dumlatb))**2 + rmserr = rmserr + err + end do + end do + rmserr = 111.2*sqrt( rmserr/9.0 ) + + write(*,'(/a,i3,1pe10.2)') & + 'test_xyindex_to_ll_wrf -- lgrid, rmserr (km) =', lgrid, rmserr + + + endif + +! +! if rms error exceeds 0.02*dx, something is wrong +! do not use the map projection routines in this case +! + dumdx = dx + if (lgrid .gt. 0) dumdx = dxn(lgrid) + if (rmserr .gt. 0.02*(1.0e-3*dumdx)) then + map_proj_method = 0 + write(*,'(/ 9(a/) )') & + '************************************************************', & + '* *', & + '* WARNING - the coordinate transfo error exceeds 0.02*dx *', & + '* *', & + '************************************************************' +! print*,'projection set to',map_proj_method + print*,'problem with the projection. wrf+flexpart stops' + stop + end if + + return + end subroutine test_xyindex_to_ll_wrf + + diff --git a/src_flexwrf_v3.1/map_proj_wrf_subaa.f90 b/src_flexwrf_v3.1/map_proj_wrf_subaa.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fa0ad5885901cf739bb49e5911f77c699e2c2d7e --- /dev/null +++ b/src_flexwrf_v3.1/map_proj_wrf_subaa.f90 @@ -0,0 +1,1090 @@ +! SUPPORTED PROJECTIONS +! --------------------- +! Cylindrical Lat/Lon (code = PROJ_LATLON) +! Mercator (code = PROJ_MERC) +! Lambert Conformal (code = PROJ_LC) +! Polar Stereographic (code = PROJ_PS) +! +! REMARKS +! ------- +! The routines contained within were adapted from routines +! obtained from the NCEP w3 library. The original NCEP routines were +! less +! flexible (e.g., polar-stereo routines only supported truelat of +! 60N/60S) +! than what we needed, so modifications based on equations in Hoke, +! Hayes, and +! Renninger (AFGWC/TN/79-003) were added to improve the flexibility. +! Additionally, coding was improved to F90 standards and the routines +! were +! combined into this module. +!----------------------------------------------------------------------- + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!dis +!dis open source license/disclaimer, forecast systems laboratory +!dis noaa/oar/fsl, 325 broadway boulder, co 80305 +!dis +!dis this software is distributed under the open source definition, +!dis which may be found at http://www.opensource.org/osd.html. +!dis +!dis in particular, redistribution and use in source and binary forms, +!dis with or without modification, are permitted provided that the +!dis following conditions are met: +!dis +!dis - redistributions of source code must retain this notice, this +!dis list of conditions and the following disclaimer. +!dis +!dis - redistributions in binary form must provide access to this +!dis notice, this list of conditions and the following disclaimer, and +!dis the underlying source code. +!dis +!dis - all modifications to this software must be clearly documented, +!dis and are solely the responsibility of the agent making the +!dis modifications. +!dis +!dis - if significant modifications or enhancements are made to this +!dis software, the fsl software policy manager +!dis (softwaremgr@fsl.noaa.gov) should be notified. +!dis +!dis this software and its documentation are in the public domain +!dis and are furnished "as is." the authors, the united states +!dis government, its instrumentalities, officers, employees, and +!dis agents make no warranty, express or implied, as to the usefulness +!dis of the software and documentation for any purpose. they assume +!dis no responsibility (1) for the use of the software and +!dis documentation; or (2) to provide technical support to users. +!dis +!dis + +! module that defines constants, data structures, and +! routines used to convert grid indices to lat/lon +! and vice versa. +! +! supported projections +! --------------------- +! cylindrical lat/lon (code = proj_latlon) +! mercator (code = proj_merc) +! lambert conformal (code = proj_lc) +! polar stereographic (code = proj_ps) +! +! remarks +! ------- +! the routines contained within were adapted from routines +! obtained from the ncep w3 library. the original ncep routines were less +! flexible (e.g., polar-stereo routines only supported truelat of 60n/60s) +! than what we needed, so modifications based on equations in hoke, hayes, and +! renninger (afgwc/tn/79-003) were added to improve the flexibility. +! additionally, coding was improved to f90 standards and the routines were +! combined into this module. +! +! assumptions +! ----------- +! grid definition: +! for mercator, lambert conformal, and polar-stereographic projections, +! the routines within assume the following: +! +! 1. grid is dimensioned (i,j) where i is the east-west direction, +! positive toward the east, and j is the north-south direction, +! positive toward the north. +! 2. origin is at (1,1) and is located at the southwest corner, +! regardless of hemispere. +! 3. grid spacing (dx) is always positive. +! 4. values of true latitudes must be positive for nh domains +! and negative for sh domains. +! +! for the latlon projection, the grid origin may be at any of the +! corners, and the deltalat and deltalon values can be signed to +! account for this using the following convention: +! origin location deltalat sign deltalon sign +! --------------- ------------- ------------- +! sw corner + + +! ne corner - - +! nw corner - + +! se corner + - +! +! data definitions: +! 1. any arguments that are a latitude value are expressed in +! degrees north with a valid range of -90 -> 90 +! 2. any arguments that are a longitude value are expressed in +! degrees east with a valid range of -180 -> 180. +! 3. distances are in meters and are always positive. +! 4. the standard longitude (stdlon) is defined as the longitude +! line which is parallel to the y-axis (j-direction), along +! which latitude increases (not the absolute value of latitude, but +! the actual latitude, such that latitude increases continuously +! from the south pole to the north pole) as j increases. +! 5. one true latitude value is required for polar-stereographic and +! mercator projections, and defines at which latitude the +! grid spacing is true. for lambert conformal, two true latitude +! values must be specified, but may be set equal to each other to +! specify a tangent projection instead of a secant projection. +! +! usage +! ----- +! to use the routines in this module, the calling routines must have the +! following statement at the beginning of its declaration block: +! use map_utils +! +! the use of the module not only provides access to the necessary routines, +! but also defines a structure of type (proj_info) that can be used +! to declare a variable of the same type to hold your map projection +! information. it also defines some integer parameters that contain +! the projection codes so one only has to use those variable names rather +! than remembering the acutal code when using them. the basic steps are +! as follows: +! +! 1. ensure the "use map_utils" is in your declarations. +! 2. declare the projection information structure as type(proj_info): +! type(proj_info) :: proj +! 3. populate your structure by calling the map_set routine: +! call map_set(code,lat1,lon1,dx,stdlon,truelat1,truelat2,nx,ny,proj) +! where: +! code (input) = one of proj_latlon, proj_merc, proj_lc, or proj_ps +! lat1 (input) = latitude of grid origin point (i,j)=(1,1) +! (see assumptions!) +! lon1 (input) = longitude of grid origin +! dx (input) = grid spacing in meters (ignored for latlon projections) +! stdlon (input) = standard longitude for proj_ps and proj_lc, +! deltalon (see assumptions) for proj_latlon, +! ignored for proj_merc +! truelat1 (input) = 1st true latitude for proj_ps, proj_lc, and +! proj_merc, deltalat (see assumptions) for proj_latlon +! truelat2 (input) = 2nd true latitude for proj_lc, +! ignored for all others. +! nx = number of points in east-west direction +! ny = number of points in north-south direction +! proj (output) = the structure of type (proj_info) that will be fully +! populated after this call +! +! 4. now that the proj structure is populated, you may call any +! of the following routines: +! +! latlon_to_ij(proj, lat, lon, i, j) +! ij_to_latlon(proj, i, j, lat, lon) +! truewind_to_gridwind(lon, proj, ugrid, vgrid, utrue, vtrue) +! gridwind_to_truewind(lon, proj, utrue, vtrue, ugrid, vgrid) +! compare_projections(proj1, proj2, same_proj) +! +! it is incumbent upon the calling routine to determine whether or +! not the values returned are within your domain bounds. all values +! of i, j, lat, and lon are real values. +! +! +! references +! ---------- +! hoke, hayes, and renninger, "map preojections and grid systems for +! meteorological applications." afgwc/tn-79/003(rev), air weather +! service, 1985. +! +! ncar mm5v3 modeling system, regridder program, module_first_guess_map.f +! ncep routines w3fb06, w3fb07, w3fb08, w3fb09, w3fb11, w3fb12 +! +! history +! ------- +! 27 mar 2001 - original version +! brent l. shaw, noaa/fsl (csu/cira) +! 02 apr 2001 - added routines to rotate winds from true to grid +! and vice versa. +! brent l. shaw, noaa/fsl (csu/cira) +! 09 apr 2001 - added compare_projections routine to compare two +! sets of projection parameters. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! define data structures to define various projections +! +! type proj_info +! +! logical proj_init ! flag to indicate if this struct is +! ! ready for use +! logical proj_cyclic ! flag indicating if this grid +! ! is cyclic in the longitudinal +! ! direction...happens with +! ! global lat/lon grids like gfs/avn +! integer proj_code ! integer code for projection type +! integer proj_nx +! integer proj_ny +! real proj_lat1 ! sw latitude (1,1) in degrees (-90->90n) +! real proj_lon1 ! sw longitude (1,1) in degrees (-180->180e) +! real proj_dx ! grid spacing in meters at truelats, used +! ! only for ps, lc, and merc projections +! real proj_dlat ! lat increment for lat/lon grids +! real proj_dlon ! lon increment for lat/lon grids +! real proj_clat ! center latitude of grid +! real proj_clon ! center longitude of grid +! real proj_stdlon ! longitude parallel to y-axis (-180->180e) +! real proj_truelat1 ! first true latitude (all projections) +! real proj_truelat2 ! second true lat (lc only) +! real proj_hemi ! 1 for nh, -1 for sh +! real proj_cone ! cone factor for lc projections +! real proj_polei ! computed i-location of pole point +! real proj_polej ! computed j-location of pole point +! real proj_rsw ! computed radius to sw corner +! real proj_rebydx ! earth radius divided by dx +! +! end type proj_info +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine map_init + ! initializes the map projection structure to missing values + + use wrf_map_utils_mod + implicit none + +! include 'include_wrf_map_utils' + pi = 3.1415927 + deg_per_rad = 180./pi + rad_per_deg = pi / 180. + +! mean earth radius in m. the value below is consistent +! with nceps routines and grids. + earth_radius_m = 6370000. +! earth_radius_m = 6371200. +! earth_radius_m = 6368750. + + proj_latlon = 0 + proj_merc = 1 + proj_lc = 3 + proj_ps = 5 + proj_rotlat = 203 + + proj_lat1 = -999.9 + proj_lon1 = -999.9 + proj_dx = -999.9 + proj_stdlon = -999.9 + proj_truelat1 = -999.9 + proj_truelat2 = -999.9 + proj_hemi = 0.0 + proj_cone = -999.9 + proj_polei = -999.9 + proj_polej = -999.9 + proj_rsw = -999.9 + proj_init = .false. + proj_nx = -99 + proj_ny = -99 + proj_cyclic = .false. + + return + end subroutine map_init + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine map_set( & + proj_code_in, lat1, lon1, dx, & + stdlon, truelat1, truelat2, & + idim, jdim ) + ! given a partially filled proj_info structure, this routine computes + ! polei, polej, rsw, and cone (if lc projection) to complete the + ! structure. this allows us to eliminate redundant calculations when + ! calling the coordinate conversion routines multiple times for the + ! same map. + ! this will generally be the first routine called when a user wants + ! to be able to use the coordinate conversion routines, and it + ! will call the appropriate routines based on the + ! proj_code which indicates which projection type this is. + use wrf_map_utils_mod + + implicit none + + ! declare arguments + integer :: proj_code_in + real :: lat1 + real :: lon1 + real :: dx + real :: stdlon + real :: truelat1 + real :: truelat2 + integer :: idim + integer :: jdim + + ! local variables + real :: center_i,center_j + real :: center_lat, center_lon + +! include 'include_wrf_map_utils' + + ! executable code + + proj_code = proj_code_in + + ! first, check for validity of mandatory variables in proj + if ( abs(lat1) .gt. 90.001 ) then + print '(a)', 'latitude of origin corner required as follows:' + print '(a)', ' -90n <= lat1 < = 90.n' + stop 'map_init' + endif + if ( abs(lon1) .gt. 180.) then + print '(a)', 'longitude of origin required as follows:' + print '(a)', ' -180e <= lon1 <= 180w' + stop 'map_init' + endif + if ((dx .le. 0.).and.(proj_code .ne. proj_latlon)) then + print '(a)', 'require grid spacing (dx) in meters be positive!' + stop 'map_init' + endif + if ((abs(stdlon) .gt. 180.).and.(proj_code .ne. proj_merc)) then + print '(a)', 'need orientation longitude (stdlon) as: ' + print '(a)', ' -180e <= lon1 <= 180w' + stop 'map_init' + endif + if (abs(truelat1).gt.90.) then + print '(a)', 'set true latitude 1 for all projections!' + stop 'map_init' + endif + + call map_init + proj_code = proj_code_in + proj_lat1 = lat1 + proj_lon1 = lon1 + proj_dx = dx + proj_stdlon = stdlon + proj_truelat1 = truelat1 + proj_truelat2 = truelat2 + proj_nx = idim + proj_ny = jdim + if (proj_code .ne. proj_latlon) then + proj_dx = dx + if (truelat1 .lt. 0.) then + proj_hemi = -1.0 + else + proj_hemi = 1.0 + endif + proj_rebydx = earth_radius_m / dx + endif + + + if (proj_code .eq. proj_ps) then + !print '(a)', 'setting up polar stereographic map...' + call set_ps + + else if (proj_code .eq. proj_lc) then + !print '(a)', 'setting up lambert conformal map...' + if (abs(proj_truelat2) .gt. 90.) then + print '(a)', & + 'second true latitude not set, assuming a tangent' + print '(a,f10.3)', 'projection at truelat1: ', proj_truelat1 + proj_truelat2=proj_truelat1 + else + ! ensure truelat1 < truelat2 + proj_truelat1 = min(truelat1,truelat2) + proj_truelat2 = max(truelat1,truelat2) + endif + call set_lc + + else if (proj_code .eq. proj_merc) then + !print '(a)', 'setting up mercator map...' + call set_merc + + else if (proj_code .eq. proj_latlon) then + !print '(a)', 'setting up cylindrical equidistant latlon map...' + ! convert lon1 to 0->360 notation + if (proj_lon1 .lt. 0.) proj_lon1 = proj_lon1 + 360. + proj_dlat = truelat1 + proj_dlon = stdlon + if (nint(proj_dlon*real(proj_nx)) .eq. 360) proj_cyclic = .true. + + else + print '(a,i2)', 'unknown projection code: ', proj_code + stop 'map_init' + + end if + + proj_init = .true. + + center_i = real(proj_nx+1)*0.5 + center_j = real(proj_ny+1)*0.5 + call ij_to_latlon(center_i,center_j,center_lat,center_lon) + proj_clat = center_lat + proj_clon = center_lon + + return + end subroutine map_set + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine latlon_to_ij(lat, lon, i, j) + ! converts input lat/lon values to the cartesian (i,j) value + ! for the given projection. + + use wrf_map_utils_mod + implicit none + + ! arguments + real :: lat + real :: lon + real :: i + real :: j + +! include 'include_wrf_map_utils' + + if (.not.proj_init) then + print '(a)', 'you have not called map_set for this projection!' + stop 'latlon_to_ij' + endif + + if (proj_code .eq. proj_ps) then + call llij_ps(lat,lon,i,j) + + else if (proj_code .eq. proj_lc) then + call llij_lc(lat,lon,i,j) + + else if (proj_code .eq. proj_latlon) then + call llij_latlon(lat,lon,i,j) +! + else if (proj_code .eq. proj_merc) then + call llij_merc(lat,lon,i,j) +! +! else if (proj_code .eq. proj_rotlat) then +! write(6,*) 'doing nothing in latlon_to_ij' + + else + print '(a,i2)','unrecognized map projection code: ', proj_code + stop 'latlon_to_ij' + + end if + + return + end subroutine latlon_to_ij + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ij_to_latlon(i, j, lat, lon) + ! computes geographical latitude and longitude for a given (i,j) point + ! in a grid with a projection of proj + + use wrf_map_utils_mod + implicit none + + ! arguments + real :: i + real :: j + real :: lat + real :: lon + +! include 'include_wrf_map_utils' + + if (.not.proj_init) then + print '(a)', 'you have not called map_set for this projection!' + stop 'ij_to_latlon' + endif + + if (proj_code .eq. proj_ps) then + call ijll_ps(i, j, lat, lon) + + else if (proj_code .eq. proj_lc) then + call ijll_lc(i, j, lat, lon) + + else if (proj_code .eq. proj_latlon) then + call ijll_latlon(i, j, lat, lon) +! + else if (proj_code .eq. proj_merc) then + call ijll_merc(i, j, lat, lon) +! +! else if (proj_code .eq. proj_rotlat) then +! write(6,*) 'doing nothing in ij_to_latlon' + + else + print '(a,i2)','unrecognized map projection code: ', proj_code + stop 'ij_to_latlon' + + end if + + return + end subroutine ij_to_latlon + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine set_ps + ! initializes a polar-stereographic map projection from the partially + ! filled proj structure. this routine computes the radius to the + ! southwest corner and computes the i/j location of the pole for use + ! in llij_ps and ijll_ps. + + use wrf_map_utils_mod + implicit none + + ! local vars + real :: ala1 + real :: alo1 + real :: reflon + real :: scale_top + real :: dumlat, dumlon + +! include 'include_wrf_map_utils' + + ! executable code + reflon = proj_stdlon + 90. + + ! cone factor + proj_cone = 1.0 + + ! compute numerator term of map scale factor + scale_top = 1. + proj_hemi * sin(proj_truelat1 * rad_per_deg) + + ! compute radius to lower-left (sw) corner + ala1 = proj_lat1 * rad_per_deg + proj_rsw =proj_rebydx*cos(ala1)*scale_top/(1.+proj_hemi*sin(ala1)) + + ! find the pole point + alo1 = (proj_lon1 - reflon) * rad_per_deg + proj_polei = 1. - proj_rsw * cos(alo1) + proj_polej = 1. - proj_hemi * proj_rsw * sin(alo1) +! print '(a,2f14.5)', 'set_ps - computed (i,j) of pole point: ', +! & proj_polei,proj_polej + + return + end subroutine set_ps + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine llij_ps( lat, lon, i, j ) + ! given latitude (-90 to 90), longitude (-180 to 180), and the + ! standard polar-stereographic projection information via the + ! public proj structure, this routine returns the i/j indices which + ! if within the domain range from 1->nx and 1->ny, respectively. + use wrf_map_utils_mod + + implicit none + + ! delcare input arguments + real :: lat + real :: lon + + ! declare output arguments + real :: i !(x-index) + real :: j !(y-index) + + ! declare local variables + real :: reflon + real :: scale_top + real :: ala + real :: alo + real :: rm + +! include 'include_wrf_map_utils' + + ! begin code + + reflon = proj_stdlon + 90. + + ! compute numerator term of map scale factor + + scale_top = 1. + proj_hemi * sin(proj_truelat1 * rad_per_deg) + + ! find radius to desired point + ala = lat * rad_per_deg + rm = proj_rebydx * cos(ala) * scale_top/(1. + proj_hemi *sin(ala)) + alo = (lon - reflon) * rad_per_deg + i = proj_polei + rm * cos(alo) + j = proj_polej + proj_hemi * rm * sin(alo) + + return + end subroutine llij_ps + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ijll_ps( i, j, lat, lon ) + + ! this is the inverse routine of llij_ps. it returns the + ! latitude and longitude of an i/j point given the projection info + ! structure. + use wrf_map_utils_mod + + implicit none + + ! declare input arguments + real :: i ! column + real :: j ! row + + ! declare output arguments + real :: lat ! -90 -> 90 north + real :: lon ! -180 -> 180 east + + ! local variables + real :: reflon + real :: scale_top + real :: xx,yy + real :: gi2, r2 + real :: arccos + +! include 'include_wrf_map_utils' + + ! begin code + + ! compute the reference longitude by rotating 90 degrees to the east + ! to find the longitude line parallel to the positive x-axis. + reflon = proj_stdlon + 90. + + ! compute numerator term of map scale factor + scale_top = 1. + proj_hemi * sin(proj_truelat1 * rad_per_deg) + + ! compute radius to point of interest + xx = i - proj_polei + yy = (j - proj_polej) * proj_hemi + r2 = xx**2 + yy**2 + + ! now the magic code + if (r2 .eq. 0.) then + lat = proj_hemi * 90. + lon = reflon + else + gi2 = (proj_rebydx * scale_top)**2. + lat = deg_per_rad * proj_hemi * asin((gi2-r2)/(gi2+r2)) + arccos = acos(xx/sqrt(r2)) + if (yy .gt. 0) then + lon = reflon + deg_per_rad * arccos + else + lon = reflon - deg_per_rad * arccos + endif + endif + + ! convert to a -180 -> 180 east convention + if (lon .gt. 180.) lon = lon - 360. + if (lon .lt. -180.) lon = lon + 360. + + return + end subroutine ijll_ps + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine set_lc + ! initialize the remaining items in the proj structure for a + ! lambert conformal grid. + + use wrf_map_utils_mod + implicit none + +! include 'include_wrf_map_utils' + + real :: arg + real :: deltalon1 + real :: tl1r + real :: ctl1r + + ! compute cone factor + call lc_cone(proj_truelat1, proj_truelat2, proj_cone) + ! print '(a,f8.6)', 'computed cone factor: ', proj_cone + ! compute longitude differences and ensure we stay out of the + ! forbidden "cut zone" + deltalon1 = proj_lon1 - proj_stdlon + if (deltalon1 .gt. +180.) deltalon1 = deltalon1 - 360. + if (deltalon1 .lt. -180.) deltalon1 = deltalon1 + 360. + + ! convert truelat1 to radian and compute cos for later use + tl1r = proj_truelat1 * rad_per_deg + ctl1r = cos(tl1r) + + ! compute the radius to our known lower-left (sw) corner + proj_rsw = proj_rebydx * ctl1r/proj_cone * & + (tan((90.*proj_hemi-proj_lat1)*rad_per_deg/2.) / & + tan((90.*proj_hemi-proj_truelat1)*rad_per_deg/2.)) & + **proj_cone + + ! find pole point + arg = proj_cone*(deltalon1*rad_per_deg) + proj_polei = 1. - proj_hemi * proj_rsw * sin(arg) + proj_polej = 1. + proj_rsw * cos(arg) + !print '(a,2f10.3)', 'computed pole i/j = ', proj_polei, proj_polej + + return + end subroutine set_lc + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine lc_cone(truelat1, truelat2, cone) + + ! routine to compute the cone factor of a lambert conformal projection + + use wrf_map_utils_mod + implicit none + +! include 'include_wrf_map_utils' + + ! input args + real :: truelat1 ! (-90 -> 90 degrees n) + real :: truelat2 ! " " " " " + + ! output args + real :: cone + + ! locals + + ! begin code + + ! first, see if this is a secant or tangent projection. for tangent + ! projections, truelat1 = truelat2 and the cone is tangent to the + ! earth surface at this latitude. for secant projections, the cone + ! intersects the earth surface at each of the distinctly different + ! latitudes + if (abs(truelat1-truelat2) .gt. 0.1) then + + ! compute cone factor following: + cone=(alog(cos(truelat1*rad_per_deg)) & + -alog(cos(truelat2*rad_per_deg))) / & + (alog(tan((90.-abs(truelat1))*rad_per_deg*0.5 ))- & + alog(tan((90.-abs(truelat2))*rad_per_deg*0.5 )) ) + else + cone = sin(abs(truelat1)*rad_per_deg ) + endif + + return + end subroutine lc_cone + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine ijll_lc( i, j, lat, lon) + + ! routine to convert from the (i,j) cartesian coordinate to the + ! geographical latitude and longitude for a lambert conformal projection. + + ! history: + ! 25 jul 01: corrected by b. shaw, noaa/fsl + ! + use wrf_map_utils_mod + implicit none + +! include 'include_wrf_map_utils' + + ! input args + real :: i ! cartesian x coordinate + real :: j ! cartesian y coordinate + + ! output args + real :: lat ! latitude (-90->90 deg n) + real :: lon ! longitude (-180->180 e) + + ! locals + real :: inew + real :: jnew + real :: r + real :: chi,chi1,chi2 + real :: r2 + real :: xx + real :: yy + + ! begin code + + chi1 = (90. - proj_hemi*proj_truelat1)*rad_per_deg + chi2 = (90. - proj_hemi*proj_truelat2)*rad_per_deg + + ! see if we are in the southern hemispere and flip the indices + ! if we are. + if (proj_hemi .eq. -1.) then + inew = -i + 2. + jnew = -j + 2. + else + inew = i + jnew = j + endif + + ! compute radius**2 to i/j location + xx = inew - proj_polei + yy = proj_polej - jnew + r2 = (xx*xx + yy*yy) + r = sqrt(r2)/proj_rebydx + + ! convert to lat/lon + if (r2 .eq. 0.) then + lat = proj_hemi * 90. + lon = proj_stdlon + else + + ! longitude + lon = proj_stdlon + deg_per_rad * atan2(proj_hemi*xx,yy) & + /proj_cone + lon = amod(lon+360., 360.) + + ! latitude. latitude determined by solving an equation adapted + ! from: + ! maling, d.h., 1973: coordinate systems and map projections + ! equations #20 in appendix i. + + if (chi1 .eq. chi2) then + chi = 2.0*atan( ( r/tan(chi1) )**(1./proj_cone) & + * tan(chi1*0.5) ) + else + chi = 2.0*atan( (r*proj_cone/sin(chi1))**(1./proj_cone) & + * tan(chi1*0.5)) + endif + lat = (90.0-chi*deg_per_rad)*proj_hemi + + endif + + if (lon .gt. +180.) lon = lon - 360. + if (lon .lt. -180.) lon = lon + 360. + + return + end subroutine ijll_lc + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + subroutine llij_lc( lat, lon, i, j) + + ! routine to compute the geographical latitude and longitude values + ! to the cartesian x/y on a lambert conformal projection. + + use wrf_map_utils_mod + implicit none +! +! include 'include_wrf_map_utils' + + ! input args + real :: lat ! latitude (-90->90 deg n) + real :: lon ! longitude (-180->180 e) + + ! output args + real :: i ! cartesian x coordinate + real :: j ! cartesian y coordinate + + ! locals + real :: arg + real :: deltalon + real :: tl1r + real :: rm + real :: ctl1r + + + ! begin code +! print*,proj_clat, proj_clon,proj_stdlon,proj_truelat1,proj_code,proj_cone + ! compute deltalon between known longitude and standard lon and ensure + ! it is not in the cut zone + deltalon = lon - proj_stdlon + if (deltalon .gt. +180.) deltalon = deltalon - 360. + if (deltalon .lt. -180.) deltalon = deltalon + 360. + + ! convert truelat1 to radian and compute cos for later use + tl1r = proj_truelat1 * rad_per_deg + ctl1r = cos(tl1r) + + ! radius to desired point + rm = proj_rebydx * ctl1r/proj_cone * & + (tan((90.*proj_hemi-lat)*rad_per_deg/2.) / & + tan((90.*proj_hemi-proj_truelat1)*rad_per_deg/2.))**proj_cone + + arg = proj_cone*(deltalon*rad_per_deg) + i = proj_polei + proj_hemi * rm * sin(arg) + j = proj_polej - rm * cos(arg) + + ! finally, if we are in the southern hemisphere, flip the i/j + ! values to a coordinate system where (1,1) is the sw corner + ! (what we assume) which is different than the original ncep + ! algorithms which used the ne corner as the origin in the + ! southern hemisphere (left-hand vs. right-hand coordinate?) + if (proj_hemi .eq. -1.) then + i = 2. - i + j = 2. - j + endif + + return + end subroutine llij_lc + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE set_merc + + ! Sets up the remaining basic elements for the mercator projection + use wrf_map_utils_mod + + IMPLICIT NONE +! TYPE(proj_info), INTENT(INOUT) :: proj + REAL :: clain + + ! Preliminary variables + + clain = COS(rad_per_deg*proj_truelat1) + proj_dlon = proj_dx / (earth_radius_m * clain) + + ! Compute distance from equator to origin, and store in the + ! proj%rsw tag. + + proj_rsw = 0. + IF (proj_lat1 .NE. 0.) THEN + proj_rsw = (ALOG(TAN(0.5*((proj_lat1+90.)*rad_per_deg))))/proj_dlon + ENDIF + RETURN + END SUBROUTINE set_merc +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE llij_merc(lat, lon, i, j) + + ! Compute i/j coordinate from lat lon for mercator projection + use wrf_map_utils_mod + + IMPLICIT NONE + REAL, INTENT(IN) :: lat + REAL, INTENT(IN) :: lon +! TYPE(proj_info),INTENT(IN) :: proj + REAL,INTENT(OUT) :: i + REAL,INTENT(OUT) :: j + REAL :: deltalon + + deltalon = lon - proj_lon1 +! deltalon = lon - proj_stdlon +! JB modif +! IF (deltalon .LT. -180.) deltalon = deltalon + 360. +! IF (deltalon .GT. 180.) deltalon = deltalon - 360. + i = 1. + (deltalon/(proj_dlon*deg_per_rad)) + j = 1. + (ALOG(TAN(0.5*((lat + 90.) * rad_per_deg)))) / & + proj_dlon - proj_rsw +! print*,'IN MERCATOR',lat,lon,i,j,proj_lon1,deltalon +! pause + RETURN + END SUBROUTINE llij_merc +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE ijll_merc(i, j, lat, lon) + + ! Compute the lat/lon from i/j for mercator projection + use wrf_map_utils_mod + + IMPLICIT NONE + REAL,INTENT(IN) :: i + REAL,INTENT(IN) :: j +! TYPE(proj_info),INTENT(IN) :: proj + REAL, INTENT(OUT) :: lat + REAL, INTENT(OUT) :: lon + + + lat = 2.0*ATAN(EXP(proj_dlon*(proj_rsw + j-1.)))*deg_per_rad - 90. + lon = (i-1.)*proj_dlon*deg_per_rad + proj_lon1 + IF (lon.GT.180.) lon = lon - 360. + IF (lon.LT.-180.) lon = lon + 360. + RETURN + END SUBROUTINE ijll_merc +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE llij_latlon(lat, lon, i, j) + + ! Compute the i/j location of a lat/lon on a LATLON grid. + use wrf_map_utils_mod + + IMPLICIT NONE + REAL, INTENT(IN) :: lat + REAL, INTENT(IN) :: lon +! TYPE(proj_info), INTENT(IN) :: proj + REAL, INTENT(OUT) :: i + REAL, INTENT(OUT) :: j + + REAL :: deltalat + REAL :: deltalon + REAL :: lon360 + REAL :: latinc + REAL :: loninc + + ! Extract the latitude and longitude increments for this grid + ! (e.g., 2.5 deg for NCEP reanalysis) from the proj structure, where + ! loninc is saved in the stdlon tag and latinc is saved in truelat1 + + latinc = proj_truelat1 + loninc = proj_stdlon + + ! Compute deltalat and deltalon as the difference between the input + ! lat/lon and the origin lat/lon + + deltalat = lat - proj_lat1 + ! To account for issues around the dateline, convert the incoming + ! longitudes to be 0->360. + IF (lon .LT. 0) THEN + lon360 = lon + 360. + ELSE + lon360 = lon + ENDIF + deltalon = lon360 - proj_lon1 + IF (deltalon .LT. 0) deltalon = deltalon + 360. + + ! Compute i/j + i = deltalon/loninc + 1. + j = deltalat/latinc + 1. + RETURN + END SUBROUTINE llij_latlon +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE ijll_latlon(i, j, lat, lon) + + ! Compute the lat/lon location of an i/j on a LATLON grid. + use wrf_map_utils_mod + + IMPLICIT NONE + REAL, INTENT(IN) :: i + REAL, INTENT(IN) :: j +! TYPE(proj_info), INTENT(IN) :: proj + REAL, INTENT(OUT) :: lat + REAL, INTENT(OUT) :: lon + + REAL :: deltalat + REAL :: deltalon + REAL :: lon360 + REAL :: latinc + REAL :: loninc + + ! Extract the latitude and longitude increments for this grid + ! (e.g., 2.5 deg for NCEP reanalysis) from the proj structure, where + ! loninc is saved in the stdlon tag and latinc is saved in truelat1 + + latinc = proj_truelat1 + loninc = proj_stdlon + + ! Compute deltalat and deltalon + + deltalat = (j-1.)*latinc + deltalon = (i-1.)*loninc + lat = proj_lat1 + deltalat + lon = proj_lon1 + deltalon + + IF ((ABS(lat) .GT. 90.).OR.(ABS(deltalon) .GT.360.)) THEN + ! Off the earth for this grid + lat = -999. + lon = -999. + ELSE + lon = lon + 360. + lon = AMOD(lon,360.) + IF (lon .GT. 180.) lon = lon -360. + ENDIF + + RETURN + END SUBROUTINE ijll_latlon +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + SUBROUTINE gridwind_to_truewind(lon,ugrid,vgrid,utrue,vtrue) + + ! Subroutine to convert a wind from grid north to true north. + use wrf_map_utils_mod + + IMPLICIT NONE + + ! Arguments + REAL, INTENT(IN) :: lon ! Longitude of point in degrees +! TYPE(proj_info),INTENT(IN):: proj ! Projection info structure + REAL, INTENT(IN) :: ugrid ! U-component, grid-relative + REAL, INTENT(IN) :: vgrid ! V-component, grid-relative + REAL, INTENT(OUT) :: utrue ! U-component, earth-relative + REAL, INTENT(OUT) :: vtrue ! V-component, earth-relative + + ! Locals + REAL :: alpha + REAL :: diff + + IF ((proj_code .EQ. PROJ_PS).OR.(proj_code .EQ. PROJ_LC))THEN + diff = lon - proj_stdlon + IF (diff .GT. 180.) diff = diff - 360. + IF (diff .LT.-180.) diff = diff + 360. + alpha = diff * proj_cone * rad_per_deg * SIGN(1.,proj_truelat1) + utrue = vgrid * SIN(alpha) + ugrid * COS(alpha) + vtrue = vgrid * COS(alpha) - ugrid * SIN(alpha) + ELSEIF ((proj_code .EQ. PROJ_MERC).OR.(proj_code .EQ.PROJ_LATLON))THEN + utrue = ugrid + vtrue = vgrid + ELSE + PRINT '(A)', 'Unrecognized projection.' + STOP 'GRIDWIND_TO_TRUEWIND' + ENDIF + + RETURN + END SUBROUTINE gridwind_to_truewind +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + diff --git a/src_flexwrf_v3.1/mean.f90 b/src_flexwrf_v3.1/mean.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d662f7f4665b1bf0c58ec33acfc534cba526fee8 --- /dev/null +++ b/src_flexwrf_v3.1/mean.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/mpi_mod.f90 b/src_flexwrf_v3.1/mpi_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cfacb8d40a648c8bee145a0986cce4447529fa0d --- /dev/null +++ b/src_flexwrf_v3.1/mpi_mod.f90 @@ -0,0 +1,43 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + module mpi_mod + use par_mod, only: dp + !includes OH concentration field as well as the height information + !for this field + + implicit none + integer,allocatable, dimension (:) :: mpi_npoint,mpi_idt,mpi_itra1, & + mpi_itramem,mpi_nclass + real,allocatable, dimension (:) :: mpi_uap,mpi_ucp,mpi_uzp, & + mpi_us,mpi_vs,mpi_ws,mpi_ztra1 + real,allocatable, dimension (:,:) :: mpi_xmass1 + real(kind=dp),allocatable, dimension (:) :: mpi_xtra1,mpi_ytra1 + integer(kind=2),allocatable, dimension (:) :: mpi_cbt + integer :: chunksize2 + integer, allocatable, dimension (:) :: dummyi2 + real, allocatable, dimension (:) :: dummyr2 + real(kind=dp),allocatable, dimension (:) :: dummyr22 + integer(kind=2),allocatable, dimension (:) :: dummyi22 +end module mpi_mod + diff --git a/src_flexwrf_v3.1/mt_kind_defs.f90 b/src_flexwrf_v3.1/mt_kind_defs.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c07a7b55e63767e62925f5ab961b23b0af92658e --- /dev/null +++ b/src_flexwrf_v3.1/mt_kind_defs.f90 @@ -0,0 +1,7 @@ +module mt_kind_defs + implicit none + public + integer, parameter :: INT32 = selected_int_kind(9) + integer, parameter :: INT64 = selected_int_kind(18) + integer, parameter :: REAL64 = selected_real_kind(15) +end module diff --git a/src_flexwrf_v3.1/mt_stream.f90 b/src_flexwrf_v3.1/mt_stream.f90 new file mode 100644 index 0000000000000000000000000000000000000000..79d9c35b68572529a273631f488bb83aed4fba8e --- /dev/null +++ b/src_flexwrf_v3.1/mt_stream.f90 @@ -0,0 +1,788 @@ +! +! A Fortran90/95 module program for Multiple Stream Mersenne Twister. +! 2010/02/12, Ken-Ichi Ishikawa [ishikawa[at]theo.phys.sci.hiroshima-u.ac.jp] +! 2010/07/20, M. S. Briggs, [michael.s.briggs[at]nasa.gov], minor improvements. +! +! This module provides the Mersenne Twister pseudo random number generator +! (MT-PRNG) with multiple stream ability. +! A long period MT generaotr (backbone stream) is divided into disjoint streams, +! and the each stream has continuous stream from the backbone stream. +! The distance between each stream is chosen to have long enough length. +! The status and parameters of the each stream are encapsulated in +! the f90 type components so that we can use multiple streams simultaneously. +! The stream length is fixed to 2^nj. +! +! This code is converted from original/sample codes located at +! Mersenne Twister Home Page: +! [http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/mt.html] +! +! For the Original MT PRNG, see also: +! M. Matsumoto and T. Nishimura, +! "Mersenne Twister: A 623-dimensionally equidistributed uniform pseudorandom +! number generator", +! ACM Trans. on Modeling and Computer Simulation Vol. 8, No. 1, +! January pp.3-30 (1998) DOI:10.1145/272991.272995. +! +! For the jump ahead mechanism, see also: +! H. Haramoto, M. Matsumoto, T. Nishimura, F. Panneton, and P. L'Ecuyer, +! "Efficient Jump Ahead for F_2-Linear Random Number Generators", +! GERAD Report G-2006-62. INFORMS Journal on Computing, 20, 3 (2008), 385-390. +! +! This routine uses; +! Fast arithmetic in GF(2)[x], [http://wwwmaths.anu.edu.au/~brent/software.html] +! NTL : A Library for doing Number Theory, [http://www.shoup.net/ntl/index.html] +! +! +! Copyright (c) 2010, Ken-Ichi Ishikawa [ishikawa[at]theo.phys.sci.hiroshima-u.ac.jp] +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are +! met: +! +! * Redistributions of source code must retain the above copyright +! notice, this list of conditions and the following disclaimer. +! +! * Redistributions in binary form must reproduce the above copyright +! notice, this list of conditions and the following disclaimer listed +! in this license in the documentation and/or other materials +! provided with the distribution. +! +! * Neither the name of the copyright holders nor the names of its +! contributors may be used to endorse or promote products derived from +! this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +! "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +! LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +! A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +! OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +! LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +! THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +! (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! + +!define _TEMPERING_ + +!ifdef _DEBUG_ +!module mt_stream_debug +!else + module mt_stream +!endif + use mt_kind_defs + implicit none + private + public :: MTS_SUCCESS + public :: MTS_FAIL + public :: mt_state + public :: new,delete + public :: init + public :: print + public :: save + public :: read + public :: set_mt19937 + public :: create_stream + public :: genrand_int32 + public :: genrand_double1 + public :: genrand_double2 + public :: genrand_double3 + public :: genrand_double4 + + integer(INT32), parameter :: MTS_SUCCESS = 0 + integer(INT32), parameter :: MTS_FAIL = -1 +!#ifdef _DEBUG_ +! integer(INT32), parameter :: MT_JUMP_DISTANCE_EXP = 16 ! test jump distance (2^16 steps) +!#else + integer(INT32), parameter :: MT_JUMP_DISTANCE_EXP = 256 ! default jump distance (2^256 steps) +!#endif + +!====================================== +! MT19937 parameters +!====================================== + integer(INT32), parameter :: MT19937_N = 624 + integer(INT32), parameter :: MT19937_M = 397 + integer(INT32), parameter :: MT19937_W = 32 + integer(INT32), parameter :: MT19937_R = 31 + integer(INT32), parameter :: MT19937_MATA = INT (Z'9908b0df', INT32) + integer(INT32), parameter :: MT19937_WMASK = INT (Z'ffffffff', INT32) + integer(INT32), parameter :: MT19937_UMASK = INT (Z'80000000', INT32) + integer(INT32), parameter :: MT19937_LMASK = INT (Z'7fffffff', INT32) + integer(INT32), parameter :: MT19937_SHFT0 = 11 + integer(INT32), parameter :: MT19937_SHFT1 = 18 + integer(INT32), parameter :: MT19937_SHFTB = 7 + integer(INT32), parameter :: MT19937_SHFTC = 15 + integer(INT32), parameter :: MT19937_MASKB = INT (Z'9d2c5680', INT32) + integer(INT32), parameter :: MT19937_MASKC = INT (Z'efc60000', INT32) + +!====================================== +! MT state +! Period = 2^(N*W-R)-1 +!====================================== + type mt_state + private + integer(INT32) :: i = -1 ! state vector index + integer(INT32) :: stream_id = -1 ! stream ID + integer(INT32) :: istatus = -1 ! initialization status + integer(INT32) :: nn = -1 ! MT parameter N + integer(INT32) :: mm = -1 ! MT parameter M + integer(INT32) :: rr = -1 ! MT parameter R + integer(INT32) :: ww = -1 ! MT parameter W (width =32) + integer(INT32) :: aaa = 0 ! Companion matrix parameter + integer(INT32) :: wmask = 0 ! 32-bit mask + integer(INT32) :: umask = 0 ! Twist mask x(1) + integer(INT32) :: lmask = 0 ! Twist mask x(0) + integer(INT32) :: shift0 = 0 ! Temparing parameters ... + integer(INT32) :: shift1 = 0 + integer(INT32) :: maskB = 0 + integer(INT32) :: maskC = 0 + integer(INT32) :: shiftB = 0 + integer(INT32) :: shiftC = 0 + integer(INT32) :: mag(0:1) = 0 ! mag(0) = 0, mag(1) = aaa + integer(INT32), pointer :: state(:) => NULL() ! state vector + end type + + type(mt_state), save :: g_mt_master ! this keeps MT parameters + integer(INT32), save :: total_stream = 0 + + interface new + module procedure mt_new + end interface + + interface delete + module procedure mt_delete + end interface + + interface print + module procedure mt_print + end interface + + interface read + module procedure mt_read + end interface + + interface save + module procedure mt_save + end interface + + interface set_mt19937 + module procedure mt_set_mt19937 + end interface + + interface init + module procedure mt_init_by_scalar + module procedure mt_init_by_array + end interface + + interface create_stream + module procedure mt_create_stream + end interface + + interface genrand_int32 + ! in [0,0xFFFFFFFF] + module procedure mt_genrand_int32 + end interface + + interface genrand_double1 + ! in [0,1] (53-bit resolution) + module procedure mt_genrand_double1 + end interface + + interface genrand_double2 + ! in [0,1) (53-bit resolution) + module procedure mt_genrand_double2 + end interface + + interface genrand_double3 + ! in (0,1) (52-bit resolution) + module procedure mt_genrand_double3 + end interface + + interface genrand_double4 + ! in (0,1] (53-bit resolution) + module procedure mt_genrand_double4 + end interface + +contains + +subroutine mt_new(this,ierr) +! +!= Allocate mt state +! + implicit none + type(mt_state), intent(inout) :: this + integer(INT32), optional, intent(out) :: ierr + character(256), parameter :: myname="mt_new" + integer(INT32) :: jerr,kerr + jerr = MTS_SUCCESS + if (0 == g_mt_master%nn) then + write(*,'(A,": MT master parameter is not initialized.")')TRIM(myname) + write(*,'(A,": Stop!")')TRIM(myname) + stop + endif + call mt_copy(g_mt_master,this) + this%stream_id = total_stream + total_stream = total_stream + 1 + if (.not.associated(this%state)) then + if (this%nn <= 0) then + jerr = MTS_FAIL + this%istatus = jerr + goto 100 + endif + allocate(this%state(0:this%nn-1),STAT=kerr) + if (kerr /= 0) then + jerr = MTS_FAIL + this%istatus = jerr + goto 100 + endif + this%istatus = jerr + goto 100 + endif +100 if (present(ierr)) then + ierr = jerr + return + else + if (jerr /= MTS_SUCCESS) then + write(*,'(A,": Something wrong.")')TRIM(myname) + write(*,'(A,": Stop!")')TRIM(myname) + stop + endif + endif +end subroutine + +subroutine mt_delete(this) +! +!= deallocate state vector +! + implicit none + type(mt_state), intent(inout) :: this + if (associated(this%state)) then + deallocate(this%state) + endif + total_stream = total_stream - 1 + return +end subroutine + +subroutine mt_set_mt19937 +! +!= set MT19937 parameters on g_mt_master +! + implicit none + g_mt_master%nn = MT19937_N + g_mt_master%mm = MT19937_M + g_mt_master%ww = MT19937_W + g_mt_master%rr = MT19937_R + g_mt_master%aaa = MT19937_MATA + g_mt_master%wmask = MT19937_WMASK + g_mt_master%umask = MT19937_UMASK + g_mt_master%lmask = MT19937_LMASK + g_mt_master%shift0 = MT19937_SHFT0 + g_mt_master%shift1 = MT19937_SHFT1 + g_mt_master%shiftB = MT19937_SHFTB + g_mt_master%shiftC = MT19937_SHFTC + g_mt_master%maskB = MT19937_MASKB + g_mt_master%maskC = MT19937_MASKC + g_mt_master%mag(0) = 0 + g_mt_master%mag(1) = g_mt_master%aaa + total_stream = 0 + return +end subroutine + +subroutine mt_copy(this,that) +! +!= duplicate/copy MT paramters +! +! that <= this +! + implicit none + type(mt_state), intent(in) :: this + type(mt_state), intent(out) :: that + that%i = this%i + that%stream_id = this%stream_id + that%istatus = this%istatus + that%nn = this%nn + that%nn = this%nn + that%mm = this%mm + that%ww = this%ww + that%aaa = this%aaa + that%rr = this%rr + that%wmask = this%wmask + that%umask = this%umask + that%lmask = this%lmask + that%shift0 = this%shift0 + that%shift1 = this%shift1 + that%shiftB = this%shiftB + that%shiftC = this%shiftC + that%maskB = this%maskB + that%maskC = this%maskC + that%mag(0) = 0 + that%mag(1) = that%aaa + return +end subroutine + +subroutine mt_save(this,unit) +! +!= save MT status to file with unit +! + implicit none + type(mt_state), intent(in) :: this + integer(INT32), intent(in) :: unit + write(unit) this%i + write(unit) this%stream_id + write(unit) this%istatus + write(unit) this%nn + write(unit) this%mm + write(unit) this%ww + write(unit) this%aaa + write(unit) this%rr + write(unit) this%wmask + write(unit) this%umask + write(unit) this%lmask + write(unit) this%shift0 + write(unit) this%shift1 + write(unit) this%shiftB + write(unit) this%shiftC + write(unit) this%maskB + write(unit) this%maskC + write(unit) this%mag(:) + write(unit) this%state(:) + return +end subroutine + +subroutine mt_read(this,unit) +! +!= read MT status from file with unit +! + implicit none + type(mt_state), intent(inout) :: this + integer(INT32), intent(in) :: unit + read(unit) this%i + read(unit) this%stream_id + read(unit) this%istatus + read(unit) this%nn + read(unit) this%mm + read(unit) this%ww + read(unit) this%aaa + read(unit) this%rr + read(unit) this%wmask + read(unit) this%umask + read(unit) this%lmask + read(unit) this%shift0 + read(unit) this%shift1 + read(unit) this%shiftB + read(unit) this%shiftC + read(unit) this%maskB + read(unit) this%maskC + read(unit) this%mag(:) + if (associated(this%state)) then + deallocate(this%state) + allocate(this%state(0:this%nn-1)) + endif + read(unit) this%state(:) + return +end subroutine + +subroutine mt_print(this) +! +!= print MT stream parameter and states +! + implicit none + type(mt_state), intent(in) :: this + character(256) :: str + write(*,'("===============================================================================")') + write(*,'(" MT PARAMETERS")') + write(str,*)this%stream_id + write(*,'(" STREAMID= ",A)')TRIM(ADJUSTL(str)) + write(str,*)this%nn*this%ww-this%rr + write(*,'(" PERIOD= 2^",A," - 1")')TRIM(ADJUSTL(str)) + write(*,'(" NN=",I8," MM=",I8," WW=",I3," RR=",I3)')this%nn,this%mm,this%ww,this%rr + write(*,'(" AVEC= 0x",Z8.8)', advance='no' )this%aaa + write(*,'(" WMASK= 0x",Z8.8)', advance='no' )this%wmask + write(*,'(" UMASK= 0x",Z8.8)', advance='no' )this%umask + write(*,'(" LMASK= 0x",Z8.8)') this%lmask + write(*,'(" MAG= 0x",Z8.8," 0x",Z8.8)') this%mag + write(*,'(" SHFT0=",I3)', advance='no' )this%shift0 + write(*,'(" SHFT1=",I3)', advance='no' )this%shift1 + write(*,'(" SHFTB=",I3)', advance='no' )this%shiftB + write(*,'(" SHFTC=",I3)', advance='no' )this%shiftC + write(*,'(" MASKB= 0x",Z8.8)', advance='no' )this%maskB + write(*,'(" MASKC= 0x",Z8.8)') this%maskC + write(str,*)this%i + write(*,'(" POINTER= ",A)')TRIM(ADJUSTL(str)) + write(*,'("===============================================================================")') + return +end subroutine + + +subroutine mt_init_by_scalar(this,iseed,ierr) +! +!= initialize MT state by a scalar seed. +! + implicit none + type(mt_state), intent(inout) :: this + integer(INT32), intent(in) :: iseed + integer(INT32), optional, intent(out) :: ierr + character(256), parameter :: myname="mt_init_by_scalar" + integer(INT32) :: i,jseed,jerr + if (.not.associated(this%state)) then + jerr = MTS_FAIL + goto 100 + endif + jseed = iseed + do i=0,this%nn-1 + this%state(i) = jseed + jseed = 1812433253 * IEOR(jseed, ISHFT(jseed,-30)) + i + 1 + enddo + this%i = this%nn + do i=0,this%nn-1 + this%state(i) = IAND(this%state(i),this%wmask) + enddo + this%mag(0) = 0 + this%mag(1) = this%aaa + jerr = MTS_SUCCESS +100 if (present(ierr)) then + ierr = jerr + else + if (jerr /= MTS_SUCCESS) then + write(*,'(A,": State vector allocation fails.")')TRIM(myname) + write(*,'(A,": Stop!")')TRIM(myname) + stop + endif + endif + return +end subroutine + +subroutine mt_init_by_array(this,iseed,ierr) +! +!= initialize MT state by array seeds. +! + implicit none + type(mt_state), intent(inout) :: this + integer(INT32), intent(in) :: iseed(0:) + integer(INT32), optional, intent(out) :: ierr + integer :: isize,i,j,k,n,jerr + character(256), parameter :: myname="mt_init_by_array" + integer(INT32), parameter :: ASEED = 19650218 + + call mt_init_by_scalar(this,ASEED,jerr) + if (jerr /= MTS_SUCCESS) goto 100 + + isize = SIZE(iseed) + n = this%nn + i = 1 + j = 0 + do k = MAX(n,isize),1,-1 + this%state(i) = IEOR(this%state(i),(IEOR(this%state(i-1),ISHFT(this%state(i-1),-30))*1664525)) + iseed(j) + j + this%state(i) = IAND(this%state(i),this%wmask) ! for WORDSIZE > 32 machines + i = i + 1 + j = j + 1 + if (i >= n) then + this%state(0) = this%state(n-1) + i = 1 + endif + if (j >= isize) j = 0 + enddo + do k = n-1,1,-1 + this%state(i) = IEOR(this%state(i),(IEOR(this%state(i-1),ISHFT(this%state(i-1),-30))*1566083941)) - i + this%state(i) = IAND(this%state(i),this%wmask) ! for WORDSIZE > 32 machines + i = i + 1 + if (i >= n) then + this%state(0) = this%state(n-1) + i = 1 + endif + enddo + this%state(0) = INT (Z'80000000', INT32) ! MSB is 1; assuring non-zero initial array + jerr = MTS_SUCCESS +100 if (present(ierr)) then + ierr = jerr + else + if (jerr /= MTS_SUCCESS) then + write(*,'(A,": mt_init_by_scalar fails.")')TRIM(myname) + write(*,'(A,": Stop!")')TRIM(myname) + stop + endif + endif + return +end subroutine + +function mt_genrand_int32(this) result(ir) +! +!= return a value in [0,0xFFFFFFFF] +! + implicit none + type(mt_state), intent(inout) :: this + integer(INT32) :: ir + integer(INT32) :: umask,lmask,n,m,is + integer(INT32) :: k,nm,n1 + if (this%i >= this%nn) then + n = this%nn + m = this%mm + lmask = this%lmask + umask = this%umask + nm = n - m + n1 = n - 1 + do k=0,nm-1 + is = IOR(IAND(this%state(k),umask),IAND(this%state(k+1),lmask)) + this%state(k) = IEOR(IEOR(this%state(k+m),ISHFT(is,-1)),this%mag(IAND(is,1))) + enddo + do k=nm,n1-1 + is = IOR(IAND(this%state(k),umask),IAND(this%state(k+1),lmask)) + this%state(k) = IEOR(IEOR(this%state(k+m-n),ISHFT(is,-1)),this%mag(IAND(is,1))) + enddo + is = IOR(IAND(this%state(n-1),umask),IAND(this%state(0),lmask)) + this%state(n-1) = IEOR(IEOR(this%state(m-1),ISHFT(is,-1)),this%mag(IAND(is,1))) + this%i = 0 + endif + + is = this%state(this%i) + this%i = this%i + 1 +!#ifdef _TEMPERING_ +! is = IEOR(is,ISHFT(is,-this%shift0)) +! is = IEOR(is,IAND(ISHFT(is, this%shiftB),this%maskB)) +! is = IEOR(is,IAND(ISHFT(is, this%shiftC),this%maskC)) +! is = IEOR(is,ISHFT(is,-this%shift1)) +!#endif + ir = is + return +end function + +subroutine mt_matvec(this,v,w) +! +!= Multiply transition matrix on a state vector v +! +! w = B v +! +! this : MT parameters(transition matrix) +! v : input vector +! w : output vector +! + implicit none + type(mt_state), intent(in) :: this + integer(INT32), intent(in) :: v(0:this%nn-1) + integer(INT32), intent(out) :: w(0:this%nn-1) + integer(INT32) :: umask,lmask,n,m,is + integer(INT32) :: k + n = this%nn + m = this%mm + lmask = this%lmask + umask = this%umask + w(0) = IAND(v(1),umask) + do k=1,n-2 + w(k) = v(k+1) + enddo + is = IOR(IAND(v(0),umask),IAND(v(1),lmask)) + w(n-1) = IEOR(IEOR(v(m),ISHFT(is,-1)),this%mag(IAND(is,1))) + return +end subroutine + +subroutine mt_create_stream(this,that,id) +! +!= Create New stream (that) with distance id*2^(jp) from (this) +! + implicit none + type(mt_state), intent(inout) :: this ! input state + type(mt_state), intent(inout) :: that ! output state + integer(INT32), intent(in) :: id + character(256), parameter :: myname="mt_create_stream" + integer(INT32), parameter :: jp = MT_JUMP_DISTANCE_EXP + if (id < 0) then + write(*,'(A,": Positive ID is requried.")')TRIM(myname) + write(*,'(A,": Stop!")')TRIM(myname) + stop + endif + call mt_jumpahead(this,that,jp,id) + that%stream_id = id + total_stream = total_stream + 1 + this%i = this%nn + return +end subroutine + +subroutine mt_jumpahead(this,that,jp,id) +! +!= Jump ahead by (id+1) * 2^jp steps. +! +! this : input state +! that : output state, proceeds by id*2^jp steps. +! + implicit none + type(mt_state), intent(inout) :: this ! input state + type(mt_state), intent(inout) :: that ! output state + integer(INT32), intent(in) :: jp ! exponent (jump step = id*2^jp) + integer(INT32), intent(in) :: id ! id (jump step = id*2^jp) + integer(INT32) :: v(0:this%nn-1) + integer(INT32) :: w(0:this%nn-1) + integer(INT32) :: s(0:this%nn-1) + integer(INT32) :: i,iwp,ibp + character(256) :: str,str2 + integer(INT32) :: p(0:this%nn-1) + integer(INT32) :: np + ! + ! external routine in + ! jump_ahead_coeff/get_coeff.cxx + ! written in C++ with NTL and gf2x libraries. + ! +!#ifdef _NTL_ +! interface get_coeff_interface +! subroutine get_coeff(nn,mm,rr,ww,avec,nj,id,pp,np) bind (C, name="get_coeff") +! use, intrinsic :: iso_c_binding, only: c_int +! integer (c_int), intent(in) :: nn,mm,rr,ww,avec,nj,id +! integer (c_int), intent(inout) :: pp(0:nn-1),np +! end subroutine get_coeff +! end interface get_coeff_interface +!#else + interface f_get_coeff_interface + subroutine f_get_coeff(nn,mm,rr,ww,avec,nj,id,pp,np) + integer, intent(in) :: nn,mm,rr,ww,avec,nj,id + integer, intent(inout) :: pp(0:nn-1),np + end subroutine f_get_coeff + end interface f_get_coeff_interface +!#endif + + !================================== + ! state copy: this => that + !================================== + call mt_copy(this,that) + + write(str,'(I12)')id + write(str2,'(I12)')jp + write(*,'("# ID ",I12)')id + write(*,'("# Jump Ahead by (",A,")*2^",A)')TRIM(ADJUSTL(str)),TRIM(ADJUSTL(str2)) + if ( this%i /= this%nn) then + write(*,'("Error in jumpahead: input state pointer should point nn.")') + write(*,'("this%i = ",I12)')this%i + write(*,'("this%nn = ",I12)')this%nn + write(str,*)this%i + write(str2,*)this%nn-1 + write(*,'(A,"-",A," random numbers are dropped.")') & + & TRIM(ADJUSTL(str)),TRIM(ADJUSTL(str2)) + write(*,'("forced to point nn")') + this%i = this%nn + endif + + !================================== + ! compute jump ahead polynomial + ! p(x) coefficients + ! for this MT parameter + !================================== +!#ifdef _NTL_ +! call get_coeff(this%nn,this%mm,this%rr,this%ww,this%aaa,jp,id,p,np) +!#else + call f_get_coeff(this%nn,this%mm,this%rr,this%ww,this%aaa,jp,id,p,np) +!#endif + + !================================== + ! multiply p(B) on a state vector v + ! p(x) : jump ahead polynomial + ! B : transition matrix + ! with simple Horner's method + ! w = p(B) v = B^(2^jp) v + !================================== + v(:) = this%state(:) + iwp = (np-1)/32 + ibp = mod(np-1,32) + if (BTEST(p(iwp),ibp)) then + w(:) = v(:) + endif + do i=np-2,0,-1 + iwp = i/32 + ibp = mod(i,32) + call mt_matvec(this,w,s) ! s = B w + if (BTEST(p(iwp),ibp)) then + w(:) = IEOR(v(:),s(:)) ! w = 1 v + s + else + w(:) = s(:) ! w = 0 v + s + endif + enddo + + if (.not. associated(that%state)) then + allocate(that%state(0:that%nn-1)) + endif + that%state(:) = w(:) + that%i = this%nn + + return +end subroutine + +function mt_genrand_double1(this) result(r) + ! + ! r in [0,1] (53-bit resolution) + ! + implicit none + type(mt_state), intent(inout) :: this + real(REAL64) :: r + real(REAL64) :: a,b + integer(INT32) :: ia,ib + ia = mt_genrand_int32(this) ! ia in [0,0xFFFFFFFF] + ib = mt_genrand_int32(this) ! ib in [0,0xFFFFFFFF] + ia = ISHFT(ia,-5) ! ia in [0,2^27-1] + ib = ISHFT(ib,-6) ! ib in [0,2^26-1] + a = REAL(ia,kind=KIND(r)) + b = REAL(ib,kind=KIND(r)) + !=============================== + ! ( a*2^26 + b ) in [0,2^53-1] + ! r = ( a*2^26 + b )/(2^53-1) + !=============================== + r = (a*67108864.0_REAL64 + b)*(1.0_REAL64/9007199254740991.0_REAL64) + return +end function + +function mt_genrand_double2(this) result(r) + ! + ! r in [0,1) (53-bit resolution) + ! + implicit none + type(mt_state), intent(inout) :: this + real(REAL64) :: r + real(REAL64) :: a,b + integer(INT32) :: ia,ib + ia = mt_genrand_int32(this) ! ia in [0,0xFFFFFFFF] + ib = mt_genrand_int32(this) ! ib in [0,0xFFFFFFFF] + ia = ISHFT(ia,-5) ! ia in [0,2^27-1] + ib = ISHFT(ib,-6) ! ib in [0,2^26-1] + a = REAL(ia,kind=KIND(r)) + b = REAL(ib,kind=KIND(r)) + !=============================== + ! ( a*2^26 + b ) in [0,2^53-1] + ! r = ( a*2^26 + b )/(2^53) + !=============================== + r = (a*67108864.0_REAL64 + b)*(1.0_REAL64/9007199254740992.0_REAL64) + return +end function + +function mt_genrand_double3(this) result(r) + ! + ! r in (0,1) (52-bit resolution) + ! + implicit none + type(mt_state), intent(inout) :: this + real(REAL64) :: r + real(REAL64) :: a,b + integer(INT32) :: ia,ib + ia = mt_genrand_int32(this) ! ia in [0,0xFFFFFFFF] + ib = mt_genrand_int32(this) ! ib in [0,0xFFFFFFFF] + ia = ISHFT(ia,-6) ! ia in [0,2^26-1] + ib = ISHFT(ib,-6) ! ib in [0,2^26-1] + a = REAL(ia,kind=KIND(r)) + b = REAL(ib,kind=KIND(r)) + !=============================== + ! ( a*2^26 + b ) in [0,2^52-1] + ! r = ( a*2^26 + b + 1/2 )/(2^52) + !=============================== + r = (a*67108864.0_REAL64 + b + 0.5_REAL64)*(1.0_REAL64/4503599627370496.0_REAL64) + return +end function + +function mt_genrand_double4(this) result(r) + ! + ! r in (0,1] (53-bit resolution) + ! + implicit none + type(mt_state), intent(inout) :: this + real(REAL64) :: r + r = 1.0_REAL64 - mt_genrand_double2(this) + return +end function + +end module diff --git a/src_flexwrf_v3.1/obukhov.f90 b/src_flexwrf_v3.1/obukhov.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3aced13873b3c41ac4d3ed523722fc7a8c8dd7f4 --- /dev/null +++ b/src_flexwrf_v3.1/obukhov.f90 @@ -0,0 +1,86 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** +! real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,akm,bkm) + 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 * +! * +! 20 Oct 2005 - R. Easter - pass plev as argument instead of * +! akm,bkm * +! * +!******************************************************************** +! * +! 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 * +! * +!******************************************************************** + +! include 'includepar' +! real akm(nwzmax),bkm(nwzmax) +! real ps,tsurf,tdsurf,tlev,ustar,hf,e,ew,tv,rhoa,plev +! real ak1,bk1,theta,thetastar + 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 +! 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 + diff --git a/src_flexwrf_v3.1/oh_mod.f90 b/src_flexwrf_v3.1/oh_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0cb0b01eda1b6905fba3a1586f41bc067e4dfe06 --- /dev/null +++ b/src_flexwrf_v3.1/oh_mod.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/ohreaction.f90 b/src_flexwrf_v3.1/ohreaction.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ea0bb0c4c269fa965d700d90dca22fe5af0e4084 --- /dev/null +++ b/src_flexwrf_v3.1/ohreaction.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/openouttraj.f90 b/src_flexwrf_v3.1/openouttraj.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9d9a49e089cd4590b7f89fcd2fceaedfbe238306 --- /dev/null +++ b/src_flexwrf_v3.1/openouttraj.f90 @@ -0,0 +1,101 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine openouttraj +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine openouttraj. * +! * +! This routine opens the output file for the plume trajectory output * +! produced by the cluster analysis. * +! * +! Author: A. Stohl * +! 27 January 2001 * +! * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! * +!******************************************************************************* +! * +! Variables: * +! * +!******************************************************************************* + + use point_mod + use par_mod + use com_mod +! include 'includepar' +! include 'includecom' + + integer i + real xp1,yp1,xp2,yp2 + real xtmp, ytmp + + +! Open output file for trajectory output +!*************************************** + + open(unitouttraj,file=path(1)(1:length(1))//'trajectories.txt', & + form='formatted',err=998) + + if (ldirect.eq.1) then + write(unitouttraj,'(i8,1x,i6,1x,a)') ibdate,ibtime,'FLEXWRF V3.0' + else + write(unitouttraj,'(i8,1x,i6,1x,a)') iedate,ietime,'FLEXWRF V3.0' + endif + write(unitouttraj,*) method,lsubgrid,lconvection + write(unitouttraj,*) numpoint + do i=1,numpoint + if (outgrid_option .eq. 0) then + xp1=xpoint1(i)*dx+xmet0 + yp1=ypoint1(i)*dy+ymet0 + xp2=xpoint2(i)*dx+xmet0 + yp2=ypoint2(i)*dy+ymet0 + endif + if (outgrid_option .eq. 1) then + xtmp = xpoint1(i)*dx+xmet0 + ytmp = ypoint1(i)*dy+ymet0 + call xymeter_to_ll_wrf( xtmp, ytmp, xp1, yp1 ) + xtmp = xpoint2(i)*dx+xmet0 + ytmp = ypoint2(i)*dy+ymet0 + call xymeter_to_ll_wrf( xtmp, ytmp, xp2, yp2 ) + endif +!jdf write(unitouttraj,*) ireleasestart(i),ireleaseend(i), +!jdf + xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i),kindz(i),npart(i) +!jdf write(unitouttraj,'(a)') compoint(i)(1:40) + write(unitouttraj,*) ireleasestart(i),ireleaseend(i), & + xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i),kindz(i),npart(i) + write(unitouttraj,'(a20)') compoint(i)(1:20) + enddo +101 format(2i5,4f11.5,2f11.3,2i5) + + 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 + diff --git a/src_flexwrf_v3.1/openreceptors.f90 b/src_flexwrf_v3.1/openreceptors.f90 new file mode 100644 index 0000000000000000000000000000000000000000..12baa3b1f796d408f9a189b91a2b6ea0bfffd4a7 --- /dev/null +++ b/src_flexwrf_v3.1/openreceptors.f90 @@ -0,0 +1,144 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine openreceptors +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of 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 * +! * +! Dec 2005, J. Fast - Output files can be either binary or ascii. * +! Write iomode_xycoord to output files. * +! Receptor positions can be lat-lon or grid-meters. * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! * +!******************************************************************************* +! * +! 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 + real :: xtmp(maxreceptor),ytmp(maxreceptor) + real :: xtmpb,ytmpb + + +! 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 + + do j = 1, numreceptor + xtmp(j) = xreceptor(j)*dx + xmet0 + ytmp(j) = yreceptor(j)*dy + ymet0 + if (outgrid_option .eq. 0) then + xtmpb = xtmp(j) + ytmpb = ytmp(j) + call xymeter_to_ll_wrf( xtmpb, ytmpb, xtmp(j), ytmp(j) ) + endif + enddo + +! Concentration output +!********************* + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + if (iouttype.eq.0) then + open(unitoutrecept,file=path(1)(1:length(1))//'receptor_conc', & + form='unformatted',err=997) + write(unitoutrecept) (receptorname(j),j=1,numreceptor) + write(unitoutrecept) (xtmp(j),ytmp(j),j=1,numreceptor), & + outgrid_option + endif + if (iouttype.eq.1) then + open(unitoutrecept,file=path(1)(1:length(1))//'receptor_conc', & + form='formatted',err=997) +! do j = 1, numreceptor +! write(unitoutrecept,*) receptorname(j) +! enddo +! write(unitoutrecept,*) (xtmp(j),ytmp(j),j=1,numreceptor), + do j=1,numreceptor + write(unitoutrecept,1001) receptorname(j), & + xtmp(j),ytmp(j),outgrid_option + enddo +1001 format(a16,f10.4,f10.4,i5) + endif + endif + +! Mixing ratio output +!******************** + + if ((iout.eq.2).or.(iout.eq.3)) then + if (iouttype.eq.0) then + open(unitoutreceptppt,file=path(1)(1:length(1))//'receptor_pptv', & + form='unformatted',err=998) + write(unitoutreceptppt) (receptorname(j),j=1,numreceptor) + write(unitoutreceptppt) (xtmp(j),ytmp(j),j=1,numreceptor), & + outgrid_option + endif + if (iouttype.eq.1) then + open(unitoutreceptppt,file=path(1)(1:length(1))//'receptor_pptv', & + form='formatted',err=998) +! do j = 1, numreceptor +! write(unitoutreceptppt,*) receptorname(j) +! enddo +! write(unitoutreceptppt,*) (xtmp(j),ytmp(j),j=1,numreceptor), + do j=1,numreceptor + write(unitoutreceptppt,1001) receptorname(j), & + xtmp(j),ytmp(j),outgrid_option + enddo + endif + 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 + diff --git a/src_flexwrf_v3.1/outg_mod.f90 b/src_flexwrf_v3.1/outg_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2f3b2bd7f4aa05fecd631efee38a3d52c69cad99 --- /dev/null +++ b/src_flexwrf_v3.1/outg_mod.f90 @@ -0,0 +1,51 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 (:,:,:,:) :: grid2 + real,allocatable, dimension (:,:,:,:) :: grid3 + real,allocatable, dimension (:,:) :: wetgrid + real,allocatable, dimension (:,:,:) :: wetgrid2 + real,allocatable, dimension (:,:) :: drygrid + real,allocatable, dimension (:,:,:) :: drygrid2 + 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 diff --git a/src_flexwrf_v3.1/outgrid_init_irreg.f90 b/src_flexwrf_v3.1/outgrid_init_irreg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0cd3f4d52660fc097feb165c5fc8d62aeca3ab25 --- /dev/null +++ b/src_flexwrf_v3.1/outgrid_init_irreg.f90 @@ -0,0 +1,591 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine outgrid_init_irreg +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine outgrid_init. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! This routine calculates, for each grid cell of the output grid, the * +! volume, the surface area, and the areas of the northward and eastward * +! facing surfaces. * +! * +! Author: A. Stohl * +! * +! 7 August 2002 * +! * +! 26 Oct 2005, R. Easter - changes in gridarea, areaeast, areanorth * +! associated with WRF horizontal grid. * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! * +!******************************************************************************* +! * +! 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 + +! include 'includepar' +! include 'includecom' + implicit none + integer :: ix,jy,kz,k,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid +! real ylat,gridarea,ylatp,ylatm,hzone,cosfact,cosfactm,cosfactp + real :: ymet,gridarea,xl1,xl2,yl1,yl2,m1,m2,tmpx,tmpy + real :: xmet,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh + integer :: ks,kp,stat,ix2,jy2 + real,parameter :: eps=nxmax/3.e5 + real :: lon2(4),lat2(4) + real ( kind = 8 ) :: sphere01_polygon_area,haversine,area1 + + + +! 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,10 +! print*,areamet(1,jy),areamet(2,jy),areamet2(2,jy) +! enddo + 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 +! +!C Calculate area of grid cell with formula M=2*pi*R*h*dx/360, +!C see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90 +!************************************************************* +! +! cosfact=cos(ylat*pi180)*r_earth +! cosfactp=cos(ylatp*pi180)*r_earth +! cosfactm=cos(ylatm*pi180)*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 +! +!C Surface are of a grid cell at a latitude ylat +!*********************************************** +! +! gridarea=2.*pi*r_earth*hzone*dxout/360. + +! for FLEXPART_WRF, dx & dy are in meters, and no cos(lat) is needed +! ??? maybe should incorporate map factor here, +! and also for areaeast & areanorth ??? + + do ix=0,numxgrid-1 +! gridarea=dxout*dyout ! what is needed is the true area based on map factors +!JB: find a way to get the area between 2 output grid cell using areamet +! xl1=(real(ix)*dxout+out_xm0)/dx +! yl1=(real(jy)*dyout+out_ym0)/dy +! xl2=(real(ix+1)*dxout+out_xm0)/dx +! yl2=(real(jy+1)*dyout+out_ym0)/dy +!! xr=out_xm0+real(numxgrid)*dxout +! m1=0.5*(m_x(int(xl1),int(yl1),1)+m_x(int(xl2),int(yl1),1)) +! m2=0.5*(m_y(int(xl1),int(yl1),1)+m_x(int(xl1),int(yl2),1)) +! area(ix,jy)=dxout*m1*dyout*m2 + +! A more precise method + tmpx=out_xm0+(float(ix))*dxout + tmpy=out_ym0+(float(jy))*dyout + call xymeter_to_ll_wrf_out(tmpx,tmpy,lon2(1),lat2(1)) + tmpx=out_xm0+(float(ix+1))*dxout + tmpy=out_ym0+(float(jy))*dyout + call xymeter_to_ll_wrf_out(tmpx,tmpy,lon2(2),lat2(2)) + tmpx=out_xm0+(float(ix+1))*dxout + tmpy=out_ym0+(float(jy+1))*dyout + call xymeter_to_ll_wrf_out(tmpx,tmpy,lon2(3),lat2(3)) + tmpx=out_xm0+(float(ix))*dxout + tmpy=out_ym0+(float(jy+1))*dyout + call xymeter_to_ll_wrf_out(tmpx,tmpy,lon2(4),lat2(4)) + area1=sphere01_polygon_area ( 4, real(lat2,kind=8), real(lon2,kind=8) ) + area(ix,jy)=real(area1)*6370000.*6370000./coefdx/coefdx +! +! Volume = area x box height +!*************************** + + volume(ix,jy,1)=area(ix,jy)*outheight(1) + +! for FLEXPART_WRF, dx & dy are in meters, and no cos(lat) is needed +! areaeast(ix,jy,1)=dyout*r_earth*pi180*outheight(1) +! areanorth(ix,jy,1)=cos(ylat*pi180)*dxout*r_earth*pi180* +! + outheight(1) + areaeast(ix,jy,1)=dyout*outheight(1) + areanorth(ix,jy,1)=dxout*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)) + areaeast(ix,jy,kz)=dyout*(outheight(kz)-outheight(kz-1)) + areanorth(ix,jy,kz)=dxout*(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 +! for FLEXPART_WRF, x & y coords are in meters, +! and the lon & lat variables below are in meters. + ymet=out_ym0+(real(jjy)+real(j1)/10.-0.05)*dyout + yl=(ymet-ymet0)/dy + do i1=1,10 + xmet=out_xm0+(real(iix)+real(i1)/10.-0.05)*dxout + xl=(xmet-xmet0)/dx + +! Determine the nest we are in +!***************************** + + ngrid=0 + do j=numbnests,1,-1 + if ((xl.gt.xln(j)).and.(xl.lt.xrn(j)).and. & + (yl.gt.yln(j)).and.(yl.lt.yrn(j))) 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 +! print*,'gridunc allocated' + 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) + allocate(drygridunc2(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 + +! print*,'alloc gridunc',numxgrid-1,numygrid-1,numzgrid,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) + allocate(grid2(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1,numzgrid,maxpointspec_act),stat=stat) + allocate(grid3(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1,numzgrid,maxpointspec_act),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) + allocate(wetgrid2(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1,maxpointspec_act),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) + allocate(drygrid2(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1,maxpointspec_act),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. +! drygridunc2(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_irreg + +function sphere01_polygon_area ( n, lat, lon ) + +!*****************************************************************************80 +! +!! SPHERE01_POLYGON_AREA returns the area of a spherical polygon. +! +! Discussion: +! +! On a unit sphere, the area of a spherical polygon with N sides +! is equal to the spherical excess: +! +! E = sum ( interior angles ) - ( N - 2 ) * pi. +! +! On a sphere with radius R, the area is the spherical excess multiplied +! by R * R. +! +! The code was revised in accordance with suggestions in Carvalho and +! Cavalcanti. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 12 August 2005 +! +! Author: +! +! Original C version by Robert Miller. +! FORTRAN90 version by John Burkardt. +! +! Reference: +! +! Paulo Cezar Pinto Carvalho, Paulo Roma Cavalcanti, +! Point in Polyhedron Testing Using Spherical Polygons, +! in Graphics Gems V, +! edited by Alan Paeth, +! Academic Press, 1995, +! ISBN: 0125434553, +! LC: T385.G6975. +! +! Robert Miller, +! Computing the Area of a Spherical Polygon, +! Graphics Gems, Volume IV, pages 132-138, +! Edited by Paul Heckbert, +! Academic Press, 1994, T385.G6974. +! +! Eric Weisstein, +! "Spherical Polygon", +! CRC Concise Encyclopedia of Mathematics, +! CRC Press, 1999. +! +! Parameters: +! +! Input, integer ( kind = 4 ) N, the number of vertices. +! +! Input, real ( kind = 8 ) LAT[N], LON[N], the latitudes and longitudes +! of the vertices of the spherical polygon. +! +! Output, real ( kind = 8 ) SPHERE01_POLYGON_AREA, the area of the +! spherical polygon, measured in spherical radians. +! + implicit none + + integer ( kind = 4 ) n + + real ( kind = 8 ) a + real ( kind = 8 ) area + real ( kind = 8 ) b + real ( kind = 8 ) beta1 + real ( kind = 8 ) beta2 + real ( kind = 8 ) c + real ( kind = 8 ) cos_b1 + real ( kind = 8 ) cos_b2 + real ( kind = 8 ) excess + real ( kind = 8 ) hav_a + real ( kind = 8 ) haversine + integer ( kind = 4 ) j + integer ( kind = 4 ) k + real ( kind = 8 ) lam + real ( kind = 8 ) lam1 + real ( kind = 8 ) lam2 + real ( kind = 8 ) lat(n) + real ( kind = 8 ) lon(n) + real ( kind = 8 ), parameter :: pi_half = 1.5707963267948966192313D+00 + real ( kind = 8 ) s + real ( kind = 8 ) sphere01_polygon_area + real ( kind = 8 ) t + real ( kind = 8 ),parameter :: degrees_to_radians=3.141592653589793D+00 / 180.0D+00 + + area = 0.0D+00 + + do j=1,n + lon(j)=lon(j)*degrees_to_radians + lat(j)=lat(j)*degrees_to_radians + enddo + do j = 1, n + 1 +! do j = 1, n + + if ( j == 1 ) then + lam1 = lon(j) + beta1 = lat(j) + lam2 = lon(j+1) + beta2 = lat(j+1) + cos_b1 = cos ( beta1 ) + cos_b2 = cos ( beta2 ) + else +! k = mod ( j + 1, n + 1 ) +! k = mod ( j , n ) + k=j + if (j.gt.n) k=1 + lam1 = lam2 + beta1 = beta2 + lam2 = lon(k) + beta2 = lat(k) +! print*,'sphere',n,k,lon(k),lat(k) + cos_b1 = cos_b2 + cos_b2 = cos ( beta2 ) + end if + + if ( lam1 /= lam2 ) then + + hav_a = haversine ( beta2 - beta1 ) & + + cos_b1 * cos_b2 * haversine ( lam2 - lam1 ) + a = 2.0D+00 * asin ( sqrt ( hav_a ) ) + + b = pi_half - beta2 + c = pi_half - beta1 + s = 0.5D+00 * ( a + b + c ) +! +! Given the three sides of a spherical triangle, we can use a formula +! to find the spherical excess. +! + t = tan ( s / 2.0D+00 ) * tan ( ( s - a ) / 2.0D+00 ) & + * tan ( ( s - b ) / 2.0D+00 ) * tan ( ( s - c ) / 2.0D+00 ) + + excess = abs ( 4.0D+00 * atan ( sqrt ( abs ( t ) ) ) ) + + if ( lam1 < lam2 ) then + lam = lam2 - lam1 + else + lam = lam2 - lam1 + 4.0D+00 * pi_half + end if + + if ( 2.0D+00 * pi_half < lam ) then + excess = -excess + end if + + area = area + excess + + end if + + end do + + sphere01_polygon_area = abs ( area ) + + return +end + +function haversine ( a ) + +!*****************************************************************************80 +! +!! HAVERSINE computes the haversine of an angle. +! +! Discussion: +! +! haversine(A) = ( 1 - cos ( A ) ) / 2 +! +! The haversine is useful in spherical trigonometry. +! +! Licensing: +! +! This code is distributed under the GNU LGPL license. +! +! Modified: +! +! 02 July 2001 +! +! Author: +! +! John Burkardt +! +! Parameters: +! +! Input, real ( kind = 8 ) A, the angle. +! +! Output, real ( kind = 8 ) HAVERSINE, the haversine of the angle. +! + implicit none + + real ( kind = 8 ) a + real ( kind = 8 ) haversine + + haversine = ( 1.0D+00 - cos ( a ) ) / 2.0D+00 + + return +end diff --git a/src_flexwrf_v3.1/outgrid_init_nest_irreg.f90 b/src_flexwrf_v3.1/outgrid_init_nest_irreg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1299a7abb6bd979827c4620840326bd03178e5c2 --- /dev/null +++ b/src_flexwrf_v3.1/outgrid_init_nest_irreg.f90 @@ -0,0 +1,287 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine outgrid_init_nest_irreg +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine outgrid_init. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! This routine calculates, for each grid cell of the output grid, the * +! volume, the surface area, and the areas of the northward and eastward * +! facing surfaces. * +! * +! Author: A. Stohl * +! * +! 7 August 2002 * +! * +! 26 Oct 2005, R. Easter - changes in gridarea, areaeast, areanorth * +! associated with WRF horizontal grid. * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! * +!******************************************************************************* +! * +! 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 unc_mod + use outg_mod + use par_mod + use com_mod + +! include 'includepar' +! include 'includecom' + implicit none + integer :: ix,jy,kz,k,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid +! real ylat,gridarea,ylatp,ylatm,hzone,cosfact,cosfactm,cosfactp + real :: ymet,gridarea,m1,m2,xl1,xl2,yl1,yl2,tmpx,tmpy + real :: xmet,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh + integer :: ks,kp,stat + real,parameter :: eps=nxmax/3.e5 + real :: lon2(4),lat2(4) + real ( kind = 8 ) :: sphere01_polygon_area,haversine,area1 + + +! 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=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 +! +!C Calculate area of grid cell with formula M=2*pi*R*h*dx/360, +!C see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90 +!************************************************************* +! +! cosfact=cos(ylat*pi180)*r_earth +! cosfactp=cos(ylatp*pi180)*r_earth +! cosfactm=cos(ylatm*pi180)*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 +! +!C Surface are of a grid cell at a latitude ylat +!*********************************************** +! +! gridarea=2.*pi*r_earth*hzone*dxout/360. + +! for FLEXPART_WRF, dx & dy are in meters, and no cos(lat) is needed +! ??? maybe should incorporate map factor here, +! and also for areaeast & areanorth ??? + +! gridarea=dxoutn*dyoutn + + do ix=0,numxgridn-1 +! xl1=(real(ix)*dxoutn+out_xm0n)/dx +! yl1=(real(jy)*dyoutn+out_ym0n)/dy +! xl2=(real(ix+1)*dxoutn+out_xm0n)/dx +! yl2=(real(jy+1)*dyoutn+out_ym0n)/dy +!! xr=out_xm0+real(numxgrid)*dxout +! m1=0.5*(m_x(int(xl1),int(yl1),1)+m_x(int(xl2),int(yl1),1)) +! m2=0.5*(m_y(int(xl1),int(yl1),1)+m_x(int(xl1),int(yl2),1)) +! arean(ix,jy)=dxoutn*m1*dyoutn*m2 + +! A more precise method + tmpx=out_xm0n+(float(ix))*dxoutn + tmpy=out_ym0n+(float(jy))*dyoutn + call xymeter_to_ll_wrf_out(tmpx,tmpy,lon2(1),lat2(1)) + tmpx=out_xm0n+(float(ix+1))*dxoutn + tmpy=out_ym0n+(float(jy))*dyoutn + call xymeter_to_ll_wrf_out(tmpx,tmpy,lon2(2),lat2(2)) + tmpx=out_xm0n+(float(ix+1))*dxoutn + tmpy=out_ym0n+(float(jy+1))*dyoutn + call xymeter_to_ll_wrf_out(tmpx,tmpy,lon2(3),lat2(3)) + tmpx=out_xm0n+(float(ix))*dxoutn + tmpy=out_ym0n+(float(jy+1))*dyoutn + call xymeter_to_ll_wrf_out(tmpx,tmpy,lon2(4),lat2(4)) + area1=sphere01_polygon_area ( 4, real(lat2,kind=8), real(lon2,kind=8) ) + arean(ix,jy)=real(area1)*6370000.*6370000./coefdx/coefdx + +! 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 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 +! for FLEXPART_WRF, x & y coords are in meters, +! and the lon & lat variables below are in meters. + ymet=out_ym0n+(real(jjy)+real(j1)/10.-0.05)*dyoutn + yl=(ymet-ymet0)/dy + do i1=1,10 + xmet=out_xm0n+(real(iix)+real(i1)/10.-0.05)*dxoutn + xl=(xmet-xmet0)/dx + +! Determine the nest we are in +!***************************** + + ngrid=0 + do j=numbnests,1,-1 + if ((xl.gt.xln(j)).and.(xl.lt.xrn(j)).and. & + (yl.gt.yln(j)).and.(yl.lt.yrn(j))) 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 + + + ! 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) + allocate(drygriduncn2(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 + + !write (*,*) 'Dimensions for fields', numxgrid,numygrid, & + ! maxspec,maxpointspec_act,nclassunc,maxageclass + + ! allocate fields for concoutput with maximum dimension of outgrid + ! and outgrid_nest + ! Initial condition field + + !************************ + ! Initialize 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_irreg + diff --git a/src_flexwrf_v3.1/outgrid_init_nest_reg.f90 b/src_flexwrf_v3.1/outgrid_init_nest_reg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7cbdf79320c30d26852a36c2add84a4b97cf2dcc --- /dev/null +++ b/src_flexwrf_v3.1/outgrid_init_nest_reg.f90 @@ -0,0 +1,266 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine outgrid_init_nest_reg +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine outgrid_init. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! This routine calculates, for each grid cell of the output grid, the * +! volume, the surface area, and the areas of the northward and eastward * +! facing surfaces. * +! * +! Author: A. Stohl * +! * +! 7 August 2002 * +! * +! 26 Oct 2005, R. Easter - changes in gridarea, areaeast, areanorth * +! associated with WRF horizontal grid. * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! July 2012, J Brioude - modified for regular output grid. * +!******************************************************************************* +! * +! 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 unc_mod + use outg_mod + use par_mod + use com_mod + +! include 'includepar' +! include 'includecom' + implicit none + integer :: ix,jy,kz,k,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid + real :: ylat,gridarea,ylatp,ylatm,hzone,cosfact,cosfactm,cosfactp + real :: ymet,xlon + real :: xmet,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh + integer :: ks,kp,stat + 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,numygridn-1 + + ylat=outlat0n+(real(jy)+0.5)*dyoutln + ylatp=ylat+0.5*dyoutln + ylatm=ylat-0.5*dyoutln + if ((ylatm.lt.0).and.(ylatp.gt.0.)) then + hzone=dyoutln*r_earth*pi180 + else + +!C Calculate area of grid cell with formula M=2*pi*R*h*dx/360, +!C see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90 +!************************************************************* +! + cosfact=cos(ylat*pi180)*r_earth + cosfactp=cos(ylatp*pi180)*r_earth + cosfactm=cos(ylatm*pi180)*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 + +!C Surface are of a grid cell at a latitude ylat +!*********************************************** +! + gridarea=2.*pi*r_earth*hzone*dxoutln/360. + +! for FLEXPART_WRF, dx & dy are in meters, and no cos(lat) is needed +! ??? maybe should incorporate map factor here, +! and also for areaeast & areanorth ??? +! gridarea=dxoutn*dyoutn + + 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 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 +! for FLEXPART_WRF, x & y coords are in meters, +! and the lon & lat variables below are in meters. + ylat=outlat0n+(float(jjy)+float(j1)/10.-0.05)*dyoutln !in degrees +! ymet=out_ym0n+(real(jjy)+real(j1)/10.-0.05)*dyoutn +! yl=(ymet-ymet0)/dy + do i1=1,10 + xlon=outlon0n+(float(iix)+float(i1)/10.-0.05)*dxoutln !in degrees +! xmet=out_xm0n+(real(iix)+real(i1)/10.-0.05)*dxoutn + call ll_to_xymeter_wrf(xlon,ylat,xmet,ymet) + yl=(ymet-ymet0)/dy + xl=(xmet-xmet0)/dx +! xl=(xmet-xmet0)/dx + +! Determine the nest we are in +!***************************** + + ngrid=0 + do j=numbnests,1,-1 + if ((xl.gt.xln(j)).and.(xl.lt.xrn(j)).and. & + (yl.gt.yln(j)).and.(yl.lt.yrn(j))) 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 + + + ! 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) + allocate(drygriduncn2(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 + + !write (*,*) 'Dimensions for fields', numxgrid,numygrid, & + ! maxspec,maxpointspec_act,nclassunc,maxageclass + + ! allocate fields for concoutput with maximum dimension of outgrid + ! and outgrid_nest + ! Initial condition field + + !************************ + ! Initialize 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_reg + diff --git a/src_flexwrf_v3.1/outgrid_init_reg.f90 b/src_flexwrf_v3.1/outgrid_init_reg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..63d69f80335a0e5a31c19f1d110d69365a9a271f --- /dev/null +++ b/src_flexwrf_v3.1/outgrid_init_reg.f90 @@ -0,0 +1,362 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine outgrid_init_reg() +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine outgrid_init. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! This routine calculates, for each grid cell of the output grid, the * +! volume, the surface area, and the areas of the northward and eastward * +! facing surfaces. * +! * +! Author: A. Stohl * +! * +! 7 August 2002 * +! * +! 26 Oct 2005, R. Easter - changes in gridarea, areaeast, areanorth * +! associated with WRF horizontal grid. * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! July 2012, J. Brioude - modified for regular output grid * +!******************************************************************************* +! * +! 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 + +! include 'includepar' +! include 'includecom' + implicit none + integer :: ix,jy,kz,k,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid + real :: ylat,gridarea,ylatp,ylatm,hzone,cosfact,cosfactm,cosfactp + real :: ymet,xlon + real :: xmet,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh + integer :: ks,kp,stat + 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+(float(jy)+0.5)*dyoutl + ylatp=ylat+0.5*dyoutl + ylatm=ylat-0.5*dyoutl + if ((ylatm.lt.0).and.(ylatp.gt.0.)) then + hzone=dyoutl*r_earth*pi180 + else + cosfact=cos(ylat*pi180)*r_earth + cosfactp=cos(ylatp*pi180)*r_earth + cosfactm=cos(ylatm*pi180)*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 +! +!C Surface are of a grid cell at a latitude ylat +!*********************************************** +! + gridarea=2.*pi*r_earth*hzone*dxoutl/360. + +! for FLEXPART_WRF, dx & dy are in meters, and no cos(lat) is needed +! ??? maybe should incorporate map factor here, +! and also for areaeast & areanorth ??? +! gridarea=dxout*dyout + + do ix=0,numxgrid-1 + area(ix,jy)=gridarea +! Volume = area x box height +!*************************** + + volume(ix,jy,1)=area(ix,jy)*outheight(1) + +! for FLEXPART_WRF, dx & dy are in meters, and no cos(lat) is needed + areaeast(ix,jy,1)=dyoutl*r_earth*pi180*outheight(1) + areanorth(ix,jy,1)=cos(ylat*pi180)*dxoutl*r_earth*pi180* & + outheight(1) +! areaeast(ix,jy,1)=dyout*outheight(1) +! areanorth(ix,jy,1)=dxout*outheight(1) + + do kz=2,numzgrid + + areaeast(ix,jy,kz)=dyoutl*r_earth*pi180* & + (outheight(kz)-outheight(kz-1)) + areanorth(ix,jy,kz)=cos(ylat*pi180)*dxoutl*r_earth*pi180* & + (outheight(kz)-outheight(kz-1)) +! areaeast(ix,jy,kz)=dyout*(outheight(kz)-outheight(kz-1)) +! areanorth(ix,jy,kz)=dxout*(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 +! for FLEXPART_WRF, x & y coords are in meters, +! and the lon & lat variables below are in meters. + ylat=outlat0+(float(jjy)+float(j1)/10.-0.05)*dyoutl !in degrees +! ymet=out_ym0+(real(jjy)+real(j1)/10.-0.05)*dyout +! yl=(ymet-ymet0)/dy + do i1=1,10 + xlon=outlon0+(float(iix)+float(i1)/10.-0.05)*dxoutl !in degrees + call ll_to_xymeter_wrf(xlon,ylat,xmet,ymet) + yl=(ymet-ymet0)/dy + xl=(xmet-xmet0)/dx + +! xmet=out_xm0+(real(iix)+real(i1)/10.-0.05)*dxout +! xl=(xmet-xmet0)/dx + +! Determine the nest we are in +!***************************** + + ngrid=0 + do j=numbnests,1,-1 + if ((xl.gt.xln(j)).and.(xl.lt.xrn(j)).and. & + (yl.gt.yln(j)).and.(yl.lt.yrn(j))) 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' + + print*,'alloc gridunc',numxgrid-1,numygrid-1,numzgrid,maxspec, & + maxpointspec_act,nclassunc,maxageclass + 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' + allocate(drygridunc2(0:numxgrid-1,0:numygrid-1,maxspec, & + maxpointspec_act,nclassunc,maxageclass),stat=stat) + 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) + allocate(grid2(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1,numzgrid,maxpointspec_act),stat=stat) + allocate(grid3(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1,numzgrid,maxpointspec_act),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) + allocate(wetgrid2(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1,maxpointspec_act),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) + allocate(drygrid2(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1,maxpointspec_act),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_reg + diff --git a/src_flexwrf_v3.1/par_mod.f90 b/src_flexwrf_v3.1/par_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b02bd56e5366523a8a8004d1dc5273cd98259842 --- /dev/null +++ b/src_flexwrf_v3.1/par_mod.f90 @@ -0,0 +1,290 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +! * +!* This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +!******************************************************************************* +! 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=3 + + ! 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,weightair=28.97 + real,parameter :: cpa=1004.6, kappa=0.286, pi180=pi/180., vonkarman=0.4 + logical :: strswitch + ! 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=364,nymax=244,nuvzmax=45,nwzmax=45,nzmax=45 + !integer,parameter :: nxmax=454,nymax=334,nuvzmax=45,nwzmax=45,nzmax=45 + integer,parameter :: nxmax=334,nymax=334,nuvzmax=61,nwzmax=61,nzmax=61 + !integer,parameter :: nxmax=182,nymax=182,nuvzmax=61,nwzmax=61,nzmax=61 + !integer,parameter :: nxmax=1081,nymax=260,nuvzmax=89,nwzmax=89,nzmax=89 + + !integer,parameter :: nxmax=45,nymax=33,nuvzmax=45,nwzmax=45,nzmax=45 + !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=0, nxmaxn=0, nymaxn=0 + integer,parameter :: maxnests=1,nxmaxn=312,nymaxn=312 + !integer,parameter :: maxnests=1,nxmaxn=312,nymaxn=312 + + ! 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=3,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 + + + integer,parameter :: turb_option_none=0 + integer,parameter :: turb_option_diagnosed=1 + integer,parameter :: turb_option_tke=2 + integer,parameter :: turb_option_mytke=3 + integer,parameter :: sfc_option_diagnosed=0 + integer,parameter :: sfc_option_wrf=1 + integer,parameter :: partoutput_use_nested=1 + !************************************************** + ! Maximum number of particles, species, and similar + !************************************************** + + integer :: maxpart=1 + integer,parameter :: maxspec=11 + + + ! 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 :: newrandomgen = 0 !added by mc to select teh new parallel random generator ; 0 is the old one if zero is chosen then adjust teh definition of rannumb and uniform_rannumb in com_mod.f90 +! integer :: newrandomgen = 0 ! JB version + + integer,parameter :: maxrand=5000000 !comment by mc: maximum number of gasussina distributed and random distributed random number for a single mpi_process + ! maxrand number of random numbers used + integer, parameter :: MAX_STREAM = 12 !added by mc : maximum total number of stream initilized (i.e. avilable) for the MT generator. + + integer,parameter :: maxomp=12 + integer,parameter :: maxrandomp=maxrand*maxomp + integer,parameter :: maxrand3=maxrand*(newrandomgen+maxomp*(1-newrandomgen)) + + !***************************************************** + ! 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=3, unitreleases=1, 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 + + ! CDA implementing a quick fix for the wet deposition scheme + !****************************************************** + ! integer code for missing values, used in wet scavenging (PS, 2012) + !****************************************************** + + integer icmv + parameter(icmv=-9999) + +end module par_mod diff --git a/src_flexwrf_v3.1/part0.f90 b/src_flexwrf_v3.1/part0.f90 new file mode 100644 index 0000000000000000000000000000000000000000..79ffa286cfb9b565065ab36bcbd8ddff05f20197 --- /dev/null +++ b/src_flexwrf_v3.1/part0.f90 @@ -0,0 +1,135 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine 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 diff --git a/src_flexwrf_v3.1/partdep.f90 b/src_flexwrf_v3.1/partdep.f90 new file mode 100644 index 0000000000000000000000000000000000000000..358165c4f584838d787462b29d3843efa9b0043a --- /dev/null +++ b/src_flexwrf_v3.1/partdep.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/partoutput.f90 b/src_flexwrf_v3.1/partoutput.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e7d8623ba1f3818f137ee35fa0f6e964175792ab --- /dev/null +++ b/src_flexwrf_v3.1/partoutput.f90 @@ -0,0 +1,328 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine partoutput(itime) +! i +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine partoutput. * +! * +! Dump all particle positions * +! * +! Author: A. Stohl * +! 12 March 1999 * +! * +! Dec 2005, J. Fast - Output files can be either binary or ascii. * +! Topo,pv,qv,... at particle positions are calculated * +! using nested fields when (partoutput_use_nested .gt. 0) * +! Particle xy coords can be either lat-lon or grid-meters. * +! Changed names of "*lon0*" & "*lat0*" variables * +! * +!******************************************************************************* +! * +! Variables: * +! * +!******************************************************************************* + + use par_mod + use com_mod + + implicit none +! include 'includepar' +! include 'includecom' + + real(kind=dp) :: jul + integer :: itime,i,j,jjjjmmdd,ihmmss + integer :: ix,jy,ixp,jyp,indexh,m,il,ind,indz,indzp + integer :: numpart_out + real :: xlon,ylat,xtmp,ytmp + 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 + + integer :: k, ngrid + real :: xtn, ytn + + +! Determine current calendar date, needed for the file name +!********************************************************** + + jul=bdate+real(itime,kind=dp)/86400._dp ! this is the current day + + call caldate(jul,jjjjmmdd,ihmmss) + write(adate,'(i8.8)') jjjjmmdd + write(atime,'(i6.6)') ihmmss + + +! Some variables needed for temporal interpolation +!************************************************* + + dt1=float(itime-memtime(1)) + dt2=float(memtime(2)-itime) + dtt=1./(dt1+dt2) + +! Open output file and write the output +!************************************** + + if (ipout.eq.1) then + if (iouttype.eq.0) & + open(unitpartout,file=path(1)(1:length(1))//'partposit_'//adate// & + atime,form='unformatted') + if (iouttype.eq.1) & + open(unitpartout,file=path(1)(1:length(1))//'partposit_'//adate// & + atime,form='formatted') + else + if (iouttype.eq.0) & + open(unitpartout,file=path(1)(1:length(1))//'partposit_end', & + form='unformatted') + if (iouttype.eq.1) & + open(unitpartout,file=path(1)(1:length(1))//'partposit_end', & + form='formatted') + endif + +! Write current time to file +!*************************** + + numpart_out = 0 + do i=1,numpart + if (itra1(i).eq.itime) numpart_out = numpart_out + 1 + enddo + + if (iouttype.eq.0) write(unitpartout) itime, & + numpart_out, outgrid_option + if (iouttype.eq.1) write(unitpartout,*) itime, & + numpart_out, outgrid_option + + do i=1,numpart + +! Take only valid particles +!************************** + + if (itra1(i).eq.itime) then + xlon=xmet0+xtra1(i)*dx + ylat=ymet0+ytra1(i)*dy + +!********************************************************************************* +! Interpolate several variables (PV, specific humidity, etc.) to particle position +!********************************************************************************* + +! If partoutput_use_nested=0, set ngrid=0, and use the outermost grid +! for calculating topo, pv, qv, ... at the particle position +! Otherwise, determine the nest we are in + ngrid=0 + if (partoutput_use_nested .gt. 0) then + do k=numbnests,1,-1 + if ((xtra1(i).gt.xln(k)).and. & + (xtra1(i).lt.xrn(k)).and. & + (ytra1(i).gt.yln(k)).and. & + (ytra1(i).lt.yrn(k))) then + ngrid=k + goto 26 + endif + enddo +26 continue + endif + + if (ngrid .le. 0) then + ix=int(xtra1(i)) + jy=int(ytra1(i)) + ddy=ytra1(i)-float(jy) + ddx=xtra1(i)-float(ix) + else + xtn=(xtra1(i)-xln(ngrid))*xresoln(ngrid) + ytn=(ytra1(i)-yln(ngrid))*yresoln(ngrid) + ix=int(xtn) + jy=int(ytn) + ddy=ytn-float(jy) + ddx=xtn-float(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 + +! Topography +!*********** + if (ngrid .le. 0) then + topo=p1*oro(ix ,jy) & + + p2*oro(ixp,jy) & + + p3*oro(ix ,jyp) & + + p4*oro(ixp,jyp) + else + topo=p1*oron(ix ,jy ,ngrid) & + + p2*oron(ixp,jy ,ngrid) & + + p3*oron(ix ,jyp,ngrid) & + + p4*oron(ixp,jyp,ngrid) + endif + +! Potential vorticity, specific humidity, temperature, and density +!***************************************************************** + + do il=2,nz + if (height(il).gt.ztra1(i)) then + indz=il-1 + indzp=il + goto 56 + endif + enddo +56 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) + + if (ngrid .le. 0) then + ! 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) + else + pv1(m)=p1*pvn(ix ,jy ,ind,indexh,ngrid) & + +p2*pvn(ixp,jy ,ind,indexh,ngrid) & + +p3*pvn(ix ,jyp,ind,indexh,ngrid) & + +p4*pvn(ixp,jyp,ind,indexh,ngrid) + qv1(m)=p1*qvn(ix ,jy ,ind,indexh,ngrid) & + +p2*qvn(ixp,jy ,ind,indexh,ngrid) & + +p3*qvn(ix ,jyp,ind,indexh,ngrid) & + +p4*qvn(ixp,jyp,ind,indexh,ngrid) + tt1(m)=p1*ttn(ix ,jy ,ind,indexh,ngrid) & + +p2*ttn(ixp,jy ,ind,indexh,ngrid) & + +p3*ttn(ix ,jyp,ind,indexh,ngrid) & + +p4*ttn(ixp,jyp,ind,indexh,ngrid) + rho1(m)=p1*rhon(ix ,jy ,ind,indexh,ngrid) & + +p2*rhon(ixp,jy ,ind,indexh,ngrid) & + +p3*rhon(ix ,jyp,ind,indexh,ngrid) & + +p4*rhon(ixp,jyp,ind,indexh,ngrid) + + endif + + enddo + 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 + enddo + 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) + + if (ngrid .le. 0) then +! 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) + + else + tr(m)=p1*tropopausen(ix ,jy ,1,indexh,ngrid) & + + p2*tropopausen(ixp,jy ,1,indexh,ngrid) & + + p3*tropopausen(ix ,jyp,1,indexh,ngrid) & + + p4*tropopausen(ixp,jyp,1,indexh,ngrid) + hm(m)=p1*hmixn(ix ,jy ,1,indexh,ngrid) & + + p2*hmixn(ixp,jy ,1,indexh,ngrid) & + + p3*hmixn(ix ,jyp,1,indexh,ngrid) & + + p4*hmixn(ixp,jyp,1,indexh,ngrid) + + endif + + enddo + + hmixi=(hm(1)*dt2+hm(2)*dt1)*dtt + tri=(tr(1)*dt2+tr(2)*dt1)*dtt + + +! Write the output +!***************** + + if (outgrid_option .eq. 1) then + xtmp = xlon + ytmp = ylat + call xymeter_to_ll_wrf( xtmp, ytmp, xlon, ylat ) + endif + if(iouttype.eq.0) & + write(unitpartout) npoint(i),xlon,ylat,ztra1(i), & + itramem(i),topo,pvi,qvi,rhoi,hmixi,tri,tti, & + (xmass1(i,j),j=1,nspec) + if(iouttype.eq.1) & + write(unitpartout,101) npoint(i),itramem(i),xlon,ylat, & + ztra1(i),topo,pvi,qvi,rhoi,hmixi,tri,tti, & + (xmass1(i,j),j=1,nspec) + endif + + enddo + + if(iouttype.eq.0) & + 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) + if(iouttype.eq.1) & + write(unitpartout,101) -99999,-99999,-9999.9,-9999.9,-9999.9, & + -9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9,-9999.9, & + (-9999.9,j=1,nspec) + +101 format( 2i10, 1p, 21e14.6 ) + + + close(unitpartout) + +end subroutine partoutput + diff --git a/src_flexwrf_v3.1/pbl_profile.f90 b/src_flexwrf_v3.1/pbl_profile.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6bb8eae06984d765c293afc474aa8cf0179c5c47 --- /dev/null +++ b/src_flexwrf_v3.1/pbl_profile.f90 @@ -0,0 +1,134 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine 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 diff --git a/src_flexwrf_v3.1/plumetraj.f90 b/src_flexwrf_v3.1/plumetraj.f90 new file mode 100644 index 0000000000000000000000000000000000000000..41bcb9ef490a07a909c1702269fd47be645cacfd --- /dev/null +++ b/src_flexwrf_v3.1/plumetraj.f90 @@ -0,0 +1,290 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine plumetraj(itime) +! i +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine plumetraj. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 * +! * +! 26 Oct 2005, R. Easter - changes associated with WRF horizontal grid. * +! Calculate the distance between 2 points directly * +! instead of using the distance function. * +! Dec 2005, R. Easter - changed names of "*lon0*" & "*lat0*" variables * +! 2011 - J brioude: modified to have better output format * +!******************************************************************************* +! * +! 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 + + + 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 + + real :: xlon,ylat,xtmp,ytmp + + 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)=xmet0+xtra1(i)*dx + yl(n)=ymet0+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 +! for FLEXPART_WRF, x,y coords are in meters, so xl,yl are in meters +! dist=distance(yl(k),xl(k),ycenter,xcenter) +!jdf +! if (outgrid_option .eq. 1) then + dist=sqrt( (yl(k)-ycenter)**2 + (xl(k)-xcenter)**2 ) + rmsdist=rmsdist+dist*dist +! endif + enddo +! if (outgrid_option .eq. 0) then + xtmp = xcenter + ytmp = ycenter + call xymeter_to_ll_wrf( xtmp, ytmp, xlon, ylat ) + xcenter = xlon + ycenter = ylat + +! xtmp = xl(k) +! ytmp = yl(k) +! call xymeter_to_ll_wrf( xtmp, ytmp, xlon, ylat ) +! dist=sqrt( (ylat-ycenter)**2 + (xlon-xcenter)**2 ) +! rmsdist=rmsdist+dist*dist +! endif +!jdf + +! end do + do k=1,ncluster +! if (outgrid_option .eq. 0) then + xtmp = xclust(k) + ytmp = yclust(k) + call xymeter_to_ll_wrf( xtmp, ytmp, xlon, ylat ) + xclust(k) = xlon + yclust(k) = ylat +! endif +! print*,xclust(k),yclust(k) + enddo + if (rmsdist.gt.0.) rmsdist=sqrt(rmsdist/real(n)) + rmsdist=max(rmsdist,0.) + +! Write out results in trajectory data file +!****************************************** + + write(unitouttraj,'(i5,1x,i8,1x,2f9.4,1x,4f8.1,1x,f8.2,1x,4f8.1,1x,3f6.1,& + &5(1x,2f9.3,1x,f7.0,1x,f6.1,1x,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 + enddo + +end subroutine plumetraj + diff --git a/src_flexwrf_v3.1/point_mod.f90 b/src_flexwrf_v3.1/point_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..05b486123904d139aae186f700e30f978dcd93a0 --- /dev/null +++ b/src_flexwrf_v3.1/point_mod.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 (:) :: xpoint12 + real,allocatable, dimension (:) :: xpoint22 + real,allocatable, dimension (:) :: ypoint12 + real,allocatable, dimension (:) :: ypoint22 + real,allocatable, dimension (:) :: releases_swlon + real,allocatable, dimension (:) :: releases_swlat + real,allocatable, dimension (:) :: releases_nelon + real,allocatable, dimension (:) :: releases_nelat + + real,allocatable, dimension (:,:) :: xmass + real,allocatable, dimension (:) :: rho_rel + +end module point_mod diff --git a/src_flexwrf_v3.1/pre_redist_kf.f90 b/src_flexwrf_v3.1/pre_redist_kf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..eefb0b92f819b4eaf55951374a25c088070462cd --- /dev/null +++ b/src_flexwrf_v3.1/pre_redist_kf.f90 @@ -0,0 +1,134 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! 8/30/2007 Created by Weiguo Wang +! Notes: +! THIS CODE IS TO prepare meteorology data for REDISTRIBUTing PARTICLES +! INVOLVED IN UPDRAFT OR/AND DOWDRAFT +! Estimate fraction of particles that may be well-mixed (for well-mixing option) + +! prob of particle involving in clouds can be pre-computed here. will optimize code later + + +! SUBROUTINE NAME: pre_redist_kf +! INPUT: +! nuvzmax-- max # of layers of flux +! nuvz -- # of layer for work array +! umf -- updraft mass flux (kg/s ?) +! dmf -- downdraft mass flux +! dz -- different height between full levels (m) +! p1d -- press (pa) +! dx -- horizontal grid size(m) +! dt -- time step (s) +!C cu_top1 -- cloud top index, zh(cu_top1) +!C cu_bot1 -- cloud bottom index, ,zh(cu_bot1) +! OUTPUT: +! zf -- height above ground level at full levels (ddz) +! zh -- height above ground level at half levels +! only for option of simple mixing +! +! umfzf -- normalized updraft mass flux*distance,min=0,max=1 +! dmfzf -- normalized downdraft mass flux*distance +! fmix -- fraction of paricels in cloud levels is mixed +! CALLED by convmix_kf.f +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + Subroutine pre_redist_kf(nuvzmax,nuvz,umf,dmf,dz,p1d,dx,dt, & ! IN & + cu_bot1,cu_top1, & ! IN + zf,zh, & ! OUT + umfzf,dmfzf,fmix) ! OUT + + IMPLICIT NONE + integer :: nuvzmax,nuvz,ldirection,n1,i,j,k + real :: cu_bot1,cu_top1,dx,dt + real,dimension(nuvzmax) :: umf,dmf,dz,umfdz,dmfdz,zh, & + p1d + + real,dimension(nuvzmax+1) :: dmfzf,umfzf,zf + real :: t1,t2,fmix,mass + +! Compute flux height, here height is above the ground level + + zf(1)=0.0 ! ground level + do i=2,nuvz+1 + zf(i) = zf(i-1) + dz(i) + zh(i-1) = 0.5*( zf(i-1) + zf(i) ) + enddo + +!! cululative dz in cloud level, for reposition option 'well-mixed' + do i=1,nuvz + umfdz(i) = 0.0 + dmfdz(i) = 0.0 + if(umf(i).ne.0.0 .and. i.le.int(cu_top1) & + .and.i.ge.int(cu_bot1)) umfdz(i)=dz(i) ! mixed within cloud +! if(umf(i).ne.0.0 .and. i.le.int(cu_top1) ! mixed between ground and cloud top +! & ) umfdz(i)=dz(i) + + if(dmf(i).ne.0.0) dmfdz(i)=dz(i) + enddo +! assume zero umf or dmf means no-cloud area +! Nomalize non-zero values (cloud up/downdraft) + t1 = 0.0 + t2 = 0.0 + do i=1,nuvz + t1=t1+umfdz(i) + t2=t2+dmfdz(i) + enddo + + if (t1 .gt. 0.0) then + do i=1,nuvz + umfdz(i)=umfdz(i)/t1 + enddo + endif + if (t2 .gt. 0.0) then + DO i=1,nuvz + dmfdz(i)=dmfdz(i)/t2 + ENDDO + endif + +! Weighted distance stating 0, ending 1.0 + umfzf(1)=0.0 + dmfzf(1)=0.0 + Do i=2,nuvz+1 + umfzf(i)=0.0 + dmfzf(i)=0.0 + if (i .le. int(cu_top1)) & + umfzf(i)=umfzf(i-1)+abs(umfdz(i-1)) + + dmfzf(i)=dmfzf(i-1)+abs(dmfdz(i-1)) + if (i .eq. 2)write(*,*)'int(cu_top1)=',int(cu_top1) +! write(*,*)i,umfzf(i),umfdz(i) + ENDdo +! estimate fraction of particles in the convective column will be mixed by cloud +! fmix=updraft flux at cloud base*dt/mass below cloud +! fmix*dt=fraction + mass=abs(p1d(1)-p1d( int(cu_bot1) )) + if (mass .le. 5000.0) mass=5000.0 + mass=dx*dx*mass/9.81 + fmix=abs(umf(int(cu_bot1)))*dt/mass + write(*,*)'PRE_redist_kf.f, mass=,fmix=',mass,fmix + + return + end subroutine pre_redist_kf + + diff --git a/src_flexwrf_v3.1/psih.f90 b/src_flexwrf_v3.1/psih.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d1116c4a581bb676c50c24e14e888e955a44946c --- /dev/null +++ b/src_flexwrf_v3.1/psih.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/psim.f90 b/src_flexwrf_v3.1/psim.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d1d570b6ed1143839128cadd734dfee8db483e07 --- /dev/null +++ b/src_flexwrf_v3.1/psim.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/qvsat.f90 b/src_flexwrf_v3.1/qvsat.f90 new file mode 100644 index 0000000000000000000000000000000000000000..55692ded240cc3a854e572d54b5f66a317a7a717 --- /dev/null +++ b/src_flexwrf_v3.1/qvsat.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +!################################################################## +!################################################################## +!###### ###### +!###### 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 diff --git a/src_flexwrf_v3.1/raerod.f90 b/src_flexwrf_v3.1/raerod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..50205c5c95b7562ba2b02dcfb84970edc82db852 --- /dev/null +++ b/src_flexwrf_v3.1/raerod.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/ran_mod.f90 b/src_flexwrf_v3.1/ran_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..36fd3f4962bb060371d099d4f277b1ba298af1be --- /dev/null +++ b/src_flexwrf_v3.1/ran_mod.f90 @@ -0,0 +1,12 @@ + + module ran_mod + + !includes OH concentration field as well as the height information + !for this field + + implicit none + integer :: inext,inextp,iff + integer :: ma(55),idummy + common /random/ inext,inextp,iff,ma,idummy +end module ran_mod + diff --git a/src_flexwrf_v3.1/random.f90 b/src_flexwrf_v3.1/random.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b83821880ff814ca1df6d8e8cce1982cd48a4e73 --- /dev/null +++ b/src_flexwrf_v3.1/random.f90 @@ -0,0 +1,155 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +! 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,inext,inextp,ma,iff) + + implicit none + + integer :: idum + real :: random1, random2, fac, v1, v2, r + integer :: inext,inextp,ma(55),iff + real, external :: ran3 + +1 v1=2.*ran3(idum,inext,inextp,ma,iff)-1. + v2=2.*ran3(idum,inext,inextp,ma,iff)-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,inext,inextp,ma,iff) + + 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 + + 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. diff --git a/src_flexwrf_v3.1/ranlux.f90 b/src_flexwrf_v3.1/ranlux.f90 new file mode 100644 index 0000000000000000000000000000000000000000..49949aad0ed3c0a3ae1610ecfcda6a2e0bdaa393 --- /dev/null +++ b/src_flexwrf_v3.1/ranlux.f90 @@ -0,0 +1,528 @@ + + MODULE luxury + +! Subtract-and-borrow random number generator proposed by +! Marsaglia and Zaman, implemented by F. James with the name +! RCARRY in 1991, and later improved by Martin Luescher +! in 1993 to produce "Luxury Pseudorandom Numbers". +! Fortran 77 coded by F. James, 1993 + +! References: +! M. Luscher, Computer Physics Communications 79 (1994) 100 +! F. James, Computer Physics Communications 79 (1994) 111 + +! LUXURY LEVELS. +! ------ ------ The available luxury levels are: + +! level 0 (p=24): equivalent to the original RCARRY of Marsaglia +! and Zaman, very long period, but fails many tests. +! level 1 (p=48): considerable improvement in quality over level 0, +! now passes the gap test, but still fails spectral test. +! level 2 (p=97): passes all known tests, but theoretically still +! defective. +! level 3 (p=223): DEFAULT VALUE. Any theoretically possible +! correlations have very small chance of being observed. +! level 4 (p=389): highest possible luxury, all 24 bits chaotic. + +!!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +!!!! Calling sequences for RANLUX: ++ +!!!! CALL RANLUX (RVEC, LEN) returns a vector RVEC of LEN ++ +!!!! 32-bit random floating point numbers between ++ +!!!! zero (not included) and one (also not incl.). ++ +!!!! CALL RLUXGO(LUX,INT,K1,K2) initializes the generator from ++ +!!!! one 32-bit integer INT and sets Luxury Level LUX ++ +!!!! which is integer between zero and MAXLEV, or if ++ +!!!! LUX .GT. 24, it sets p=LUX directly. K1 and K2 ++ +!!!! should be set to zero unless restarting at a break++ +!!!! point given by output of RLUXAT (see RLUXAT). ++ +!!!! CALL RLUXAT(LUX,INT,K1,K2) gets the values of four integers++ +!!!! which can be used to restart the RANLUX generator ++ +!!!! at the current point by calling RLUXGO. K1 and K2++ +!!!! specify how many numbers were generated since the ++ +!!!! initialization with LUX and INT. The restarting ++ +!!!! skips over K1+K2*E9 numbers, so it can be long.++ +!!!! A more efficient but less convenient way of restarting is by: ++ +!!!! CALL RLUXIN(ISVEC) restarts the generator from vector ++ +!!!! ISVEC of 25 32-bit integers (see RLUXUT) ++ +!!!! CALL RLUXUT(ISVEC) outputs the current values of the 25 ++ +!!!! 32-bit integer seeds, to be used for restarting ++ +!!!! ISVEC must be dimensioned 25 in the calling program ++ +!!!! ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +IMPLICIT NONE + +INTEGER :: iseeds(24), isdext(25) +INTEGER, PARAMETER :: maxlev = 4, lxdflt = 3 +INTEGER :: ndskip(0:maxlev) = (/ 0, 24, 73, 199, 365 /) +INTEGER :: next(24), igiga = 1000000000, jsdflt = 314159265 +REAL, PARAMETER :: twop12 = 4096. +INTEGER, PARAMETER :: itwo24 = 2**24, icons = 2147483563 +INTEGER :: luxlev = lxdflt, nskip, inseed, jseed +LOGICAL :: notyet = .true. +INTEGER :: in24 = 0, kount = 0, mkount = 0, i24 = 24, j24 = 10 +REAL :: seeds(24), carry = 0., twom24, twom12 + +! default +! Luxury Level 0 1 2 *3* 4 +! ndskip /0, 24, 73, 199, 365/ +! Corresponds to p=24 48 97 223 389 +! time factor 1 2 3 6 10 on slow workstation +! 1 1.5 2 3 5 on fast mainframe + +PUBLIC notyet, i24, j24, carry, seeds, twom24, twom12, luxlev +PUBLIC nskip, ndskip, in24, next, kount, mkount, inseed + + +CONTAINS + + +SUBROUTINE ranlux(rvec, lenv) + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: lenv +REAL, INTENT(OUT) :: rvec(lenv) + +! Local variables + +INTEGER :: i, k, lp, ivec, isk +REAL :: uni + +! NOTYET is .TRUE. if no initialization has been performed yet. +! Default Initialization by Multiplicative Congruential + +IF (notyet) THEN + notyet = .false. + jseed = jsdflt + inseed = jseed + WRITE (6,'(A,I12)') ' RANLUX DEFAULT INITIALIZATION: ', jseed + luxlev = lxdflt + nskip = ndskip(luxlev) + lp = nskip + 24 + in24 = 0 + kount = 0 + mkount = 0 + WRITE (6,'(A,I2,A,I4)') ' RANLUX DEFAULT LUXURY LEVEL = ', luxlev, & + ' p =', lp + twom24 = 1. + DO i = 1, 24 + twom24 = twom24 * 0.5 + k = jseed / 53668 + jseed = 40014 * (jseed-k*53668) - k * 12211 + IF (jseed.LT.0) jseed = jseed + icons + iseeds(i) = MOD(jseed,itwo24) + END DO + twom12 = twom24 * 4096. + DO i = 1, 24 + seeds(i) = REAL(iseeds(i)) * twom24 + next(i) = i - 1 + END DO + next(1) = 24 + i24 = 24 + j24 = 10 + carry = 0. + IF (seeds(24).EQ.0.) carry = twom24 +END IF + +! The Generator proper: "Subtract-with-borrow", +! as proposed by Marsaglia and Zaman, +! Florida State University, March, 1989 + +DO ivec = 1, lenv + uni = seeds(j24) - seeds(i24) - carry + IF (uni.LT.0.) THEN + uni = uni + 1.0 + carry = twom24 + ELSE + carry = 0. + END IF + seeds(i24) = uni + i24 = next(i24) + j24 = next(j24) + rvec(ivec) = uni +! small numbers (with less than 12 "significant" bits) are "padded". + IF (uni.LT.twom12) THEN + rvec(ivec) = rvec(ivec) + twom24 * seeds(j24) +! and zero is forbidden in case someone takes a logarithm + IF (rvec(ivec).EQ.0.) rvec(ivec) = twom24 * twom24 + END IF +! Skipping to luxury. As proposed by Martin Luscher. + in24 = in24 + 1 + IF (in24.EQ.24) THEN + in24 = 0 + kount = kount + nskip + DO isk = 1, nskip + uni = seeds(j24) - seeds(i24) - carry + IF (uni.LT.0.) THEN + uni = uni + 1.0 + carry = twom24 + ELSE + carry = 0. + END IF + seeds(i24) = uni + i24 = next(i24) + j24 = next(j24) + END DO + END IF +END DO +kount = kount + lenv +IF (kount.GE.igiga) THEN + mkount = mkount + 1 + kount = kount - igiga +END IF +RETURN + +END SUBROUTINE ranlux + + +! Subroutine to input and float integer seeds from previous run +SUBROUTINE rluxin +! the following IF BLOCK added by Phillip Helbig, based on conversation +! with Fred James; an equivalent correction has been published by James. + +IMPLICIT NONE + +! Local variables + +INTEGER :: i, isd + +IF (notyet) THEN + WRITE (6,'(A)') ' Proper results ONLY with initialisation from 25 ', & + 'integers obtained with RLUXUT' + notyet = .false. +END IF + +twom24 = 1. +DO i = 1, 24 + next(i) = i - 1 + twom24 = twom24 * 0.5 +END DO +next(1) = 24 +twom12 = twom24 * 4096. +WRITE (6,'(A)') ' FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS:' +WRITE (6,'(5X,5I12)') isdext +DO i = 1, 24 + seeds(i) = REAL(isdext(i)) * twom24 +END DO +carry = 0. +IF (isdext(25).LT.0) carry = twom24 +isd = IABS(isdext(25)) +i24 = MOD(isd,100) +isd = isd / 100 +j24 = MOD(isd,100) +isd = isd / 100 +in24 = MOD(isd,100) +isd = isd / 100 +luxlev = isd +IF (luxlev.LE.maxlev) THEN + nskip = ndskip(luxlev) + WRITE (6,'(A,I2)') ' RANLUX LUXURY LEVEL SET BY RLUXIN TO: ', luxlev +ELSE IF (luxlev.GE.24) THEN + nskip = luxlev - 24 + WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXIN TO:', luxlev +ELSE + nskip = ndskip(maxlev) + WRITE (6,'(A,I5)') ' RANLUX ILLEGAL LUXURY RLUXIN: ', luxlev + luxlev = maxlev +END IF +inseed = -1 +RETURN + +END SUBROUTINE rluxin + + +! Subroutine to ouput seeds as integers +SUBROUTINE rluxut + +IMPLICIT NONE + +! Local variables + +INTEGER :: i + +DO i = 1, 24 + isdext(i) = INT(seeds(i)*twop12*twop12) +END DO +isdext(25) = i24 + 100 * j24 + 10000 * in24 + 1000000 * luxlev +IF (carry.GT.0.) isdext(25) = -isdext(25) +RETURN + +END SUBROUTINE rluxut + + +! Subroutine to output the "convenient" restart point +SUBROUTINE rluxat(lout, inout, k1, k2) + +IMPLICIT NONE + +INTEGER, INTENT(OUT) :: lout, inout, k1, k2 + +lout = luxlev +inout = inseed +k1 = kount +k2 = mkount +RETURN + +END SUBROUTINE rluxat + + +! Subroutine to initialize from one or three integers +SUBROUTINE rluxgo(lux, ins, k1, k2) + +IMPLICIT NONE + +INTEGER, INTENT(IN) :: lux, ins, k1, k2 + +! Local variables + +INTEGER :: ilx, i, iouter, isk, k, inner, izip, izip2 +REAL :: uni + +IF (lux.LT.0) THEN + luxlev = lxdflt +ELSE IF (lux.LE.maxlev) THEN + luxlev = lux +ELSE IF (lux.LT.24.OR.lux.GT.2000) THEN + luxlev = maxlev + WRITE (6,'(A,I7)') ' RANLUX ILLEGAL LUXURY RLUXGO: ', lux +ELSE + luxlev = lux + DO ilx = 0, maxlev + IF (lux.EQ.ndskip(ilx)+24) luxlev = ilx + END DO +END IF +IF (luxlev.LE.maxlev) THEN + nskip = ndskip(luxlev) + WRITE (6,'(A,I2,A,I4)') ' RANLUX LUXURY LEVEL SET BY RLUXGO :', luxlev, & + ' P=', nskip + 24 +ELSE + nskip = luxlev - 24 + WRITE (6,'(A,I5)') ' RANLUX P-VALUE SET BY RLUXGO TO:', luxlev +END IF +in24 = 0 +IF (ins.LT.0) WRITE (6,'(A)') & + ' Illegal initialization by RLUXGO, negative input seed' +IF (ins.GT.0) THEN + jseed = ins + WRITE (6,'(A,3I12)') ' RANLUX INITIALIZED BY RLUXGO FROM SEEDS', jseed, k1, k2 +ELSE + jseed = jsdflt + WRITE (6,'(A)') ' RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED' +END IF +inseed = jseed +notyet = .false. +twom24 = 1. +DO i = 1, 24 + twom24 = twom24 * 0.5 + k = jseed / 53668 + jseed = 40014 * (jseed-k*53668) - k * 12211 + IF (jseed.LT.0) jseed = jseed + icons + iseeds(i) = MOD(jseed,itwo24) +END DO +twom12 = twom24 * 4096. +DO i = 1, 24 + seeds(i) = REAL(iseeds(i)) * twom24 + next(i) = i - 1 +END DO +next(1) = 24 +i24 = 24 +j24 = 10 +carry = 0. +IF (seeds(24).EQ.0.) carry = twom24 +! If restarting at a break point, skip K1 + IGIGA*K2 +! Note that this is the number of numbers delivered to +! the user PLUS the number skipped (if luxury .GT. 0). +kount = k1 +mkount = k2 +IF (k1+k2.NE.0) THEN + DO iouter = 1, k2 + 1 + inner = igiga + IF (iouter.EQ.k2+1) inner = k1 + DO isk = 1, inner + uni = seeds(j24) - seeds(i24) - carry + IF (uni.LT.0.) THEN + uni = uni + 1.0 + carry = twom24 + ELSE + carry = 0. + END IF + seeds(i24) = uni + i24 = next(i24) + j24 = next(j24) + END DO + END DO +! Get the right value of IN24 by direct calculation + in24 = MOD(kount,nskip+24) + IF (mkount.GT.0) THEN + izip = MOD(igiga, nskip+24) + izip2 = mkount * izip + in24 + in24 = MOD(izip2, nskip+24) + END IF +! Now IN24 had better be between zero and 23 inclusive + IF (in24.GT.23) THEN + WRITE (6,'(A/A,3I11,A,I5)') & + ' Error in RESTARTING with RLUXGO:', ' The values', ins, & + k1, k2, ' cannot occur at luxury level', luxlev + in24 = 0 + END IF +END IF +RETURN + +END SUBROUTINE rluxgo + + +END MODULE luxury + + + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +subroutine luxtst +! Exercise for the RANLUX Pseudorandom number generator. + +USE luxury + +IMPLICIT NONE + +REAL :: rvec(1000) +INTEGER :: i1, i2, i3, i4, li + +! check that we get the right numbers (machine-indep.) +WRITE (6,'(/A)') ' CALL RANLUX(RVEC,100)' +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX default numbers 1- 5:', rvec(1:5) +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX default numbers 101-105:', rvec(1:5) + +WRITE (6,'(/A)') ' CALL RLUXGO(0,0,0,0)' +CALL rluxgo(0,0,0,0) +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX luxury level 0, 1- 5:', rvec(1:5) +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX luxury level 0, 101-105:', rvec(1:5) + +WRITE (6,'(/A)') ' CALL RLUXGO(389,1,0,0)' +CALL rluxgo(389,1,0,0) +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX luxury p=389, 1- 5:', rvec(1:5) +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX luxury p=389, 101-105:', rvec(1:5) + +WRITE (6,'(/A)') ' CALL RLUXGO(75,0,0,0)' +CALL rluxgo(75,0,0,0) +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX luxury p= 75, 1- 5:', rvec(1:5) +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX luxury p= 75, 101-105:', rvec(1:5) + +WRITE (6,'(/A)') ' test restarting from the full vector' +CALL rluxut +WRITE (6,'(/A/(1X,5I14))') ' current RANLUX status saved:', isdext +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX numbers 1- 5:', rvec(1:5) +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX numbers 101-105:', rvec(1:5) + +WRITE (6,'(/A)') ' previous RANLUX status will be restored' +CALL rluxin +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX numbers 1- 5:', rvec(1:5) +CALL ranlux(rvec,100) +WRITE (6,'(A/9X,5F12.8)') ' RANLUX numbers 101-105:', rvec(1:5) + +WRITE (6,'(/A)') ' test the restarting by skipping' +CALL rluxgo(4,7674985,0,0) +CALL rluxat(i1,i2,i3,i4) +WRITE (6,'(A,4I10)') ' RLUXAT values =', i1, i2, i3, i4 +DO li = 1, 10 + CALL ranlux(rvec,1000) +END DO +CALL rluxat(i1,i2,i3,i4) +WRITE (6,'(A,4I10)') ' RLUXAT values =', i1, i2, i3, i4 +CALL ranlux(rvec,200) +WRITE (6,'(A,2F10.6)') ' Next and 200th numbers are:', rvec(1), rvec(200) +CALL rluxgo(i1,i2,i3,i4) +CALL ranlux(rvec,200) +WRITE (6,'(A,2F10.6)') ' Next and 200th numbers are:', rvec(1), rvec(200) + +WRITE (6,'(/A)') ' The following should provoke an error message' +CALL rluxgo(4,11111,31,0) +STOP + +! OUTPUT FROM THE ABOVE TEST PROGRAM SHOULD BE: +! -------------------------------------------- +! CALL RANLUX(RVEC,100) +! RANLUX DEFAULT INITIALIZATION: 314159265 +! RANLUX DEFAULT LUXURY LEVEL = 3 p = 223 +! RANLUX default numbers 1- 5: +! 0.53981817 0.76155043 0.06029940 0.79600263 0.30631220 +! RANLUX default numbers 101-105: +! 0.43156743 0.03774416 0.24897110 0.00147784 0.90274453 + +! CALL RLUXGO(0,0,0,0) +! RANLUX LUXURY LEVEL SET BY RLUXGO : 0 P= 24 +! RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED +! RANLUX luxury level 0, 1- 5: +! 0.53981817 0.76155043 0.06029940 0.79600263 0.30631220 +! RANLUX luxury level 0, 101-105: +! 0.41538775 0.05330932 0.58195311 0.91397446 0.67034441 + +! CALL RLUXGO(389,1,0,0) +! RANLUX LUXURY LEVEL SET BY RLUXGO : 4 P= 389 +! RANLUX INITIALIZED BY RLUXGO FROM SEEDS 1 0 0 +! RANLUX luxury p=389, 1- 5: +! 0.94589490 0.47347850 0.95152789 0.42971975 0.09127384 +! RANLUX luxury p=389, 101-105: +! 0.02618265 0.03775346 0.97274780 0.13302165 0.43126065 + +! CALL RLUXGO(75,0,0,0) +! RANLUX P-VALUE SET BY RLUXGO TO: 75 +! RANLUX INITIALIZED BY RLUXGO FROM DEFAULT SEED +! RANLUX luxury p= 75, 1- 5: +! 0.53981817 0.76155043 0.06029940 0.79600263 0.30631220 +! RANLUX luxury p= 75, 101-105: +! 0.25600731 0.23443210 0.59164381 0.59035838 0.07011414 + +! test restarting from the full vector + +! current RANLUX status saved: +! 16156027 16534309 15243811 2751687 6002207 +! 7979506 1301976 4567313 4305996 5872599 +! 12003090 2146823 12606367 4111505 5979640 +! 12739666 10489318 14036909 11729352 8061448 +! 7832659 6069758 3197719 1832730 75080216 +! RANLUX numbers 1- 5: +! 0.22617835 0.60655993 0.86417443 0.43920082 0.23382509 +! RANLUX numbers 101-105: +! 0.08107197 0.21466845 0.84856731 0.94078046 0.85626233 + +! previous RANLUX status will be restored +! FULL INITIALIZATION OF RANLUX WITH 25 INTEGERS: +! 16156027 16534309 15243811 2751687 6002207 +! 7979506 1301976 4567313 4305996 5872599 +! 12003090 2146823 12606367 4111505 5979640 +! 12739666 10489318 14036909 11729352 8061448 +! 7832659 6069758 3197719 1832730 75080216 +! RANLUX P-VALUE SET BY RLUXIN TO: 75 +! RANLUX numbers 1- 5: +! 0.22617835 0.60655993 0.86417443 0.43920082 0.23382509 +! RANLUX numbers 101-105: +! 0.08107197 0.21466845 0.84856731 0.94078046 0.85626233 + +! test the restarting by skipping +! RANLUX LUXURY LEVEL SET BY RLUXGO : 4 P= 389 +! RANLUX INITIALIZED BY RLUXGO FROM SEEDS 7674985 0 0 +! RLUXAT values = 4 7674985 0 0 +! RLUXAT values = 4 7674985 161840 0 +! Next and 200th numbers are: 0.019648 0.590586 +! RANLUX LUXURY LEVEL SET BY RLUXGO : 4 P= 389 +! RANLUX INITIALIZED BY RLUXGO FROM SEEDS 7674985 161840 0 +! Next and 200th numbers are: 0.019648 0.590586 + +! The following should provoke an error message +! RANLUX LUXURY LEVEL SET BY RLUXGO : 4 P= 389 +! RANLUX INITIALIZED BY RLUXGO FROM SEEDS 11111 31 0 +! Error in RESTARTING with RLUXGO: +! The values 11111 31 0 cannot occur at luxury level 4 +END subroutine luxtst + diff --git a/src_flexwrf_v3.1/re_initialize_particle.f90 b/src_flexwrf_v3.1/re_initialize_particle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b554ae5fe3d6db0057eacdb3de338cdfde6f7783 --- /dev/null +++ b/src_flexwrf_v3.1/re_initialize_particle.f90 @@ -0,0 +1,134 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + + subroutine re_initialize_particle(zp,ust,wst,h,sigmaw,wp,nrand,ol) +! i i i i i i/o i/o +!zp: particle position +!ust: velocity scale +!wst: velocity scale +!sigmaw: vertical velcotiy standard deviation +!wp: particle velocity +!nrand: random number counter +!=============== CBL skewed vertical profiles and formulation of LHH 1996 with profile of w3 from lHB 2000 ================================================================ +!=============== LHH formulation has been modified to account for variable density profiles and backward in time or forward in time simulations = +!=============== by Massimo Cassiani ( mc ) , NILU, 2012-2013 = +!=============== this routine re-initialize particle velocity if a numerical instability in the cbl scheme met a specific condition = +!=============== (see routine cbl.f90 and Cassiani et al. 2013 = +!=============== the particle velocity is extracted from the updraft and downdraft distribution as required = +!=============== this re-initialization si not perfectly consistent with teh well-mixed condition see Cassiani et al. 2013 for details but the error introduced is small = +!=============== but for the rpesent this is faste and simpler and shoudl be ok = +!============================================================================================================================================================================ + use par_mod, only:pi + use com_mod, only:ldirect,rannumb +! use ieee_arithmetic + + implicit none + + + real :: usurad2,usurad2p,C0,costluar4,eps + parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=2,costluar4=0.66667,eps=0.000001) + + integer idum,nrand + real :: wp,zp,ust,wst,h,dens,ddens,sigmaw,dsigmawdz,tlw,dcas,dcas1,ran3,gasdev + real :: w3,w2,wpold + real :: z, & + skew, & + skew2, & + radw2, & + fluarw,fluarw2, & + rluarw, & + xluarw, & + aluarw, & + bluarw, & + sigmawa, & + sigmawb, & + ath, & + bth, & + wb,wa + real timedir + real ol,transition + !--------------------------------------------------------------------------- +! print*,'INSIDE INIT',zp,ust,wst,h,sigmaw,wp,nrand +! wpold=wp + nrand=nrand+1 + dcas1=rannumb(nrand) + timedir=ldirect !direction of time forward (1) or backward(-1) + z=zp/h + + transition=1. !comment by mc: in this version added transtion fucntion see Cassiani et al. 2013 + if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5 + + ! w2=((1.7*(z*(1.-0.7*z)*(1.-z))**(2./3.))+1.e-2)*(wst**2) + w2=sigmaw*sigmaw !this is correct and use hanna routine if commented it is for test reason + !w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3) *1.5 !the 1.5 is to test with increased skeweness see also cbl.f90 + w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3) *transition !note added a transition fucntion, comemnt by mc + skew=w3/(w2**1.5) + skew2=skew*skew + radw2=sigmaw !sqrt(w2) + + if (skew.ne.0) then ! the limit must be considered explicitly to avoid NaN + fluarw=costluar4*skew**0.333333333333333 + fluarw2=fluarw*fluarw + rluarw=(1.+fluarw2)**3.*skew2/((3.+fluarw2)**2.*fluarw2) !-> r + xluarw=rluarw**0.5 !(1.+fluarw2)**1.5*skew/((3.+fluarw2)*fluarw) !----> r^1/2 + else + fluarw=0. + fluarw2=0. + rluarw=0. + xluarw=0. + end if + + aluarw=0.5*(1.-xluarw/(4.+rluarw)**0.5) + bluarw=1.-aluarw + + sigmawa=radw2*(bluarw/(aluarw*(1.+fluarw2)))**0.5 + sigmawb=radw2*(aluarw/(bluarw*(1.+fluarw2)))**0.5 + + wa=(fluarw*sigmawa) + wb=(fluarw*sigmawb) + + + + if ((sign(1.,wp)*timedir).gt.0) then !updraft + +100 wp=(dcas1*sigmawa+wa) + if (wp.lt.0) then + nrand=nrand+1 + dcas1=rannumb(nrand) + goto 100 + end if + wp=wp*timedir + else if ((sign(1.,wp)*timedir).lt.0) then !downdraft +101 wp=(dcas1*sigmawb-wb) + if (wp.gt.0) then + nrand=nrand+1 + dcas1=rannumb(nrand) + goto 101 + end if + wp=wp*timedir + end if +!if (ieee_is_nan(wp)) print*,'PROBLEM INSIDE',dcas1,nrand,sigmawa,fluarw,sigmawb,wb,aluarw,fluarw,xluarw,zp,ust,wst,h,sigmaw,wpold,nrand + return + end + diff --git a/src_flexwrf_v3.1/read_ncwrfout.f90 b/src_flexwrf_v3.1/read_ncwrfout.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2a24834d2e7306c0fcfb54d04f7553ee91315b5b --- /dev/null +++ b/src_flexwrf_v3.1/read_ncwrfout.f90 @@ -0,0 +1,1016 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +!********************************************************************** +! FLEXPART SOURCE FILE READ_NCWRFOUT - CONTAINS * +! * +! SUBROUTINE READ_NCWRFOUT_GRIDINFO * +! SUBROUTINE READ_NCWRFOUT_1REALFIELD * +! SUBROUTINE READ_NCWRFOUT_1DATETIME * +! * +!********************************************************************** +! * +! AUTHOR: R. Easter & J. Fast, PNNL * +! DATE: 2005-autumn-?? * +! LAST UPDATE: same * +! * +!********************************************************************** +! * +! DESCRIPTION: * +! * +! These routines read the netcdf wrf output files. * +! * +! 13 JUNE 2007, add more arguments-- ext_scalar,pbl_physcis +!********************************************************************** + + +!----------------------------------------------------------------------- + subroutine read_ncwrfout_gridinfo( ierr, idiagaa, fnamenc, & + n_west_east, n_south_north, n_bottom_top, & + dx_met, dy_met, & + m_grid_id, m_parent_grid_id, m_parent_grid_ratio, & + i_parent_start, j_parent_start, & + map_proj_id, map_stdlon, map_truelat1, map_truelat2, & + ext_scalar,pbl_physics,microphysics) +! +! reads grid definition information from a netcdf wrf output file +! +! arguments +! ierr - output - if non-zero, an error occurred +! while opening or reading from the file +! idiagaa - input - if positive, testing diagnostics are printed +! fnamenc - input - path+filename of the wrf output file +! n_west_east - output - east_west dimension of the "T-grid" +! n_south_north - output - south_north dimension of the "T-grid" +! n_bottom_top - output - bottom_top dimension of the "T-grid" +! dx_met, dy_met - output - horizontal grid spacing (m) +! m_grid_id - output - grid id number +! m_parent_grid_id - output - grid id number of parent grid +! m_parent_grid_ratio - output - ratio of parent grid dxy to current grid dxy +! i_parent_start, j_parent_start - output - location of lower left corner +! of current grid relative to the parent grid. +! (if there is no parent grid, then the above 4 "...parent..." variables +! area set to -987.) +! map_proj_id - WRF map projection id (2=polar stereographic) +! map_stdlon - map projection standard longitude (deg) +! map_truelat1, truelat2 - map projection true latitudes (deg) +! +! ext_scalar -- dimension of ex_scalar +! pbl_physics -- type of PBL scheme +! microphysics -- micorphysice scheme used + + include 'netcdf.inc' +! use netcdf +! implicit none + +! arguments + integer :: ierr, idiagaa, & + n_west_east, n_south_north, n_bottom_top, & + m_grid_id, m_parent_grid_id, m_parent_grid_ratio, & + i_parent_start, j_parent_start, map_proj_id, & + ext_scalar,pbl_physics,microphysics + + real :: dx_met, dy_met, map_stdlon, map_truelat1, map_truelat2 + + character*(*) fnamenc + +! local variables + integer,parameter :: maxdim=20 + integer,parameter :: ibadaa= -987 + integer,parameter :: xbadaa= -987 + + integer :: i, iatt, idimid_unlim, idum, iret, ivtype + integer :: l, lenatt, lendim(maxdim) + integer :: natts_tot, ncid, ndims_tot, nvars_tot + integer :: n_west_east_stag, n_south_north_stag, n_bottom_top_stag + + real :: duma + real, allocatable, dimension(:) :: duma_alloc + + character(len=80) :: dimname(maxdim) + character(len=80) :: attname + character(len=1000) :: dumch1000 + +! externals +! integer nf_close +! integer nf_inq +! integer nf_inq_dim +! integer nf_open + + + +! initialize with "missing values" + n_west_east = ibadaa + n_south_north = ibadaa + n_bottom_top = ibadaa + dx_met = xbadaa + dy_met = xbadaa + m_grid_id = ibadaa + m_parent_grid_id = ibadaa + m_parent_grid_ratio = ibadaa + i_parent_start = ibadaa + j_parent_start = ibadaa + ext_scalar = ibadaa + pbl_physics = ibadaa + microphysics = ibadaa +! +! open the netcdf file +! + ncid = 10 +!C write(*,*)'xxx inside read_ncwrfout.f fnamenc=',fnamenc +!C write(*,*)'mp_physics=',microphysics + +! print*,'filename ',fnamenc + iret = nf_open( fnamenc, NF_NOWRITE, ncid ) + if (iret .ne. nf_noerr) then + write(*,9100) 'error doing open 123',fnamenc +! print*, NF_NOWRITE, ncid,iret + ierr = -1 + return + end if + +9100 format( / '*** read_ncwrfout_gridinfo -- ', a / & + 'file = ', a ) +9110 format( / '*** read_ncwrfout_gridinfo -- ', a, 1x, i8 / & + 'file = ', a ) +9120 format( / '*** read_ncwrfout_gridinfo -- ', a, 2(1x,i8) / & + 'file = ', a ) + +90030 format( a, 2i6, 2(2x,a) ) + +! +! get information on dimensions +! + iret = nf_inq( ncid, & + ndims_tot, nvars_tot, natts_tot, idimid_unlim ) + if (iret .ne. nf_noerr) then + write(*,9100) 'error inquiring dimensions', fnamenc + ierr = -2 + return + end if + + n_west_east_stag = ibadaa + n_south_north_stag = ibadaa + n_bottom_top_stag = ibadaa + + do i = 1, min(ndims_tot,maxdim) + iret = nf_inq_dim( ncid, i, dimname(i), lendim(i) ) + if (iret .ne. nf_noerr) then + write(*,9110) 'error inquiring dimensions for dim#', i, fnamenc + ierr = -2 + return + end if + end do + + do i = 1, min(ndims_tot,maxdim) + if (dimname(i) .eq. 'west_east') & + n_west_east = lendim(i) + if (dimname(i) .eq. 'south_north') & + n_south_north = lendim(i) + if (dimname(i) .eq. 'bottom_top') & + n_bottom_top = lendim(i) + if (dimname(i) .eq. 'west_east_stag') & + n_west_east_stag = lendim(i) + if (dimname(i) .eq. 'south_north_stag') & + n_south_north_stag = lendim(i) + if (dimname(i) .eq. 'bottom_top_stag') & + n_bottom_top_stag = lendim(i) + if (dimname(i) .eq. 'ext_scalar') & + ext_scalar = lendim(i) + + end do + + if (idiagaa .gt. 0) then + write(*,9100) 'diagnostics', fnamenc + do i = 1, min(ndims_tot,maxdim) + write(*,90030) 'dim #, len, name =', & + i, lendim(i), dimname(i) + end do + end if + + if ((n_west_east .le. 0) .or. & + (n_west_east+1 .ne. n_west_east_stag)) then + write(*,9120) 'bad n_west_east, n_west_east_stag = ', & + n_west_east, n_west_east_stag, fnamenc + ierr = -3 + return + end if + + if ((n_south_north .le. 0) .or. & + (n_south_north+1 .ne. n_south_north_stag)) then + write(*,9120) 'bad n_south_north, n_south_north_stag = ', & + n_south_north, n_south_north_stag, fnamenc + ierr = -3 + return + end if + + if ((n_bottom_top .le. 0) .or. & + (n_bottom_top+1 .ne. n_bottom_top_stag)) then + write(*,9120) 'bad n_bottom_top, n_bottom_top_stag = ', & + n_bottom_top, n_bottom_top_stag, fnamenc + ierr = -3 + return + end if + +! +! get information on global attributes +! + +! first just do diagnostics + if (idiagaa .gt. 0) then + write(*,*) + write(*,*) 'attribute #, name, type, value' + end if + do iatt = 1, natts_tot + iret = nf_inq_attname( ncid, nf_global, iatt, attname) + if (iret .ne. nf_noerr) goto 3600 + iret = nf_inq_att( ncid, nf_global, attname, ivtype, lenatt ) + if (iret .ne. nf_noerr) goto 3600 + if (ivtype .eq. 2) then + iret = nf_get_att_text( ncid, nf_global, attname, dumch1000 ) + if (iret .ne. nf_noerr) goto 3600 + i = max(1,min(1000,lenatt)) + if (idiagaa .gt. 0) write(*,91010) & + iatt, attname(1:40), ivtype, lenatt, dumch1000(1:i) + else if (ivtype .eq. 4) then + iret = nf_get_att_int( ncid, nf_global, attname, idum ) + if (iret .ne. nf_noerr) goto 3600 + if (idiagaa .gt. 0) write(*,91020) & + iatt, attname(1:40), ivtype, lenatt, idum + else if ((ivtype .eq. 5) .and. (lenatt .eq. 1)) then + iret = nf_get_att_real( ncid, nf_global, attname, duma ) + if (iret .ne. nf_noerr) goto 3600 + if (idiagaa .gt. 0) write(*,91030) & + iatt, attname(1:40), ivtype, lenatt, duma + else if ((ivtype .eq. 5) .and. (lenatt .gt. 1)) then + allocate( duma_alloc(lenatt) ) + iret = nf_get_att_real( ncid, nf_global, attname, duma_alloc ) + if (iret .ne. nf_noerr) goto 3600 + if (idiagaa .gt. 0) then + write(*,91010) iatt, attname(1:40), ivtype, lenatt + write(*,91040) (duma_alloc(i), i=1,lenatt) + end if + deallocate( duma_alloc ) + else + if (idiagaa .gt. 0) write(*,'(i4,1x,a,2(1x,i6))') & + iatt, attname(1:40), ivtype, lenatt + goto 3400 + endif + + if (attname .eq. 'GRID_ID') then + m_grid_id = idum + else if (attname .eq. 'PARENT_ID') then + m_parent_grid_id = idum + else if (attname .eq. 'PARENT_GRID_RATIO') then + m_parent_grid_ratio = idum + else if (attname .eq. 'I_PARENT_START') then + i_parent_start = idum + else if (attname .eq. 'J_PARENT_START') then + j_parent_start = idum + else if (attname .eq. 'DX') then + dx_met = duma + else if (attname .eq. 'DY') then + dy_met = duma + else if (attname .eq. 'MAP_PROJ') then + map_proj_id = idum + else if (attname .eq. 'STAND_LON') then + map_stdlon = duma + else if (attname .eq. 'TRUELAT1') then + map_truelat1 = duma + else if (attname .eq. 'TRUELAT2') then + map_truelat2 = duma + else if (attname .eq. 'BL_PBL_PHYSICS') then + pbl_physics = idum + else if (attname .eq. 'MP_PHYSICS') then + microphysics = idum + end if + enddo +3400 continue +91010 format( i4, 1x, a, 2(1x,i6), 1x, a ) +91020 format( i4, 1x, a, 2(1x,i6), 1x, i10 ) +91030 format( i4, 1x, a, 2(1x,i6), 1x, 1pe12.4 ) +91040 format(( 12x, 5(1pe12.4) )) + + goto 3900 + +3600 write(*,9110) 'error inquiring attribute', iatt, fnamenc + stop + +3900 continue + +!C write(*,*)'mp_physics=',microphysics,pbl_physics + +! +! close and return +! + iret = nf_close( ncid ) + ierr = 0 + + return + end subroutine read_ncwrfout_gridinfo + + + +!----------------------------------------------------------------------- + subroutine read_ncwrfout_1datetime( ierr, fnamenc, & + itime, jyyyymmdd, jhhmmss ) +! +! a wrf output file may contain data at multiple time. This routine returns +! the date & time of the "itime" data group in the file. +! +! arguments +! ierr - output - if non-zero, an error occurred +! while opening or reading from the file, +! or itime < 0, or itime > number of times in the file. +! fnamenc - input - path+filename of the wrf output file +! itime - input - specifies which data/time to return. +! 1 for first, 2 for second, ... +! jyyyymmdd - output - date as 8 decimal digits (yyyymmdd). +! yyyy=year, mm=month, dd=day of month. +! jhhmmss - output - time of day as 6 decimal digits (hhmmss). +! hh=hour, mm=minute, ss=second +! if (jyyyymmdd=jhhmmss=-1, then ierr is non-zero, and vice-versa) +! + +! use netcdf + include 'netcdf.inc' +!implicit none + + +! arguments + integer :: ierr, itime, jyyyymmdd, jhhmmss + character*(*) fnamenc + +! local variables + integer,parameter :: ndims_maxbb=4 ! max number of dimensions for a variable + + integer :: i, id_var, iret, itype_var + integer :: iduma, idumb, idumc + integer :: id_dim(ndims_maxbb) + integer :: istart(ndims_maxbb), icount(ndims_maxbb) + integer :: lendim(ndims_maxbb) + integer :: natts_tot, ncid, ndims + + character(len=32) timetext + character(len=80) varname, varnamenc + +! externals +! integer nf_close +! integer nf_inq +! integer nf_inq_dim +! integer nf_open + + + + jyyyymmdd = -1 + jhhmmss = -1 + +! +! open the netcdf file +! + ncid = 10 + iret = nf_open( fnamenc, NF_NOWRITE, ncid ) + if (iret .ne. nf_noerr) then + write(*,9100) 'error doing open 370', fnamenc + ierr = -1 + goto 8100 + end if + +9100 format( / '*** read_ncwrfout_1datetime -- ', a / & + 'file = ', a ) +9110 format( / '*** read_ncwrfout_1datetime -- ', a, 1x, i8 / & + 'file = ', a ) +9120 format( / '*** read_ncwrfout_1datetime -- ', a, 2(1x,i8) / & + 'file = ', a ) +9130 format( / '*** read_ncwrfout_1datetime -- ', a, 3(1x,i8) / & + 'file = ', a ) +9115 format( / '*** read_ncwrfout_1datetime -- ', a / a, 1x, i8 / & + 'file = ', a ) +9125 format( / '*** read_ncwrfout_1datetime -- ', a / a, 2(1x,i8) / & + 'file = ', a ) +9135 format( / '*** read_ncwrfout_1datetime -- ', a / a, 3(1x,i8) / & + 'file = ', a ) + +90030 format( a, 2i6, 2(2x,a) ) + +! +! get information on the variable +! + varname = 'Times' + iret = nf_inq_varid( ncid, varname, id_var ) + if (iret .ne. nf_noerr) then + write(*,9100) 'error inquiring var id for ' // varname, fnamenc + ierr = -1 + goto 8100 + end if + + iret = nf_inq_var( ncid, id_var, & + varnamenc, itype_var, ndims, id_dim, natts_tot ) + if (iret .ne. nf_noerr) then + write(*,9100) 'error inquiring var info for ' // varname, fnamenc + ierr = -1 + goto 8100 + end if + +! check variable type + if (itype_var .ne. nf_char) then + write(*,9110) 'var type wrong for ' // varname, & + itype_var, fnamenc + ierr = -1 + goto 8100 + end if + + +! check number of dimensions + if (ndims .ne. 2) then + write(*,9115) 'var ndims is wrong for ' // varname, & + 'ndims =', ndims, fnamenc + ierr = -1 + goto 8100 + end if + +! get sizes of dimensions +! dimension 1 = # of characters in date/time string +! dimension 2 = # of times in the file + do i = 1, ndims + iret = nf_inq_dimlen( ncid, id_dim(i), lendim(i) ) + if (iret .ne. nf_noerr) then + write(*,9115) 'error inquiring var dim len for ' // varname, & + 'idim =', i, fnamenc + ierr = -1 + goto 8100 + end if + end do + + if (itime .lt. 1) then + ierr = -11 + goto 8100 + else if (itime .gt. lendim(2)) then + ierr = -12 + goto 8100 + end if + +! get the data and extract the data & time + do i = 1, ndims_maxbb + istart(i) = 1 + icount(i) = 1 + end do + istart(1) = 1 + icount(1) = lendim(1) + istart(2) = itime + icount(2) = 1 + iret = nf_get_vara_text( ncid, id_var, istart, icount, timetext ) + if (iret .ne. nf_noerr) then + write(*,9100) 'error reading var data for ' // varname, & + fnamenc + ierr = -1 + goto 8100 + end if + + read( timetext, '(i4,1x,i2,1x,i2)', iostat=iret ) & + iduma, idumb, idumc + if (iret .ne. 0) then + write(*,9125) & + 'error reading from timetext = "' // timetext // '"', & + 'itime, lendim(1) =', itime, lendim(1), fnamenc + ierr = -1 + goto 8100 + end if + jyyyymmdd = iduma*10000 + idumb*100 + idumc + + read( timetext, '(11x,i2,1x,i2,1x,i2)', iostat=iret ) & + iduma, idumb, idumc + if (iret .ne. 0) then + write(*,9125) & + 'error reading from timetext = "' // timetext // '"', & + 'itime, lendim(1) =', itime, lendim(1), fnamenc + ierr = -1 + goto 8100 + end if + jhhmmss = iduma*10000 + idumb*100 + idumc + +! +! success - close and return +! + iret = nf_close( ncid ) + ierr = 0 + return + +! +! failure - close and return +! +8100 iret = nf_close( ncid ) + return + + end subroutine read_ncwrfout_1datetime + + + +!----------------------------------------------------------------------- + subroutine read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, vardata, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) +! +! reads of real (single precision) field at one time from a netcdf wrf output file +! +! arguments +! ierr - output - if non-zero, an error occurred +! while opening or reading from the file +! -1 = error opening file +! -2 = requested variable is not in the file +! -3 = error while inquiring about the variable +! -4 = variable type is other than real (single precision) +! ... = check below, in the code, for explanation of other ierr values. +! idiagaa - input - if positive, testing diagnostics are printed +! fnamenc - input - path+filename of the wrf output file +! varname - input - field name +! vardata - output - the data for the field +! itime - input - specifies which time to read. +! (1 for first time in the file, 2 for second, ...) +! ndims - output - number of (netcdf) dimensions of the field. +! This includes the time dimension. +! ndims_exp - input - expected number of dimensions of the field. +! An error occurs if ndims .ne. ndims_exp. +! ndims_max - input - The dimension/size of the lendim_... arrays. +! lendim - output - The size of each of the "ndims" dimensions. +! lendim_exp - input - The expected size of each of the "ndims" dimensions. +! If lendim_exp .gt. 0, then an error occurs if lendim .ne. lendim_exp. +! lendim_max - input - The maximum size of each dimension. These are +! The dimensions of the vardata array. +! +! use netcdf + include 'netcdf.inc' +!implicit none + + +! arguments + integer :: ierr, idiagaa, itime, & + ndims, ndims_exp, ndims_max, & + lendim(ndims_max), lendim_exp(ndims_max), & + lendim_max(ndims_max) + + real :: vardata( lendim_max(1), lendim_max(2), lendim_max(3) ) + + character*(*) fnamenc, varname + +! local variables + integer,parameter :: ndims_maxbb=4 ! max number of dimensions for a variable + integer,parameter :: ibadaa=-987 + integer,parameter :: xbadaa=-987 + integer,parameter :: ijktestmax=500 + + integer :: i, iatt, id_var, iret, itype_var + integer :: itot, ijktot, ii + integer :: id_dim(ndims_maxbb) + integer :: istart(ndims_maxbb), icount(ndims_maxbb) + integer :: j, jtot, jj + integer :: k, ktot, kk + integer :: l, lenatt + integer :: lendim_use(ndims_maxbb) + integer :: m + integer :: natts_tot, ncid, ndiffa, ndiffb + + real :: duma, dumb + real :: testavg(ijktestmax,3,2), & + testmin(ijktestmax,3,2), testmax(ijktestmax,3,2) + + character(len=80) varnamenc + character(len=80) dimname(ndims_maxbb) + +! externals +! integer nf_close +! integer nf_inq +! integer nf_inq_dim +! integer nf_open + +! print*,'dim array',lendim_max(1), lendim_max(2), lendim_max(3) + +! +! open the netcdf file +! + ncid = 10 + iret = nf_open( fnamenc, NF_NOWRITE, ncid ) + if (iret .ne. nf_noerr) then + write(*,9100) 'error doing open 592', fnamenc + ierr = -1 + return + end if + +9100 format( / '*** read_ncwrfout_1realfield -- ', a / & + 'file = ', a ) +9110 format( / '*** read_ncwrfout_1realfield -- ', a, 1x, i8 / & + 'file = ', a ) +9120 format( / '*** read_ncwrfout_1realfield -- ', a, 2(1x,i8) / & + 'file = ', a ) +9130 format( / '*** read_ncwrfout_1realfield -- ', a, 3(1x,i8) / & + 'file = ', a ) +9115 format( / '*** read_ncwrfout_1realfield -- ', a / a, 1x, i8 / & + 'file = ', a ) +9125 format( / '*** read_ncwrfout_1realfield -- ', a / a, 2(1x,i8) / & + 'file = ', a ) +9135 format( / '*** read_ncwrfout_1realfield -- ', a / a, 3(1x,i8) / & + 'file = ', a ) + +90030 format( a, 2i6, 2(2x,a) ) + +! +! get information on the variable +! + iret = nf_inq_varid( ncid, varname, id_var ) + if (iret .ne. nf_noerr) then +! write(*,9100) 'error inquiring var id for ' // varname, fnamenc + ierr = -2 + goto 8100 + end if + + iret = nf_inq_var( ncid, id_var, & + varnamenc, itype_var, ndims, id_dim, natts_tot ) + if (iret .ne. nf_noerr) then + write(*,9100) 'error inquiring var info for ' // varname, fnamenc + ierr = -3 + goto 8100 + end if + +! check variable type + if (itype_var .ne. nf_real) then + write(*,9110) 'var type wrong for ' // varname, & + itype_var, fnamenc + ierr = -4 + goto 8100 + end if + + +! check number of dimensions + if (ndims_exp .le. 0) then + write(*,9115) & + 'bad ndims_exp for ' // varname, & + 'ndims_exp =', ndims_exp, fnamenc + ierr = -11 + goto 8100 + end if + if (ndims .ne. ndims_exp) then + write(*,9125) 'var ndims mismatch for ' // varname, & + 'ndims_exp, ndims =', ndims_exp, ndims, fnamenc + ierr = -12 + goto 8100 + end if + if (ndims .gt. ndims_max) then + write(*,9125) 'var ndims > ndims_max for ' // varname, & + 'ndims, ndims_max =', ndims, ndims_max, fnamenc + ierr = -13 + goto 8100 + end if + if (ndims .gt. ndims_maxbb) then + write(*,9125) 'var ndims > ndims_maxbb for ' // varname, & + 'ndims, ndims_maxbb =', ndims, ndims_maxbb, fnamenc + ierr = -14 + goto 8100 + end if + +! check size of each dimension + do i = 1, ndims_exp + iret = nf_inq_dimlen( ncid, id_dim(i), lendim(i) ) + if (iret .ne. nf_noerr) then + write(*,9110) 'error inquiring var dim len for ' // varname, & + i, fnamenc + ierr = -15 + goto 8100 + end if + if ((i .lt. ndims_exp) .and. (lendim_exp(i) .gt. 0) .and. & + (lendim(i) .ne. lendim_exp(i))) then +! print*,i,ndims_exp,lendim_exp(i),lendim(i),lendim_exp(i) + write(*,9130) 'var lendim mismatch for ' // varname, & + i, lendim_exp(i), lendim(i), fnamenc + ierr = -16 + goto 8100 + end if + if ((i .lt. ndims_exp) .and. & + (lendim(i) .gt. lendim_max(i))) then + write(*,9130) 'var lendim too big for ' // varname, & + i, lendim_max(i), lendim(i), fnamenc + ierr = -17 + goto 8100 + end if + if ((i .eq. ndims_exp) .and. (lendim(i) .lt. itime)) then + write(*,9130) 'var itime < ntimes for ' // varname, & + i, itime, lendim(i), fnamenc + ierr = -18 + goto 8100 + end if + end do + +! do diagnostics on the dimensions + if (idiagaa .gt. 0) then + write(*,'(/a)') & + 'read_ncwrfout_1realfield - dim info for var = ' // & + varname(1:20) + do i = 1, ndims + iret = nf_inq_dim( ncid, id_dim(i), dimname(i), lendim(i) ) + if (iret .ne. nf_noerr) then + write(*,9115) 'error inquiring var dim info for ' // varname, & + 'idim =', i, fnamenc + ierr = -19 + goto 8100 + end if + write(*,'(a,3i5,2x,a)') ' i,id,len,name =', & + i, id_dim(i), lendim(i), dimname(i)(1:32) + end do + end if + +! +! get the data +! + do i = 1, ndims_maxbb + istart(i) = 1 + icount(i) = 1 + end do + do i = 1, ndims_exp - 1 + istart(i) = 1 + icount(i) = lendim(i) + end do +! in wrfout files, the last dimension should always be time + istart(ndims_exp) = itime + icount(ndims_exp) = 1 + + iret = nf_get_vara_real( ncid, id_var, istart, icount, vardata ) + if (iret .ne. nf_noerr) then + write(*,9120) 'error reading var data for ' // varname, & + fnamenc + ierr = -21 + goto 8100 + end if + +! +! reorder the data +! + lendim_use(1) = lendim(1) + lendim_use(2) = 1 + if (ndims_exp .ge. 3) lendim_use(2) = lendim(2) + lendim_use(3) = 1 + if (ndims_exp .ge. 4) lendim_use(3) = lendim(3) + +! print*,'dim to go',lendim_use(1),lendim_use(2),lendim_use(3) +! print*,'value in',lendim_use, lendim_max + call reorder_ncwrfout_1realfield( ierr, idiagaa, & + varname, vardata, vardata, & + lendim_use, lendim_max ) + + if (ierr .ne. 0) then + print*, 'error re-ordering var data for ', varname, & + fnamenc + ierr = -22 + goto 8100 + end if + +! +! success - close and return +! + iret = nf_close( ncid ) + ierr = 0 + return + +! +! error - close and return +! +8100 iret = nf_close( ncid ) + return + + end subroutine read_ncwrfout_1realfield + + + +!----------------------------------------------------------------------- + subroutine reorder_ncwrfout_1realfield( ierr, idiagaa, & + varname, vardata_in, vardata_out, & + lendim_use, lendim_max ) +! +! reorders a real (single precision) field +! the nf_get_vara_real loads the data for a field into +! a contiguous block of memory starting at vardata(1,1,1) +! it does not know if perhaps lendim() < lendim_max() +! this routine corrects for that, so that the data are +! loaded into non-contiguous blocks when lendim() < lendim_max() +! +! arguments +! ierr - output - if non-zero, an error occurred while re-ordering +! idiagaa - input - if positive, testing diagnostics are printed +! varname - input - field name +! +! vardata_in - input - the data for the field +! vardata_out - output - the data for the field +! In the calling program, vardata_in & vardata_out are usually +! the same array. This routine "pretends" that they are +! different, and specifies their dimensions differently, +! to facilitate the reordering. +! +! lendim_use - input - The actual size of the spatial dimensions of the field. +! lendim_max - input - The actual spatial dimensions of the vardata array. +! Most wrf fields are spatially either 1d (z), 2d (xy), or 3d (xyz). +! For a 1d spatial field (e.g., z only), set +! lendim_use(1) = nz, lendim_max(1) = nz_max +! lendim_use(2) = 1, lendim_max(2) = 1 +! lendim_use(3) = 1, lendim_max(3) = 1 +! For a 2d spatial field (e.g., xy only), set +! lendim_use(1) = nx, lendim_max(1) = nx_max +! lendim_use(2) = ny lendim_max(2) = ny_max +! lendim_use(3) = 1, lendim_max(3) = 1 +! For a 3d spatial field (xyz), set +! lendim_use(1) = nx, lendim_max(1) = nx_max +! lendim_use(2) = ny lendim_max(2) = ny_max +! lendim_use(3) = nz lendim_max(3) = nz_max +! + +! use netcdf + include 'netcdf.inc' +!implicit none + + +! arguments + integer :: ierr, idiagaa, & + lendim_use(3), lendim_max(3) + + real :: vardata_in( lendim_use(1), lendim_use(2), lendim_use(3) ) + real :: vardata_out( lendim_max(1), lendim_max(2), lendim_max(3) ) + + character*(*) varname + +! local variables + integer,parameter :: ijktestmax=500 + integer,parameter :: check_reordering=1 + + integer :: i, j, k, m, n + integer :: itestend, jtestend, ktestend + integer :: ijk, ijktestend + integer :: ndiffa, ndiffb + + real :: duma, dumb + real :: testavg(ijktestmax,3,2), & + testmin(ijktestmax,3,2), testmax(ijktestmax,3,2) + +! +! the testavg/min/max are avg, min, and max values for +! a i (or j or k) fixed and j,k (or i,k or i,j) varying +! they are computed before and after the data has been reordered +! then compared at the end +! an error occurs if they do not match +! +! print*,'size in out',lendim_use(1), lendim_use(2), lendim_use(3) +! print*,'size in out',lendim_max(1), lendim_max(2), lendim_max(3) + if (check_reordering .gt. 0) then + + do n = 1, 2 + do m = 1, 3 + do i = 1, ijktestmax + testavg(i,m,n) = 0.0 + testmin(i,m,n) = +1.0e37 + testmax(i,m,n) = -1.0e37 + end do + end do + end do +! print*,varname + ktestend = min( ijktestmax, lendim_use(3) ) + jtestend = min( ijktestmax, lendim_use(2) ) + itestend = min( ijktestmax, lendim_use(1) ) +! print*,'ktestend',ktestend +! pass 1 -- compute the test---(:,:,1) from vardata_in + do k = 1, ktestend + do j = 1, jtestend + do i = 1, itestend + duma = vardata_in(i,j,k) + testavg(i,1,1) = testavg(i,1,1) + duma + testmin(i,1,1) = min( testmin(i,1,1), duma ) + testmax(i,1,1) = max( testmax(i,1,1), duma ) + testavg(j,2,1) = testavg(j,2,1) + duma + testmin(j,2,1) = min( testmin(j,2,1), duma ) + testmax(j,2,1) = max( testmax(j,2,1), duma ) + testavg(k,3,1) = testavg(k,3,1) + duma + testmin(k,3,1) = min( testmin(k,3,1), duma ) + testmax(k,3,1) = max( testmax(k,3,1), duma ) + end do + end do + end do + + end if ! if (check_reordering .gt. 0) then + +! pass 2 -- shift the data values +! print*,'max',lendim_max + do k = lendim_use(3), 1, -1 + do j = lendim_use(2), 1, -1 + do i = lendim_use(1), 1, -1 +! print*,i,j,k + vardata_out(i,j,k) = vardata_in(i,j,k) + end do + end do + end do + +! pass 3 -- compute the test---(:,:,2) from vardata_out + if (check_reordering .gt. 0) then + + do k = 1, ktestend + do j = 1, jtestend + do i = 1, itestend + duma = vardata_out(i,j,k) + testavg(i,1,2) = testavg(i,1,2) + duma + testmin(i,1,2) = min( testmin(i,1,2), duma ) + testmax(i,1,2) = max( testmax(i,1,2), duma ) + testavg(j,2,2) = testavg(j,2,2) + duma + testmin(j,2,2) = min( testmin(j,2,2), duma ) + testmax(j,2,2) = max( testmax(j,2,2), duma ) + testavg(k,3,2) = testavg(k,3,2) + duma + testmin(k,3,2) = min( testmin(k,3,2), duma ) + testmax(k,3,2) = max( testmax(k,3,2), duma ) + end do + end do + end do + +! now compare the test---(:,:,1) & test---(:,:,2) + ndiffb = 0 + do m = 1, 3 + if (m .eq. 1) then + ijktestend = itestend + duma = 1.0/(jtestend*ktestend) + if (idiagaa .gt. 0) write(*,'(a,a)') varname(1:20), & + 'i, testavg(i,1), testmin(i,1), testmax(i,1)' + else if (m .eq. 2) then + ijktestend = jtestend + duma = 1.0/(itestend*ktestend) + if (idiagaa .gt. 0) write(*,'(a,a)') varname(1:20), & + 'j, testavg(j,2), testmin(j,2), testmax(j,2)' + else + ijktestend = ktestend + duma = 1.0/(itestend*jtestend) + if (idiagaa .gt. 0) write(*,'(a,a)') varname(1:20), & + 'k, testavg(k,3), testmin(k,3), testmax(k,3)' + end if + + ndiffa = 0 + do ijk = 1, ijktestend + i = ijk + dumb = max( abs(testavg(i,m,1)), abs(testavg(i,m,2)) )*2.0e-7 + if (abs(testavg(i,m,1)-testavg(i,m,2)) .gt. dumb) ndiffa = ndiffa + 1 + dumb = max( abs(testmin(i,m,1)), abs(testmin(i,m,2)) )*2.0e-7 + if (abs(testmin(i,m,1)-testmin(i,m,2)) .gt. dumb) ndiffa = ndiffa + 1 + dumb = max( abs(testmax(i,m,1)), abs(testmax(i,m,2)) )*2.0e-7 + if (abs(testmax(i,m,1)-testmax(i,m,2)) .gt. dumb) ndiffa = ndiffa + 1 + end do + + if (ndiffa .le. 0) then + if (idiagaa .gt. 0) write(*,*) ' *** no differences' + else + do ijk = 1, ijktestend + i = ijk + if (idiagaa .gt. 0) write(*,'(i3,1p,3(2x,2e11.3))') i, & + testavg(i,m,1)*duma, & + (testavg(i,m,1)-testavg(i,m,2))*duma, & + testmin(i,m,1), (testmin(i,m,1)-testmin(i,m,2)), & + testmax(i,m,1), (testmax(i,m,1)-testmax(i,m,2)) + end do + end if + + ndiffb = ndiffb + ndiffa + end do + + if (ndiffb .gt. 0) then + ierr = -12 + goto 8100 + end if + + end if ! if (check_reordering .gt. 0) then + +! +! success +! + ierr = 0 + return + +! +! error +! +8100 return + + end subroutine reorder_ncwrfout_1realfield + + + diff --git a/src_flexwrf_v3.1/readdepo.f90 b/src_flexwrf_v3.1/readdepo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bd8af155a58238e6defec9619fb83dafc07897f3 --- /dev/null +++ b/src_flexwrf_v3.1/readdepo.f90 @@ -0,0 +1,146 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine 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', & + open(unitwesely,file='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 diff --git a/src_flexwrf_v3.1/readinput.f90 b/src_flexwrf_v3.1/readinput.f90 new file mode 100644 index 0000000000000000000000000000000000000000..49f7d28072c70a8616eb018aceec7de221cd9027 --- /dev/null +++ b/src_flexwrf_v3.1/readinput.f90 @@ -0,0 +1,2014 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine readinput +!******************************************************************************* +! * +! 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: * +! len(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 + use outg_mod + use point_mod +! use xmass_mod + + implicit none +! include 'includepar' +! include 'includecom' + + integer :: i, j, numtable,numpoint2 + integer :: hhh,mi,ss,pos_spec + character(len=50) :: line + logical :: old + integer :: idiff,ldat,ltim,wftime1(maxwf),numbwfn(maxnests),k + integer :: wftime1n(maxnests,maxwf),wftimen(maxnests,maxwf) + real(kind=dp) :: jul,juldate,beg,end,jul1,jul2 +! double precision juldate,jul,beg,end,jul1,jul2 + character(len=80) :: fname,wfname1(maxwf),wfname1n(maxnests,maxwf) + character(len=10) :: spec, wfspec1(maxwf),wfspec1n(maxnests,maxwf) + real :: outhelp,xr,xr1,yr,yr1 + real :: xtmp, xtmp1, xtmp2, ytmp, ytmp1, ytmp2 +! 10-mar-2006 rce - flexpart_wrf - eps should be a small dx/dy value in meters +! parameter(eps=1.e-4) + real,parameter :: eps=10.0 + real :: x,y,xm,ym + character(len=16) :: receptor + integer :: numpartmax,id1,it1,id2,it2,idow,ihour + integer :: emitvar,stat,nparttot,nparttot2,outgriddef,outgriddefn + real :: vsh(ni),fracth(ni),schmih(ni),releaserate,releaserate2 + character(len=3) :: aspecnumb + character(len=10) :: specname(maxtable) + real :: cun + logical :: spec_found +! Read the pathname information stored in unitpath +!************************************************* + nparttot=0 +! print*,'path2' +! print*,'path',unitpath +! open(unitpath,file='flexwrf.input',status='old',err=801) + open(unitpath,file=inputname,status='old',err=801) + +! jdf start read pathnames +!************************************************* + call skplin(1,unitpath) + do i=1,numpath + read(unitpath,'(a)',err=800) path(i) + length(i)=index(path(i),' ')-1 + enddo + +! 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 + enddo + + if (path(numpath+2*(i-1)+1)(1:5).ne.'=====') then + write(*,*) ' #### FLEXPART MODEL ERROR! NUMBER OF PATHS #### ' + write(*,*) ' #### IN FORMER PATHNAMES FILE GREATER THAN #### ' + write(*,*) ' #### MAXNESTS IN PAR_MOD.F90, INCREASE THIS #### ' + write(*,*) ' #### OR REMOVE EXTRA PATHS FROM PATHNAMES #### ' + stop + endif + +! Determine number of available nested domains +!********************************************* + +30 numbnests=i-1 + +! jdf end read pathnames +!************************************************* +! jdf start read command +!************************************************* +! +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine readcommand. * +! * +! This routine reads the user specifications for the current model run. * +! * +! Author: A. Stohl * +! * +! 18 May 1996 * +! * +! Nov-Dec-2005, R. Easter - input turb_option, add_sfc_level, iouttype * +! * +!******************************************************************************* +! * +! Variables: * +! bdate beginning date as Julian date * +! ctl factor by which time step must be smaller than * +! Lagrangian time scale * +! edate ending date as Julian date * +! hhh hour * +! 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 * +! 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 * +! mi minute * +! ss second * +! * +! Constants: * +! unitcommand unit connected to file COMMAND * +! +! 9-10-2007, W Wang * +! add turb_option_tke and turb_option_mytke +! 1 Oct, 2007 +! add dt_conv input, time intervals to call convection, seconds +!******************************************************************************* + + +! Open the command file and read user options +!******************************************** + + read(unitcommand,*) ldirect + read(unitcommand,*) ibdate,ibtime + read(unitcommand,*) iedate,ietime + read(unitcommand,*) loutstep + read(unitcommand,*) loutaver + read(unitcommand,*) loutsample + read(unitcommand,*) itsplit + read(unitcommand,*) lsynctime + read(unitcommand,*) ctl + read(unitcommand,*) ifine + read(unitcommand,*) iout + read(unitcommand,*) ipout + read(unitcommand,*) lsubgrid + read(unitcommand,*) lconvection + read(unitcommand,*) dt_conv + read(unitcommand,*) lagespectra + read(unitcommand,*) ipin + read(unitcommand,*) iflux + read(unitcommand,*) ioutputforeachrelease + read(unitcommand,*) mdomainfill + read(unitcommand,*) ind_source + read(unitcommand,*) ind_receptor + read(unitcommand,*) nested_output + read(unitcommand,*) linit_cond +! if(nested_output.ge.1) then +! write(*,'(/a/a/a/)') & +! '*** Nested grid output is not fully implemented ***', & +! '*** Set NESTED_OUTPUT=0 in COMMAND file ***' +! stop +! endif +! FLEXPART_WRF - read turb_option, add_sfc_level + read(unitcommand,*) turb_option + read(unitcommand,*) cblflag ! added by mc for cbl option +! read(unitcommand,*) add_sfc_level + add_sfc_level=1 + read(unitcommand,*) sfc_option + read(unitcommand,*) wind_option + read(unitcommand,*) time_option + read(unitcommand,*) outgrid_option + read(unitcommand,*) numpoint_option + read(unitcommand,*) iouttype + read(unitcommand,*) ncnumrec + read(unitcommand,*) option_verbose + + 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 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 #### ' + 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 #### ' + 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.0).or.(iout.gt.5)) then +! write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### ' +! write(*,*) ' #### IOUT MUST BE 0, 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! : #### ' + 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! : ####' + 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! : ####' + 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 + !***************************************************************************** + +! print*,'ioutput',ioutputforeachrelease,ldirect + if ((ldirect.lt.0).and.(ioutputforeachrelease.eq.0)) then + write(*,*) '#### FLEXPART MODEL ERROR! : ####' + 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! : ####' + 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! : ####' + 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! : ####' + 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! : #### ' + 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 + + if ((ipout.ne.0).and.(ipout.ne.1).and.(ipout.ne.2)) then + write(*,*) ' #### FLEXPART MODEL ERROR! : #### ' + write(*,*) ' #### IPOUT MUST BE 1, 2 OR 3! #### ' + stop + endif + + +! Check whether convection scheme is either turned on or off +!*********************************************************** + +! if ((lconvection.ne.0).and.(lconvection.ne.1)) then + if ((lconvection.lt.0).or. (lconvection.gt.3)) then + write(*,*) ' #### FLEXPART MODEL ERROR! : #### ' +! write(*,*) ' #### LCONVECTION MUST BE SET TO EITHER 1 OR 0#### ' + write(*,*) ' #### LCONVECTION MUST BE SET TO 0 or 3 #### ' + + 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. #### ' + 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 #### ' + 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 #### ' + 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 #### ' + 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 + + if (ncnumrec.le.0) then + write(*,*) ' #### FLEXPART MODEL ERROR! NUMREC MUST #### ' + write(*,*) ' #### BE GREATER THAN 0 #### ' + stop + endif + +! FLEXPART_WRF - check turb_option, add_sfc_level + if ((turb_option.ne.turb_option_none ) .and. & + (turb_option.ne.turb_option_diagnosed) .and. & + (turb_option.ne.turb_option_tke ) .and. & + (turb_option.ne.turb_option_mytke)) then + write(*,*) ' #### FLEXPART MODEL ERROR! #### ' + write(*,*) ' #### TURB_OPTION MUST BE ONE OF: #### ' + write(*,'(5x,5i5)') turb_option_none, turb_option_diagnosed, & + turb_option_tke,turb_option_mytke + write(*,*) ' #### --------------------------------- #### ' + stop + endif + + if ((add_sfc_level.ne.0) .and. (add_sfc_level.ne.1)) then + write(*,*) ' #### FLEXPART MODEL ERROR! #### ' + write(*,*) ' #### ADD_SFC_LAYER MUST BE 0 or 1 #### ' + stop + endif + + if ((sfc_option.ne.sfc_option_diagnosed) .and. & + (sfc_option.ne.sfc_option_wrf )) then + write(*,*) ' #### FLEXPART MODEL ERROR! #### ' + write(*,*) ' #### SFC_OPTION MUST BE ONE OF: #### ' + write(*,'(5x,5i5)') sfc_option_diagnosed, sfc_option_wrf + write(*,*) ' #### --------------------------------- #### ' + stop + endif + +! iouttype -- convert negative values to 0; positive out of range values to 2 + if (iouttype .lt. 0) iouttype = 0 + if (iouttype .gt. 2) iouttype = 2 + +! Conversion of format HHHMISS to seconds +!**************************************** + + hhh=ideltas/10000 + mi=(ideltas-10000*hhh)/100 + ss=ideltas-10000*hhh-100*mi + ideltas=hhh*3600+60*mi+ss + + +! 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(*,*) ' #### INPUT FILE MUST BE EITHER -1 OR 1. #### ' + stop + endif + +! jdf end read command +!************************************************* +! jdf start read ageclasees +!************************************************* +! +!******************************************************************************* +! * +! This routine reads the age classes to be used for the current model run. * +! * +! Author: A. Stohl * +! * +! 20 March 2000 * +! * +!******************************************************************************* +! * +! Variables: * +! * +! Constants: * +! * +!******************************************************************************* + +! If age spectra claculation is switched on, +! open the AGECLASSSES file and read user options +!************************************************ + + call skplin(1,unitpath) + read(unitpath,*) nageclass + read(unitpath,*) lage(1) + if (nageclass.gt.maxageclass) then + write(*,*) ' #### FLEXPART MODEL ERROR! NUMBER OF AGE #### ' + write(*,*) ' #### CLASSES GREATER THAN MAXIMUM ALLOWED. #### ' + write(*,*) ' #### CHANGE SETTINGS IN AGECLASSES OR #### ' + write(*,*) ' #### RECOMPILE WITH LARGER MAXAGECLASS IN #### ' + write(*,*) ' #### FILE PAR_MOD.F90 #### ' + stop + endif + + if (lage(1).le.0) then + write(*,*) ' #### FLEXPART MODEL ERROR! AGE OF FIRST #### ' + write(*,*) ' #### CLASS MUST BE GREATER THAN ZERO. CHANGE #### ' + write(*,*) ' #### SETTINGS IN AGECLASSES. #### ' + stop + endif + +! If age spectra calculation is switched off, set number of age classes +! to 1 and maximum age to a large number +!********************************************************************** + + + do i=2,nageclass + read(unitpath,*) lage(i) +! print*,'age',lage(i),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 AGECLASSES. #### ' + stop + endif + enddo + if (lagespectra.ne.1) then + nageclass=1 + lage(nageclass)=999999999 + endif + +! jdf end read ageclasses +!************************************************* +! jdf start read available +!************************************************* +! +!******************************************************************************* +! * +! 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 * +! * +! 12 October 2005, R. Easter - * +! fname,wfname1,wfname1n changed from char*10 to char*80; * +! reads from unitavailab changed to free format * +! * +!******************************************************************************* +! * +! 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 * +! * +!******************************************************************************* + +! 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. + end=bdate+dble(real(ideltas)/86400.)+dble(real(idiffmax)/ & + 86400.) + else ! backward trajectories + beg=bdate+dble(real(ideltas)/86400.)-dble(real(idiffmax)/ & + 86400.) + end=bdate+1. + endif + +! Open the wind field availability file and read available wind fields +! within the modelling period. +!********************************************************************* + + open(unitavailab,file=path(3)(1:length(3)),status='old', & + err=804) + + do i=1,3 + read(unitavailab,*) + enddo + + numbwf=0 +100 read(unitavailab,*,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 + wfspec1(numbwf)=spec + wftime1(numbwf)=nint((jul-bdate)*86400.) + 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=803) + + do i=1,3 + read(unitavailab,*) + enddo + + numbwfn(k)=0 +700 read(unitavailab,*,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.) + endif + goto 700 ! next wind field + +699 continue + + enddo + close(unitavailab) + + +! 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 + enddo + +! 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(*,*) 'FLEXTRA 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 + enddo + enddo + + +! For backward trajectories, reverse the order of the windfields +!*************************************************************** + + do i=1,numbwf + wfdt(i)=-999999 + enddo + if (ideltas.ge.0) then + do i=1,numbwf + wfname(i)=wfname1(i) + wfspec(i)=wfspec1(i) + wftime(i)=wftime1(i) + if(i.gt.1) wfdt(i)=wftime1(i)-wftime1(i-1) + enddo + 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) + enddo + enddo + else + do i=1,numbwf + wfname(numbwf-i+1)=wfname1(i) + wfspec(numbwf-i+1)=wfspec1(i) + wftime(numbwf-i+1)=wftime1(i) +! if(i.lt.numbwf) wfdt(numbwf-i+1)=wftime1(i+1)-wftime1(i) + if(i.gt.1) wfdt(numbwf-i+1)=wftime1(i)-wftime1(i-1) + enddo + 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) + enddo + enddo + 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 + enddo + + do k=1,numbnests + if (numbwfn(k).ne.numbwf) then + write(*,*) 'FLEXTRA 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(*,*) 'FLEXTRA 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 + enddo + enddo + +! 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 + enddo + + call gridcheck() + call gridcheck_nests() + +! jdf end read available +!************************************************* +! jdf start read outgrid +!************************************************* +! +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine readoutgrid. * +! * +! This routine reads the user specifications for the output grid. * +! * +! Author: A. Stohl * +! * +! 4 June 1996 * +! * +! Dec 2005, R. Easter - * +! The output grid is defined by specifying its southwest and * +! northease corners, either in degrees-latlon or grid-meters * +! Changes to some read formats (wider fields). * +! Changed names of "*lon0*" & "*lat0*" variables * +! 10 Mar 2006, R. Easter - * +! Change eps from 1.0e-4 (degrees value) to 10.0 (meters value) * +! * +!******************************************************************************* +! * +! Variables: * +! dxout,dyout grid distance * +! numxgrid,numygrid,numzgrid grid dimensions * +! out_xm0,out_ym0 lower left corner of grid * +! outheight(maxzgrid) height levels of output grid [m] * +! * +! Constants: * +! unitpath unit connected to file OUTGRID * +! * +!******************************************************************************* + +! Open the OUTGRID file and read output grid specifications +!********************************************************** + + call skplin(1,unitpath) + + +! 1. Read horizontal grid specifications +! +! *** NOTE *** +! [xtmp1, ytmp1] are the coordinates of the southwest corner +! of the first (i.e., southwest or lower-left) output grid cell +! [xtmp2, ytmp2] are the coordinates of the northeast corner +! of the last (i.e,, northeast or upper-right) output grid cell +!**************************************** + +! read(unitpath,'(f15.8)') xtmp1 + read(unitpath,*) xtmp1 +! read(unitpath,'(f15.8)') ytmp1 + read(unitpath,*) ytmp1 +! read(unitpath,'(2x,i7)') numxgrid + read(unitpath,*) numxgrid +! read(unitpath,'(2x,i7)') numygrid + read(unitpath,*) numygrid +! read(unitpath,'(2x,i4)') outgriddef + read(unitpath,*) outgriddef + if (outgriddef.eq.1) then +! read(unitpath,'(f15.8)') xtmp2 + read(unitpath,*) xtmp2 +! read(unitpath,'(f15.8)') ytmp2 + read(unitpath,*) ytmp2 + else +! read(unitpath,'(f15.8)') dxout +! read(unitpath,'(f15.8)') dyout + read(unitpath,*) dxout + read(unitpath,*) dyout + xtmp2=dxout*real(numxgrid)+xtmp1 + ytmp2=dyout*real(numygrid)+ytmp1 + endif + + if (option_verbose.eq. 1) then + write(*,'(/a)') 'readoutgrid diagnostics' + write(*,'(a,1p,2e18.10)') 'xtmp1, ytmp1 (in)', xtmp1, ytmp1 + write(*,'(a,1p,2e18.10)') 'xtmp2, ytmp2 (in)', xtmp2, ytmp2 + endif + if (outgrid_option .eq. 1) then +! In this case, the above inputs are the actual geographical lat/lon +! of the southwest & northeast corners of the output grid +! Need to convert from lat/lon to grid-meters + outgrid_swlon = xtmp1 + outgrid_swlat = ytmp1 + + outgrid_nelon = xtmp2 + outgrid_nelat = ytmp2 + call ll_to_xymeter_wrf( outgrid_swlon, outgrid_swlat, & + out_xm0, out_ym0 ) + call ll_to_xymeter_wrf( outgrid_nelon, outgrid_nelat, & + xtmp, ytmp ) +! 10-mar-2006 rce +! If out_xm0 is very close to mother grid sw corner (=xmet0), set it to that +! If xtmp is very close to mother grid ne corner (=xmet0+nxmin1*dx), set it to that +! Do similar for out_ym0 & ytmp + if (abs(out_xm0-xmet0) .le. eps) out_xm0 = xmet0 + if (abs(out_ym0-ymet0) .le. eps) out_ym0 = ymet0 + xr1 = xmet0 + real(nxmin1)*dx + yr1 = ymet0 + real(nymin1)*dy + if (abs(xtmp-xr1) .le. eps) xtmp = xr1 + if (abs(ytmp-yr1) .le. eps) ytmp = yr1 + dxout = (xtmp - out_xm0)/numxgrid + dyout = (ytmp - out_ym0)/numygrid + if (outgrid_option.eq.1) then ! regular + outlat0=outgrid_swlat + outlon0=outgrid_swlon + dyoutl=(outgrid_nelat-outgrid_swlat)/numygrid + dxoutl= (outgrid_nelon-outgrid_swlon)/numxgrid + endif + else +! In this case, the above inputs are in grid-meters +! Need to convert from grid-meters to lat/lon + out_xm0 = xtmp1 + out_ym0 = ytmp1 + dxout = (xtmp2 - xtmp1)/numxgrid + dyout = (ytmp2 - ytmp1)/numygrid + call xymeter_to_ll_wrf( xtmp1, ytmp1, & + outgrid_swlon, outgrid_swlat ) + call xymeter_to_ll_wrf( xtmp2, ytmp2, & + outgrid_nelon, outgrid_nelat ) + if (option_verbose.eq. 1) then + write(*,'(f15.10,5x,a)') outgrid_swlon, 'outgrid_swlon' + write(*,'(f15.10,5x,a)') outgrid_swlat, 'outgrid_swlat' + write(*,'(f15.10,5x,a)') outgrid_nelon, 'outgrid_nelon' + write(*,'(f15.10,5x,a)') outgrid_nelat, 'outgrid_nelat' + endif + end if + if (option_verbose.eq. 1) then + write(*,'(a,1p,2e18.10)') 'out_xm0, out_ym0 ', out_xm0, out_ym0 + write(*,'(a,1p,2e18.10)') 'dxout, dyout ', dxout, dyout + endif + +! Check validity of output grid (shall be within model domain) +!************************************************************* + + xr=out_xm0+real(numxgrid)*dxout + yr=out_ym0+real(numygrid)*dyout + xr1=xmet0+real(nxmin1+1)*dx + yr1=ymet0+real(nymin1+1)*dy + if (outgrid_option.lt.1) then +! print*,'nx',nxmin1,nymin1 + if ((out_xm0+eps.lt.xmet0).or.(out_ym0+eps.lt.ymet0) & + .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then + write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####' + write(*,*) ' #### GRID IS OUTSIDE MODEL DOMAIN. CHANGE ####' + write(*,*) ' #### OUTGRID IN INPUT FILE ####' + write(*,'(a)') path(1)(1:length(1)) + stop + endif + endif +! if ((numxgrid.gt.maxxgrid).or.(numygrid.gt.maxygrid)) then +! write(*,*) ' #### FLEXPART MODEL ERROR! DIMENSIONS OF ####' +! write(*,*) ' #### OUTPUT GRID EXCEED MAXIMUM VALUES. ####' +! write(*,*) ' #### CHANGE FILE $FLEXPART/options/OUTGRID. ####' +! stop +! endif + +! 2. Vertical levels of output grid +!********************************** + + read(unitpath,*) numzgrid +! if (numzgrid.gt.maxzgrid) then +! write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY HEIGHT #### ' +! write(*,*) ' #### LEVELS ARE GIVEN FOR OUTPUT GRID. #### ' +! write(*,*) ' #### MAXIMUM NUMBER IS ',maxzgrid,' #### ' +! write(*,*) ' #### PLEASE MAKE CHANGES IN FILE OUTGRID. #### ' +! stop +! endif + + 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' + + 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' + + do j=1,numzgrid + read(unitpath,*) outhelp + outheight(j)=outhelp + enddo + + +! 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 OUTGRID. #### ' + endif + enddo + +! 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. + enddo + + xoutshift=xmet0-out_xm0 + youtshift=ymet0-out_ym0 + + if(nested_output .eq. 1) then + call skplin(1,unitpath) +! read(unitpath,'(f15.8)') xtmp1 +! read(unitpath,'(f15.8)') ytmp1 +! read(unitpath,'(4x,i5)') numxgridn +! read(unitpath,'(4x,i5)') numygridn +! read(unitpath,'(2x,i4)') outgriddefn + read(unitpath,*) xtmp1 + read(unitpath,*) ytmp1 + read(unitpath,*) numxgridn + read(unitpath,*) numygridn + read(unitpath,*) outgriddefn + if (outgriddefn.eq.1) then +! read(unitpath,'(f15.8)') xtmp2 +! read(unitpath,'(f15.8)') ytmp2 + read(unitpath,*) xtmp2 + read(unitpath,*) ytmp2 + else +! read(unitpath,'(f15.8)') dxoutn +! read(unitpath,'(f15.8)') dyoutn + read(unitpath,*) dxoutn + read(unitpath,*) dyoutn + xtmp2=dxoutn*real(numxgridn)+xtmp1 + ytmp2=dyoutn*real(numygridn)+ytmp1 + endif + + write(*,'(/a)') 'readoutgrid_nest diagnostics' + write(*,'(a,1p,2e18.10)') 'xtmp1, ytmp1 (in)', xtmp1, ytmp1 + write(*,'(a,1p,2e18.10)') 'xtmp2, ytmp2 (in)', xtmp2, ytmp2 + if (outgrid_option .eq. 1) then +! In this case, the above inputs are the actual geographical lat/lon +! of the southwest & northeast corners of the output grid +! Need to convert from lat/lon to grid-meters + outgridn_swlon = xtmp1 + outgridn_swlat = ytmp1 + outgridn_nelon = xtmp2 + outgridn_nelat = ytmp2 + call ll_to_xymeter_wrf( outgridn_swlon, outgridn_swlat, & + out_xm0n, out_ym0n ) + call ll_to_xymeter_wrf( outgridn_nelon, outgridn_nelat, & + xtmp, ytmp ) + dxoutn = (xtmp - out_xm0n)/numxgridn + dyoutn = (ytmp - out_ym0n)/numygridn + if (outgrid_option.eq.1) then ! regular + outlat0n=outgridn_swlat + outlon0n=outgridn_swlon + dyoutln=(outgridn_nelat-outgridn_swlat)/numygridn + dxoutln= (outgridn_nelon-outgridn_swlon)/numxgridn + endif + + else +! In this case, the above inputs are in grid-meters +! Need to convert from grid-meters to lat/lon + out_xm0n = xtmp1 + out_ym0n = ytmp1 + dxoutn = (xtmp2 - xtmp1)/numxgridn + dyoutn = (ytmp2 - ytmp1)/numygridn + call xymeter_to_ll_wrf( xtmp1, ytmp1, & + outgridn_swlon, outgridn_swlat ) + call xymeter_to_ll_wrf( xtmp2, ytmp2, & + outgridn_nelon, outgridn_nelat ) + write(*,'(f15.10,5x,a)') outgridn_swlon, 'outgridn_swlon' + write(*,'(f15.10,5x,a)') outgridn_swlat, 'outgridn_swlat' + write(*,'(f15.10,5x,a)') outgridn_nelon, 'outgridn_nelon' + write(*,'(f15.10,5x,a)') outgridn_nelat, 'outgridn_nelat' + endif + write(*,'(a,1p,2e18.10)') 'out_xm0n, out_ym0n',out_xm0n,out_ym0n + write(*,'(a,1p,2e18.10)') 'dxoutn, dyoutn ',dxoutn,dyoutn + + +! Check validity of output grid (shall be within model domain) +!************************************************************* + + xr=out_xm0n+real(numxgridn)*dxoutn + yr=out_ym0n+real(numygridn)*dyoutn + xr1=xmet0+real(nxmin1+1)*dx + yr1=ymet0+real(nymin1+1)*dy + if ((out_xm0n+eps.lt.xmet0).or.(out_ym0n+eps.lt.ymet0) & + .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(*,*) ' #### OUTGRID ####' + write(*,'(a)') path(1)(1:length(1)) + stop + endif +! if ((numxgridn.gt.maxxgridn).or.(numygridn.gt.maxygridn)) then +! write(*,*) ' #### FLEXPART MODEL ERROR! DIMENSIONS OF ####' +! write(*,*) ' #### OUTPUT NEST EXCEED MAXIMUM VALUES. ####' +! write(*,*) ' #### CHANGE FILE $FLEXPART/options/OUTGRID. ####' +! stop +! endif + xoutshiftn=xmet0-out_xm0n + youtshiftn=ymet0-out_ym0n + allocate(orooutn(0:numxgridn-1,0:numygridn-1) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate orooutn' + allocate(arean(0:numxgridn-1,0:numygridn-1) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate arean' + allocate(volumen(0:numxgridn-1,0:numygridn-1,numzgrid) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate volumen' + + endif + +! jdf end read outgrid +!************************************************* +! jdf start read receptors +!************************************************* +! +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine assignland. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! This routine reads the user specifications for the receptor points. * +! * +! Author: A. Stohl * +! * +! 1 August 1996 * +! * +! Oct 2005, R. Easter - change calc of receptorarea() * +! Dec 2005, R. Easter - x/yrecptor values may be input either as * +! degrees-latlon or grid-meters * +! Changes to some read formats (wider fields). * +! Changed names of "*lon0*" & "*lat0*" variables * +! * +!******************************************************************************* +! * +! 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 * +! * +!******************************************************************************* + + call skplin(1,unitpath) + read(unitpath,*) numreceptor +! For backward runs, do not allow receptor output. Thus, set number of receptors to zero +!*************************************************************************************** + + if (ldirect.lt.0) then + numreceptor=0 + endif + +! Open the RECEPTORS file and read output grid specifications +!************************************************************ +! Read the names and coordinates of the receptors +!************************************************ + + if (numreceptor.gt.maxreceptor) then + write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### ' + write(*,*) ' #### POINTS ARE GIVEN. #### ' + write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### ' + write(*,*) ' #### PLEASE MAKE CHANGES IN RECEPTORS #### ' + stop + endif + do j=1,numreceptor + read(unitpath,'(4x,a16)') receptor + read(unitpath,*) x + read(unitpath,*) y + receptorname(j)=receptor + + write(*,'(/a,i5)') 'readreceptor diagnostics, j =', j + write(*,'(a,1p,2e18.10)') 'x, y (in) ', x, y + if (numpoint_option .eq. 1) then +! In this case, the above inputs are the actual geographical lat/lon +! Need to convert from lat/lon to grid-index coordinates + receptor_lon(j) = x + receptor_lat(j) = y + call ll_to_xyindex_wrf( receptor_lon(j), receptor_lat(j), & + xreceptor(j), yreceptor(j) ) + else +! In this case, the above inputs are in grid-meters +! Need to convert from grid-meters to grid-index coordinates, then to lat/lon + xreceptor(j)=(x-xmet0)/dx + yreceptor(j)=(y-ymet0)/dy + call xyindex_to_ll_wrf( 0, xreceptor(j), yreceptor(j), & + receptor_lon(j), receptor_lat(j) ) + write(*,'(f15.10,5x,a)') receptor_lon(j), 'receptor_lon' + write(*,'(f15.10,5x,a)') receptor_lat(j), 'receptor_lat' + end if + write(*,'(a,1p,2e18.10)') 'x, yreceptor', & + xreceptor(j), yreceptor(j) + +! for FLEXPART_WRF, dx & dy are in meters, +! receptorarea() appears to be area in m**2 of a mother grid cell +! centers on x,y +! xm=r_earth*cos(y*pi/180.)*dx/180.*pi +! ym=r_earth*dy/180.*pi + xm=dx + ym=dy + receptorarea(j)=xm*ym + enddo + +! jdf end read receptors +!************************************************* +! jdf start read species +!************************************************* +! +!******************************************************************************* +! * +! This routine reads names and physical constants of chemical species/ * +! radionuclides available with FLEXPART. * +! * +! 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 * +! * +! Constants: * +! * +!******************************************************************************* + +! Open the SPECIES file and read species names and properties +!************************************************************ + + read(unitpath,*) + read(unitpath,*) numtable + read(unitpath,*) + + do i=1,numtable + read(unitpath,21) specname(i),decaytime(i), & + wetscava(i),wetscavb(i),drydiff(i),dryhenry(i),dryactiv(i), & + partrho(i),partmean(i),partsig(i),dryvelo(i),weightmol(i), & + ohreact(i),spec_ass(i),kao(i) +! read(unitpath,21) specname(i),decay(i), & +! weta(i),wetb(i),reldiff(i),henry(i),f0(i), & +! density(i),dquer(i),dsigma(i),dryvel(i),weightmolar(i), & +! ohreact(i),spec_ass(i),kao(i) + pos_spec=i + + if ((wetscava(i).gt.0.).and.(dryhenry(i).le.0.)) then + if (partmean(i).le.0.) goto 996 ! no particle, no henry set + endif + + + if (spec_ass(i).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 (partsig(i).eq.1.) partsig(i)=1.0001 ! avoid realing exception + if (partsig(i).eq.0.) partsig(i)=1.0001 ! avoid realing exception + + if ((drydiff(i).gt.0.).and.(partrho(i).gt.0.)) then + write(*,*) '#### FLEXPART MODEL ERROR! SPECIES FORMAT ####' + write(*,*) '#### IS CORRUPT. SPECIES CANNOT BE BOTH ####' + write(*,*) '#### PARTICLE AND GAS. ####' + stop + endif + enddo + +21 format(4x,a10,f10.1,e11.1,f6.2,f7.1,e9.1,f5.1,e10.1,2e8.1,2f8.2, & + e18.1,i18,f18.2) + +! jdf end read species +!************************************************* +! jdf start read releases +!************************************************* +! +!******************************************************************************* +! * +! This routine reads the release point specifications for the current * +! model run. Several release points can be used at the same time. * +! * +! Note: This is the FLEXPART_WRF version of subroutine readreleases. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! Author: A. Stohl * +! 18 May 1996 * +! * +! Update: 29 January 2001 * +! Release altitude can be either in magl or masl * +! * +! Nov 2005, R. Easter - Do not adjust xpoint1 & 2 by +/-360 degrees * +! Dec 2005, R. Easter - x/ypoint1/2 values may be input either as * +! degrees-latlon or grid-meters * +! * +!******************************************************************************* +! * +! 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 are* +! weta, wetb parameters to determine the wet scavenging coefficient * +! zpoint1,zpoint2 height range, over which release takes place * +! * +!******************************************************************************* + + DEP=.false. + DRYDEP=.false. + WETDEP=.false. + do i=1,maxspec + DRYDEPSPEC(i)=.false. + enddo + +! Open the releases file and read user options +!********************************************* + +! 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(1,unitpath) + +! Read the number of species and the link to the species information table +! Assign species-specific parameters needed for physical processes +!************************************************************************* + + read(unitpath,*) nspec + read(unitpath,*) emitvar + if (nspec.gt.maxspec) then + 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 + endif + do i=1,nspec + read(unitpath,*) link(i) + species(i)=specname(link(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 +!***************** + + weightmolar(i)=weightmol(link(i)) + 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/decaytime(link(i)) !conversion half life to decay constant + +! Wet deposition +!*************** + + weta(i)=wetscava(link(i)) + wetb(i)=wetscavb(link(i)) + +! Dry deposition of gases +!************************ + + reldiff(i)=drydiff(link(i)) ! Diffusivity rel. to H20 + henry(i)=dryhenry(link(i)) ! Henry constant + f0(i)=dryactiv(link(i)) ! activity + if (reldiff(i).gt.0.) & + rm(i)=1./(henry(i)/3000.+100.*f0(i)) ! mesophyll resistance + +! Dry deposition of particles +!**************************** + + vsetaver(i)=0. + density(i)=partrho(link(i)) ! Particle density + dquer(i)=partmean(link(i))*1000000. ! Conversion m to um + dsigma(i)=partsig(link(i)) + if (density(i).gt.0.) then ! Additional parameters +! call part0(dquer(i),dsigma(i),density(i),fracth,schmih,vsh) + 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) + enddo + endif + +! Dry deposition for constant deposition velocity +!************************************************ + + dryvel(i)=dryvelo(link(i))*0.01 ! conversion to m/s + + if (weta(i).gt.0.) WETDEP=.true. + if ((reldiff(i).gt.0.).or.(density(i).gt.0.).or. & + (dryvel(i).gt.0.)) then + DRYDEP=.true. + DRYDEPSPEC(i)=.true. + endif + + +! 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. + enddo + do j=1,7 + area_dow(i,j)=1. + point_dow(i,j)=1. + enddo + +! write(aspecnumb,'(i3.3)') link(i) +! open(unitemissvar,file=path(1)(1:len(1))//'EMISSION_VARIATION_' +! + //aspecnumb//'.dat',status='old',err=35) +! read(unitemissvar,*) + if(emitvar.eq.1) then + do j=1,24 ! 24 hours, starting with 0-1 local time + read(unitpath,*) ihour,area_hour(i,j),point_hour(i,j) + enddo +! read(unitemissvar,*) + do j=1,7 ! 7 days of the week, starting with Monday + read(unitpath,*) idow,area_dow(i,j),point_dow(i,j) + enddo +! close(unitemissvar) + endif + +!35 continue + enddo + if (WETDEP.or.DRYDEP) DEP=.true. + + +! Read specifications for each release point +!******************************************* + + numpoint=0 + numpartmax=0 + releaserate=0. + releaserate2=0. + read(unitpath,*) numpoint + +! numpoint2=numpoint+500 + numpoint2=numpoint+0 + allocate(ireleasestart(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(ireleaseend(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(xpoint1(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(xpoint12(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(xpoint22(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(ypoint12(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(ypoint22(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(releases_swlon(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(releases_swlat(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(releases_nelon(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(releases_nelat(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(xpoint2(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(ypoint1(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(ypoint2(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(zpoint1(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(zpoint2(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(kindz(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(xmass(numpoint2,maxspec) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(rho_rel(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + allocate(npart(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' +! print*,'allocate xmassa',numpoint + allocate(xmasssave(numpoint2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate RELEASPOINT' + + if (option_verbose.eq. 1) then + write (*,*) ' Releasepoints allocated: ', numpoint + endif + do i=1,numpoint + xmasssave(i)=0. + end do + + + +! if (numpoint.gt.maxpoint) goto 997 + do j=1,numpoint + read(unitpath,*) id1,it1 + read(unitpath,*) id2,it2 + read(unitpath,*) xpoint1(j) + read(unitpath,*) ypoint1(j) + read(unitpath,*) xpoint2(j) + read(unitpath,*) ypoint2(j) + read(unitpath,*) kindz(j) + read(unitpath,*) zpoint1(j) + read(unitpath,*) zpoint2(j) + read(unitpath,*) npart(j) + do i=1,nspec + read(unitpath,*) xmass(j,i) + enddo + nparttot=nparttot+npart(j) + if (j.le.2000) then + read(unitreleases,'(a40)',err=998) compoint(j)(1:40) + else + read(unitreleases,'(a40)',err=998) compoint(2001)(1:40) + endif + +! read(unitpath,'(a20)',err=998) compoint(j)(1:20) + + if(option_verbose.ge.1) print*,'release location=',j +! write(*,'(/a,i7)') 'readreleases diagnostics - numpoint = ', j +! write(*,'(a,1p,2e18.10)') 'x, ypoint1 (in) ', & +! xpoint1(j), ypoint1(j) +! write(*,'(a,1p,2e18.10)') 'x, ypoint2 (in) ', & +! xpoint2(j), ypoint2(j) +! JB +! In this case, the above inputs are the actual geographical lat/lon +! of the southwest & northeast corners of the release area +! Need to convert from lat/lon to grid-meters +! if (outgrid_option.eq.1) then !regular + if (numpoint_option.eq.1) then !regular + xpoint12(j)=xpoint1(j) + xpoint22(j)=xpoint2(j) + ypoint12(j)=ypoint1(j) + ypoint22(j)=ypoint2(j) + + + releases_swlon(j) = xpoint1(j) + releases_swlat(j) = ypoint1(j) + releases_nelon(j) = xpoint2(j) + releases_nelat(j) = ypoint2(j) + call ll_to_xymeter_wrf( releases_swlon(j), releases_swlat(j), & + xpoint1(j), ypoint1(j) ) + call ll_to_xymeter_wrf( releases_nelon(j), releases_nelat(j), & + xpoint2(j), ypoint2(j) ) + + else +! write(*,'(a,1p,2e18.10)') 'x, ypoint1 ', +! & xpoint1(j), ypoint1(j) +! write(*,'(a,1p,2e18.10)') 'x, ypoint2 ', +! & xpoint2(j), ypoint2(j) +! else +! In this case, the above inputs are in grid-meters +! Need to convert from grid-meters to lat/lon + call xymeter_to_ll_wrf( xpoint1(j), ypoint1(j), & + releases_swlon(j), releases_swlat(j) ) + call xymeter_to_ll_wrf( xpoint2(j), ypoint2(j), & + releases_nelon(j), releases_nelat(j) ) + endif +! write(*,'(f15.10,5x,a)') releases_swlon(j), 'releases_swlon' +! write(*,'(f15.10,5x,a)') releases_swlat(j), 'releases_swlat' +! write(*,'(f15.10,5x,a)') releases_nelon(j), 'releases_nelon' +! write(*,'(f15.10,5x,a)') releases_nelat(j), 'releases_nelat' +! end if + +! If a release point contains no particles, stop and issue error message +!*********************************************************************** + + if (npart(j).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 +!********************************************************************* + +! FLEXPART_WRF - x & y coords are in meters, so the following lines +! (which adjust longitude by +/-360 degrees) are not needed +! +! 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(j)=int((jul1-bdate)*86400.) + ireleaseend(j)=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(j)=int((jul1-bdate)*86400.) + ireleaseend(j)=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(j).ne.ireleaseend(j)) then + releaserate=releaserate+real(npart(j))/ & + real(ireleaseend(j)-ireleasestart(j)) +! print*,'release',ireleaseend(j),ireleasestart(j) + else + releaserate=99999999. + endif + if (ireleaseend(j)-ireleasestart(j).lt.lage(nageclass)) then + releaserate2=releaserate2+real(npart(j)) + else + releaserate2=releaserate2+real(npart(j))*real(lage(nageclass))/ & + real(ireleaseend(j)-ireleasestart(j)) + endif + numpartmax=numpartmax+npart(j) + + if (ioutputforeachrelease.eq.1) then + maxpointspec_act=numpoint + else + maxpointspec_act=1 + endif + + enddo + + maxpart=int(releaserate2*1.1) +! print*,'maxpart',maxpart,releaserate2,nparttot +! maxpart=40000000 + +! print*,'numpoint',numpoint +! print*,'NPARTTOT',nparttot,lage(4),lage(5),lage(6),nageclass +! print*,'maxpart',maxpart,real(lage(nageclass)),releaserate,releaserate2,real(lage(nageclass))*1.1*releaserate +! nparttot2=nparttot+500000 +! nparttot2=nparttot + + nparttot2=maxpart + allocate(xmass1(nparttot2,nspec) & + ,stat=stat) +! allocate(drydep1(nparttot2,nspec) & +! ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate xmass1' + allocate(itra1(nparttot2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate itra1' + allocate(npoint(nparttot2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate npoint' + allocate(nclass(nparttot2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate nclass' + allocate(idt(nparttot2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate idt ' + allocate(itramem(nparttot2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate itrame' + allocate(itrasplit(nparttot2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate itrasp' + allocate(xtra1(nparttot2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate xtra1 ' + allocate(ytra1(nparttot2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate ytra1 ' + allocate(ztra1(nparttot2) & + ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate ztra1 ' + + do j=1,nparttot2 + itra1(j)=-999999999 + enddo + + + 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 + + +! Make a consistency check, whether the forward/backward switch is correctly set +!******************************************************************************* + +! if (ldirect.eq.1) then +! if (maxpointspec.lt.nspec) then +! write(*,*) '#####################################################' +! write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####' +! write(*,*) '#### ####' +! write(*,*) '#### ERROR - PARAMETER MAXPOINTSPEC IS NOT ####' +! write(*,*) '#### CORRECTLY SET FOR A FORWARD SIMULATION. ####' +! write(*,*) '#### CHANGE APPROPRIATELY IN FILE INCLUDEPAR. ####' +! write(*,*) '#####################################################' +! endif +! else +! if (maxpointspec.lt.numpoint) then +! write(*,*) '#####################################################' +! write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####' +! write(*,*) '#### ####' +! write(*,*) '#### ERROR - PARAMETER MAXPOINTSPEC IS NOT ####' +! write(*,*) '#### CORRECTLY SET FOR A BACKWARD SIMULATION. ####' +! write(*,*) '#### CHANGE APPROPRIATELY IN FILE INCLUDEPAR. ####' +! write(*,*) '#####################################################' +! endif +! endif + + return + +! jdf end read releases +!************************************************* + +997 write(*,*) '#####################################################' + write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####' + write(*,*) '#### ####' + write(*,*) '#### ERROR - NUMBER OF RELEASE POINTS SPECIFIED ####' + write(*,*) '#### IN "RELEASES" EXCEEDS THE MAXIMUM ####' + write(*,*) '#### ALLOWED NUMBER. ####' + write(*,*) '#####################################################' + stop + + +998 write(*,*) '#####################################################' + write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####' + write(*,*) '#### ####' + write(*,*) '#### FATAL ERROR - "RELEASES" IS ####' + write(*,*) '#### CORRUPT. PLEASE CHECK YOUR INPUTS FOR ####' + write(*,*) '#### MISTAKES OR GET A NEW "RELEASES"- ####' + 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 + +800 write(*,*) ' #### TRAJECTORY MODEL ERROR! ERROR WHILE #### ' + write(*,*) ' #### READING FILE PATHNAMES. #### ' + stop + +801 write(*,*) '#### TRAJECTORY MODEL ERROR! FILE '// inputname + write(*,*) '#### CANNOT BE OPENED IN THE CURRENT WORKING #### ' + write(*,*) '#### DIRECTORY. #### ' + stop + +803 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 + +804 write(*,*) ' #### FLEXPART MODEL ERROR! FILE #### ' + write(*,'(a)') ' '//path(3)(1:length(3)) + write(*,*) ' #### CANNOT BE OPENED #### ' + stop +996 write(*,*) '#####################################################' + write(*,*) '#### FLEXPART MODEL ERROR! #### ' + write(*,*) '#### WET DEPOSITION SWITCHED ON, BUT NO HENRYS #### ' + write(*,*) '#### CONSTANT IS SET ####' + write(*,*) '#### PLEASE MODIFY SPECIES DESCR. #### ' + write(*,*) '#####################################################' + stop + + end diff --git a/src_flexwrf_v3.1/readlanduse.f90 b/src_flexwrf_v3.1/readlanduse.f90 new file mode 100644 index 0000000000000000000000000000000000000000..19a9038b46f3c617bfea8c24f503d4177533b5d9 --- /dev/null +++ b/src_flexwrf_v3.1/readlanduse.f90 @@ -0,0 +1,172 @@ +!********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine 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', & + open(unitland,file='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', & + open(unitsurfdata,file='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) + read(unitsurfdata,'(45x,f4.3)') z0(i) + end do + close(unitsurfdata) + + return + + ! Issue error messages + !********************* + +998 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####' + write(*,*) ' #### LANDUSE INVENTORY DOES NOT EXIST ####' + write(*,*) ' #### IT IS NEEDED FOR DRY DEPOSITION ####' + write(*,*) ' #### COPY DATA FROM src_flexwrf_v3.0/data ####' + write(*,*) ' #### IN YOUR CURRENT DIRECTORY ####' + write(*,*) ' #### OR USE A DIFFERENT SPECIES ####' + stop + +999 write(*,*) ' #### FLEXPART ERROR! FILE CONTAINING ####' + write(*,*) ' #### RELATION LANDUSE,z0 DOES NOT EXIST ####' + write(*,*) ' #### IT IS NEEDED FOR DRY DEPOSITION ####' + write(*,*) ' #### COPY DATA FROM src_flexwrf_v3.0/data ####' + write(*,*) ' #### IN YOUR CURRENT DIRECTORY ####' + write(*,*) ' #### OR USE A DIFFERENT SPECIES ####' + stop + +end subroutine readlanduse diff --git a/src_flexwrf_v3.1/readohfield.f90 b/src_flexwrf_v3.1/readohfield.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5de1d9d4c882d68755c217b8930e2b95f38dd167 --- /dev/null +++ b/src_flexwrf_v3.1/readohfield.f90 @@ -0,0 +1,90 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine 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', & + open(unitOH,file='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 ####' + write(*,*) ' #### IT IS NEEDED FOR OH REACTION ####' + write(*,*) ' #### COPY DATA FROM src_flexwrf_v3.0/data ####' + write(*,*) ' #### IN YOUR CURRENT DIRECTORY ####' + write(*,*) ' #### OR USE A DIFFERENT SPECIES ####' + + stop + +end subroutine readohfield diff --git a/src_flexwrf_v3.1/readpartpositions.f90 b/src_flexwrf_v3.1/readpartpositions.f90 new file mode 100644 index 0000000000000000000000000000000000000000..736b95454018a8b73e84754a4011b490c6b4ba71 --- /dev/null +++ b/src_flexwrf_v3.1/readpartpositions.f90 @@ -0,0 +1,270 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine readpartpositions +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of 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 * +! * +! Dec 2005, R. Easter * +! Changed names of "*lon0*" & "*lat0*" variables * +! Reads either binary or ascii output files from previous run. * +! Particle positions may be in lat-lon or grid-meter units. * +! * +!******************************************************************************* +! * +! Variables: * +! * +!******************************************************************************* + +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + + implicit none + + integer :: ibdatein,ibtimein,nspecin,itimein,numpointin,i,j,ix + integer :: iomode_xycoord_in, numpart_in + integer :: itmp,ntmp, numxgridin,numygridin + real :: xlonin,ylatin,ran1,topo,hmixi,pvi,qvi,rhoi,tri,tti + real :: xtmp + character :: specin*7 + character :: ctmp*1 + real(kind=dp) :: julin,julpartin,juldate + integer :: idummy = -8 + + +! Open and read header file of dumped particle data +!***************************************** + + if (iouttype .eq. 0) then + + open(unitpartin,file=path(1)(1:length(1))//'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 + enddo + + 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) + enddo + enddo + read(unitpartin) + read(unitpartin) + + do ix=0,numxgrid-1 + read(unitpartin) + enddo + + close(unitpartin) + + else ! (iouttype .eq. 1) + + open(unitpartin,file=path(1)(1:length(1))//'header', & + form='formatted',err=998) + +! with formatted header file, need to read every variable +! because some of the "writes" cover multiple lines +! (and the number of lines is compiler dependent) + read(unitpartin,*) ibdatein,ibtimein + read(unitpartin,*) ctmp ! version id + read(unitpartin,*) itmp,itmp,itmp,itmp ! loutstep,loutaver,... + read(unitpartin,*) xtmp,xtmp,numxgridin,numygridin,xtmp,xtmp ! outgrid x,y info + + read(unitpartin,*) ntmp,(xtmp, i=1,ntmp) ! numzgrid,(outheight(i),i=1,numzgrid) + read(unitpartin,*) itmp,itmp ! jjjjmmdd,ihmmss + read(unitpartin,*) nspecin,itmp,itmp + nspecin=nspecin/3 + if ((ldirect.eq.1).and.(nspec.ne.nspecin)) goto 997 + + do i=1,nspecin + read(unitpartin,*) itmp ! 1 + read(unitpartin,*) ctmp ! "WD" name + read(unitpartin,*) itmp ! 1 + read(unitpartin,*) ctmp ! "DD" name + read(unitpartin,*) j + read(unitpartin,*) specin + if ((ldirect.eq.1).and.(species(i)(1:7).ne.specin)) goto 996 + enddo + + read(unitpartin,*) numpointin +! if (numpointin.ne.numpoint) goto 995 + do i=1,numpointin + read(unitpartin,*) itmp,itmp,itmp ! release start,end,kindz + read(unitpartin,*) xtmp,xtmp,xtmp,xtmp,xtmp,xtmp ! release x,y,z info + read(unitpartin,*) itmp,itmp ! npart(i), 1 + read(unitpartin,*) ctmp ! compoint(i) + do j=1,nspec + read(unitpartin,*) xtmp ! xmass(i,j) + read(unitpartin,*) xtmp ! xmass(i,j) + read(unitpartin,*) xtmp ! xmass(i,j) + enddo + enddo + read(unitpartin,*) itmp,itmp,itmp ! method,lsubgrid,lconvection + read(unitpartin,*) ntmp,(itmp, i=1,ntmp) ! nageclass,(lage(i),i=1,nageclass) + + do ix=0,numxgridin-1 + read(unitpartin,*) (xtmp, j=0,numygridin-1) ! oroout + enddo + + close(unitpartin) + + endif ! (iouttype .eq. 0/1) + + +! Open and read data file of dumped particle data +!*************************************** + + if (iouttype .eq. 0) then + open(unitpartin,file=path(1)(1:length(1))//'partposit_end', & + form='unformatted',err=998) + else + open(unitpartin,file=path(1)(1:length(1))//'partposit_end', & + form='formatted',err=998) + endif + +100 continue + if (iouttype .eq. 0) then + read(unitpartin,end=99) itimein,numpart_in, & + iomode_xycoord_in + else + read(unitpartin,*,end=99) itimein,numpart_in, & + iomode_xycoord_in + endif + +! iomode_xycoord of previous & current runs must match + if (iomode_xycoord_in .ne. outgrid_option) then + write(*,'(/a/a/)') '*** readpartpositions fatal error', & + 'outgrid_option from previous & current runs differ' + stop + end if + + i=0 +200 i=i+1 + if (iouttype .eq. 0) then + read(unitpartin) npoint(i),xlonin,ylatin,ztra1(i),itramem(i), & + topo,pvi,qvi,rhoi,hmixi,tri,tti,(xmass1(i,j),j=1,nspec) + else + read(unitpartin,*) npoint(i),itramem(i),xlonin,ylatin,ztra1(i), & + topo,pvi,qvi,rhoi,hmixi,tri,tti,(xmass1(i,j),j=1,nspec) + endif + + if (xlonin.eq.-9999.9) goto 100 + + if (outgrid_option .eq. 1) then +! convert from lat-lon to grid-index coordinates + call ll_to_xyindex_wrf( xlonin, ylatin, xtra1(i), ytra1(i) ) + else +! convert from grid-meter to grid-index coordinates + xtra1(i)=(xlonin-xmet0)/dx + ytra1(i)=(ylatin-ymet0)/dy + endif + goto 200 + +99 numpart=i-1 + + close(unitpartin) + + +! Set nclass, idt, itra1, itramem, itrasplit to be consistent +! with current run +!*************************************** + + 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 + enddo + 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.#### ' + write(*,*) 'julin: ',julin + write(*,*) 'bdate: ',bdate + 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(1)(1:length(1))//'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 + diff --git a/src_flexwrf_v3.1/readwind.f90 b/src_flexwrf_v3.1/readwind.f90 new file mode 100644 index 0000000000000000000000000000000000000000..faaecd767f56a193e9f7a09b7b19be9b68676264 --- /dev/null +++ b/src_flexwrf_v3.1/readwind.f90 @@ -0,0 +1,1459 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine readwind(indj,n,uuh,vvh,wwh,divh) +!********************************************************************** +! * +! TRAJECTORY MODEL SUBROUTINE READWIND * +! * +!********************************************************************** +! * +! AUTHOR: G. WOTAWA * +! DATE: 1997-08-05 * +! LAST UPDATE: 2000-10-17, Andreas Stohl * +! * +! Bernd C. Krueger, Feb. 2001: Variables tth and qvh * +! (on eta coordinates) in common block * +! * +! Oct-Dec, 2005: R. Easter. Major changes for WRF. * +! 06-nov-2005 rce - change uuh,vvh dimension back to original * +! 16-nov-2005 rce - zzh is shifted like pph,tth * +! * +! 11-June-2007, W.WANG -- read TKE, change ndims_exp=1 for P_TOP +! 19-Oct -2007, read tcc, RAINC, RAINNC, CLDFRA,W0AVG +! Note RAINC, RAINNC are accumulated prec +! Dec 2011, J Brioude: modifications, notably for the mean wind +! +! D. Arnold May 2012: quick fix - for CLDFRA +! CLDFRA was for sub-grid variability of precipitation +! within a cell from Hertel et al., 1995 (grid cells of approx. 150 km) +! WRF will be typically be run at higher resolutions, therefore +! we simply skip this condition and consider the maximum fraction +! no more reading of CLDFRA needed, initialized to 0. +! Same modifications for the nested domains! + +!********************************************************************** +! * +! Note: This is the FLEXPART_WRF version of subroutine readwind. * +! The met fields are read from WRF netcdf output files. * +! There are many differences from the FLEXPART version. * +! * +! 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 "T-grid" vertical levels wwf model * +! (the unstaggered "bottom_top" dimension) * +! uu,vv,ww wind fields * +! tt,qv temperature and specific humidity * +! ps surface pressure * +! * +!********************************************************************** +! + +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + +! subr arguments + integer :: indj, n + + 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) +! real(kind=4) :: urot(0:nxmax-1,0:nymax-1,nuvzmax) +! real(kind=4) :: vrot(0:nxmax-1,0:nymax-1,nuvzmax) + real(kind=4) :: divh(0:nxmax-1,0:nymax-1,nuvzmax) + real(kind=4) :: mu(0:nxmax-1,0:nymax-1,1),mu2 + real(kind=4) :: mub(0:nxmax-1,0:nymax-1,1) +! real :: utrue1,vtrue1,utrue2,vtrue2,dumy +! real(kind=4) :: m_u(0:nxmax-1,0:nymax-1,1) +! real(kind=4) :: m_v(0:nxmax-1,0:nymax-1,1) +! real(kind=4) :: m_w(0:nxmax-1,0:nymax-1,1) + +! real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax) +! real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax) +! real :: urot(0:nxmax-1,0:nymax-1,nuvzmax) +! real :: vrot(0:nxmax-1,0:nymax-1,nuvzmax) +! real :: wwh(0:nxmax-1,0:nymax-1,nwzmax) +! real :: divh(0:nxmax-1,0:nymax-1,nuvzmax) +! real :: mu(0:nxmax-1,0:nymax-1,1),mu2 +! real :: mub(0:nxmax-1,0:nymax-1,1) +! real :: m_u(0:nxmax-1,0:nymax-1,1) +! real :: m_v(0:nxmax-1,0:nymax-1,1) +! real :: m_x(0:nxmax-1,0:nymax-1,1) +! real :: m_y(0:nxmax-1,0:nymax-1,1) +! real :: m_z(0:nxmax-1,0:nymax-1,1) + +! local variables + integer,parameter :: ndims_max=4 + + integer :: i, idiagaa, ierr, ifn, itime + integer :: iduma + integer :: j, jhhmmss, jyyyymmdd + integer :: k, kbgn + integer :: lendim(ndims_max), lendim_exp(ndims_max), & + lendim_max(ndims_max) + integer :: levdiff2 + integer :: ndims, ndims_exp + integer :: n_west_east, n_south_north, n_bottom_top + integer :: m_grid_id_dum, m_parent_grid_id_dum, & + m_parent_grid_ratio_dum, & + i_parent_start_dum, j_parent_start_dum, & + map_proj_id_dum, & + ext_scalar,pbl_physics,mp_physics_dum + + real :: dx_met, dy_met + real :: duma, dumb, dumc, dumd, dume + real :: dumdz +! real(kind=4) :: dumarray_aa(nwzmax+1) +! real(kind=4) :: dumarray_pp(0:nxmax-1,0:nymax-1,nwzmax+1) + real :: dumarray_aa(nwzmax+1) + real :: dumarray_pp(0:nxmax-1,0:nymax-1,nwzmax+1) + real :: ewater_mb, esatwater_mb + real :: ew ! this is an external function + real :: map_stdlon_dum, map_truelat1_dum, map_truelat2_dum + real :: pint + real :: toler + +! real(kind=4) :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1) + real :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1) + real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1 + + real(kind=dp) :: jul,juldate + + character(len=160) :: fnamenc, varname,fnamenc2 + + logical :: hflswitch + +! +! get grid info from the wrf netcdf file +! and check it for consistency against values from gridcheck +! + fnamenc = path(2)(1:length(2))//wfname(indj) + idiagaa = 0 + + call read_ncwrfout_gridinfo( ierr, idiagaa, fnamenc, & + n_west_east, n_south_north, n_bottom_top, & + dx_met, dy_met, & + m_grid_id_dum, m_parent_grid_id_dum, m_parent_grid_ratio_dum, & + i_parent_start_dum, j_parent_start_dum, & + map_proj_id_dum, map_stdlon_dum, & + map_truelat1_dum, map_truelat2_dum, & + ext_scalar,pbl_physics,mp_physics_dum ) + if (ierr .ne. 0) then + write(*,9100) 'error getting gridinfor for met file', fnamenc + stop + end if + +9100 format( / '*** readwind -- ', a ) +9110 format( / '*** readwind -- ', a, 1x, i8 / & + 'file = ', a ) +9120 format( / '*** readwind -- ', a, 2(1x,i8) / & + 'file = ', a ) +9130 format( / '*** readwind -- ', a, 3(1x,i8) / & + 'file = ', a ) +9115 format( / '*** readwind -- ', a / a, 1x, i8 / & + 'file = ', a ) +9125 format( / '*** readwind -- ', a / a, 2(1x,i8) / & + 'file = ', a ) +9135 format( / '*** readwind -- ', a / a, 3(1x,i8) / & + 'file = ', a ) + + toler = 2.0e-7 + + if (nx .ne. n_west_east) then + write(*,9100) 'nx not consistent', fnamenc + stop + end if + if (ny .ne. n_south_north) then + write(*,9100) 'ny not consistent', fnamenc + stop + end if + if (nlev_ec .ne. n_bottom_top) then + write(*,9100) 'nlev_ec not consistent', fnamenc + stop + end if + if (nwz .ne. n_bottom_top+1) then + write(*,9100) 'nwz not consistent', fnamenc + stop + end if +! if (nuvz .ne. n_bottom_top+1) then +! write(*,9100) 'nuvz not consistent', fnamenc +! stop +! end if + + if (m_grid_id(0) .ne. m_grid_id_dum) then + write(*,9100) 'm_grid_id not consistent', fnamenc + write(*,*) m_grid_id(0), m_grid_id_dum + stop + end if + if (m_parent_grid_id(0) .ne. m_parent_grid_id_dum) then + write(*,9100) 'm_parent_grid_id not consistent', fnamenc + stop + end if + if (m_parent_grid_ratio(0) .ne. m_parent_grid_ratio_dum) then + write(*,9100) 'm_parent_grid_ratio not consistent', fnamenc + stop + end if + if (i_parent_start(0) .ne. i_parent_start_dum) then + write(*,9100) 'i_parent_start not consistent', fnamenc + stop + end if + if (j_parent_start(0) .ne. j_parent_start_dum) then + write(*,9100) 'j_parent_start not consistent', fnamenc + stop + end if + + if (abs(dx - dx_met) .gt. toler*abs(dx)) then + write(*,9100) 'dx not consistent', fnamenc + stop + end if + if (abs(dy - dy_met) .gt. toler*abs(dy)) then + write(*,9100) 'dy not consistent', fnamenc + stop + end if + +! locate the date/time in the file + itime = 0 +1100 itime = itime + 1 + call read_ncwrfout_1datetime( ierr, fnamenc, & + itime, jyyyymmdd, jhhmmss ) + if (ierr .eq. -1) then + write(*,9100) 'error reading time from met file', fnamenc + stop + else if (ierr .ne. 0) then + write(*,9125) 'unable to locate date/time in met file', & + 'indj, itime =', indj, itime, fnamenc + stop + else + jul = juldate( jyyyymmdd, jhhmmss ) + duma = (jul-bdate)*86400. + iduma = nint(duma) + if (iduma .ne. wftime(indj)) goto 1100 + end if + if (option_verbose.eq.1) then + write(*,*) + write(*,*) 'readwind processing wrfout file =' + write(*,*) fnamenc + write(*,*) 'itime, ymd, hms =', itime, jyyyymmdd, jhhmmss + + endif +! read eta_w_wrf, eta_u_wrf, p_top_wrf, ylat2d, xlon2d from the +! netcdf wrfout file and compare to those from the 1st met. file + + varname = 'ZNW' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nwz + lendim_max(1) = nwzmax+1 + ndims_exp = 2 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_aa, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + fnamenc2='wrfout_d03_zn.nc' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc2, & + varname, dumarray_aa, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of ZNW', fnamenc + stop + end if + end if + do k = 1, nwz + if (abs(eta_w_wrf(k) - dumarray_aa(k)) & + .gt. toler*abs(eta_w_wrf(k))) then + write(*,9100) 'eta_w_wrf not consistent', fnamenc + stop + end if + end do + + varname = 'ZNU' + lendim_exp(1) = nwz-1 + lendim_max(1) = nwzmax+1 + ndims_exp = 2 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_aa, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + fnamenc2='wrfout_d03_zn.nc' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc2, & + varname, dumarray_aa, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + + write(*,9100) 'error doing ncread of ZNU', fnamenc + stop + end if + end if + do k = 1, nwz-1 + if (abs(eta_u_wrf(k) - dumarray_aa(k)) & + .gt. toler*abs(eta_u_wrf(k))) then + write(*,9100) 'eta_u_wrf not consistent', fnamenc + stop + end if + end do + +! varname = 'P_TOP' +! lendim_exp(1) = 1 +! lendim_max(1) = 6 +! ndims_exp = 2 +! if (ext_scalar .lt. 0) ndims_exp = 1 +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, duma, & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing ncread of P_TOP', fnamenc +! stop +! end if +! if (abs(p_top_wrf - duma) .gt. toler*abs(p_top_wrf)) then +! write(*,9100) 'p_top_wrf not consistent', fnamenc +! stop +! end if + + varname = 'XLAT' + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + ndims_exp = 3 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_pp, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,9100) 'error doing ncread of XLAT', fnamenc + stop + end if + toler = 1.0e-6 + do j = 0, ny-1 + do i = 0, nx-1 + if (abs(ylat2d(i,j) - dumarray_pp(i,j,1)) .gt. & + toler*abs(ylat2d(i,j))) then + write(*,9100) 'ylat2d not consistent', fnamenc + write(*,'(a,2i5,2f16.6)') 'i,j,ylats =', i, j, & + ylat2d(i,j), dumarray_pp(i,j,1) + stop + end if + end do + end do + + varname = 'XLONG' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_pp, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,9100) 'error doing ncread of XLONG', fnamenc + stop + end if + do j = 0, ny-1 + do i = 0, nx-1 + if (abs(xlon2d(i,j) - dumarray_pp(i,j,1)) .gt. & + toler*abs(xlon2d(i,j))) then + write(*,9100) 'xlon2d not consistent', fnamenc + write(*,'(a,2i5,2f16.6)') 'i,j,xlons =', i, j, & + xlon2d(i,j), dumarray_pp(i,j,1) + stop + end if + end do + end do + + +! +! +! now read the data fields for current time +! the following are read from ecmwf met files +! U VELOCITY +! V VELOCITY +! W VELOCITY +! TEMPERATURE +! SPEC. HUMIDITY +! SURF. PRESS. +! SEA LEVEL PRESS. +! 10 M U VELOCITY +! 10 M V VELOCITY +! 2 M TEMPERATURE +! 2 M DEW POINT +! SNOW DEPTH +! CLOUD COVER +! LARGE SCALE PREC. +! CONVECTIVE PREC. +! SENS. HEAT FLUX +! SOLAR RADIATION +! EW SURFACE STRESS +! NS SURFACE STRESS +! ECMWF OROGRAPHY +! STANDARD DEVIATION OF OROGRAPHY +! ECMWF LAND SEA MASK +! +! + hflswitch=.false. + strswitch=.false. + levdiff2=nlev_ec-nwz+1 + + kbgn = 1 + add_sfc_level +! at this point +! if add_sfc_level=1, then nuvz=nwz and kbgn=2 +! if add_sfc_level=0, then nuvz=nwz-1 and kbgn=1 + +! u wind velocity +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz +! (interpolate it from "U-grid" to "T-grid" later) + if (wind_option.le.0) varname = 'U' + if (wind_option.eq.1) varname = 'AVGFLX_RUM' + if (wind_option.eq.2) varname = 'U' + + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nx+1 + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + ndims_exp = 4 + if (time_option.eq.0) then + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, uuh(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of U', fnamenc + if (wind_option.le.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + + stop + end if + + endif !test on time_option + +! v wind velocity +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz +! (interpolate it from "V-grid" to "T-grid" later) + if (wind_option.le.0) varname = 'V' + if (wind_option.eq.1) varname = 'AVGFLX_RVM' + if (wind_option.eq.2) varname = 'V' + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny+1 + lendim_max(2) = nymax + if (time_option.eq.0) then + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, vvh(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of V', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + + endif !test on time_option + +! w wind velocity +! this is on the "W-grid", and +! the wrf output file contains nwz levels, so no shifting needed + if (wind_option.le.0) varname = 'W' + if (wind_option.eq.1) varname = 'AVGFLX_WWM' + if (wind_option.eq.2) varname = 'WW' +! print*,'varname',varname + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + lendim_exp(3) = nwz + lendim_max(3) = nwzmax + if (time_option.eq.0) then + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, wwh, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of W', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + + endif !test on time_option + +! pressure - read base state and perturbation pressure, +! then combine +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz + varname = 'PB' + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, pph(0,0,kbgn,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of PB', fnamenc + stop + end if + + varname = 'P' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_pp(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of P', fnamenc + stop + end if + + do k = kbgn, nuvz + do j = 0, nymin1 + do i = 0, nxmin1 + pph(i,j,k,n) = pph(i,j,k,n) + dumarray_pp(i,j,k) + end do + end do + end do + + +! height - read base state and perturbation geopotential, +! then combine and divide by gravity +! these are on the "W-grid", and +! the wrf output file contains nwz levels +! shift them also so they will be consistent with pph + varname = 'PHB' + lendim_exp(3) = nwz + lendim_max(3) = nwzmax+1 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, zzh(0,0,kbgn,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of PB', fnamenc + stop + end if + + varname = 'PH' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_pp(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of P', fnamenc + stop + end if + + do k = kbgn, nwz+add_sfc_level + do j = 0, nymin1 + do i = 0, nxmin1 + zzh(i,j,k,n) = & + (zzh(i,j,k,n) + dumarray_pp(i,j,k))/9.81 + end do + end do + end do + +! now use dumarray_pp to store 1/density for stress calculation below +! if(sfc_option .eq. sfc_option_wrf) then + +! varname = 'ALT' +! lendim_exp(3) = nuvz-add_sfc_level +! lendim_max(3) = nwzmax +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, dumarray_pp(0,0,kbgn), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing ncread of ALT', fnamenc +! stop +! end if + +! end if + +! temperature - read perturbation potential temperature, +! add 300. (base value), then add and convert +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz + varname = 'T' + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tth(0,0,kbgn,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of T', fnamenc + stop + end if + + do k = kbgn, nuvz + do j = 0, nymin1 + do i = 0, nxmin1 +! save potential temperature to ptth + ptth(i,j,k,n)=tth(i,j,k,n)+300. + tth(i,j,k,n) = (tth(i,j,k,n) + 300.) * & + (pph(i,j,k,n)/1.0e5)**0.286 + + end do + end do + end do + +!- + if (turb_option .eq. turb_option_tke .or. & + turb_option .eq. turb_option_mytke ) then + print*, 'READ TKE',turb_option +! TKE - read Turbulent Kinetic, +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz + varname = 'TKE' + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tkeh(0,0,kbgn,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + + if (ierr .ne. 0) then + print*,'NO TKE available. Try TKE_PBL instead' + varname = 'TKE_PBL' + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tkeh(0,0,kbgn,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + endif + if (ierr .ne. 0) then + print*,'NO TKE_PBL available. Try QKE instead' + varname = 'qke' + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tkeh(0,0,kbgn,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + tkeh=tkeh/2. !conversion of qke + endif + if (ierr .ne. 0) then + varname = 'QKE' + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tkeh(0,0,kbgn,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + tkeh=tkeh/2. !conversion of qke + endif + + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of TKE', fnamenc + write(*,*)'change turb_option NOT to use TKE or change input file' + print*,'change SFC_OPTION to 0 as well' + stop + end if + + endif + + +!- + +! specific humidity - read mixing ratio (kg-water-vapor/kg-dry-air), +! then convert to (kg-water-vapor/kg-moist-air) +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz + varname = 'QVAPOR' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, qvh(0,0,kbgn,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of QVAPOR', fnamenc + stop + end if + + do k = kbgn, nuvz + do j = 0, nymin1 + do i = 0, nxmin1 + qvh(i,j,k,n) = max( qvh(i,j,k,n), 0.0 ) + qvh(i,j,k,n) = qvh(i,j,k,n)/(1.0 + qvh(i,j,k,n)) + end do + end do + end do + + +! surface pressure + varname = 'PSFC' + lendim_exp(3) = 0 + lendim_max(3) = 1 + ndims_exp = 3 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, ps(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of PSFC', fnamenc + stop + end if + +! for the mexico city grid 3 simulation, the surface and +! level 1 pressures are not as consistent as one would like, +! with the problems occuring near the domain boundaries. +! so do the following +! -- calculate surface pressure from lowest level pressure, temp, height +! -- use wrf pressures (pph array) wherever possible +! (avoid using surface pressure and the akz/bkz, akm/bkm) + do j = 0, nymin1 + do i = 0, nxmin1 + duma = ps(i,j,1,n) + dumdz = 0.5*(zzh(i,j,kbgn+1,n) - zzh(i,j,kbgn,n)) + tv = tth(i,j,kbgn,n)*(1.+0.61*qvh(i,j,kbgn,n)) + ps(i,j,1,n) = pph(i,j,kbgn,n)*exp( dumdz*ga/(r_air*tv) ) + end do + end do + + +! 10 meter u velocity +! note: u10 is on the "T-grid" already + varname = 'U10' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, u10(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of U10', fnamenc + stop + end if + + +! 10 meter v velocity +! note: v10 is on the "T-grid" already + varname = 'V10' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, v10(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of V10', fnamenc + stop + end if + + +! 2 meter temperature + varname = 'T2' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tt2(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of T2', fnamenc + stop + end if + + +! 2 meter dew point - read 2 meter water vapor mixing ratio +! then calculate the dew point + varname = 'Q2' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, td2(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of Q2' +!, fnamenc + do j = 0, nymin1 + do i = 0, nxmin1 +! 29-nov-2005 - changed qvh(i,j,1,n) to qvh(i,j,kbgn,n) here + td2(i,j,1,n) = qvh(i,j,kbgn,n) + end do + end do + end if + + if (wind_option.ge.1) then +! print*,'mean wind from WRF is used' +! print*,'option ',wind_option + varname = 'MU' + + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, mu(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing MU', fnamenc + stop + end if + + varname = 'MUB' + + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, mub(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing MUV', fnamenc + stop + end if + endif + +! varname = 'MAPFAC_UX' +! varname = 'MAPFAC_UY' !try +! lendim_exp(1) = nx+1 +! lendim_max(1) = nxmax +! lendim_exp(2) = ny +! lendim_max(2) = nymax +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_u(0,0,1), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP U', fnamenc +! stop +! end if +! +! varname = 'MAPFAC_VY' +! varname = 'MAPFAC_VX' !try +! lendim_exp(1) = nx +! lendim_max(1) = nxmax +! lendim_exp(2) = ny+1 +! lendim_max(2) = nymax +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_v(0,0,1), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP V', fnamenc +! stop +! end if + +! varname = 'MAPFAC_MX' +! lendim_exp(1) = nx +! lendim_max(1) = nxmax +! lendim_exp(2) = ny +! lendim_max(2) = nymax +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_x(0,0,1), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP X', fnamenc +! varname = 'MAPFAC_U' +! lendim_exp(1) = nx+1 +! lendim_max(1) = nxmax +! lendim_exp(2) = ny +! lendim_max(2) = nymax +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_u(0,0,1), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! do j = 0, nymin1 +! do i = 0, nxmin1 +! m_x(i,j,1)=(m_u(i,j,1)+m_u(i+1,j,1))*0.5 +! enddo +! enddo +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP U', fnamenc +! print*,'NO MAP FACTOR IS GOING TO BE USED.' +! print*,'LARGE UNCERTAINTIES TO BE EXPECTED' +! do j = 0, nymin1 +! do i = 0, nxmin1 +! m_x(i,j,1)=1. +! enddo +! enddo +! end if +! end if + +! varname = 'MAPFAC_M' +! lendim_exp(1) = nx +! lendim_max(1) = nxmax +! lendim_exp(2) = ny +! lendim_max(2) = nymax +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_z(0,0,1), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP W', fnamenc +! stop +! end if + +! varname = 'MAPFAC_MY' +! lendim_exp(1) = nx +! lendim_max(1) = nxmax +! lendim_exp(2) = ny +! lendim_max(2) = nymax +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_y(0,0,1), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP Y', fnamenc +! varname = 'MAPFAC_V' +! lendim_exp(1) = nx +! lendim_max(1) = nxmax +! lendim_exp(2) = ny+1 +! lendim_max(2) = nymax +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_v(0,0,1), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! do j = 0, nymin1 +! do i = 0, nxmin1 +! m_y(i,j,1)=(m_v(i,j,1)+m_v(i,j+1,1))*0.5 +! enddo +! enddo +! if (ierr .ne. 0) then +! write(*,9100) 'ERROR doing MAP V', fnamenc +! print*,'NO MAP FACTOR IS GOING TO BE USED.' +! print*,'LARGE UNCERTAINTIES TO BE EXPECTED' +! do j = 0, nymin1 +! do i = 0, nxmin1 +! m_y(i,j,1)=1. +! enddo +! enddo +! end if +! end if + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + + + +! calculate water vapor pressure in mb, from sfc pressure +! and 2 m mixing ratio + iduma = 0 + do j = 0, nymin1 + do i = 0, nxmin1 +! 29-nov-2005 - added this to catch occasional tt2n=0.0 values + duma = max( 100.0, tth(i,j,kbgn,n)-50.0 ) + if (tt2(i,j,1,n) .le. duma) then + iduma = iduma + 1 + if (iduma .eq. 1) then + write(*,*) 'readwind - bad tt2 at' + write(*,*) 'i, j, tt2 =', i, j, tt2(i,j,1,n) + end if +! stop + tt2(i,j,1,n) = tth(i,j,kbgn,n) + td2(i,j,1,n) = qvh(i,j,kbgn,n) + end if + duma = td2(i,j,1,n)/0.622 + ewater_mb = 0.01*( 0.99976*ps(i,j,1,n)*duma/(1.0+duma) ) + esatwater_mb = 0.01*ew(tt2(i,j,1,n)) + ewater_mb = max( 1.0e-10, min( esatwater_mb, ewater_mb ) ) +! then use the following, which is from an old 1970's report +! (reference not available, but the formula works) +! tdew(in C) = (4318.76/(19.5166 - ln(ewater(in mb)))) - 243.893 + td2(i,j,1,n) = 273.16 + & + (4318.76/(19.5166 - log(ewater_mb))) - 243.893 + end do + end do + if (iduma .gt. 0) write(*,*) & + 'readwind - bad tt2 count =', iduma + + +! sea level pressure - calculate it from surface pressure and +! ground elevation using standard atmosphere relations + do j = 0, nymin1 + do i = 0, nxmin1 + msl(i,j,1,n) = ps(i,j,1,n)/ & + ((1.0 - 6.5e-3*oro(i,j)/288.0)**5.2553) + end do + end do + + +! large scale precipitation +! convective precipitation +! the wrf output files contain these as "accumulated totals" +! I need to find out if these are accumulated over the output +! file frequency, or over the total run. +! For now, set to zero +! total cloud cover +! Doesn't appear to be any 2-d cloud cover field in the +! wrf output. +! For now, set to zero + do j = 0, nymin1 + do i = 0, nxmin1 + lsprec(i,j,1,n) = 0.0 + convprec(i,j,1,n) = 0.0 + tcc(i,j,1,n) = 0.0 + end do + end do + +! +! Large-scale precipitation (accumulated rain, mm) +! will convert to mm/h in interpolat_rain.f + varname = 'RAINNC' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, lsprec(0,0,1,n), & + itime, & + dims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of RAINNC,set to zero', fnamenc + do j = 0, nymin1 + do i = 0, nxmin1 + lsprec(i,j,1,n) = 0.0 + end do + end do + end if + +! +! Convective cumulus precipitation (accumulated rain, mm) + + varname = 'RAINC' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, convprec(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of RAINC, set to zero', fnamenc + do j = 0, nymin1 + do i = 0, nxmin1 + convprec(i,j,1,n) = 0.0 + end do + end do + end if + +! +! Clound fraction (cloud cover) +! varname = 'CLDFRA' +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, tcc(0,0,1,n), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +!! write(*,9100) 'error doing ncread of CLDFRA, set to zero' +!!, fnamenc +! do j = 0, nymin1 +! do i = 0, nxmin1 +! tcc(i,j,1,n) = 0.0 +! end do +! end do +! end if +!!C write(*,*)'read CLDFRA 0-sucess ',ierr + +! + +! snow depth + varname = 'SNOWH' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, sd(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then +! write(*,9100) 'error doing ncread of SNOWH', fnamenc + do j = 0, nymin1 + do i = 0, nxmin1 + sd(i,j,1,n) = 0.0 + end do + end do + end if + + +! surface sensible heat flux (positive <--> upwards) + varname = 'HFX' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, sshf(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + do j = 0, nymin1 + do i = 0, nxmin1 + sshf(i,j,1,n) = -sshf(i,j,1,n) + end do + end do + + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of HFX', fnamenc + do j = 0, nymin1 + do i = 0, nxmin1 + sshf(i,j,1,n) = 0.0 + end do + end do + hflswitch=.false. ! Heat flux is not available + else + hflswitch=.true. ! Heat flux is available +! limit to values to bounds originally used by flexpart? +! do 1502 j=0,nymin1 +! do 1502 i=0,nxmin1 +! 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. +!1502 continue + end if + +! ustar + varname = 'UST' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, ustar(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of UST', fnamenc + do j = 0, nymin1 + do i = 0, nxmin1 + ustar(i,j,1,n) = 0.0 + end do + end do + strswitch=.false. ! ustar is not available + else + strswitch=.true. ! ustar is available + do j=0,nymin1 + do i=0,nxmin1 +! surfstr(i,j,1,n)=ustar(i,j,1,n)/dumarray_pp(i,j,kbgn) + enddo + enddo + end if + +! pblh + if(sfc_option .eq. sfc_option_wrf) then + varname = 'PBLH' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, hmix(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of PBLH', fnamenc + stop + endif + + endif + +! surface solar radiation flux (positive <--> downwards) + varname = 'SWDOWN' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, ssr(0,0,1,n), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of SWDOWN', fnamenc + do j = 0, nymin1 + do i = 0, nxmin1 + ssr(i,j,1,n) = 0.0 + end do + end do + else + do j = 0, nymin1 + do i = 0, nxmin1 + ssr(i,j,1,n) = max( ssr(i,j,1,n), 0.0 ) + end do + end do + end if + + +! ew & ns surface stress +! Doesn't appear to be any 2-d cloud cover field in the +! wrf output. +! For now, set to zero + do j = 0, nymin1 + do i = 0, nxmin1 + ewss(i,j) = 0.0 + nsss(i,j) = 0.0 + end do + end do +! strswitch=.false. ! Surface stress is not available + + +! orography +! standard deviation of orography +! land sea mask +! these should be fixed during a simulation +! so there is no reason to do them again ?? + + +! *** done with reading the wrf output file *** + +! print*,'uu out1',uuh(0,259,1:10) +! print*,'mu out1',mu(0,259,1),mub(0,259,1) +! print*,'m_xn out1',m_x(0,259,1),m_y(0,259,1) + + +! interpolate uuh from the "U-grid" to the "T-grid" +! interpolate vvh from the "V-grid" to the "T-grid" +! new: convert mass weighted wind to wind. +! print*,'wind_option',wind_option + if (wind_option.le.0) then +! if (wind_option.eq.-1) then +! call calc_uvmet(uuh,vvh,urot,vrot,1) +! endif + do k = kbgn, nuvz + do j = 0, nymin1 + do i = 0, nxmin1 +! needs to rotate u and v to work. needs read alpha or something like that. +! if in mercator, no need. +! divh(i,j,k)=(uuh(i+1,j,k)-uuh(i,j,k))/dx & +! +(vvh(i,j+1,k)-vvh(i,j,k))/dy + if (wind_option.lt.0) then + divh(i,j,k)=(uuh(i+1,j,k)-uuh(i,j,k))/dx*m_x(i,j,1) & + +(vvh(i,j+1,k)-vvh(i,j,k))/dy*m_y(i,j,1) + endif + uuh(i,j,k) = 0.5*(uuh(i,j,k) + uuh(i+1,j,k)) + vvh(i,j,k) = 0.5*(vvh(i,j,k) + vvh(i,j+1,k)) + end do + end do + end do + elseif (wind_option.eq.1) then + do k = kbgn, nuvz + do j = 0, nymin1 + do i = 0, nxmin1 +! uuh(i,j,k) = 0.5*(uuh(i,j,k)*m_u(i,j,1) + uuh(i+1,j,k)*m_u(i+1,j,1)) +! vvh(i,j,k) = 0.5*(vvh(i,j,k)*m_v(i,j,1) + vvh(i,j+1,k)*m_v(i,j+1,1)) + uuh(i,j,k) = 0.5*(uuh(i,j,k) + uuh(i+1,j,k)) + vvh(i,j,k) = 0.5*(vvh(i,j,k) + vvh(i,j+1,k)) + mu2=mu(i,j,1)+mub(i,j,1) +! uuh(i,j,k) = uuh(i,j,k)/mu2!*0.5*(m_u(i,j,1)+m_u(i+1,j,1)) +! vvh(i,j,k) = vvh(i,j,k)/mu2!*0.5*(m_v(i,j,1)+m_v(i,j+1,1)) +! m_y=0.5*(m_v(i,j,1)+m_v(i,j+1,1)) + uuh(i,j,k) = uuh(i,j,k)/mu2 !*m_y(i,j,1) !without m=true wind + vvh(i,j,k) = vvh(i,j,k)/mu2 !*m_x(i,j,1) + wwh(i,j,k) = wwh(i,j,k)/mu2 !*m_y(i,j,1) + end do + end do + end do + elseif (wind_option.eq.2) then + do k = kbgn, nuvz + do j = 0, nymin1 + do i = 0, nxmin1 + uuh(i,j,k) = 0.5*(uuh(i,j,k) + uuh(i+1,j,k)) + vvh(i,j,k) = 0.5*(vvh(i,j,k) + vvh(i,j+1,k)) + mu2=mu(i,j,1)+mub(i,j,1) + wwh(i,j,k) = wwh(i,j,k)/mu2 !*m_y(i,j,1) + end do + end do + end do + + endif + + +! for ecmwf flexpart, if nwz = nlev_ec+1, then wwh is set +! to zero at the top level +! for wrf, nlev_ec==n_bottom_top and so nwz = nlev_ec+1. +! however, it doesn't seem appropriate to zero wwh at +! the model top which might be ~100 hPa. +! so deactivate this for now +! if(levdiff2.eq.0) then +! iwmax=nlev_ec+1 +! do 60 i=0,nxmin1 +! do 60 j=0,nymin1 +!60 wwh(i,j,nlev_ec+1)=0. +! endif + +! For global fields, assign the leftmost data column also to the rightmost +! data column; if required, shift whole grid by nxshift grid points +! +! FLEXPART_WRF - all "global" stuff is turned off +!************************************************************************* + +! 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 + +! CALCULATE SURFSTR + if(sfc_option .eq. sfc_option_diagnosed) then + do i=0,nxmin1 + do j=0,nymin1 + surfstr(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2) + enddo + enddo + strswitch=.false. + endif + + if ((.not.hflswitch).or.(.not.strswitch)) then + write(*,*) 'WARNING: No (or incomplete) flux data ' // & + 'contained in WRF output 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 +! +! FLEXPART_WRF - use k=(2+add_sfc_level) here instead of k=3 +!*************************************************************************** + + k = 2 + add_sfc_level + do i=0,nxmin1 + do j=0,nymin1 +! plev1=akz(3)+bkz(3)*ps(i,j,1,n) + plev1=pph(i,j,k,n) + pmean=0.5*(ps(i,j,1,n)+plev1) + tv=tth(i,j,k,n)*(1.+0.61*qvh(i,j,k,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,k)**2+vvh(i,j,k)**2) + call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, & + tt2(i,j,1,n),tth(i,j,k,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. + enddo + enddo + 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 +! +! Note that the uuh, vvh, tth, & qvh data have already been shifted +! upwards by one level, when they were read in. +!************************************************************************** + + if (add_sfc_level .eq. 1) then + do j = 0, nymin1 + do i = 0, nxmin1 + uuh(i,j,1) = u10(i,j,1,n) + vvh(i,j,1) = v10(i,j,1,n) + tth(i,j,1,n) = tt2(i,j,1,n) + ptth(i,j,1,n) = ptth(i,j,2,n) + qvh(i,j,1,n) = qvh(i,j,2,n) + tkeh(i,j,1,n)=tkeh(i,j,2,n) +! pressure at 2 m AGL + pph(i,j,1,n) = 0.99976*ps(i,j,1,n) +! height (MSL) at ground level (shift it down) + zzh(i,j,1,n) = zzh(i,j,2,n) +! height (MSL) at top of the added level + zzh(i,j,2,n) = zzh(i,j,1,n) + 4.0 + if (hmix(i,j,1,n).lt.hmixmin) hmix(i,j,1,n)=hmixmin + + enddo + enddo + end if + + + do i=0,nxmax-1 + do j=0,nymax-1 + do k=1,nuvzmax + u_wrf(i,j,k,n)=uuh(i,j,k) + v_wrf(i,j,k,n)=vvh(i,j,k) + enddo + enddo + enddo + + do i=0,nxmax-1 + do j=0,nymax-1 + do k=1,nwzmax + w_wrf(i,j,k,n)=wwh(i,j,k) + enddo + enddo + enddo + + + + + + return + end subroutine readwind + diff --git a/src_flexwrf_v3.1/readwind_nests.f90 b/src_flexwrf_v3.1/readwind_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4dd4336e1b65139a1fb40b4c3595185ad663b55d --- /dev/null +++ b/src_flexwrf_v3.1/readwind_nests.f90 @@ -0,0 +1,1359 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine readwind_nests(indj,n,uuhn,vvhn,wwhn,divhn) +! i i o o o, o +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine readwind_nests. * +! The met fields are read from WRF netcdf output files. * +! There are many differences from the FLEXPART version. * +! * +! 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 * +! * +! Oct-Dec 2005, R. Easter -- Major changes for WRF. * +! * +! 11 June 2007, input tkehn from WRF +! 13 JUNE 2007 add ext_scalar, pbl_physics +! 19 Oct 2007 add RAINC, RAINNC, CLDFRA +! Feb 2012, adapt it for mean wind. Jerome Brioude +!******************************************************************************* + + use par_mod + use com_mod + +! include 'includepar' +! include 'includecom' + +! subr arguments + integer :: indj,n + real(kind=4) :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) + real(kind=4) :: divhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) + real(kind=4) :: mu(0:nxmaxn-1,0:nymaxn-1,1),mu2 + real(kind=4) :: mub(0:nxmaxn-1,0:nymaxn-1,1) +! real(kind=4) :: m_u(0:nxmaxn-1,0:nymaxn-1,1) +! real(kind=4) :: m_v(0:nxmaxn-1,0:nymaxn-1,1) +! real(kind=4) :: m_w(0:nxmaxn-1,0:nymaxn-1,1) +! 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) +! real :: mu(0:nxmaxn-1,0:nymaxn-1,1),mu2 +! real :: mub(0:nxmaxn-1,0:nymaxn-1,1) +! real(kind=4) :: m_un(0:nxmaxn-1,0:nymaxn-1,1,maxnests) +! real(kind=4) :: m_vn(0:nxmaxn-1,0:nymaxn-1,1,maxnests) +! real :: m_w(0:nxmaxn-1,0:nymaxn-1,1) + + +! local variables + integer,parameter :: ndims_max=4 + + integer :: i, idiagaa, ierr, itime + integer :: iduma + integer :: j, jhhmmss, jyyyymmdd + integer :: k, kbgn + integer :: l + integer :: lendim(ndims_max), lendim_exp(ndims_max), & + lendim_max(ndims_max) + integer :: m,levdiff2 + integer :: ndims, ndims_exp, & + ext_scalar,pbl_physics,mp_physics_dum + integer :: n_west_east, n_south_north, n_bottom_top + integer :: m_grid_id_dum, m_parent_grid_id_dum, & + m_parent_grid_ratio_dum, & + i_parent_start_dum, j_parent_start_dum, & + map_proj_id_dum + + real :: dx_met, dy_met + real :: duma, dumb, dumc, dumd, dume + real :: dumdz + real :: dumarray_aa(nwzmax+1) + real(kind=4) :: dumarray_pp(0:nxmaxn-1,0:nymaxn-1,nwzmax+1) + real :: ewater_mb, esatwater_mb + real :: ew ! this is an external function + real :: map_stdlon_dum, map_truelat1_dum, map_truelat2_dum + real :: toler + + real :: ewss(0:nxmaxn-1,0:nymaxn-1),nsss(0:nxmaxn-1,0:nymaxn-1) + real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1 + + real(kind=dp) :: jul,juldate + character(len=160) :: fnamenc, varname,fnamenc2 + + logical :: hflswitch + + +! +! main loop -- process each nest +! + do l=1,numbnests + +! +! get grid info from the wrf netcdf file +! and check it for consistency against values from gridcheck +! + m = numpath+2*(l-1)+1 + fnamenc = path(m)(1:length(m)) // wfnamen(l,indj) + + idiagaa = 0 + + call read_ncwrfout_gridinfo( ierr, idiagaa, fnamenc, & + n_west_east, n_south_north, n_bottom_top, & + dx_met, dy_met, & + m_grid_id_dum, m_parent_grid_id_dum, m_parent_grid_ratio_dum, & + i_parent_start_dum, j_parent_start_dum, & + map_proj_id_dum, map_stdlon_dum, & + map_truelat1_dum, map_truelat2_dum, & + ext_scalar,pbl_physics,mp_physics_dum ) + if (ierr .ne. 0) then + write(*,9100) l, 'error getting gridinfo for met file', & + fnamenc + stop + end if + +! subtract 1 here because i & j indexing in flexpart always starts at 0 + i_parent_start_dum = i_parent_start_dum-1 + j_parent_start_dum = j_parent_start_dum-1 + +9100 format( / '*** readwind_nests, l=', i2, ' -- ', & + a / 'file = ', a ) +9110 format( / '*** readwind_nests, l=', i2, ' -- ', & + a, 1x, i8 / 'file = ', a ) +9120 format( / '*** readwind_nests, l=', i2, ' -- ', & + a, 2(1x,i8) / 'file = ', a ) +9130 format( / '*** readwind_nests, l=', i2, ' -- ', & + a, 3(1x,i8) / 'file = ', a ) +9115 format( / '*** readwind_nests, l=', i2, ' -- ', & + a / a, 1x, i8 / 'file = ', a ) +9125 format( / '*** readwind_nests, l=', i2, ' -- ', & + a / a, 2(1x,i8) / 'file = ', a ) +9135 format( / '*** readwind_nests, l=', i2, ' -- ', & + a / a, 3(1x,i8) / 'file = ', a ) + + toler = 2.0e-7 + + if (nxn(l) .ne. n_west_east) then + write(*,9100) l, 'nx not consistent', fnamenc + stop + end if + if (nyn(l) .ne. n_south_north) then + write(*,9100) l, 'ny not consistent', fnamenc + stop + end if + if (nlev_ec .ne. n_bottom_top) then + write(*,9100) l, 'nlev_ec not consistent', fnamenc + stop + end if + if (nwz .ne. n_bottom_top+1) then + write(*,9100) l, 'nwz not consistent', fnamenc + stop + end if + if (nuvz .ne. n_bottom_top+add_sfc_level) then + write(*,9100) l, 'nuvz not consistent', fnamenc + stop + end if + + if (m_grid_id(l) .ne. m_grid_id_dum) then + write(*,9100) l, 'm_grid_id not consistent', fnamenc + write(*,*) m_grid_id(l), m_grid_id_dum + stop + end if + if (m_parent_grid_id(l) .ne. m_parent_grid_id_dum) then + write(*,9100) l, 'm_parent_grid_id not consistent', fnamenc + stop + end if + if (m_parent_grid_ratio(l) .ne. m_parent_grid_ratio_dum) then + write(*,9100) l, 'm_parent_grid_ratio not consistent', fnamenc + stop + end if + if (i_parent_start(l) .ne. i_parent_start_dum) then + write(*,9100) l, 'i_parent_start not consistent', fnamenc + stop + end if + if (j_parent_start(l) .ne. j_parent_start_dum) then + write(*,9100) l, 'j_parent_start not consistent', fnamenc + stop + end if + + if (abs(dxn(l) - dx_met) .gt. toler*abs(dxn(l))) then + write(*,9100) l, 'dx not consistent', fnamenc + stop + end if + if (abs(dyn(l) - dy_met) .gt. toler*abs(dyn(l))) then + write(*,9100) l, 'dy not consistent', fnamenc + stop + end if + +! locate the date/time in the file + itime = 0 +1100 itime = itime + 1 + call read_ncwrfout_1datetime( ierr, fnamenc, & + itime, jyyyymmdd, jhhmmss ) + if (ierr .eq. -1) then + write(*,9100) l, 'error reading time from met file', fnamenc + stop + else if (ierr .ne. 0) then + write(*,9125) l, 'unable to locate date/time in met file', & + 'indj, itime =', indj, itime, fnamenc + stop + else + jul = juldate( jyyyymmdd, jhhmmss ) + duma = (jul-bdate)*86400. + iduma = nint(duma) + if (iduma .ne. wftime(indj)) goto 1100 + end if + if (option_verbose.eq.1) then + + write(*,*) + write(*,*) 'readwind_nests processing wrfout file =' + write(*,*) fnamenc + write(*,*) 'itime, ymd, hms =', itime, jyyyymmdd, jhhmmss + endif + +! read eta_w_wrf, eta_u_wrf, p_top_wrf, ylat2d, xlon2d from the +! netcdf wrfout file and compare to those from the 1st met. file + + varname = 'ZNW' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nwz + lendim_max(1) = nwzmax + ndims_exp = 2 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_aa, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + fnamenc2='wrfout_d03_zn.nc' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc2, & + varname, dumarray_aa, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of ZNW', fnamenc + stop + end if + end if + do k = 1, nwz + if (abs(eta_w_wrf(k) - dumarray_aa(k)) & + .gt. toler*abs(eta_w_wrf(k))) then + write(*,9100) l, 'eta_w_wrf not consistent', fnamenc + stop + end if + end do + + varname = 'ZNU' + lendim_exp(1) = nwz-1 + lendim_max(1) = nwzmax + ndims_exp = 2 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_aa, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + fnamenc2='wrfout_d03_zn.nc' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc2, & + varname, dumarray_aa, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + + write(*,9100) l, 'error doing ncread of ZNU', fnamenc + stop + end if + end if + do k = 1, nwz-1 + if (abs(eta_u_wrf(k) - dumarray_aa(k)) & + .gt. toler*abs(eta_u_wrf(k))) then + write(*,9100) l, 'eta_u_wrf not consistent', fnamenc + stop + end if + end do + +! varname = 'P_TOP' +! lendim_exp(1) = 1 +! lendim_max(1) = 1 +! ndims_exp = 2 +! if (ext_scalar .lt. 0) ndims_exp = 1 +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, duma, & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) l, 'error doing ncread of P_TOP', fnamenc +! stop +! end if +! if (abs(p_top_wrf - duma) .gt. toler*abs(p_top_wrf)) then +! write(*,9100) l, 'p_top_wrf not consistent', fnamenc +! stop +! end if + + varname = 'XLAT' + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + ndims_exp = 3 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_pp, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,9100) 'error doing ncread of XLAT', fnamenc + stop + end if + toler = 1.0e-6 + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + if (abs(ylat2dn(i,j,l) - dumarray_pp(i,j,1)) .gt. & + toler*abs(ylat2dn(i,j,l))) then + write(*,9100) l, 'ylat2dn not consistent', fnamenc + write(*,'(a,2i5,2f16.6)') 'i,j,ylats =', i, j, & + ylat2dn(i,j,l), dumarray_pp(i,j,1) + stop + end if + end do + end do + + varname = 'XLONG' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_pp, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,*) + write(*,9100) 'error doing ncread of XLONG', fnamenc + stop + end if + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + if (abs(xlon2dn(i,j,l) - dumarray_pp(i,j,1)) .gt. & + toler*abs(xlon2dn(i,j,l))) then + write(*,9100) l, 'xlon2dn not consistent', fnamenc + write(*,'(a,2i5,2f16.6)') 'i,j,xlons =', i, j, & + xlon2dn(i,j,l), dumarray_pp(i,j,1) + stop + end if + end do + end do + + +! +! +! now read the data fields for current time +! the following are read from ecmwf met files +! U VELOCITY +! V VELOCITY +! W VELOCITY +! TEMPERATURE +! SPEC. HUMIDITY +! SURF. PRESS. +! SEA LEVEL PRESS. +! 10 M U VELOCITY +! 10 M V VELOCITY +! 2 M TEMPERATURE +! 2 M DEW POINT +! SNOW DEPTH +! CLOUD COVER +! LARGE SCALE PREC. +! CONVECTIVE PREC. +! SENS. HEAT FLUX +! SOLAR RADIATION +! EW SURFACE STRESS +! NS SURFACE STRESS +! ECMWF OROGRAPHY +! STANDARD DEVIATION OF OROGRAPHY +! ECMWF LAND SEA MASK +! +! + hflswitch=.false. + strswitch=.false. +! JB + levdiff2=nlev_ec-nwz+1 + + + kbgn = 1 + add_sfc_level +! at this point +! if add_sfc_level=1, then nuvz=nwz and kbgn=2 +! if add_sfc_level=0, then nuvz=nwz-1 and kbgn=1 + +! u wind velocity +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz +! (interpolate it from "U-grid" to "T-grid" later) + if (wind_option.le.0) varname = 'U' + if (wind_option.eq.1) varname = 'AVGFLX_RUM' + if (wind_option.eq.2) varname = 'U' + + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nxn(l)+1 + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + ndims_exp = 4 + if (time_option.eq.0) then + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, uuhn(0,0,kbgn,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of U', fnamenc + if (wind_option.le.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + endif + +! v wind velocity +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz +! (interpolate it from "V-grid" to "T-grid" later) + if (wind_option.le.0) varname = 'V' + if (wind_option.eq.1) varname = 'AVGFLX_RVM' + if (wind_option.eq.2) varname = 'V' + + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l)+1 + lendim_max(2) = nymaxn + if (time_option.eq.0) then + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, vvhn(0,0,kbgn,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of V', fnamenc + if (wind_option.le.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + + endif +! w wind velocity +! this is on the "W-grid", and +! the wrf output file contains nwz levels, so no shifting needed +! varname = 'W' + if (wind_option.le.0) varname = 'W' + if (wind_option.eq.1) varname = 'AVGFLX_WWM' + if (wind_option.eq.2) varname = 'WW' + + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + lendim_exp(3) = nwz + lendim_max(3) = nwzmax + if (time_option.eq.0) then + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, wwhn(0,0,1,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of W', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + + stop + end if + endif + +! pressure - read base state and perturbation pressure, +! then combine +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz + varname = 'PB' + lendim_exp(3) = nuvz-1 + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, pphn(0,0,kbgn,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of PB', fnamenc + stop + end if + + varname = 'P' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_pp(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of P', fnamenc + stop + end if + + do k = kbgn, nuvz + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + pphn(i,j,k,n,l) = pphn(i,j,k,n,l) + dumarray_pp(i,j,k) + end do + end do + end do + + +! height - read base state and perturbation geopotential, +! then combine and divide by gravity +! these are on the "W-grid", and +! the wrf output file contains nwz levels +! shift them also so they will be consistent with pph + varname = 'PHB' + lendim_exp(3) = nwz + lendim_max(3) = nwzmax+1 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, zzhn(0,0,kbgn,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of PB', fnamenc + stop + end if + + varname = 'PH' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_pp(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of P', fnamenc + stop + end if + + do k = kbgn, nwz+add_sfc_level + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + zzhn(i,j,k,n,l) = & + (zzhn(i,j,k,n,l) + dumarray_pp(i,j,k))/9.81 + end do + end do + end do + +! now use dumarray_pp to store 1/density for stress calculation below + if(sfc_option .eq. sfc_option_wrf) then + + varname = 'ALT' + lendim_exp(3) = nuvz-1 + lendim_max(3) = nwzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, dumarray_pp(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of ALT', fnamenc + stop + end if + + end if + +! temperature - read perturbation potential temperature, +! add t00 (base value), then add and convert +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz + varname = 'T' + lendim_exp(3) = nuvz-1 + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tthn(0,0,kbgn,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of T', fnamenc + stop + end if + + do k = kbgn, nuvz + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 +! save pot tempereature to ptthn + ptthn(i,j,k,n,l) = tthn(i,j,k,n,l)+300. + tthn(i,j,k,n,l) = (tthn(i,j,k,n,l) + 300.) * & + (pphn(i,j,k,n,l)/1.0e5)**0.286 + end do + end do + end do + + if (turb_option .eq. turb_option_tke .or. & + turb_option .eq. turb_option_mytke) then +!- +! TKE - read TKE +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz + varname = 'TKE' + lendim_exp(3) = nuvz-1 + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tkehn(0,0,kbgn,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + varname = 'TKE_PBL' + lendim_exp(3) = nuvz-1 + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tkehn(0,0,kbgn,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + endif + if (ierr .ne. 0) then +! print*,'NO TKE_PBL available. Try QKE instead' + varname = 'qke' + lendim_exp(3) = nuvz-1 + lendim_max(3) = nuvzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tkehn(0,0,kbgn,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + tkeh=tkeh/2. !conversion of qke + endif + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of TKE', fnamenc + write(*,*)'Change turb_option NOT to use TKE, or change inputfile' + print*,'change SFC_OPTION to 0 as well' + stop + end if + + endif +!- + + +! specific humidity - read mixing ratio (kg-water-vapor/kg-dry-air), +! then convert to (kg-water-vapor/kg-moist-air) +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz + varname = 'QVAPOR' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, qvhn(0,0,kbgn,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of QVAPOR', fnamenc + stop + end if + + do k = kbgn, nuvz + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + qvhn(i,j,k,n,l) = max( qvhn(i,j,k,n,l), 0.0 ) + qvhn(i,j,k,n,l) = qvhn(i,j,k,n,l)/(1.0 + qvhn(i,j,k,n,l)) + end do + end do + end do + + +! surface pressure + varname = 'PSFC' + lendim_exp(3) = 0 + lendim_max(3) = 1 + ndims_exp = 3 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, psn(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of PSFC', fnamenc + stop + end if + +! for the mexico city grid 3 simulation, the surface and +! level 1 pressures are not as consistent as one would like, +! with the problems occuring near the domain boundaries. +! so diagnose surface pressure from other variables + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + +! better fix +! -- calculate surface pressure from lowest level pressure, temp, height +! -- use wrf pressures (pph array) wherever possible +! (avoid using surface pressure and the akz/bkz, akm/bkm) + duma = psn(i,j,1,n,l) + dumdz = 0.5*(zzhn(i,j,kbgn+1,n,l) - zzhn(i,j,kbgn,n,l)) + tv = tthn(i,j,kbgn,n,l)*(1.+0.61*qvhn(i,j,kbgn,n,l)) + psn(i,j,1,n,l) = pphn(i,j,kbgn,n,l)*exp( dumdz*ga/(r_air*tv) ) + + end do + end do + + +! 10 meter u velocity +! note: u10 is on the "T-grid" already + varname = 'U10' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, u10n(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of U10', fnamenc + stop + end if + + +! 10 meter v velocity +! note: v10 is on the "T-grid" already + varname = 'V10' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, v10n(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of V10', fnamenc + stop + end if + + +! 2 meter temperature + varname = 'T2' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tt2n(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of T2', fnamenc + stop + end if + + +! 2 meter dew point - read 2 meter water vapor mixing ratio +! then calculate the dew point + varname = 'Q2' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, td2n(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of Q2', fnamenc + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 +! 29-nov-2005 - changed qvhn(i,j,1,n,l) to qvhn(i,j,kbgn,n,l) here + td2n(i,j,1,n,l) = qvhn(i,j,kbgn,n,l) + end do + end do + end if + + if (wind_option.ge.1) then +! print*,'mean wind from WRF is used' + varname = 'MU ' + + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, mu(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing MU', fnamenc + stop + end if + + varname = 'MUB' + + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, mub(0,0,1), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing MUB', fnamenc + stop + end if + endif + +! varname = 'MAPFAC_MX' +! lendim_exp(1) = nxn(l) +! lendim_max(1) = nxmaxn +! lendim_exp(2) = nyn(l) +! lendim_max(2) = nymaxn +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_xn(0,0,1,l), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP X', fnamenc +! varname = 'MAPFAC_U' +! lendim_exp(1) = nxn(l)+1 +! lendim_max(1) = nxmaxn +! lendim_exp(2) = nyn(l) +! lendim_max(2) = nymaxn +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_un(0,0,1,l), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! do j = 0, nyn(l)-1 +! do i = 0, nxn(l)-1 +! m_xn(i,j,1,l)=(m_un(i,j,1,l)+m_un(i+1,j,1,l))*0.5 +! enddo +! enddo +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP U', fnamenc +! print*,'NO MAP FACTOR IS GOING TO BE USED.' +! print*,'LARGE UNCERTAINTIES TO BE EXPECTED' +! do j = 0, nyn(l)-1 +! do i = 0, nxn(l)-1 +! m_xn(i,j,1)=1. +! enddo +! enddo +! end if +! end if +! +! varname = 'MAPFAC_MY' +! lendim_exp(1) = nxn(l) +! lendim_max(1) = nxmaxn +! lendim_exp(2) = nyn(l) +! lendim_max(2) = nymaxn +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_yn(0,0,1,l), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP Y', fnamenc +! varname = 'MAPFAC_V' +! lendim_exp(1) = nxn(l) +! lendim_max(1) = nxmaxn +! lendim_exp(2) = nyn(l)+1 +! lendim_max(2) = nymaxn +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_vn(0,0,1,l), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! do j = 0, nyn(l)-1 +! do i = 0, nxn(l)-1 +! m_yn(i,j,1,l)=(m_vn(i,j,1,l)+m_vn(i,j+1,1,l))*0.5 +! enddo +! enddo +! if (ierr .ne. 0) then +! write(*,9100) 'ERROR doing MAP V', fnamenc +! print*,'NO MAP FACTOR IS GOING TO BE USED.' +! print*,'LARGE UNCERTAINTIES TO BE EXPECTED' +! do j = 0, nyn(l)-1 +! do i = 0, nxn(l)-1 +! m_yn(i,j,1,l)=1. +! enddo +! enddo +! end if +! end if + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + +! varname = 'MAPFAC_U' +! lendim_exp(1) = nxn(l)+1 +! lendim_max(1) = nxmaxn +! lendim_exp(2) = nyn(l) +! lendim_max(2) = nymaxn +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_un(0,0,1,l), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP U', fnamenc +! stop +! end if +! +! varname = 'MAPFAC_V' +! lendim_exp(1) = nxn(l) +! lendim_max(1) = nxmaxn +! lendim_exp(2) = nyn(l)+1 +! lendim_max(2) = nymaxn +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_vn(0,0,1,l), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP V', fnamenc +! stop +! end if +! +! varname = 'MAPFAC_M' +! lendim_exp(1) = nxn(l) +! lendim_max(1) = nxmaxn +! lendim_exp(2) = nyn(l) +! lendim_max(2) = nymaxn +! +! call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & +! varname, m_w(0,0,1), & +! itime, & +! ndims, ndims_exp, ndims_max, & +! lendim, lendim_exp, lendim_max ) +! if (ierr .ne. 0) then +! write(*,9100) 'error doing MAP W', fnamenc +! stop +! end if + + + + + +! calculate water vapor pressure in mb, from sfc pressure +! and 2 m mixing ratio + iduma = 0 + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 +! 29-nov-2005 - added this to catch occasional tt2n=0.0 values + duma = max( 100.0, tthn(i,j,kbgn,n,l)-50.0 ) + if (tt2n(i,j,1,n,l) .le. duma) then + iduma = iduma + 1 + if (iduma .eq. 1) then + write(*,*) 'readwind_nests - bad tt2n at' + write(*,*) 'l, i, j, tt2n =', l, i, j, tt2n(i,j,1,n,l) + end if + tt2n(i,j,1,n,l) = tthn(i,j,kbgn,n,l) + td2n(i,j,1,n,l) = qvhn(i,j,kbgn,n,l) + end if + duma = td2n(i,j,1,n,l)/0.622 + ewater_mb = 0.01*( 0.99976*psn(i,j,1,n,l)*duma/(1.0+duma) ) + esatwater_mb = 0.01*ew(tt2n(i,j,1,n,l)) + ewater_mb = max( 1.0e-10, min( esatwater_mb, ewater_mb ) ) +! then use the following, which is from an old 1970's report +! (reference not available, but the formula works) +! tdew(in C) = (4318.76/(19.5166 - ln(ewater(in mb)))) - 243.893 + td2n(i,j,1,n,l) = 273.16 + & + (4318.76/(19.5166 - log(ewater_mb))) - 243.893 + end do + end do + if (iduma .gt. 0) write(*,*) & + 'readwind_nests - bad tt2n count =', iduma + + +! sea level pressure - calculate it from surface pressure and +! ground elevation using standard atmosphere relations + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + msln(i,j,1,n,l) = psn(i,j,1,n,l)/ & + ((1.0 - 6.5e-3*oron(i,j,l)/288.0)**5.2553) + end do + end do + + +! large scale precipitation +! convective precipitation +! the wrf output files contain these as "accumulated totals" +! I need to find out if these are accumulated over the output +! file frequency, or over the total run. +! For now, set to zero +! total cloud cover +! Doesn't appear to be any 2-d cloud cover field in the +! wrf output. +! For now, set to zero + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + lsprecn(i,j,1,n,l) = 0.0 + convprecn(i,j,1,n,l) = 0.0 + tccn(i,j,1,n,l) = 0.0 + end do + end do + +!C +! Large scale precipitation, (accumulated value, mm) + + varname = 'RAINNC' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, lsprecn(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of RAINNC, set to zero', fnamenc + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + lsprecn(i,j,1,n,l) = 0.0 + end do + end do + end if + +! +! Convective precipitation, (accumulated value, mm) + + varname = 'RAINC' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, convprecn(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of RAINC, set to zero', fnamenc + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + convprecn(i,j,1,n,l) = 0.0 + end do + end do + end if + +! CLOUD FRACTION (clound cover) + + varname = 'CLDFRA' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, tccn(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then +! write(*,9100) l, 'error doing ncread of CLDFRA, set to zero', fnamenc + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + tccn(i,j,1,n,l) = 0.0 + end do + end do + end if + + +! snow depth + varname = 'SNOWH' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, sdn(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then +! write(*,9100) l, 'error doing ncread of SNOWH', fnamenc + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + sdn(i,j,1,n,l) = 0.0 + end do + end do + end if + + +! surface sensible heat flux (positive <--> upwards) + varname = 'HFX' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, sshfn(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + sshfn(i,j,1,n,l) = -sshfn(i,j,1,n,l) + end do + end do + + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of HFX', fnamenc + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + sshfn(i,j,1,n,l) = 0.0 + end do + end do + hflswitch=.false. ! Heat flux is not available + else + hflswitch=.true. ! Heat flux is available +! limit to values to bounds originally used by flexpart? +! do 1502 j=0,nyn(l)-1 +! do 1502 i=0,nxn(l)-1 +! 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. +!1502 continue + end if + +! ustar + varname = 'UST' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, ustarn(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of UST', fnamenc + do j = 0, nyn(l) + do i = 0, nxn(l) + ustarn(i,j,1,n,l) = 0.0 + end do + end do + strswitch=.false. ! ustar is not available + else + strswitch=.true. ! ustar is available + do j=0,nyn(l) + do i=0,nxn(l) + surfstrn(i,j,1,n,l)=ustarn(i,j,1,n,l)/dumarray_pp(i,j,kbgn) + enddo + enddo + + end if + + if(sfc_option .eq. sfc_option_wrf) then +! pblh + varname = 'PBLH' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, hmixn(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of PBLH', fnamenc + stop + endif + + endif + +! surface solar radiation flux (positive <--> downwards) + varname = 'SWDOWN' + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, ssrn(0,0,1,n,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) l, 'error doing ncread of SWDOWN', fnamenc + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + ssrn(i,j,1,n,l) = 0.0 + end do + end do + else + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + ssrn(i,j,1,n,l) = max( ssrn(i,j,1,n,l), 0.0 ) + end do + end do + end if + + +! ew & ns surface stress +! Doesn't appear to be any 2-d cloud cover field in the +! wrf output. +! For now, set to zero + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + ewss(i,j) = 0.0 + nsss(i,j) = 0.0 + end do + end do +! strswitch=.false. ! Surface stress is not available + + +! orography +! standard deviation of orography +! land sea mask +! these should be fixed during a simulation +! so there is no reason to do them again ?? + + +! *** done with reading the wrf output file *** + + +! print*,'uu out1',uuhn(0,259,1:10,1) +! print*,'mu out1',mu(0,259,1),mub(0,259,1) +! print*,'m_xn out1',m_xn(0,259,1,1),m_yn(0,259,1,1) + + +! interpolate uuh from the "U-grid" to the "T-grid" +! interpolate vvh from the "V-grid" to the "T-grid" + if (wind_option.le.0) then + do k = kbgn, nuvz + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + if (wind_option.lt.0) then + divhn(i,j,k,l)=(uuhn(i+1,j,k,l)-uuhn(i,j,k,l))/dxn(l)*m_xn(i,j,1,l) & + +(vvhn(i,j+1,k,l)-vvhn(i,j,k,l))/dyn(l)*m_yn(i,j,1,l) + endif + uuhn(i,j,k,l) = 0.5*(uuhn(i,j,k,l) + uuhn(i+1,j,k,l)) + vvhn(i,j,k,l) = 0.5*(vvhn(i,j,k,l) + vvhn(i,j+1,k,l)) + end do + end do + end do + elseif (wind_option.eq.1) then + do k = kbgn, nuvz + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + uuhn(i,j,k,l) = 0.5*(uuhn(i,j,k,l) + uuhn(i+1,j,k,l)) + vvhn(i,j,k,l) = 0.5*(vvhn(i,j,k,l) + vvhn(i,j+1,k,l)) + mu2=mu(i,j,1)+mub(i,j,1) + uuhn(i,j,k,l) = uuhn(i,j,k,l)/mu2 !*m_yn(i,j,1,l) + vvhn(i,j,k,l) = vvhn(i,j,k,l)/mu2 !*m_xn(i,j,1,l) + wwhn(i,j,k,l) = wwhn(i,j,k,l)/mu2 !*m_yn(i,j,1,l) + end do + end do + end do + elseif (wind_option.eq.2) then + do k = kbgn, nuvz + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + uuhn(i,j,k,l) = 0.5*(uuhn(i,j,k,l) + uuhn(i+1,j,k,l)) + vvhn(i,j,k,l) = 0.5*(vvhn(i,j,k,l) + vvhn(i,j+1,k,l)) + mu2=mu(i,j,1)+mub(i,j,1) + wwhn(i,j,k,l) = wwhn(i,j,k,l)/mu2 !*m_yn(i,j,1,l) + end do + end do + end do + + endif + +! print*,'uu out2',uuhn(0,259,1:10,1) +! print*,'mu out2',mu(0,259,1),mub(0,259,1) +! print*,'m_xn out2',m_xn(0,259,1,1),m_yn(0,259,1,1) + +! CALCULATE SURFSTR + if(sfc_option .eq. sfc_option_diagnosed) then + do j=0,nyn(l)-1 + do i=0,nxn(l)-1 + surfstrn(i,j,1,n,l)=sqrt(ewss(i,j)**2+nsss(i,j)**2) + enddo + enddo + strswitch=.false. ! Surface stress is not available + endif + + if ((.not.hflswitch).or.(.not.strswitch)) then + write(*,*) 'WARNING: No (or incomplete) flux data ' // & + 'contained in WRF output 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 +! +! FLEXPART_WRF - use k=(2+add_sfc_level) here instead of k=3 +!*************************************************************************** + k = 2 + add_sfc_level + do j=0,nyn(l)-1 + do i=0,nxn(l)-1 +! plev1=akz(3)+bkz(3)*psn(i,j,1,n,l) + plev1=pphn(i,j,k,n,l) + pmean=0.5*(psn(i,j,1,n,l)+plev1) + tv=tthn(i,j,k,n,l)*(1.+0.61*qvhn(i,j,k,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,k,l)**2+vvhn(i,j,k,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,k,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. + enddo + enddo + 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 +! +! Note that the uuh, vvh, tth, & qvh data have already been shifted +! upwards by one level, when they were read in. +!************************************************************************** + + if (add_sfc_level .eq. 1) then + do j = 0, nyn(l)-1 + do i = 0, nxn(l)-1 + uuhn(i,j,1,l) = u10n(i,j,1,n,l) + vvhn(i,j,1,l) = v10n(i,j,1,n,l) + tthn(i,j,1,n,l) = tt2n(i,j,1,n,l) + ptthn(i,j,1,n,l) = ptthn(i,j,2,n,l) + qvhn(i,j,1,n,l) = qvhn(i,j,2,n,l) + tkehn(i,j,1,n,l) =tkehn(i,j,2,n,l) +! pressure at 2 m AGL + pphn(i,j,1,n,l) = 0.99976*psn(i,j,1,n,l) +! height (MSL) at ground level (shift it down) + zzhn(i,j,1,n,l) = zzhn(i,j,2,n,l) +! height (MSL) at top of the added level + zzhn(i,j,2,n,l) = zzhn(i,j,1,n,l) + 4.0 + if (hmixn(i,j,1,n,l).lt.hmixmin) hmixn(i,j,1,n,l)=hmixmin + + enddo + enddo + end if + + + do i=0,nxn(L)-1 + do j=0,nyn(L)-1 + do k=1,nuvzmax + un_wrf(i,j,k,n,l)=uuhn(i,j,k,l) + vn_wrf(i,j,k,n,l)=vvhn(i,j,k,l) + enddo + enddo + enddo + + do i=0,nxn(L)-1 + do j=0,nyn(L)-1 + do k=1,nwzmax + wn_wrf(i,j,k,n,l)=wwhn(i,j,k,l) + enddo + enddo + enddo + + + + + enddo !loop over the nests + + + + + return + end subroutine readwind_nests diff --git a/src_flexwrf_v3.1/readwind_nests_timeav.f90 b/src_flexwrf_v3.1/readwind_nests_timeav.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5c3626868e7c2bbcfb82cb24323b0f6a0c87e8e6 --- /dev/null +++ b/src_flexwrf_v3.1/readwind_nests_timeav.f90 @@ -0,0 +1,404 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine readwind_nests_timeav(indj,n,uuhn,vvhn,wwhn) +!********************************************************************** +! * +! TRAJECTORY MODEL SUBROUTINE READWIND * +! * +!********************************************************************** +! * +! April 2012, J. Brioude: This routine handles the difference in time +! for time-average fields. +!********************************************************************** +! * +! Note: This is the FLEXPART_WRF version of subroutine readwind. * +! The met fields are read from WRF netcdf output files. * +! There are many differences from the FLEXPART version. * +! * +! 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 "T-grid" vertical levels wwf model * +! (the unstaggered "bottom_top" dimension) * +! uu,vv,ww wind fields * +! tt,qv temperature and specific humidity * +! ps surface pressure * +! * +!********************************************************************** +! + +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + +! subr arguments + integer :: indj, n + + real(kind=4) :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) + real(kind=4) :: uuhn2(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: vvhn2(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: wwhn2(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) + +! local variables + integer,parameter :: ndims_max=4 + + integer :: i, idiagaa, ierr, ifn, itime + integer :: iduma,indj2,l + integer :: j, jhhmmss, jyyyymmdd + integer :: k, kbgn + integer :: lendim(ndims_max), lendim_exp(ndims_max), & + lendim_max(ndims_max) + integer :: levdiff2,deltat,deltat2 + integer :: ndims, ndims_exp + integer :: n_west_east, n_south_north, n_bottom_top + integer :: m_grid_id_dum, m_parent_grid_id_dum, & + m_parent_grid_ratio_dum, & + i_parent_start_dum, j_parent_start_dum, & + map_proj_id_dum, & + ext_scalar,pbl_physics,mp_physics_dum + + real :: dx_met, dy_met + real :: duma, dumb, dumc, dumd, dume + real :: dumdz +! real(kind=4) :: dumarray_aa(nwzmax+1) +! real(kind=4) :: dumarray_pp(0:nxmax-1,0:nymax-1,nwzmax+1) + real :: dumarray_aa(nwzmax+1) + real :: dumarray_pp(0:nxmax-1,0:nymax-1,nwzmax+1) + real :: ewater_mb, esatwater_mb + real :: ew ! this is an external function + real :: map_stdlon_dum, map_truelat1_dum, map_truelat2_dum + real :: pint + real :: toler + +! real(kind=4) :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1) + real :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1) + real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1 + + real(kind=dp) :: jul,juldate + + character(len=160) :: fnamenc, varname,fnamenc2 + + logical :: hflswitch + +! +! get grid info from the wrf netcdf file +! and check it for consistency against values from gridcheck +! + +! +! main loop -- process each nest +! + do l=1,numbnests + + m = numpath+2*(l-1)+1 + fnamenc = path(m)(1:length(m)) // wfnamen(l,indj) + +! fnamenc = path(2)(1:length(2))//wfname(indj) + idiagaa = 0 + + call read_ncwrfout_gridinfo( ierr, idiagaa, fnamenc, & + n_west_east, n_south_north, n_bottom_top, & + dx_met, dy_met, & + m_grid_id_dum, m_parent_grid_id_dum, m_parent_grid_ratio_dum, & + i_parent_start_dum, j_parent_start_dum, & + map_proj_id_dum, map_stdlon_dum, & + map_truelat1_dum, map_truelat2_dum, & + ext_scalar,pbl_physics,mp_physics_dum ) + if (ierr .ne. 0) then + write(*,9100) 'error getting gridinfor for met file', fnamenc + stop + end if + + i_parent_start_dum = i_parent_start_dum-1 + j_parent_start_dum = j_parent_start_dum-1 + + +9100 format( / '*** readwind -- ', a ) +9110 format( / '*** readwind -- ', a, 1x, i8 / & + 'file = ', a ) +9120 format( / '*** readwind -- ', a, 2(1x,i8) / & + 'file = ', a ) +9130 format( / '*** readwind -- ', a, 3(1x,i8) / & + 'file = ', a ) +9115 format( / '*** readwind -- ', a / a, 1x, i8 / & + 'file = ', a ) +9125 format( / '*** readwind -- ', a / a, 2(1x,i8) / & + 'file = ', a ) +9135 format( / '*** readwind -- ', a / a, 3(1x,i8) / & + 'file = ', a ) + + +! READ THE FIRST FILE + if (ldirect.eq.1) indj2=indj + if (ldirect.eq.-1) indj2=indj + deltat=wfdt(indj2) + fnamenc = path(m)(1:length(m)) // wfnamen(l,indj2) +! locate the date/time in the file + itime = 0 +1100 itime = itime + 1 + call read_ncwrfout_1datetime( ierr, fnamenc, & + itime, jyyyymmdd, jhhmmss ) + if (ierr .eq. -1) then + write(*,9100) 'error reading time from met file', fnamenc + stop + else if (ierr .ne. 0) then + write(*,9125) 'unable to locate date/time in met file', & + 'indj, itime =', indj2, itime, fnamenc + stop + else + jul = juldate( jyyyymmdd, jhhmmss ) + duma = (jul-bdate)*86400. + iduma = nint(duma) + if (iduma .ne. wftime(indj2)) goto 1100 + end if + write(*,*) + write(*,*) 'readwind_nests processing wrfout file =' + write(*,*) fnamenc + write(*,*) 'itime, ymd, hms =', itime, jyyyymmdd, jhhmmss + + kbgn = 1 + add_sfc_level + + if (wind_option.eq.1) varname = 'AVGFLX_RUM' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nxn(l)+1 + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + ndims_exp = 4 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, uuhn(0,0,kbgn,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of U', fnamenc + if (wind_option.le.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + + stop + end if + + +! v wind velocity +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz +! (interpolate it from "V-grid" to "T-grid" later) + if (wind_option.eq.1) varname = 'AVGFLX_RVM' + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l)+1 + lendim_max(2) = nymaxn + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, vvhn(0,0,kbgn,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of V', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + + +! w wind velocity +! this is on the "W-grid", and +! the wrf output file contains nwz levels, so no shifting needed + if (wind_option.eq.1) varname = 'AVGFLX_WWM' +! print*,'varname',varname + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + lendim_exp(3) = nwz + lendim_max(3) = nwzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, wwhn(0,0,1,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of W', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + +! READ THE SECOND FILE and average +! deltat must be equal to deltat2, otherwise the time-average wind cannot be +! fixed. +! deltat is assumed to be the same than the WRF output. + + if (ldirect.eq.1) indj2=indj+1 + if (ldirect.eq.-1) indj2=indj-1 + deltat2=wfdt(indj2) + fnamenc = path(m)(1:length(m)) // wfnamen(l,indj2) + + if (deltat.eq.deltat2 .and. indj2.ge.1 .and.indj2.le.numbwf) then +! locate the date/time in the file + itime = 0 +1101 itime = itime + 1 + call read_ncwrfout_1datetime( ierr, fnamenc, & + itime, jyyyymmdd, jhhmmss ) + if (ierr .eq. -1) then + write(*,9100) 'error reading time from met file', fnamenc + stop + else if (ierr .ne. 0) then + write(*,9125) 'unable to locate date/time in met file', & + 'indj, itime =', indj2, itime, fnamenc + stop + else + jul = juldate( jyyyymmdd, jhhmmss ) + duma = (jul-bdate)*86400. + iduma = nint(duma) + if (iduma .ne. wftime(indj2)) goto 1101 + end if + if (option_verbose.eq.1) then + write(*,*) + write(*,*) 'readwind processing wrfout file =' + write(*,*) fnamenc + write(*,*) 'itime, ymd, hms =', itime, jyyyymmdd, jhhmmss + endif + kbgn = 1 + add_sfc_level + + if (wind_option.eq.1) varname = 'AVGFLX_RUM' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nxn(l)+1 + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + ndims_exp = 4 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, uuhn2(0,0,kbgn,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of U', fnamenc + if (wind_option.le.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + + stop + end if + + +! v wind velocity +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz +! (interpolate it from "V-grid" to "T-grid" later) + if (wind_option.eq.1) varname = 'AVGFLX_RVM' + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l)+1 + lendim_max(2) = nymaxn + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, vvhn2(0,0,kbgn,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of V', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + + +! w wind velocity +! this is on the "W-grid", and +! the wrf output file contains nwz levels, so no shifting needed + if (wind_option.eq.1) varname = 'AVGFLX_WWM' +! print*,'varname',varname + lendim_exp(1) = nxn(l) + lendim_max(1) = nxmaxn + lendim_exp(2) = nyn(l) + lendim_max(2) = nymaxn + lendim_exp(3) = nwz + lendim_max(3) = nwzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, wwhn2(0,0,1,l), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of W', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + + + do k=1,nuvzmax + do j=0,nymax-1 + do i=0,nxmax-1 + uuhn(i,j,k,l)=0.5*(uuhn(i,j,k,l)+uuhn2(i,j,k,l)) + vvhn(i,j,k,l)=0.5*(vvhn(i,j,k,l)+vvhn2(i,j,k,l)) + enddo + enddo + enddo + do k=1,nwzmax + do j=0,nymax-1 + do i=0,nxmax-1 + wwhn(i,j,k,l)=0.5*(wwhn(i,j,k,l)+wwhn2(i,j,k,l)) + enddo + enddo + enddo + + + endif ! test on deltat + + enddo ! loop over the nests + + return + end subroutine readwind_nests_timeav + diff --git a/src_flexwrf_v3.1/readwind_timeav.f90 b/src_flexwrf_v3.1/readwind_timeav.f90 new file mode 100644 index 0000000000000000000000000000000000000000..926123a2defef5ec404c91365d629fdae52cbbab --- /dev/null +++ b/src_flexwrf_v3.1/readwind_timeav.f90 @@ -0,0 +1,454 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine readwind_timeav(indj,n,uuh,vvh,wwh) +!********************************************************************** +! * +! TRAJECTORY MODEL SUBROUTINE READWIND * +! * +!********************************************************************** +! * +! April 2012, J. Brioude: This routine handles the difference in time +! for time-average fields. +!********************************************************************** +! * +! Note: This is the FLEXPART_WRF version of subroutine readwind. * +! The met fields are read from WRF netcdf output files. * +! There are many differences from the FLEXPART version. * +! * +! 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 "T-grid" vertical levels wwf model * +! (the unstaggered "bottom_top" dimension) * +! uu,vv,ww wind fields * +! tt,qv temperature and specific humidity * +! ps surface pressure * +! * +!********************************************************************** +! + +! include 'includepar' +! include 'includecom' + use par_mod + use com_mod + +! subr arguments + integer :: indj, n + + 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) + real(kind=4) :: uuh2(0:nxmax-1,0:nymax-1,nuvzmax) + real(kind=4) :: vvh2(0:nxmax-1,0:nymax-1,nuvzmax) + real(kind=4) :: wwh2(0:nxmax-1,0:nymax-1,nwzmax) + +! local variables + integer,parameter :: ndims_max=4 + + integer :: i, idiagaa, ierr, ifn, itime + integer :: iduma,indj2 + integer :: j, jhhmmss, jyyyymmdd + integer :: k, kbgn + integer :: lendim(ndims_max), lendim_exp(ndims_max), & + lendim_max(ndims_max) + integer :: levdiff2,deltat,deltat2 + integer :: ndims, ndims_exp + integer :: n_west_east, n_south_north, n_bottom_top + integer :: m_grid_id_dum, m_parent_grid_id_dum, & + m_parent_grid_ratio_dum, & + i_parent_start_dum, j_parent_start_dum, & + map_proj_id_dum, & + ext_scalar,pbl_physics,mp_physics_dum + + real :: dx_met, dy_met + real :: duma, dumb, dumc, dumd, dume + real :: dumdz +! real(kind=4) :: dumarray_aa(nwzmax+1) +! real(kind=4) :: dumarray_pp(0:nxmax-1,0:nymax-1,nwzmax+1) + real :: dumarray_aa(nwzmax+1) + real :: dumarray_pp(0:nxmax-1,0:nymax-1,nwzmax+1) + real :: ewater_mb, esatwater_mb + real :: ew ! this is an external function + real :: map_stdlon_dum, map_truelat1_dum, map_truelat2_dum + real :: pint + real :: toler + +! real(kind=4) :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1) + real :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1) + real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1 + + real(kind=dp) :: jul,juldate + + character(len=160) :: fnamenc, varname,fnamenc2 + + logical :: hflswitch + +! +! get grid info from the wrf netcdf file +! and check it for consistency against values from gridcheck +! + +! print*,'entering timeav' + + fnamenc = path(2)(1:length(2))//wfname(indj) + idiagaa = 0 + + call read_ncwrfout_gridinfo( ierr, idiagaa, fnamenc, & + n_west_east, n_south_north, n_bottom_top, & + dx_met, dy_met, & + m_grid_id_dum, m_parent_grid_id_dum, m_parent_grid_ratio_dum, & + i_parent_start_dum, j_parent_start_dum, & + map_proj_id_dum, map_stdlon_dum, & + map_truelat1_dum, map_truelat2_dum, & + ext_scalar,pbl_physics,mp_physics_dum ) + if (ierr .ne. 0) then + write(*,9100) 'error getting gridinfor for met file', fnamenc + stop + end if + +9100 format( / '*** readwind -- ', a ) +9110 format( / '*** readwind -- ', a, 1x, i8 / & + 'file = ', a ) +9120 format( / '*** readwind -- ', a, 2(1x,i8) / & + 'file = ', a ) +9130 format( / '*** readwind -- ', a, 3(1x,i8) / & + 'file = ', a ) +9115 format( / '*** readwind -- ', a / a, 1x, i8 / & + 'file = ', a ) +9125 format( / '*** readwind -- ', a / a, 2(1x,i8) / & + 'file = ', a ) +9135 format( / '*** readwind -- ', a / a, 3(1x,i8) / & + 'file = ', a ) + + toler = 2.0e-7 + + if (nx .ne. n_west_east) then + write(*,9100) 'nx not consistent', fnamenc + stop + end if + if (ny .ne. n_south_north) then + write(*,9100) 'ny not consistent', fnamenc + stop + end if + if (nlev_ec .ne. n_bottom_top) then + write(*,9100) 'nlev_ec not consistent', fnamenc + stop + end if + if (nwz .ne. n_bottom_top+1) then + write(*,9100) 'nwz not consistent', fnamenc + stop + end if +! if (nuvz .ne. n_bottom_top+1) then +! write(*,9100) 'nuvz not consistent', fnamenc +! stop +! end if + + if (m_grid_id(0) .ne. m_grid_id_dum) then + write(*,9100) 'm_grid_id not consistent', fnamenc + write(*,*) m_grid_id(0), m_grid_id_dum + stop + end if + if (m_parent_grid_id(0) .ne. m_parent_grid_id_dum) then + write(*,9100) 'm_parent_grid_id not consistent', fnamenc + stop + end if + if (m_parent_grid_ratio(0) .ne. m_parent_grid_ratio_dum) then + write(*,9100) 'm_parent_grid_ratio not consistent', fnamenc + stop + end if + if (i_parent_start(0) .ne. i_parent_start_dum) then + write(*,9100) 'i_parent_start not consistent', fnamenc + stop + end if + if (j_parent_start(0) .ne. j_parent_start_dum) then + write(*,9100) 'j_parent_start not consistent', fnamenc + stop + end if + + if (abs(dx - dx_met) .gt. toler*abs(dx)) then + write(*,9100) 'dx not consistent', fnamenc + stop + end if + if (abs(dy - dy_met) .gt. toler*abs(dy)) then + write(*,9100) 'dy not consistent', fnamenc + stop + end if + + +! READ THE FIRST FILE + if (ldirect.eq.1) indj2=indj + if (ldirect.eq.-1) indj2=indj + deltat=wfdt(indj2) + fnamenc = path(2)(1:length(2))//wfname(indj2) +! locate the date/time in the file + itime = 0 +1100 itime = itime + 1 + call read_ncwrfout_1datetime( ierr, fnamenc, & + itime, jyyyymmdd, jhhmmss ) + if (ierr .eq. -1) then + write(*,9100) 'error reading time from met file', fnamenc + stop + else if (ierr .ne. 0) then + write(*,9125) 'unable to locate date/time in met file', & + 'indj, itime =', indj2, itime, fnamenc + stop + else + jul = juldate( jyyyymmdd, jhhmmss ) + duma = (jul-bdate)*86400. + iduma = nint(duma) + if (iduma .ne. wftime(indj2)) goto 1100 + end if + if (option_verbose.eq.1) then + write(*,*) + write(*,*) 'readwind processing wrfout file =' + write(*,*) fnamenc + write(*,*) 'itime, ymd, hms =', itime, jyyyymmdd, jhhmmss + endif + kbgn = 1 + add_sfc_level + + if (wind_option.eq.1) varname = 'AVGFLX_RUM' + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nx+1 + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + ndims_exp = 4 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, uuh(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of U', fnamenc + if (wind_option.le.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + + stop + end if + + +! v wind velocity +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz +! (interpolate it from "V-grid" to "T-grid" later) + if (wind_option.eq.1) varname = 'AVGFLX_RVM' + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny+1 + lendim_max(2) = nymax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, vvh(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of V', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + + +! w wind velocity +! this is on the "W-grid", and +! the wrf output file contains nwz levels, so no shifting needed + if (wind_option.eq.1) varname = 'AVGFLX_WWM' +! print*,'varname',varname + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + lendim_exp(3) = nwz + lendim_max(3) = nwzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, wwh, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of W', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + +! READ THE SECOND FILE and average +! deltat must be equal to deltat2, otherwise the time-average wind cannot be +! fixed. +! deltat is assumed to be the same than the WRF output. + + if (ldirect.eq.1) indj2=indj+1 + if (ldirect.eq.-1) indj2=indj-1 + deltat2=wfdt(indj2) + fnamenc = path(2)(1:length(2))//wfname(indj2) + +! print*,'test timeav',deltat,deltat2,indj2,numbwf + if (deltat.eq.deltat2 .and. indj2.ge.1 .and.indj2.le.numbwf) then +! print*,'reading second file in timeav',deltat,deltat2,indj2 +! locate the date/time in the file + itime = 0 +1101 itime = itime + 1 + call read_ncwrfout_1datetime( ierr, fnamenc, & + itime, jyyyymmdd, jhhmmss ) + if (ierr .eq. -1) then + write(*,9100) 'error reading time from met file', fnamenc + stop + else if (ierr .ne. 0) then + write(*,9125) 'unable to locate date/time in met file', & + 'indj, itime =', indj2, itime, fnamenc + stop + else + jul = juldate( jyyyymmdd, jhhmmss ) + duma = (jul-bdate)*86400. + iduma = nint(duma) + if (iduma .ne. wftime(indj2)) goto 1101 + end if + if (option_verbose.eq.1) then + write(*,*) + write(*,*) 'readwind processing wrfout file =' + write(*,*) fnamenc + write(*,*) 'itime, ymd, hms =', itime, jyyyymmdd, jhhmmss + endif + kbgn = 1 + add_sfc_level + + if (wind_option.eq.1) varname = 'AVGFLX_RUM' +! print*,'varname',varname + do i = 1, ndims_max + lendim_exp(i) = 0 + lendim_max(i) = 1 + end do + lendim_exp(1) = nx+1 + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + lendim_exp(3) = nuvz-add_sfc_level + lendim_max(3) = nuvzmax + ndims_exp = 4 + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, uuh2(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of U', fnamenc + if (wind_option.le.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + + stop + end if + + +! v wind velocity +! the wrf output file contains (nuvz-add_sfc_level) levels +! read the data into k=kbgn,nuvz +! (interpolate it from "V-grid" to "T-grid" later) + if (wind_option.eq.1) varname = 'AVGFLX_RVM' +! print*,'varname',varname + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny+1 + lendim_max(2) = nymax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, vvh2(0,0,kbgn), & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of V', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + + +! w wind velocity +! this is on the "W-grid", and +! the wrf output file contains nwz levels, so no shifting needed + if (wind_option.eq.1) varname = 'AVGFLX_WWM' +! print*,'varname',varname + lendim_exp(1) = nx + lendim_max(1) = nxmax + lendim_exp(2) = ny + lendim_max(2) = nymax + lendim_exp(3) = nwz + lendim_max(3) = nwzmax + call read_ncwrfout_1realfield( ierr, idiagaa, fnamenc, & + varname, wwh2, & + itime, & + ndims, ndims_exp, ndims_max, & + lendim, lendim_exp, lendim_max ) + if (ierr .ne. 0) then + write(*,9100) 'error doing ncread of W', fnamenc + if (wind_option.eq.0) print*,'you asked snapshot winds' + if (wind_option.eq.1) print*,'you asked mean winds' + print*,'change wind_option' + stop + end if + +! print*,'start modif timeav' + do k=1,nuvzmax + do j=0,nymax-1 + do i=0,nxmax-1 + uuh(i,j,k)=0.5*(uuh(i,j,k)+uuh2(i,j,k)) + vvh(i,j,k)=0.5*(vvh(i,j,k)+vvh2(i,j,k)) + enddo + enddo + enddo + do k=1,nwzmax + do j=0,nymax-1 + do i=0,nxmax-1 + wwh(i,j,k)=0.5*(wwh(i,j,k)+wwh2(i,j,k)) + enddo + enddo + enddo +! print*,'end modif timeav' + + + endif ! test on deltat + +! print*,'out of entering timeav' + + return + end subroutine readwind_timeav + diff --git a/src_flexwrf_v3.1/redist.f90 b/src_flexwrf_v3.1/redist.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3858ef64d32236920cfefa276e0aa7d88ba8cedf --- /dev/null +++ b/src_flexwrf_v3.1/redist.f90 @@ -0,0 +1,253 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine 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 diff --git a/src_flexwrf_v3.1/redist_kf.f90 b/src_flexwrf_v3.1/redist_kf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..696022634d42b0b4081bb2312e24373749e1a1f6 --- /dev/null +++ b/src_flexwrf_v3.1/redist_kf.f90 @@ -0,0 +1,272 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + +! THIS CODE IS TO REDISTRIBUTE PARTICLES INVOLVED IN UPDRAFT OR/AND DOWDRAFT +! TWO OPTIONS: 2- simply well-mixed inside updraft +! mixing is based on convective mass flux, downdraft is not considered +! 3- particle positions based on entrainment/detrainment rates +! if they are available +! 0- no convection +! 1- has been used by old code + +! SUBROUTINE NAME: redist_kf +! CALLED by convmix_kf.f +! meteoroloy data are from pre_redist_kf.f that is called inside convmix_kf.f +! +! INPUT: +! dx -- horizontal grid size +! nuvzmax -- # of layer for mass flux +! umf -- updraft mass flux +! uer -- updraft entrament flux +! udr -- updraft detrainment flux +! dmf -- downdraft mass flux +! der -- downdraft entrainment flux +! ddr -- downdraft detrainment flux +! rho1d -- air density +! dz1d-- delt z between full levels +! ldirect -- flag for forward (+1) or backward (-1) run +! delt -- time step (s) +! umfzf -- normalized up-mass-flux weighted distance, +! dmfzf -- normalized down-mass-flux weighted distance,(not used) +! fmix -- estimated fraction of particles that will be mixed (for LCONVECTION=2) +! zf -- distance above ground at full levels +! zh -- """"""""""""""""""""""""half levels + +! IN/OUTPUT: +! zp -- particle z position (IN/OUT) + + Subroutine redist_kf(mix_option,ldirect,delt,dx, & ! IN + dz1d,nuvzmax, nuvz,umf,uer,udr,dmf, & ! IN + der,ddr,rho1d, & ! IN + zf,zh, & ! IN + umfzf,dmfzf,fmix, & ! IN + zp) ! IN/OUT + + + IMPLICIT NONE + integer :: nuvzmax,nuvz,ldirect,i,j,k,kk,mix_option + integer,parameter :: well_mix=2 + integer,parameter :: prob_mix=3 + real,dimension(nuvzmax):: umf,uer,udr,zh,dz1d + real,dimension(nuvzmax):: dmf,der,ddr,rho1d + real,dimension(nuvzmax+1):: zf,umfzf,dmfzf + real :: zp,delt,dx,fup,fdown,ftotal,totalmass + real :: rn,rn1,rn2,ddz,fde,w_sub,ran3,fmix + real :: uptop,downtop ! top of updraft and downdraft +! data well_mix,prob_mix/2,3/ + +! Check if particle position is below convection cloud top +! find top height of updraft + uptop=0.0 + do i=nuvz,1,-1 + if (umf(i) .gt. 1e-20) then + if (i .eq. nuvz) uptop = zh(nuvz) + if (i .lt. nuvz) uptop = zh(i+1) + goto 81 + endif + enddo +81 continue ! updraft top + + downtop=0.0 + do i=nuvz,1,-1 + if (abs(dmf(i)) .gt. 1e-20) then + if (i .eq. nuvz) downtop=zh(nuvz) + if (i .lt. nuvz) downtop=zh(i+1) + goto 82 + endif + enddo +82 continue ! downdraft top + + + if (zp .ge. uptop) goto 89 ! no convective adjustment + + DO i=1,nuvz + if (zp .ge. zf(i) .and. zp .lt. zf(i+1)) goto 90 + ENDDO +90 kk=i ! kk is grid # of the particle before reposition + totalmass=rho1d(kk)*dz1d(kk)*dx*dx ! air mass kg + + +!+++++++++ +! NOw start to reposition particle +! +! Simply mix all particles by assigning a random position within cloud +! In this case, backward run is not wroking since this reposition process is not +! reversible. + + IF (mix_option .eq. well_mix) then ! Well-mixed + +!! only consider updraft (usually >> downdraft flux) +!! Choose a random # evenly distributed in [0,1] + rn=ran3(88) + + if (rn .le. fmix) then ! inside cloud + write(*,*)'well mixed, fmix=,rn=',fmix,rn +! --|-- umfzf(j), zf(j) +! --|X- rn2 (particle position) +! --|-- umfzf(j-1),zf(j-1) + + rn2=ran3(881) + + do j=2,nuvz+1 + if(umfzf(j) .ge. rn2) then + zp = zf(j)-(umfzf(j)-rn)/ & + (umfzf(j)-umfzf(j-1))*dz1d(j-1) + goto 92 + endif + enddo +92 continue + write(*,*)'old position=',kk, & + 'repositioned at k=,umfzf(j),rn',j,umfzf(j),rn + endif ! inside cloud + ENDIF ! Well-mixed + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!!!!!!!!! reposition based on probabilities of entrainment and detrainment +!!!!!!!!!!!!!!!! FORWARD treatment +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + IF (mix_option .eq. prob_mix .and. ldirect .gt. 0)then !! prob_mix+ forward + fup = abs(uer(kk))*delt/totalmass + fdown=abs(der(kk))*delt/totalmass + ftotal=fup+fdown ! ignore downward flux if 0*fdown + if (ftotal .le. 1e-10) goto 89 ! return if no cloud +! pick a random number to see if particle is inside cloud + rn = ran3(88) + + + if (rn .le. ftotal) then ! in + rn1=ran3(881) + write(*,*)'inside cloud, kk,ftotal,rn=',kk,ftotal,rn + if (rn1 .le. fup/ftotal) then ! updraft +! parcel will move upward till all particles inside are detrained +! umf(k+1)=umf(k)+uer(k+1)-udr(k+1) +! +! ---|--- +! ---|+++ +! ---|--- zf(j+2) +! ---|+++ udr(j+1), half level, partile is detrained here +! ---|--- zf(j+1) +! ........ +! ---|+++ uer(kk), particle is entrained here + write(*,*)'updraft','fup=',fup,uer(kk)*delt,totalmass + write(*,*)'fdown=',fdown,fdown/ftotal + do j=kk,nuvz-1 + rn=ran3(882) + if (umf(j) .eq. 0.0) goto 98 + fde = abs(udr(j+1)/umf(j)) ! detrainment probability at level j+1 + if (rn .lt. fde .or. zh(j+1) .ge. uptop) goto 98 ! being detrtained from air parcel + ! or reach cloud top + enddo +98 zp=zf(j+1) + rn*(zf(j+2)-zf(j+1)) ! particle is detrained between zf(j+1) and zf(j+2) + write(*,*)'detrain at',j+1,rn,zp,'old=',zf(kk) + else !up/down +! move downward till detrained or get to ground + do j=kk,2,-1 + rn=ran3(883) + if(dmf(j) .eq. 0.0) goto 102 + fde = abs(ddr(j-1)/dmf(j)) ! detrainment at level j-1 + if(rn .lt. fde .or. j .eq. 2) goto 102 + enddo +102 zp=zf(j-1)+rn*(zf(j)-zf(j-1)) + + write(*,*)'downward prob,detrain at',fdown/ftotal,j-1 + + endif ! downdraft + + else ! in /OUT +!! outside cloud +!! displace particle according to compensating subsidence + w_sub =(abs(umf(kk))-abs(dmf(kk)))/rho1d(kk)/dx/dx + zp = zp - w_sub*delt + write(*,*)'subsidence== distance(m)',w_sub*delt, & + 'rn,ftotal=',rn,ftotal + endif ! OUT + ENDIF !! prob_mix + forward +!!!!!!!!! END OF FORWARD treatment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!!!!!!!! ------------------------------------------------------------- +!!!!!!!! backward +!!!!!!!! reverse all processes, e.g., up --> down, down --> up, entrainment -> detrainment +!!!!!!!! detrainment --> entrainment,,,,,,, +!!!!!!!! ------------------------------------------------------------- + + IF (mix_option .eq. prob_mix .and. ldirect .lt. 0) then !! prob_mix + backward + fdown = abs(udr(kk))*delt/totalmass + fup = abs(ddr(kk))*delt/totalmass + ftotal=fup+fdown ! +! ftotal=fup ! ignore downdraft + if (ftotal .le. 1e-10) goto 89 + +! pick a random number to see if particle is inside cloud + rn = ran3(88) + if (rn .le. ftotal) then ! in + rn1=ran3(881) + if (rn1 .lt. fup/ftotal) then ! updraft +! parcel will move "upward" till all particles inside being detrained + + do j=kk,nuvz-1 + rn=ran3(j) + if (dmf(j) .eq. 0.0) goto 981 + fde = abs(der(j+1)/dmf(j)) ! "detrainment" probability at level j+1 + if (rn .lt. fde .or. zh(j+1) .ge. downtop) goto 981 ! being detrtained from air parcel + ! or reach cloud top + enddo +981 zp=zf(j+1) + rn*(zf(j+2)-zf(j+1)) ! partice is detrained between zf(j+1) and j+2 + + else !up/down +! move downward till detrained or get to ground + do j=kk,2,-1 + rn=ran3(j) + if (umf(j) .eq. 0.0) goto 1021 + fde = abs(uer(j-1)/umf(j)) ! "detrainment" at level j-1 + if(rn .lt. fde .or. j .eq. 2) goto 1021 + enddo +1021 zp=zf(j-1)+rn*(zf(j)-zf(j-1)) + + endif ! downdraft + + else ! in /OUT +!! outside cloud +!! displace particle according to compensating subsidence + w_sub =(abs(dmf(kk))-abs(umf(kk)))/rho1d(kk)/dx/dx + zp = zp - w_sub*delt + endif ! OUT + ENDIF !! prob_mix + backward + +!-------------- END OF BACKWARD treatment ------------------ + + + + + +!+++++++++ +! END OF calculating particle position + + +89 continue + + return + end subroutine redist_kf + + + diff --git a/src_flexwrf_v3.1/releaseparticles_irreg.f90 b/src_flexwrf_v3.1/releaseparticles_irreg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..151badd2fce5f2c730d1b099a00403c07fa21c28 --- /dev/null +++ b/src_flexwrf_v3.1/releaseparticles_irreg.f90 @@ -0,0 +1,417 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine releaseparticles_irreg(itime) +! o +!******************************************************************************* +! * +! This subroutine releases particles from the release locations. * +! * +! Note: This is the FLEXPART_WRF version of subroutine gridcheck. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 * +! * +! 14 Nov 2005, R. Easter - use xyindex_to_ll_wrf to get lat,lon * +! * +!******************************************************************************* +! * +! 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 par_mod + use com_mod + use point_mod +! use xmass_mod + +! include 'includepar' +! include 'includecom' + + real :: xaux,yaux,zaux,ran1,rfraction +!,xmasssave(maxpoint) + 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 + real :: dumx, dumy, ylatav + real,parameter :: eps=1.e-8 + 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 + + 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 +!********************************* + +! FLEXPART_WRF - use this routine to get lat,lon +! xlonav=xlon0+(xpoint2(i)+xpoint1(i))/2.*dx ! longitude needed to determine local time + dumx = (xpoint2(i)+xpoint1(i))*0.5 + dumy = (ypoint2(i)+ypoint1(i))*0.5 + call xyindex_to_ll_wrf( 0, dumx, dumy, xlonav, ylatav ) + + 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) + enddo + 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 + enddo +! Assign certain properties to particle +!************************************** + + 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 + enddo +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.eps) ztra1(ipart)=eps ! Minimum starting height is eps + 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 + enddo +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) + enddo + 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) + enddo + endif + rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz + + +! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density +!******************************************************************** + + do k=1,nspec + xmass1(ipart,k)=xmass1(ipart,k)*rhoout + enddo + 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 +! print*,'numpart release',numpart,ipart,maxpart + + 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_irreg + diff --git a/src_flexwrf_v3.1/releaseparticles_reg.f90 b/src_flexwrf_v3.1/releaseparticles_reg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..06516d3cce9357d8c03066a18e31d2f2e51bd74d --- /dev/null +++ b/src_flexwrf_v3.1/releaseparticles_reg.f90 @@ -0,0 +1,432 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine releaseparticles_reg(itime) +! o +!******************************************************************************* +! * +! This subroutine releases particles from the release locations. * +! * +! Note: This is the FLEXPART_WRF version of subroutine gridcheck. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 * +! * +! 14 Nov 2005, R. Easter - use xyindex_to_ll_wrf to get lat,lon * +! July 2012, J. Brioude: regular lat/lon grid coordinates * +!******************************************************************************* +! * +! 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 par_mod + use com_mod + use point_mod +! use xmass_mod + +! include 'includepar' +! include 'includecom' + + real :: xaux,yaux,zaux,ran1,rfraction +!,xmasssave(maxpoint) + 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,xlon,ylat,x1,y1 + real :: dumx, dumy, ylatav,xaux2,yaux2 + real,parameter :: eps=1.e-8 + 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 + + 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 +! print*,'test rel time',itime,itra1(2),itra1(2000),itra1(4000) + do i=1,numpoint +! print*,'numpoint',numpoint,itime,ireleasestart(i) + if ((itime.ge.ireleasestart(i)).and. & ! are we within release interval? + (itime.le.ireleaseend(i))) then + +! Determine the local day and time +!********************************* + +! FLEXPART_WRF - use this routine to get lat,lon +! xlonav=xlon0+(xpoint2(i)+xpoint1(i))/2.*dx ! longitude needed to determine local time + dumx = (xpoint2(i)+xpoint1(i))*0.5 + dumy = (ypoint2(i)+ypoint1(i))*0.5 + call xyindex_to_ll_wrf( 0, dumx, dumy, xlonav, ylatav ) + + 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) + enddo + 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 +! rfraction=rfraction+xmasssave(1) ! number to be released at this time + numrel=int(rfraction) + xmasssave(i)=rfraction-real(numrel) +! xmasssave(1)=rfraction-real(numrel) + else + numrel=npart(i) + endif + +! xaux=xpoint2(i)-xpoint1(i) +! yaux=ypoint2(i)-ypoint1(i) + xaux2=xpoint22(i)-xpoint12(i) + yaux2=ypoint22(i)-ypoint12(i) + zaux=zpoint2(i)-zpoint1(i) +! print*,'numrel',numrel,numpart + 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 +!***************************************************************************************** +! print*,'empty',ipart,itra1(ipart),itime +! Determine horizontal particle position +!*************************************** + +! xtra1(ipart)=xpoint1(i)+ran1(idummy)*xaux + xlon=xpoint12(i)+ran1(idummy)*xaux2 + ylat=ypoint12(i)+ran1(idummy)*yaux2 +!JB: a tester +! print*,'map_std',map_stdlon + call ll_to_xymeter_wrf(xlon,ylat,x1,y1) + xtra1(ipart)=(x1-xmet0)/dx + ytra1(ipart)=(y1-ymet0)/dy + + 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 + enddo +! Assign certain properties to particle +!************************************** + + 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 +! print*,'ipart 1',ipart,ztra1(ipart) +! 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 + enddo +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.eps) ztra1(ipart)=eps ! Minimum starting height is eps + 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 + enddo +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) + enddo + 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) + enddo + endif + rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz + + +! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density +!******************************************************************** + + do k=1,nspec + xmass1(ipart,k)=xmass1(ipart,k)*rhoout + enddo + 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 +! print*,'numpart in rel',numpart +! print*,'test rel0',npoint(5139),npoint(6002),npoint(100003) +! print*,'numpart release',numpart,ipart,maxpart + + 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_reg + diff --git a/src_flexwrf_v3.1/richardson.f90 b/src_flexwrf_v3.1/richardson.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f6f32cc0e98cd46d7a940b8548e2ca9890e06eb8 --- /dev/null +++ b/src_flexwrf_v3.1/richardson.f90 @@ -0,0 +1,250 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, & + pplev,hf,tt2,td2,h,wst,hmixplus,ierr,sfc_option) +! subroutine richardson(psurf,ust,ttlev,qvlev,ulev,vlev,nuvz, +! +akz,bkz,hf,tt2,td2,h,wst,hmixplus,ierr) + +! i i i i i i i +! i i i i i o o o +!**************************************************************************** +! * +! Note: This is the FLEXPART_WRF version of subroutine richardson. * +! * +! 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. * +! * +! 17 Oct 2005 - R. Easter - added ierr status flag (0=ok, -1=fail) * +! 15 Nov 2005 - R. Easter - use pplev instead of akz,bkz * +! * +!**************************************************************************** +! * +! 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 * +! * +!**************************************************************************** + +! include 'includepar' + +! integer ierr +! integer i,k,nuvz,itmax,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 pplev(nuvz),ulev(nuvz),vlev(nuvz),hf,wst,tt2,td2,ew +! real psurf,ust,ttlev(nuvz),qvlev(nuvz),h,const,ric,b,excess,bs +! real thetaold,zl,ul,vl,thetal,ril,hmixplus,wspeed,bvfsq,bvf +! real f_qvsat,rh,rhold,rhl,theta1,theta2,zl1,zl2,thetam +! parameter(const=r_air/ga,ric=0.25,b=100.,bs=8.5,itmax=3) + + use par_mod + + implicit none + + integer :: i,k,nuvz,iter,ierr + real :: tv,tvold,zref,z,zold,pint,pold,theta,thetaref,ri + real :: pplev(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 + + real :: duma + integer :: sfc_option + + 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 + pint=pplev(k) ! 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 + + if (k .ge. nuvz) then + write(*,*) 'richardson not working -- k = nuvz' + ierr = -10 + goto 7000 + end if + +20 continue + +! Determine Richardson number between the critical levels +!******************************************************** + + zl1=zold + theta1=thetaold + do i=1,20 + zl=zold+float(i)/20.*(z-zold) + ul=ulev(k-1)+float(i)/20.*(ulev(k)-ulev(k-1)) + vl=vlev(k-1)+float(i)/20.*(vlev(k)-vlev(k-1)) + thetal=thetaold+float(i)/20.*(theta-thetaold) + rhl=rhold+float(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 + enddo + +25 continue +! if sfc_option = sfc_option_wrf, +! pbl heights are read from WRF met. files and put into hmix (=h) +!JB +! h=zl + if(sfc_option .eq. sfc_option_diagnosed) h=zl + if (h .le. 0.0) then + write(*,*) 'richardson not working -- bad h =', h + ierr = -20 + goto 7000 +! else if (h .lt. 10.0) then +! write(*,*) 'richardson not working -- too small h =', h +! ierr = +20 +! return + end if + + 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 ! keconv = kinetic energy + endif ! used for lifting + + +! 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 + + ierr = 0 + return + +! Fatal error -- print the inputs +7000 continue + write(*,'(a )') 'nuvz' + write(*,'(i5 )') nuvz + write(*,'(a )') 'psurf,ust,hf,tt2,td2,h,wst,hmixplus' + write(*,'(1p,4e18.10)') psurf,ust,hf,tt2,td2,h,wst,hmixplus + write(*,'(a )') 'ttlev' + write(*,'(1p,4e18.10)') ttlev + write(*,'(a )') 'qvlev' + write(*,'(1p,4e18.10)') qvlev + write(*,'(a )') 'ulev' + write(*,'(1p,4e18.10)') ulev + write(*,'(a )') 'vlev' + write(*,'(1p,4e18.10)') vlev + write(*,'(a )') 'pplev' + write(*,'(1p,4e18.10)') pplev + return + +end subroutine richardson + diff --git a/src_flexwrf_v3.1/scalev.f90 b/src_flexwrf_v3.1/scalev.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1249d8f5fcf8e601be7837014cc3e713d846559a --- /dev/null +++ b/src_flexwrf_v3.1/scalev.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/senddouble_mpi.f90 b/src_flexwrf_v3.1/senddouble_mpi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e9f6c57ee7e821bedd1624e766d68c3b8ba48897 --- /dev/null +++ b/src_flexwrf_v3.1/senddouble_mpi.f90 @@ -0,0 +1,114 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + ! routine used to send double precision vectors by MPI + ! Author: J. Brioude * + ! March 2012 * + ! * + + subroutine senddouble_mpi(tag,numpart2,chunksize,direc) + + use mpi_mod + use com_mod + implicit none + include 'mpif.h' + +! character :: varname*20 + integer :: chunksize,numpart2,jj1 +! real(kind=dp) :: dummyr(numpart2), +! real(kind=dp) :: dummyr22(chunksize) + integer :: myid,ierr,ntasks,ii,jdeb,jfin,jj,direc,tag +! integer :: MPI_COMM_WORLD + + integer :: jj2,from,jj3 + integer, dimension(MPI_STATUS_SIZE) :: status + + call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) + call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) + if (direc.eq.0) then ! the slaves get + + if (myid.eq.0) then + do ii=1,ntasks-1 + do jj2=1,chunksize + jj=(jj2-1)*ntasks+ii+1 +! do jj=ii+1,numpart2+ii,ntasks +! jj2=(jj-ii-1)/ntasks+1 +! dummyr2(jj2)=dummyr(jj) + if (tag.eq.11) dummyr22(jj2)=xtra1(jj) + if (tag.eq.12) dummyr22(jj2)=ytra1(jj) + enddo + call MPI_SEND(dummyr22, chunksize, MPI_DOUBLE_PRECISION, ii,tag, MPI_COMM_WORLD, ierr) + enddo +! chunksize2=int((numpart2-1)/ntasks)+1 +! chunksize2=chunksize + ii=0 + do jj=1,numpart2,ntasks + ii=ii+1 + jj2=jj + enddo + chunksize2=ii+numpart2-jj2 + + if (tag.eq.11) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_xtra1(jj3)=xtra1(jj) + enddo + mpi_xtra1(jj3:chunksize2)=xtra1(jj2:numpart2) + elseif (tag.eq.12) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_ytra1(jj3)=ytra1(jj) + enddo + mpi_ytra1(jj3:chunksize2)=ytra1(jj2:numpart2) + endif + + else ! the slaves receive + if (tag.eq.11) call MPI_RECV(mpi_xtra1, chunksize, MPI_DOUBLE_PRECISION, 0,11, MPI_COMM_WORLD,status, ierr) + if (tag.eq.12) call MPI_RECV(mpi_ytra1, chunksize, MPI_DOUBLE_PRECISION, 0,12, MPI_COMM_WORLD,status, ierr) + endif + + else ! the master is going to get + + if (myid.gt.0) then !slaves send + if (tag.eq.11) call MPI_SEND(mpi_xtra1, chunksize, MPI_DOUBLE_PRECISION, 0,11, MPI_COMM_WORLD, ierr) + if (tag.eq.12) call MPI_SEND(mpi_ytra1, chunksize, MPI_DOUBLE_PRECISION, 0,12, MPI_COMM_WORLD, ierr) + + else ! the master gets + + do from =1,ntasks-1 + call MPI_RECV(dummyr22, chunksize, MPI_DOUBLE_PRECISION, from,tag, MPI_COMM_WORLD,status,ierr) + jj1=(from-1)*chunksize+1 + jj2=from*chunksize + if (tag.eq.11) xtra1(jj1:jj2)=dummyr22(1:chunksize) + if (tag.eq.12) ytra1(jj1:jj2)=dummyr22(1:chunksize) + enddo + + if (tag.eq.11) xtra1(jj2+1:numpart2)=mpi_xtra1(1:chunksize2) + if (tag.eq.12) ytra1(jj2+1:numpart2)=mpi_ytra1(1:chunksize2) + + + endif + + endif + + end subroutine senddouble_mpi diff --git a/src_flexwrf_v3.1/senddrydep_mpi.f90 b/src_flexwrf_v3.1/senddrydep_mpi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1397c96e5be25167796a436d045a1688a8b4b5fd --- /dev/null +++ b/src_flexwrf_v3.1/senddrydep_mpi.f90 @@ -0,0 +1,77 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + ! routine used to send real array of dry deposition by MPI + ! Author: J. Brioude * + ! January 2013 * + subroutine senddrydep_mpi(chunksize) + + use mpi_mod + use com_mod + use unc_mod, only: drygridunc2 + use par_mod, only: nclassunc + implicit none + include 'mpif.h' +! character :: varname*20 + integer :: chunksize,numpart2,ks +! real :: dummyr(numpart2,nspec2), + real :: dummyr(chunksize) + integer :: myid,ierr,ntasks,ii,jdeb,jfin,jj,tag,direc +! integer :: MPI_COMM_WORLD + + integer :: tag2,nspec2,ix,jy,l,nage,kp + integer :: jj2,from + integer, dimension(MPI_STATUS_SIZE) :: status + + call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) + call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) + +! chunksize=numxgrid*numygrid + do ks=1,nspec + do kp=1,maxpointspec_act + do nage=1,nageclass + do l=1,nclassunc + tag=ks*1000000+kp*10000+nage*100+l + + if (myid.gt.0) then !slaves send + + call MPI_SEND(drygridunc2(0,0,ks,kp,l,nage), chunksize, MPI_REAL,0,tag, MPI_COMM_WORLD, ierr) + + else ! the master gets + do from =1,ntasks-1 + call MPI_RECV(dummyr, chunksize, MPI_REAL, from,tag, MPI_COMM_WORLD,status,ierr) + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + drygridunc2(ix,jy,ks,kp,l,nage)=drygridunc2(ix,jy,ks,kp,l,nage)+ & + dummyr(ix+1+jy*numxgrid) + enddo + enddo + enddo + + endif + + enddo + enddo + enddo + enddo + end subroutine senddrydep_mpi diff --git a/src_flexwrf_v3.1/senddrydep_nest_mpi.f90 b/src_flexwrf_v3.1/senddrydep_nest_mpi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cbd80605882bc6740562ac1f96fb0f36b2e96760 --- /dev/null +++ b/src_flexwrf_v3.1/senddrydep_nest_mpi.f90 @@ -0,0 +1,77 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + ! routine used to send real array of dry deposition by MPI + ! Author: J. Brioude * + ! January 2013 * + subroutine senddrydep_nest_mpi(chunksize) + + use mpi_mod + use com_mod + use unc_mod, only: drygriduncn2 + use par_mod, only: nclassunc + implicit none + include 'mpif.h' +! character :: varname*20 + integer :: chunksize,numpart2,ks +! real :: dummyr(numpart2,nspec2), + real :: dummyr(chunksize) + integer :: myid,ierr,ntasks,ii,jdeb,jfin,jj,tag,direc +! integer :: MPI_COMM_WORLD + + integer :: tag2,nspec2,ix,jy,l,nage,kp + integer :: jj2,from + integer, dimension(MPI_STATUS_SIZE) :: status + + call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) + call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) + +! chunksize=numxgrid*numygrid + do ks=1,nspec + do kp=1,maxpointspec_act + do nage=1,nageclass + do l=1,nclassunc + tag=ks*1000000+kp*10000+nage*100+l + + if (myid.gt.0) then !slaves send + + call MPI_SEND(drygriduncn2(0,0,ks,kp,l,nage), chunksize, MPI_REAL,0,tag, MPI_COMM_WORLD, ierr) + + else ! the master gets + do from =1,ntasks-1 + call MPI_RECV(dummyr, chunksize, MPI_REAL, from,tag, MPI_COMM_WORLD,status,ierr) + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + drygriduncn2(ix,jy,ks,kp,l,nage)=drygriduncn2(ix,jy,ks,kp,l,nage)+ & + dummyr(ix+1+jy*numxgridn) + enddo + enddo + enddo + + endif + + enddo + enddo + enddo + enddo + end subroutine senddrydep_nest_mpi diff --git a/src_flexwrf_v3.1/sendint2_mpi.f90 b/src_flexwrf_v3.1/sendint2_mpi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0d49f5a5db2038e7c797407d81dc33ec71d862af --- /dev/null +++ b/src_flexwrf_v3.1/sendint2_mpi.f90 @@ -0,0 +1,99 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + ! routine used to send integer*2 vectors by MPI + ! Author: J. Brioude * + ! March 2012 * + subroutine sendint2_mpi(tag,numpart2,chunksize,direc) + + use mpi_mod + use com_mod + + implicit none + include 'mpif.h' + +! character :: varname*20 + integer :: chunksize,numpart2,jj1 +! integer(kind=2) :: dummyi(numpart2), +! integer(kind=2) :: dummyi22(numpart2) + integer :: myid,ierr,ntasks,ii,jdeb,jfin,jj,direc,tag +! integer :: MPI_COMM_WORLD + + integer :: jj2,from,jj3 + integer, dimension(MPI_STATUS_SIZE) :: status + + call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) + call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) + if (direc.eq.0) then ! the slaves get + + if (myid.eq.0) then + do ii=1,ntasks-1 + do jj2=1,chunksize + jj=(jj2-1)*ntasks+ii+1 +! do jj=ii+1,numpart2+ii,ntasks +! jj2=(jj-ii-1)/ntasks+1 +! dummyi2(jj2)=dummyi(jj) + if (tag.eq.13) dummyi22(jj2)=cbt(jj) + enddo + call MPI_SEND(dummyi22, chunksize, MPI_INTEGER2, ii,tag, MPI_COMM_WORLD, ierr) + enddo +! chunksize2=int((numpart2-1)/ntasks)+1 +! chunksize2=chunksize + ii=0 + do jj=1,numpart2,ntasks + ii=ii+1 + jj2=jj + enddo + chunksize2=ii+numpart2-jj2 + + if (tag.eq.13) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_cbt(jj3)=cbt(jj) + enddo + mpi_cbt(jj3:chunksize2)=cbt(jj2:numpart2) + + endif + + else ! the slaves receive + if (tag.eq.13) call MPI_RECV(mpi_cbt, chunksize, MPI_INTEGER2, 0,13, MPI_COMM_WORLD,status, ierr) + endif + + else ! the master is going to get + if (myid.gt.0) then !slaves send + if (tag.eq.13) call MPI_SEND(mpi_cbt, chunksize, MPI_INTEGER2, 0,13, MPI_COMM_WORLD, ierr) + + else ! the master gets + do from =1,ntasks-1 + call MPI_RECV(dummyi22, chunksize, MPI_INTEGER2, from,tag, MPI_COMM_WORLD,status,ierr) + jj1=(from-1)*chunksize+1 + jj2=from*chunksize + if (tag.eq.13) cbt(jj1:jj2)=dummyi22(1:chunksize) + enddo + if (tag.eq.13) cbt(jj2+1:numpart2)=mpi_cbt(1:chunksize2) + + endif + + endif + + end subroutine sendint2_mpi diff --git a/src_flexwrf_v3.1/sendint_mpi.f90 b/src_flexwrf_v3.1/sendint_mpi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..57bc61e264d2d822611bfb498ffc6c97a4e74aa6 --- /dev/null +++ b/src_flexwrf_v3.1/sendint_mpi.f90 @@ -0,0 +1,142 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + ! routine used to send integer vectors by MPI + ! Author: J. Brioude * + ! March 2012 * + subroutine sendint_mpi(tag,numpart2,chunksize,direc) + + use mpi_mod + use com_mod + implicit none + include 'mpif.h' + +! character :: varname*20 + integer :: chunksize,numpart2,jj1 +! integer :: dummyi(numpart2), +! integer :: dummyi2(chunksize), +! integer :: MPI_COMM_WORLD + integer :: myid,ierr,ntasks,ii,jdeb,jfin,jj,direc,tag + integer :: jj2,from,jj3 + integer, dimension(MPI_STATUS_SIZE) :: status + + call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) + call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) + if (direc.eq.0) then ! the slaves get + + if (myid.eq.0) then + do ii=1,ntasks-1 + do jj2=1,chunksize + jj=(jj2-1)*ntasks+ii+1 + +! do jj=ii+1,numpart2+ii+1,ntasks +! jj2=(jj-ii-1)/ntasks+1 +! dummyi2(jj2)=dummyi(jj) + if (tag.eq.1) dummyi2(jj2)=npoint(jj) + if (tag.eq.2) dummyi2(jj2)=idt(jj) + if (tag.eq.3) dummyi2(jj2)=itra1(jj) + if (tag.eq.14) dummyi2(jj2)=itramem(jj) + if (tag.eq.15) dummyi2(jj2)=nclass(jj) + enddo + call MPI_SEND(dummyi2, chunksize, MPI_INTEGER, ii,tag, MPI_COMM_WORLD, ierr) + enddo + +! chunksize2=int((numpart2-1)/ntasks)+1 +! chunksize2=chunksize + ii=0 + do jj=1,numpart2,ntasks + ii=ii+1 + jj2=jj + enddo + chunksize2=ii+numpart2-jj2 + if (tag.eq.1) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_npoint(jj3)=npoint(jj) + enddo + mpi_npoint(jj3:chunksize2)=npoint(jj2:numpart2) + elseif (tag.eq.2) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_idt(jj3)=idt(jj) + enddo + mpi_idt(jj3:chunksize2)=idt(jj2:numpart2) + elseif (tag.eq.3) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_itra1(jj3)=itra1(jj) + enddo + mpi_itra1(jj3:chunksize2)=itra1(jj2:numpart2) + elseif (tag.eq.14) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_itramem(jj3)=itramem(jj) + enddo + mpi_itramem(jj3:chunksize2)=itramem(jj2:numpart2) + elseif (tag.eq.15) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_nclass(jj3)=nclass(jj) + enddo + mpi_nclass(jj3:chunksize2)=nclass(jj2:numpart2) + endif + + else ! the slaves receive + if (tag.eq.1) call MPI_RECV(mpi_npoint, chunksize, MPI_INTEGER, 0,1,MPI_COMM_WORLD,status, ierr) + if (tag.eq.2) call MPI_RECV(mpi_idt, chunksize, MPI_INTEGER, 0,2,MPI_COMM_WORLD,status, ierr) + if (tag.eq.3) call MPI_RECV(mpi_itra1, chunksize, MPI_INTEGER, 0,3,MPI_COMM_WORLD,status, ierr) + if (tag.eq.14) call MPI_RECV(mpi_itramem, chunksize, MPI_INTEGER, 0,14,MPI_COMM_WORLD,status, ierr) + if (tag.eq.15) call MPI_RECV(mpi_nclass, chunksize, MPI_INTEGER, 0,15,MPI_COMM_WORLD,status, ierr) + endif + + else ! the master is going to get + if (myid.gt.0) then !slaves send + if (tag.eq.1) call MPI_SEND(mpi_npoint, chunksize, MPI_INTEGER, 0,1, MPI_COMM_WORLD, ierr) + if (tag.eq.2) call MPI_SEND(mpi_idt, chunksize, MPI_INTEGER, 0,2, MPI_COMM_WORLD, ierr) + if (tag.eq.3) call MPI_SEND(mpi_itra1, chunksize, MPI_INTEGER, 0,3, MPI_COMM_WORLD, ierr) + if (tag.eq.14) call MPI_SEND(mpi_itramem, chunksize, MPI_INTEGER, 0,14, MPI_COMM_WORLD, ierr) + if (tag.eq.15) call MPI_SEND(mpi_nclass, chunksize, MPI_INTEGER, 0,15, MPI_COMM_WORLD, ierr) + + else ! the master gets + + do from =1,ntasks-1 + call MPI_RECV(dummyi2, chunksize, MPI_INTEGER, from,tag, MPI_COMM_WORLD,status,ierr) + jj1=(from-1)*chunksize+1 + jj2=from*chunksize + if (tag.eq.1) npoint(jj1:jj2)=dummyi2(1:chunksize) + if (tag.eq.2) idt(jj1:jj2)=dummyi2(1:chunksize) + if (tag.eq.3) itra1(jj1:jj2)=dummyi2(1:chunksize) + if (tag.eq.14) itramem(jj1:jj2)=dummyi2(1:chunksize) + if (tag.eq.15) nclass(jj1:jj2)=dummyi2(1:chunksize) + enddo + if (tag.eq.1) npoint(jj2+1:numpart2)=mpi_npoint(1:chunksize2) + if (tag.eq.2) idt(jj2+1:numpart2)=mpi_idt(1:chunksize2) + if (tag.eq.3) itra1(jj2+1:numpart2)=mpi_itra1(1:chunksize2) + if (tag.eq.14) itramem(jj2+1:numpart2)=mpi_itramem(1:chunksize2) + if (tag.eq.15) nclass(jj2+1:numpart2)=mpi_nclass(1:chunksize2) + + endif + + endif + + end subroutine sendint_mpi diff --git a/src_flexwrf_v3.1/sendreal2d_mpi.f90 b/src_flexwrf_v3.1/sendreal2d_mpi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f89b9468a23455017705fe8effd7d511ae312f2c --- /dev/null +++ b/src_flexwrf_v3.1/sendreal2d_mpi.f90 @@ -0,0 +1,104 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + ! routine used to send 2D real array by MPI + ! Author: J. Brioude * + ! March 2012 * + subroutine sendreal2d_mpi(tag2,numpart2,nspec2,chunksize,direc) + + use mpi_mod + use com_mod + implicit none + include 'mpif.h' + +! character :: varname*20 + integer :: chunksize,numpart2,ks,jj1 +! real :: dummyr(numpart2,nspec2), +! real :: dummyr2(chunksize) + integer :: myid,ierr,ntasks,ii,jdeb,jfin,jj,tag,direc +! integer :: MPI_COMM_WORLD + + integer :: tag2,nspec2 + integer :: jj2,from,jj3 + integer, dimension(MPI_STATUS_SIZE) :: status + + call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) + call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) + + do ks=1,nspec2 + tag=100+ks + + if (direc.eq.0) then ! the slaves get + + if (myid.eq.0) then + do ii=1,ntasks-1 + do jj2=1,chunksize + jj=(jj2-1)*ntasks+ii+1 +! do jj=ii+1,numpart2+ii,ntasks +! jj2=(jj-ii-1)/ntasks+1 +! dummyr2(jj2)=dummyr(jj,ks) + dummyr2(jj2)=xmass1(jj,ks) + enddo + call MPI_SEND(dummyr2, chunksize, MPI_REAL, ii,tag,MPI_COMM_WORLD, ierr) + enddo + +! chunksize2=int((numpart2-1)/ntasks)+1 +! chunksize2=chunksize + ii=0 + do jj=1,numpart2,ntasks + ii=ii+1 + jj2=jj + enddo + chunksize2=ii+numpart2-jj2 + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_xmass1(jj3,ks)=xmass1(jj,ks) + enddo + mpi_xmass1(jj3:chunksize2,ks)=xmass1(jj2:numpart2,ks) + + else ! slave receive + call MPI_RECV(mpi_xmass1(1,ks), chunksize, MPI_REAL, 0,tag, MPI_COMM_WORLD,status, ierr) + endif + + else ! the master is going to get + + if (myid.gt.0) then !slaves send + + call MPI_SEND(mpi_xmass1(1,ks), chunksize, MPI_REAL,0,tag, MPI_COMM_WORLD, ierr) + + else ! the master gets + do from =1,ntasks-1 + call MPI_RECV(dummyr2, chunksize, MPI_REAL, from,tag, MPI_COMM_WORLD,status,ierr) + jj1=(from-1)*chunksize+1 + jj2=from*chunksize + xmass1(jj1:jj2,ks)=dummyr2(1:chunksize) + enddo + xmass1(jj2+1:numpart2,ks)=mpi_xmass1(1:chunksize2,ks) + + endif + + endif + + + enddo + end subroutine sendreal2d_mpi diff --git a/src_flexwrf_v3.1/sendreal_mpi.f90 b/src_flexwrf_v3.1/sendreal_mpi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0d18b2dd9bf4127302c8f3ea20863d8ac6fba9a2 --- /dev/null +++ b/src_flexwrf_v3.1/sendreal_mpi.f90 @@ -0,0 +1,175 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + ! routine used to send real vectors by MPI + ! Author: J. Brioude * + ! March 2012 * + subroutine sendreal_mpi(tag,numpart2,chunksize,direc) + + use mpi_mod + use com_mod + implicit none + include 'mpif.h' + +! character :: varname*20 + integer :: chunksize,numpart2,jj1 +! real :: dummyr(numpart), +! real :: dummyr2(chunksize) + integer :: myid,ierr,ntasks,ii,jdeb,jfin,jj,direc,tag +! integer :: MPI_COMM_WORLD + integer :: jj2,from,jj3 + integer, dimension(MPI_STATUS_SIZE) :: status + + call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) + call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) + + if (direc.eq.0) then ! the slaves get + + if (myid.eq.0) then ! master sends + do ii=1,ntasks-1 +! jdeb=(ii-1)*chunksize+1 +! jfin=(ii)*chunksize +! do jj=jdeb,jfin +! do jj=ii+1,numpart2+ii,ntasks + do jj2=1,chunksize +! jj2=jj-jdeb+1 +! jj2=(jj-ii-1)/ntasks+1 + jj=(jj2-1)*ntasks+ii+1 +! dummyr2(jj2)=dummyr(jj) + if (tag.eq.4) dummyr2(jj2)=uap(jj) + if (tag.eq.5) dummyr2(jj2)=ucp(jj) + if (tag.eq.6) dummyr2(jj2)=uzp(jj) + if (tag.eq.7) dummyr2(jj2)=us(jj) + if (tag.eq.8) dummyr2(jj2)=vs(jj) + if (tag.eq.9) dummyr2(jj2)=ws(jj) + if (tag.eq.10) dummyr2(jj2)=ztra1(jj) + enddo + call MPI_SEND(dummyr2, chunksize, MPI_REAL, ii,tag, MPI_COMM_WORLD, ierr) + enddo + +! jdeb=(ntasks-1)*chunksize+1 +! jfin=numpart +! chunksize2=jfin-jdeb+1 +! chunksize2=int((numpart2-1)/ntasks)+1 +! chunksize2=chunksize + ii=0 + do jj=1,numpart2,ntasks + ii=ii+1 + jj2=jj + enddo + chunksize2=ii+numpart2-jj2 + + if (tag.eq.4) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_uap(jj3)=uap(jj) + enddo + mpi_uap(jj3:chunksize2)=uap(jj2:numpart2) + elseif (tag.eq.5) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_ucp(jj3)=ucp(jj) + enddo + mpi_ucp(jj3:chunksize2)=ucp(jj2:numpart2) + elseif (tag.eq.6) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_uzp(jj3)=uzp(jj) + enddo + mpi_uzp(jj3:chunksize2)=uzp(jj2:numpart2) + elseif (tag.eq.7) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_us(jj3)=us(jj) + enddo + mpi_us(jj3:chunksize2)=us(jj2:numpart2) + elseif (tag.eq.8) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_vs(jj3)=vs(jj) + enddo + mpi_vs(jj3:chunksize2)=vs(jj2:numpart2) + elseif (tag.eq.9) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_ws(jj3)=ws(jj) + enddo + mpi_ws(jj3:chunksize2)=ws(jj2:numpart2) + elseif (tag.eq.10) then + do jj=1,numpart2,ntasks + jj3=(jj-1)/ntasks+1 + mpi_ztra1(jj3)=ztra1(jj) + enddo + mpi_ztra1(jj3:chunksize2)=ztra1(jj2:numpart2) + endif + + else ! the slaves receive + if (tag.eq.4) call MPI_RECV(mpi_uap, chunksize, MPI_REAL, 0,4,MPI_COMM_WORLD,status, ierr) + if (tag.eq.5) call MPI_RECV(mpi_ucp, chunksize, MPI_REAL, 0,5,MPI_COMM_WORLD,status, ierr) + if (tag.eq.6) call MPI_RECV(mpi_uzp, chunksize, MPI_REAL, 0,6,MPI_COMM_WORLD,status, ierr) + if (tag.eq.7) call MPI_RECV(mpi_us, chunksize, MPI_REAL, 0,7,MPI_COMM_WORLD,status, ierr) + if (tag.eq.8) call MPI_RECV(mpi_vs, chunksize, MPI_REAL, 0,8,MPI_COMM_WORLD,status, ierr) + if (tag.eq.9) call MPI_RECV(mpi_ws, chunksize, MPI_REAL, 0,9,MPI_COMM_WORLD,status, ierr) + if (tag.eq.10) call MPI_RECV(mpi_ztra1, chunksize, MPI_REAL, 0,10,MPI_COMM_WORLD,status, ierr) + endif + + else ! the master is going to get + + if (myid.gt.0) then !slaves send + + if (tag.eq.4) call MPI_SEND(mpi_uap, chunksize, MPI_REAL, 0,4, MPI_COMM_WORLD, ierr) + if (tag.eq.5) call MPI_SEND(mpi_ucp, chunksize, MPI_REAL, 0,5, MPI_COMM_WORLD, ierr) + if (tag.eq.6) call MPI_SEND(mpi_uzp, chunksize, MPI_REAL, 0,6, MPI_COMM_WORLD, ierr) + if (tag.eq.7) call MPI_SEND(mpi_us, chunksize, MPI_REAL, 0,7, MPI_COMM_WORLD, ierr) + if (tag.eq.8) call MPI_SEND(mpi_vs, chunksize, MPI_REAL, 0,8, MPI_COMM_WORLD, ierr) + if (tag.eq.9) call MPI_SEND(mpi_ws, chunksize, MPI_REAL, 0,9, MPI_COMM_WORLD, ierr) + if (tag.eq.10) call MPI_SEND(mpi_ztra1, chunksize, MPI_REAL, 0,10, MPI_COMM_WORLD, ierr) + + else ! the master gets + + do from =1,ntasks-1 + call MPI_RECV(dummyr2, chunksize, MPI_REAL, from,tag, MPI_COMM_WORLD,status,ierr) + jj1=(from-1)*chunksize+1 + jj2=from*chunksize + if (tag.eq.4) uap(jj1:jj2)=dummyr2(1:chunksize) + if (tag.eq.5) ucp(jj1:jj2)=dummyr2(1:chunksize) + if (tag.eq.6) uzp(jj1:jj2)=dummyr2(1:chunksize) + if (tag.eq.7) us(jj1:jj2)=dummyr2(1:chunksize) + if (tag.eq.8) vs(jj1:jj2)=dummyr2(1:chunksize) + if (tag.eq.9) ws(jj1:jj2)=dummyr2(1:chunksize) + if (tag.eq.10) ztra1(jj1:jj2)=dummyr2(1:chunksize) + + enddo + if (tag.eq.4) uap(jj2+1:numpart2)=mpi_uap(1:chunksize2) + if (tag.eq.5) ucp(jj2+1:numpart2)=mpi_ucp(1:chunksize2) + if (tag.eq.6) uzp(jj2+1:numpart2)=mpi_uzp(1:chunksize2) + if (tag.eq.7) us(jj2+1:numpart2)=mpi_us(1:chunksize2) + if (tag.eq.8) vs(jj2+1:numpart2)=mpi_vs(1:chunksize2) + if (tag.eq.9) ws(jj2+1:numpart2)=mpi_ws(1:chunksize2) + if (tag.eq.10) ztra1(jj2+1:numpart2)=mpi_ztra1(1:chunksize2) + + + endif + + endif + end subroutine sendreal_mpi diff --git a/src_flexwrf_v3.1/shift_field.f90 b/src_flexwrf_v3.1/shift_field.f90 new file mode 100644 index 0000000000000000000000000000000000000000..aceb9e49bd7ecbfea44ddd5df17b68bbb2c08dde --- /dev/null +++ b/src_flexwrf_v3.1/shift_field.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/shift_field_0.f90 b/src_flexwrf_v3.1/shift_field_0.f90 new file mode 100644 index 0000000000000000000000000000000000000000..690753c8ff468b163901b062ed5c1c0d95441009 --- /dev/null +++ b/src_flexwrf_v3.1/shift_field_0.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/skplin.f90 b/src_flexwrf_v3.1/skplin.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2db7b8f4f94f8971330509429df29ae46555051f --- /dev/null +++ b/src_flexwrf_v3.1/skplin.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/sort2.f90 b/src_flexwrf_v3.1/sort2.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ecd6df31a6243de1c034689c53d89db59d0641a6 --- /dev/null +++ b/src_flexwrf_v3.1/sort2.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +! 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. diff --git a/src_flexwrf_v3.1/timemanager.f90 b/src_flexwrf_v3.1/timemanager.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bf2d2854c26cf6d8885091c531c54bbda29dea36 --- /dev/null +++ b/src_flexwrf_v3.1/timemanager.f90 @@ -0,0 +1,1050 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine timemanager(mts) + +!******************************************************************************* +! * +! 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 * +! * +! Dec 2005, J. Fast - Only call conccalc & concoutput when (iout.ge.1) * +! Aug 2007, W. Wang - call KFeta convection scheme (lconvection=2or3) +! Note, backward is unavailabe for lconvection=2 +! Mar 2012, J. Brioude: modifications to handle openmp and mpi * +!******************************************************************************* +! 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 * +! jtime [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 interpolation * +! xtra1(maxpart), ytra1(maxpart), ztra1(maxpart) = * +! spatial positions of trajectories * +! * +! Constants: * +! maxpart maximum number of trajectories * +! * +!******************************************************************************* + +! include 'includepar' +! include 'includecom' + 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 mpi_mod + use mt_stream + +! use ran_mod +! use interpol_mod + + implicit none + +! include 'mpif.h' + + integer :: ix,jy,j,ks,kp,l,n,jtime,nstop,nstop1 +!,MPI_COMM_WORLD +! integer :: ksp + integer :: loutnext,loutstart,loutend,jj,chunksize +!,chunksize2 + integer :: chunksize3,omp_get_num_threads + integer :: ldeltat,itage,nage,th_itra1,i + real :: outnum,weight,prob(maxspec),nrand,decfact +! real :: uap(maxpart),ucp(maxpart),uzp(maxpart) +! real :: us(maxpart),vs(maxpart),ws(maxpart) +! integer(kind=2) :: cbt(maxpart) +! real,allocatable, dimension (:) :: uap,ucp,uzp +! real,allocatable, dimension (:) :: us,vs,ws +! integer(kind=2),allocatable, dimension (:) :: cbt + real :: drydeposit(maxspec),gridtotalunc,wetgridtotalunc + real :: drygridtotalunc,xold,yold,zold,xmassfract +! integer j,k,l,n,jtime,nstop,nstop1 +! 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),cbt(maxpart) +! real drydeposit(maxspec),gridtotalunc,wetgridtotalunc +! real drygridtotalunc,xold,yold,zold +! real xm,xm1 + + + integer :: th_npoint,th_idt,th_itramem,jdeb,jfin,stat,th_nclass + integer,save :: cpt(maxomp)=0 +! integer,save :: cpt(24)=0 + real(kind=dp) :: th_xtra1,th_ytra1 + real :: th_ztra1,th_uap,th_ucp,th_uzp + real :: th_us,th_vs,th_ws,ran3 + integer(kind=2) :: th_cbt + integer :: OMP_GET_THREAD_NUM,from + + real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2 + integer :: ixp,jyp,ngrid,indz,indzp,nbp,jj2,ii,offset + logical :: depoindicator(maxspec) + logical,save :: indzindicator(nzmax) + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz,th_xmass1(maxspec) + real :: start, finish + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(nzmax) + real :: u,v,w,usig,vsig,wsig,pvi + integer*4 :: now(3) + integer :: ttime,cpttra +! integer, dimension(MPI_STATUS_SIZE) :: status +! integer, dimension(MPI_STATUS_SIZE) :: status + integer :: myid,ntasks,ierr,islave,tag2,ompid,n_threads,tag3,i_omp + type (mt_state) :: mts (0: MAX_STREAM) + +!************************ + +!JB +! call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) +! call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) +! myid gives the info on the node id + ntasks=1 + myid=0 + loutnext=loutstep/2 + outnum=0. + loutstart=loutnext-loutaver/2 + loutend=loutnext+loutaver/2 + +! if (myid.eq.0) then + allocate(uap(maxpart) ,stat=stat) + allocate(ucp(maxpart) ,stat=stat) + allocate(uzp(maxpart) ,stat=stat) + allocate(us(maxpart) ,stat=stat) + allocate(vs(maxpart) ,stat=stat) + allocate(ws(maxpart) ,stat=stat) + allocate(cbt(maxpart) ,stat=stat) +! endif + +!********************************************************************** +! Loop over the whole modelling period in time steps of mintime seconds +!********************************************************************** + +! print*,'time',myid,ideltas,lsynctime + do jtime=0,ideltas,lsynctime + + +! print*,'jtime',jtime +! Computation of wet deposition 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. jtime .ne. 0 .and. numpart .gt. 0) & + call wetdepo(jtime,lsynctime,loutnext) + + if (OHREA .and. jtime .ne. 0 .and. numpart .gt. 0) & + call ohreaction(jtime,lsynctime,loutnext) + +! compute convection for backward runs +!************************************* + +! if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(jtime.lt.0)) +! & call convmix(jtime) + + if ((ldirect.eq.-1).and.(jtime.lt.0)) then + if (lconvection .eq. 1) call convmix(jtime) + if (lconvection .eq. 2 .or. lconvection .eq. 3) & + call convmix_kfeta(jtime) + endif + +! Get necessary wind fields if not available +!******************************************* + +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + call cpu_time(start) + call getfields(jtime,nstop1) + if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE' +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) +! print*,'read wind time',ttime + +! Release particles +!****************** + +!JB + if (myid.eq.0) then ! I let only the master thread releasing the particles and calculate the output +! call itime(now) + call cpu_time(start) + if (mdomainfill.ge.1) then + if (jtime.eq.0) then + call init_domainfill() + else + call boundcond_domainfill(jtime,loutend) + endif + else + if (numpoint_option.eq.0) then + call releaseparticles_irreg(jtime) + elseif (numpoint_option.eq.1) then +! print*,'avant release' + call releaseparticles_reg(jtime) + endif + endif +! do i=1,numpart +! print*,'ipart 2',myid,i,ztra1(i) +! enddo +! print*,'test rel',npoint(1),npoint(2),npoint(3) + +! print*,'test rel1',npoint(5139),npoint(6002),npoint(100003) +! 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(jtime) + + if (ldirect.eq.1) then + if (lconvection.eq.1)call convmix(jtime) + if (lconvection.eq.2 .or. lconvection .eq. 3) & + call convmix_kfeta(jtime) + endif + +! If middle of averaging period of output fields is reached, accumulated +! deposited mass radioactively decays +!*********************************************************************** + + if (DEP.and.(jtime.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 (mod(jtime,loutsample).eq.0) then +! xm=0. +! xm1=0. +! do 247 j=1,numpart +!47 if (itra1(j).eq.jtime) xm1=xm1+xmass1(j,1) +! xm=xm1 +! do 248 nage=1,nageclass +! do 248 ix=0,numxgrid-1 +! do 248 jy=0,numygrid-1 +! do 248 l=1,nclassunc +!48 xm=xm+wetgridunc(ix,jy,1,l,nage)+drygridunc(ix,jy,1,l,nage) +! write(*,'(i6,4f10.3)') jtime,xm,xm1 +! endif +!!! CHANGE + + +! Check whether concentrations are to be calculated +!************************************************** + + if ((ldirect*jtime.ge.ldirect*loutstart).and. & + (ldirect*jtime.le.ldirect*loutend)) then ! add to grid + if (mod(jtime-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 ((jtime.eq.loutstart).or.(jtime.eq.loutend)) then + weight=0.5 + else + weight=1.0 + endif + outnum=outnum+weight + if(iout.ge.1) then + if (outgrid_option.eq.0) then + call conccalc_irreg(jtime,weight) + elseif (outgrid_option.eq.1) then + call conccalc_reg(jtime,weight) + endif + endif + endif + + +! if ((mquasilag.eq.1).and.(jtime.eq.(loutstart+loutend)/2)) & +! call partoutput_short(jtime) ! dump particle positions in extremely compressed format + + +! Output and reinitialization of grid +! If necessary, first sample of new grid is also taken +!***************************************************** + + if ((jtime.eq.loutend).and.(outnum.gt.0.)) then +! print*,'iout',iout,ipout,outgrid_option + if ((iout.le.3.).or.(iout.eq.5)) then + if(iout.ge.1) then + if (outgrid_option.eq.0) then + call concoutput_irreg(jtime,outnum,gridtotalunc, & + wetgridtotalunc,drygridtotalunc) + if (nested_output.eq.1) call concoutput_nest_irreg(jtime,outnum) + elseif (outgrid_option.eq.1) then + call concoutput_reg(jtime,outnum,gridtotalunc, & + wetgridtotalunc,drygridtotalunc) + if (nested_output.eq.1) call concoutput_nest_reg(jtime,outnum) + endif + endif + +! if (nested_output.eq.1.and.iout.ge.1) +! + call concoutput_nest(jtime,outnum) + outnum=0. + endif + if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(jtime) + if (iflux.eq.1) call fluxoutput(jtime) + write(*,45) jtime,numpart,gridtotalunc,wetgridtotalunc, & + drygridtotalunc +45 format(i9,' SECONDS SIMULATED: ',i9, & + ' PARTICLES: Uncertainty: ',3f7.3) + if (ipout.ge.1) call partoutput(jtime) ! dump particle positions + loutnext=loutnext+loutstep + loutstart=loutnext-loutaver/2 + loutend=loutnext+loutaver/2 + if (jtime.eq.loutstart) then + weight=0.5 + outnum=outnum+weight + if(iout.ge.1) then + if (outgrid_option.eq.0) then + call conccalc_irreg(jtime,weight) + elseif (outgrid_option.eq.1) then + call conccalc_reg(jtime,weight) + endif + endif + 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*jtime.ge.ldirect*itsplit) then + n=numpart + do j=1,numpart + if (ldirect*jtime.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 + + + + +! Loop over all particles +!************************ + + + chunksize=int(numpart/ntasks) !if sent homogeneously +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) + +! print*,'processing time',ttime + endif !over myid +!JB +! at this stage, I assume that each node has the same shared memory because they run getfields. +! now we need to split the trajectories into pieces for each node +! if (myid.eq.0) then + + if (jtime.eq.ideltas) exit + +! Compute interval since radioactive decay of deposited mass was computed +!************************************************************************ + + if (jtime.lt.loutnext) then + ldeltat=jtime-(loutnext-loutstep) + else ! first half of next interval + ldeltat=jtime-loutnext + endif + + +! if (myid.eq.0) then +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + call cpu_time(start) +! do ii=1,ntasks-1 +! call MPI_SEND(chunksize,1, MPI_INTEGER, ii,3001, MPI_COMM_WORLD, ierr) +! call MPI_SEND(numpart,1, MPI_INTEGER, ii,3002, MPI_COMM_WORLD, ierr) +! enddo +! else +! call MPI_RECV(chunksize,1, MPI_INTEGER, 0,3001, MPI_COMM_WORLD,status, ierr) +! call MPI_RECV(numpart,1, MPI_INTEGER, 0,3002, MPI_COMM_WORLD,status, ierr) +! endif +! print*,'numpart',numpart + chunksize2=chunksize + if (chunksize2.eq.0) chunksize2=1 +! print*,'chunk',myid,chunksize2,numpart +! if (ntasks.gt.1) then +! allocate(mpi_npoint(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 1' +! allocate(mpi_idt(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 2' +! allocate(mpi_itra1(chunksize2) ,stat=stat) +! allocate(mpi_itramem(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 3' +! allocate(mpi_uap(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 4' +! allocate(mpi_ucp(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 5' +! allocate(mpi_uzp(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 6' +! allocate(mpi_us(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 7' +! allocate(mpi_vs(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 8' +! allocate(mpi_ws(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 82' +! allocate(mpi_xtra1(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not 9' +! allocate(mpi_ytra1(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not10' +! allocate(mpi_ztra1(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not11' +! allocate(mpi_cbt(chunksize2) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not12' +! allocate(mpi_xmass1(chunksize2,nspec) ,stat=stat) +! if (stat.ne.0) write(*,*)'ERROR: could not13' +! allocate(mpi_nclass(chunksize2) ,stat=stat) +! chunksize2=chunksize +! endif +!JB +! here I am going to send the infos to each slave nodes. +! if (numpart.gt.0 .and. ntasks.gt.1 ) then +! call MPI_BARRIER(MPI_COMM_WORLD,ierr) +! +! call sendint_mpi(1,npoint(1:numpart),numpart,chunksize,0) +! call sendint_mpi(2,idt(1:numpart),numpart,chunksize,0) +! call sendint_mpi(3,itra1(1:numpart),numpart,chunksize,0) +! call sendreal_mpi(4,uap(1:numpart),numpart,chunksize,0) +! call sendreal_mpi(5,ucp(1:numpart),numpart,chunksize,0) +! call sendreal_mpi(6,uzp(1:numpart),numpart,chunksize,0) +! call sendreal_mpi(7,us(1:numpart),numpart,chunksize,0) +! call sendreal_mpi(8,vs(1:numpart),numpart,chunksize,0) +! call sendreal_mpi(9,ws(1:numpart),numpart,chunksize,0) +! call sendreal_mpi(10,ztra1(1:numpart),numpart,chunksize,0) +! call senddouble_mpi(11,xtra1(1:numpart),numpart,chunksize,0) +! call senddouble_mpi(12,ytra1(1:numpart),numpart,chunksize,0) +! call sendint2_mpi(13,cbt(1:numpart),numpart,chunksize,0) +! call sendint_mpi(14,itramem(1:numpart),numpart,chunksize,0) +! call sendint_mpi(15,nclass(1:numpart),numpart,chunksize,0) +! call sendreal2d_mpi(99,xmass1(1:numpart,1:nspec),numpart,nspec,chunksize,0) +! +! if (myid.eq.0) then +!! call itime(now) +!! ttime=now(1)*3600+now(2)*60+now(3)-ttime +! call cpu_time(finish) +! +!! print*,'sending time',ttime +! print*,'sending time',finish-start +! endif +! endif !if statement on numpart et ntasks + +! sigw,dsigwdz,dsigw2dz,cpt(nbp),ompid) + +! initialize the temporary drydeposition grid + + if (DRYDEP.and.ldirect.gt.0) then + do ks=1,nspec + do kp=1,maxpointspec_act + do nage=1,nageclass + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + do l=1,nclassunc + drygridunc2(ix,jy,ks,kp,l,nage)=0. + end do + end do + end do + if (nested_output.eq.1) then + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + do l=1,nclassunc + drygriduncn2(ix,jy,ks,kp,l,nage)=0. + end do + end do + end do + endif + end do + end do + end do + endif + +!JB +! now we are entering the openmp zone. + +! print*,'continue',myid,chunksize2 +!!!$OMP PARALLEL NUM_THREADS(10) DEFAULT(SHARED) & +!$OMP PARALLEL DEFAULT(SHARED) & +!$OMP PRIVATE(jj, th_npoint, th_idt, th_uap, th_ucp, & +!$OMP th_uzp, th_us, th_vs, th_ws, th_xtra1, th_ytra1, th_ztra1,decfact, & +!$OMP th_cbt, xold, yold, zold, kp, itage, prob, nstop, xmassfract, & +!$OMP th_nclass,chunksize3,start,finish,ngrid,ompid,depoindicator,nbp, & +!$OMP indzindicator,cpttra,th_xmass1,th_itra1,th_itramem,drydeposit,n_threads) & +!$OMP SHARED(height,rho,tt,vsetaver,dquer,xtra1,ytra1,ztra1, & +!$OMP density,cunningham,itra1,ioutputforeachrelease,cbt,iflux, & +!$OMP uun,vvn,wwn,ustar,wstar,oli,uupol,vvpol,uu,vv,ww,drhodz,ptt,tke, & +!$OMP rhon,drhodzn,pttn,tken,vdep,vdepn,itramem,nageclass,lage, & +!$OMP jtime,ldirect,memind,nglobal,switchnorthg,m_x,m_y,m_xn,m_yn, & +!$OMP switchsouthg,numbnests,xln,xrn,yln,yrn,memtime,xresoln, & +!$OMP yresoln,hmix,hmixn,tropopause, & +!$OMP tropopausen,lsynctime,dxconst,dyconst,mdomainfill, & +!$OMP turb_option,turbswitch,ifine,chunksize,chunksize2, & +!!!maxrand, & +!$OMP xmass,xmass1,DRYDEP,DRYDEPSPEC,nspec,rannumb,uniform_rannumb,cpt, & +!$OMP lwindinterv,npart,npoint,idt,uap,ucp,uzp,us,vs,ws, & +!$OMP linit_cond,decay,ldeltat,nclass,nested_output,numpart, & +!$OMP mpi_npoint,mpi_idt, mpi_uap, mpi_ucp, mpi_uzp, mpi_us, mpi_vs, & +!$OMP mpi_ws, mpi_xtra1, mpi_ytra1, mpi_ztra1, & +!$OMP mpi_cbt,drygridunc2,drygriduncn2, & +!$OMP mpi_xmass1, mpi_itra1,myid,mpi_itramem,mpi_nclass, & +!$OMP mts) + +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + call cpu_time(start) +! chunksize3=int(chunksize2/omp_get_num_threads())+1 + n_threads=omp_get_num_threads() + ompid=OMP_GET_THREAD_NUM() + chunksize3=int(real(chunksize2)/real(n_threads)/20.)+1 !more efficient + + if (ompid+1.gt.maxomp) then + print*,'problem with maxomp. modify par_mod.f90',maxomp,ompid+1 + stop + endif + + cpttra=0 +! print*,'chunksi',chunksize2,myid + if (chunksize2.gt.0 .and. numpart.gt.0 ) then +! print*,'test rel2',npoint(5139),npoint(6002),npoint(100003) +!!!$OMP DO SCHEDULE(STATIC,10) +!$OMP DO SCHEDULE(STATIC,chunksize3) +!!!$OMP DO SCHEDULE(GUIDED,1) +!!!$OMP DO +! do jj=1,numpart +! do jj=numpart,1,-1 +! print*,jj + do jj=1,chunksize2 + +! If integration step is due, do it +!********************************** +!$OMP CRITICAL +! if (ntasks.gt.1) then +! th_itra1=mpi_itra1(jj) +! th_itramem=mpi_itramem(jj) +! th_npoint=mpi_npoint(jj) +! else + th_itra1=itra1(jj) + th_itramem=itramem(jj) + th_npoint=npoint(jj) +! endif +!$OMP END CRITICAL +! if (th_itra1(jj).eq.jtime) then + if (th_itra1.eq.jtime .and. th_npoint.gt.0 .and. th_npoint.le.numpoint) then + cpttra=cpttra+1 + +! print*,'avant init',j +! Initialize newly released particle +!*********************************** +!$OMP CRITICAL +! if (ntasks.eq.1) then + th_npoint=npoint(jj) + th_idt=idt(jj) + th_uap=uap(jj) + th_ucp=ucp(jj) + th_uzp=uzp(jj) + th_us=us(jj) + th_vs=vs(jj) + th_ws=ws(jj) + th_xtra1=xtra1(jj) + th_ytra1=ytra1(jj) + th_ztra1=ztra1(jj) + th_nclass=nclass(jj) + th_cbt=cbt(jj) + do ks=1,nspec + th_xmass1(ks)=xmass1(jj,ks) + enddo +! else +! th_npoint=mpi_npoint(jj) +! th_idt=mpi_idt(jj) +! th_uap=mpi_uap(jj) +! th_ucp=mpi_ucp(jj) +! th_uzp=mpi_uzp(jj) +! th_us=mpi_us(jj) +! th_vs=mpi_vs(jj) +! th_ws=mpi_ws(jj) +! th_xtra1=mpi_xtra1(jj) +! th_ytra1=mpi_ytra1(jj) +! th_ztra1=mpi_ztra1(jj) +! th_nclass=mpi_nclass(jj) +! th_cbt=mpi_cbt(jj) +! do ks=1,nspec +! th_xmass1(ks)=mpi_xmass1(jj,ks) +! enddo +! endif +!$OMP END CRITICAL + if (ioutputforeachrelease.eq.1) then + kp=npoint(jj) + else + kp=1 + endif + +! Determine age class of the particle +! itage=abs(itra1(jj)-itramem(jj)) + itage=abs(th_itra1-th_itramem) + do nage=1,nageclass + if (itage.lt.lage(nage)) exit + enddo +! if (jj.lt.5) print*,'xmass1',th_xmass1(1) +! nbp=OMP_GET_THREAD_NUM()+1 + nbp=ompid+1 +! print*,th_npoint,jj,npoint(jj) +! print*,'befo',th_xtra1,th_ytra1,th_ztra1 +! iff=0 +! if ((itramem(jj).eq.jtime).or.(jtime.eq.0)) & +! if (jj.eq.103) print*,th_xtra1,th_ytra1,th_ztra1 + if ((th_itramem.eq.jtime).or.(jtime.eq.0)) then +! call initialize(jtime,idt(j),uap(j),ucp(j),uzp(j), & +! us(j),vs(j),ws(j),xtra1(j),ytra1(j),ztra1(j),cbt(j)) + call initialize(jtime,th_idt,th_uap,th_ucp,th_uzp, & + th_us,th_vs,th_ws,th_xtra1,th_ytra1,th_ztra1,th_cbt, & + ngrid,depoindicator,indzindicator,cpt(nbp),ompid,myid,n_threads,mts ) + endif + +! print*,'after',th_xtra1,th_ytra1,th_ztra1 +! Memorize particle positions +!**************************** + +! xold=xtra1(j) +! yold=ytra1(j) +! zold=ztra1(j) + xold=th_xtra1 + yold=th_ytra1 + zold=th_ztra1 +! Integrate Lagevin equation for lsynctime seconds +!************************************************* +! write(*,*)'numpart,jtime, particle #=',numpart,jtime,j + +! call advance(jtime,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)) +! if (jj.eq.103) print*,'bef',th_xtra1,th_ytra1,th_ztra1 + call advance(jtime,th_npoint,th_idt,th_uap,th_ucp,th_uzp, & + th_us,th_vs,th_ws,nstop,th_xtra1,& + th_ytra1,th_ztra1,prob,th_cbt, & + ngrid,depoindicator,indzindicator,cpt(nbp),ompid,myid,n_threads,mts ) +! if (jj.eq.103) print*,'aft',th_xtra1,th_ytra1,th_ztra1 +! Calculate the gross fluxes across layer interfaces +!*************************************************** + + + if (iflux.eq.1) call calcfluxes(nage,jj,xold,yold,zold) + +! if (jj.lt.5) print*,'coord after',myid,th_itra1,th_xmass1(1),DRYDEPSPEC(ks) + +! Determine, when next time step is due +! If trajectory is terminated, mark it +!************************************** + do ks=1,nspec + drydeposit(ks)=0. + enddo + + if (nstop.gt.1) then + if (linit_cond.ge.1) call initial_cond_calc(jtime,jj) +! itra1(jj)=-999999999 + th_itra1=-999999999 + else +! itra1(jj)=jtime+lsynctime + th_itra1=jtime+lsynctime + + +! if (jj.lt.5) print*,'coord after2',myid,th_itra1,th_xmass1(1),DRYDEPSPEC(ks) +! Dry deposition and radioactive decay for each species +!****************************************************** + 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 + drydeposit(ks)=th_xmass1(ks)*prob(ks)*decfact +! xmass1(j,ks)=xmass1(j,ks)*(1.-prob(ks))*decfact + th_xmass1(ks)=th_xmass1(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 + th_xmass1(ks)=th_xmass1(ks)*decfact + endif +! if (jj.lt.5) print*,'coord after3',myid,th_itra1,th_xmass1(1),DRYDEPSPEC(ks),xmass(th_npoint,1) + + if (mdomainfill.eq.0) then + if (xmass(th_npoint,ks).gt.0.) & +! xmassfract=max(xmassfract,real(npart(npoint(jj)))* & + xmassfract=max(xmassfract,real(npart(th_npoint))* & +! xmass1(j,ks)/xmass(npoint(j),ks)) + th_xmass1(ks)/xmass(th_npoint,ks)) + else + xmassfract=1. + endif + + end do + + if (xmassfract.lt.0.000001) then ! terminate all particles carrying less mass +! itra1(jj)=-999999999 + th_itra1=-999999999 + endif + + ! Sabine Eckhardt, June 2008 + ! don't create depofield for backward runs + if (DRYDEP.AND.(ldirect.eq.1)) then +! call drydepokernel(nclass(jj),drydeposit,real(xtra1(jj)), & + call drydepokernel(th_nclass,drydeposit,real(th_xtra1), & +! real(ytra1(jj)),nage,kp) + real(th_ytra1),itage,nage,kp) + if (nested_output.eq.1) call drydepokernel_nest( & +! nclass(jj),drydeposit,real(xtra1(jj)),real(ytra1(jj)), & + th_nclass,drydeposit,real(th_xtra1),real(th_ytra1), & + itage,nage,kp) + endif + + ! Terminate trajectories that are older than maximum allowed age + !*************************************************************** + +! if (abs(itra1(jj)-itramem(jj)).ge.lage(nageclass)) then + if (abs(th_itra1-th_itramem).ge.lage(nageclass)) then + if (linit_cond.ge.1) & + call initial_cond_calc(jtime+lsynctime,jj) +! itra1(jj)=-999999999 + th_itra1=-999999999 + endif + endif +!! print*,xtra1(j),th_xtra1,OMP_GET_THREAD_NUM() +!$OMP CRITICAL +! if (ntasks.eq.1) then + npoint(jj)=th_npoint + idt(jj)=th_idt + uap(jj)=th_uap + ucp(jj)=th_ucp + uzp(jj)=th_uzp + us(jj)=th_us + vs(jj)=th_vs + ws(jj)=th_ws + xtra1(jj)=th_xtra1 + ytra1(jj)=th_ytra1 + ztra1(jj)=th_ztra1 + cbt(jj)=th_cbt + do ks=1,nspec + xmass1(jj,ks)=th_xmass1(ks) + enddo + ! itramem(jj)=th_itramem + itra1(jj)=th_itra1 +! else +! mpi_npoint(jj)=th_npoint +! mpi_idt(jj)=th_idt +! mpi_uap(jj)=th_uap +! mpi_ucp(jj)=th_ucp +! mpi_uzp(jj)=th_uzp +! mpi_us(jj)=th_us +! mpi_vs(jj)=th_vs +! mpi_ws(jj)=th_ws +! mpi_xtra1(jj)=th_xtra1 +! mpi_ytra1(jj)=th_ytra1 +! mpi_ztra1(jj)=th_ztra1 +!! mpi_nclass(jj)=th_nclass +! mpi_cbt(jj)=th_cbt +! do ks=1,nspec +! mpi_xmass1(jj,ks)=th_xmass1(ks) +! enddo +!! mpi_itramem(jj)=th_itramem +! mpi_itra1(jj)=th_itra1 +! endif +! if (jj.lt.5) print*,'coord cont',th_itra1 + +!$OMP END CRITICAL + + endif + + end do !loop over particles +!$OMP END DO + endif +!!!$OMP +!!!$OMP FLUSH(npoint,idt,uap,ucp,uzp,us,vs,ws,xtra1,ytra1,ztra1,cbt,xmass1,itra1) +!!!$OMP FLUSH +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) +! print*,'time',ttime,cpttra,myid,OMP_GET_THREAD_NUM() + if (option_verbose.eq.1) then + print*,'time',finish-start,cpttra,myid,ompid + endif +!$OMP END PARALLEL +!JB +! the openmp is done. the output above gives how long it takes to finish the loop over the particles. good benchmark + + +! here we use mpi to use the mpi_* arrays to update the big ones in the master +! thread + +! call MPI_REDUCE (mypi ,pi ,1, MPI_DOUBLE_PRECISION , MPI_SUM ,0, & +! MPI_COMM_WORLD , ierr ) +! print*,'after loop',myid,chunksize + if (chunksize.gt.0 .and. ntasks.gt.1) then + +!JB +! I need a barrier so each node is a the same place +! I am going to send the new results to the master thread now. +! call MPI_BARRIER(MPI_COMM_WORLD,ierr) + if (myid.eq.0) then +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + call cpu_time(start) + endif +! call sendint_mpi(1,npoint(1:numpart),numpart,chunksize,1) +! call sendint_mpi(2,idt(1:numpart),numpart,chunksize,1) +! call sendint_mpi(3,itra1(1:numpart),numpart,chunksize,1) +! call sendreal_mpi(4,uap(1:numpart),numpart,chunksize,1) +! call sendreal_mpi(5,ucp(1:numpart),numpart,chunksize,1) +! call sendreal_mpi(6,uzp(1:numpart),numpart,chunksize,1) +! call sendreal_mpi(7,us(1:numpart),numpart,chunksize,1) +! call sendreal_mpi(8,vs(1:numpart),numpart,chunksize,1) +! call sendreal_mpi(9,ws(1:numpart),numpart,chunksize,1) +! call sendreal_mpi(10,ztra1(1:numpart),numpart,chunksize,1) +! call senddouble_mpi(11,xtra1(1:numpart),numpart,chunksize,1) +! call senddouble_mpi(12,ytra1(1:numpart),numpart,chunksize,1) +! call sendint2_mpi(13,cbt(1:numpart),numpart,chunksize,1) +! call sendint_mpi(14,itramem(1:numpart),numpart,chunksize,1) +!! call sendint_mpi(15,nclass(1:numpart),numpart,chunksize2,1) +! call sendreal2d_mpi(99,xmass1(1:numpart,1:nspec),numpart,nspec,chunksize,1) + + if (myid.eq.0) then +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) +! print*,'receiving time',ttime + if (option_verbose.eq.1) then + print*,'receiving time',finish-start + endif + endif + endif !finish transfering between nodes +! if (ntasks.gt.1) then +!! print*,'before dealloc',myid +! deallocate(mpi_npoint,mpi_idt,mpi_itra1) +!! print*,'after dealloc, part1',myid +! deallocate(mpi_uap,mpi_ucp,mpi_uzp) +!! print*,'after dealloc, part12',myid +! deallocate(mpi_us,mpi_vs,mpi_ws,mpi_ztra1) +!! print*,'after dealloc, part2',myid +! deallocate(mpi_xtra1,mpi_ytra1) +!! print*,'after dealloc, part3',myid +! deallocate(mpi_cbt) +!! print*,'after dealloc, part4',myid +! deallocate(mpi_xmass1) +!! print*,'after dealloc',myid +! endif +! update the drydepo + if (DRYDEP.and.ldirect.gt.0) then + do ks=1,nspec + do kp=1,maxpointspec_act + do nage=1,nageclass + + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + do l=1,nclassunc + drygridunc(ix,jy,ks,kp,l,nage)=drygridunc(ix,jy,ks,kp,l,nage) & + +drygridunc2(ix,jy,ks,kp,l,nage) + end do + end do + end do + if (nested_output.eq.1) then + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + do l=1,nclassunc + drygriduncn(ix,jy,ks,kp,l,nage)=drygriduncn(ix,jy,ks,kp,l,nage) & + +drygriduncn2(ix,jy,ks,kp,l,nage) + end do + end do + end do + endif + + end do + end do + end do + endif + + end do !loop over time + + + ! Complete the calculation of initial conditions for particles not yet terminated + !***************************************************************************** + + do j=1,numpart + if (linit_cond.ge.1) call initial_cond_calc(jtime,j) + end do + + if (ipout.eq.2) call partoutput(jtime) ! dump particle positions + + if (linit_cond.ge.1) call initial_cond_output(jtime) ! 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 + deallocate(gridunc) + deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmass) + deallocate(ireleasestart,ireleaseend,npart,kindz) +! deallocate(xmasssave) + if (myid.eq.0) then + if (nested_output.eq.1) then + deallocate(orooutn, arean, volumen) + if (ldirect.gt.0) then + deallocate(griduncn,drygriduncn,wetgriduncn,drygriduncn2) + endif + endif + if (ldirect.gt.0) then + if (allocated(drygridunc)) deallocate(drygridunc) + if (allocated(wetgridunc)) deallocate(wetgridunc) + if (allocated(drygridunc2)) deallocate(drygridunc2) + if (allocated(drygriduncn2)) deallocate(drygriduncn2) + endif + deallocate(outheight,outheighthalf) + deallocate(oroout, area, volume) + endif +end subroutine timemanager + + + diff --git a/src_flexwrf_v3.1/timemanager_mpi.f90 b/src_flexwrf_v3.1/timemanager_mpi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0e84569e3ae67e0c0ba60cf30a35a4da4ef58e5d --- /dev/null +++ b/src_flexwrf_v3.1/timemanager_mpi.f90 @@ -0,0 +1,1148 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine timemanager_mpi(mts) + +!******************************************************************************* +! * +! 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 * +! * +! Dec 2005, J. Fast - Only call conccalc & concoutput when (iout.ge.1) * +! Aug 2007, W. Wang - call KFeta convection scheme (lconvection=2or3) +! Note, backward is unavailabe for lconvection=2 +! Mar 2012, J. Brioude: modifications to handle openmp and mpi * +!******************************************************************************* +! 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 * +! jtime [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 interpolation * +! xtra1(maxpart), ytra1(maxpart), ztra1(maxpart) = * +! spatial positions of trajectories * +! * +! Constants: * +! maxpart maximum number of trajectories * +! * +!******************************************************************************* + +! include 'includepar' +! include 'includecom' + 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 mpi_mod + use mt_stream + +! use ran_mod +! use interpol_mod + + implicit none + + include 'mpif.h' + + integer :: ix,jy,j,ks,kp,l,n,jtime,nstop,nstop1 +! integer :: MPI_COMM_WORLD +! integer :: ksp + integer :: loutnext,loutstart,loutend,jj,chunksize +!,chunksize2 + integer :: chunksize3,omp_get_num_threads + integer :: ldeltat,itage,nage,th_itra1,i + real :: outnum,weight,prob(maxspec),nrand,decfact +! real :: uap(maxpart),ucp(maxpart),uzp(maxpart) +! real :: us(maxpart),vs(maxpart),ws(maxpart) +! integer(kind=2) :: cbt(maxpart) +! real,allocatable, dimension (:) :: uap,ucp,uzp +! real,allocatable, dimension (:) :: us,vs,ws +! integer(kind=2),allocatable, dimension (:) :: cbt + real :: drydeposit(maxspec),gridtotalunc,wetgridtotalunc + real :: drygridtotalunc,xold,yold,zold,xmassfract +! integer j,k,l,n,jtime,nstop,nstop1 +! 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),cbt(maxpart) +! real drydeposit(maxspec),gridtotalunc,wetgridtotalunc +! real drygridtotalunc,xold,yold,zold +! real xm,xm1 + + + integer :: th_npoint,th_idt,th_itramem,jdeb,jfin,stat,th_nclass +! integer,save :: cpt(24)=0 + integer,save :: cpt(maxomp)=0 + + real(kind=dp) :: th_xtra1,th_ytra1 + real :: th_ztra1,th_uap,th_ucp,th_uzp + real :: th_us,th_vs,th_ws,ran3 + integer(kind=2) :: th_cbt + integer :: OMP_GET_THREAD_NUM,from + + real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2 + integer :: ixp,jyp,ngrid,indz,indzp,nbp,jj2,ii,offset + logical :: depoindicator(maxspec) + logical,save :: indzindicator(nzmax) + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz,th_xmass1(maxspec) + real :: start, finish + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(nzmax) + real :: u,v,w,usig,vsig,wsig,pvi + integer*4 :: now(3) + integer :: ttime,cpttra + integer, dimension(MPI_STATUS_SIZE) :: status + integer :: myid,ntasks,ierr,islave,tag2,ompid,n_threads,tag3,i_omp + type (mt_state) :: mts (0: MAX_STREAM) +!************************ + +!JB + call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) + call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) +! myid gives the info on the node id + + loutnext=loutstep/2 + outnum=0. + loutstart=loutnext-loutaver/2 + loutend=loutnext+loutaver/2 + +! if (myid.eq.0) then + allocate(uap(maxpart) ,stat=stat) + allocate(ucp(maxpart) ,stat=stat) + allocate(uzp(maxpart) ,stat=stat) + allocate(us(maxpart) ,stat=stat) + allocate(vs(maxpart) ,stat=stat) + allocate(ws(maxpart) ,stat=stat) + allocate(cbt(maxpart) ,stat=stat) +! endif +! if (chunksize2.eq.0) chunksize2=1 + chunksize2=int(maxpart/ntasks)+1 !if sent homogeneously +! print*,'chunk',myid,chunksize2,numpart + if (ntasks.gt.1) then + allocate(mpi_npoint(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 1' + allocate(mpi_idt(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 2' + allocate(mpi_itra1(chunksize2) ,stat=stat) + allocate(mpi_itramem(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 3' + allocate(mpi_uap(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 4' + allocate(mpi_ucp(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 5' + allocate(mpi_uzp(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 6' + allocate(mpi_us(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 7' + allocate(mpi_vs(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 8' + allocate(mpi_ws(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 82' + allocate(mpi_xtra1(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not 9' + allocate(mpi_ytra1(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not10' + allocate(mpi_ztra1(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not11' + allocate(mpi_cbt(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not12' + allocate(mpi_xmass1(chunksize2,nspec) ,stat=stat) +! allocate(mpi_drydep1(chunksize2,nspec) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not13' + allocate(mpi_nclass(chunksize2) ,stat=stat) + allocate(dummyi2(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not14' + allocate(dummyr2(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not15' + allocate(dummyi22(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not16' + allocate(dummyr22(chunksize2) ,stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not17' + chunksize2=chunksize + endif + +!********************************************************************** +! Loop over the whole modelling period in time steps of mintime seconds +!********************************************************************** + +! print*,'time',myid,ideltas,lsynctime + do jtime=0,ideltas,lsynctime + + + +! print*,'jtime',jtime +! Computation of wet deposition 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. jtime .ne. 0 .and. numpart .gt. 0) & + call wetdepo(jtime,lsynctime,loutnext) + + if (OHREA .and. jtime .ne. 0 .and. numpart .gt. 0) & + call ohreaction(jtime,lsynctime,loutnext) + +! compute convection for backward runs +!************************************* + +! if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(jtime.lt.0)) +! & call convmix(jtime) + + if ((ldirect.eq.-1).and.(jtime.lt.0)) then + if (lconvection .eq. 1) call convmix(jtime) + if (lconvection .eq. 2 .or. lconvection .eq. 3) & + call convmix_kfeta(jtime) + endif + +! Get necessary wind fields if not available +!******************************************* + +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + call cpu_time(start) + call getfields(jtime,nstop1) + if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE' +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) +! print*,'read wind time',ttime + if (option_verbose.eq.1) then + print*,'read wind time',finish-start + endif +! Release particles +!****************** + +!JB + if (myid.eq.0) then ! I let only the master thread releasing the particles and calculate the output +! call itime(now) + call cpu_time(start) + if (mdomainfill.ge.1) then + if (jtime.eq.0) then + call init_domainfill() + else + call boundcond_domainfill(jtime,loutend) + endif + else + if (numpoint_option.eq.0) then + call releaseparticles_irreg(jtime) + elseif (numpoint_option.eq.1) then +! print*,'avant release' + call releaseparticles_reg(jtime) + endif + endif +! do i=1,numpart +! print*,'ipart 2',myid,i,ztra1(i) +! enddo +! print*,'test rel',npoint(1),npoint(2),npoint(3) + +! print*,'test rel1',npoint(5139),npoint(6002),npoint(100003) +! 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(jtime) + + if (ldirect.eq.1) then + if (lconvection.eq.1)call convmix(jtime) + if (lconvection.eq.2 .or. lconvection .eq. 3) & + call convmix_kfeta(jtime) + endif +! print*,'intermediaire' + +! If middle of averaging period of output fields is reached, accumulated +! deposited mass radioactively decays +!*********************************************************************** + + if (DEP.and.(jtime.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 (mod(jtime,loutsample).eq.0) then +! xm=0. +! xm1=0. +! do 247 j=1,numpart +!47 if (itra1(j).eq.jtime) xm1=xm1+xmass1(j,1) +! xm=xm1 +! do 248 nage=1,nageclass +! do 248 ix=0,numxgrid-1 +! do 248 jy=0,numygrid-1 +! do 248 l=1,nclassunc +!48 xm=xm+wetgridunc(ix,jy,1,l,nage)+drygridunc(ix,jy,1,l,nage) +! write(*,'(i6,4f10.3)') jtime,xm,xm1 +! endif +!!! CHANGE + + +! Check whether concentrations are to be calculated +!************************************************** + + if ((ldirect*jtime.ge.ldirect*loutstart).and. & + (ldirect*jtime.le.ldirect*loutend)) then ! add to grid + if (mod(jtime-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 ((jtime.eq.loutstart).or.(jtime.eq.loutend)) then + weight=0.5 + else + weight=1.0 + endif +! print*,'avant conccalc' + outnum=outnum+weight + if(iout.ge.1) then + if (outgrid_option.eq.0) then + call conccalc_irreg(jtime,weight) + elseif (outgrid_option.eq.1) then + call conccalc_reg(jtime,weight) + endif + endif + endif + +! print*,'apres conccalc' + +! if ((mquasilag.eq.1).and.(jtime.eq.(loutstart+loutend)/2)) & +! call partoutput_short(jtime) ! dump particle positions in extremely compressed format + + +! Output and reinitialization of grid +! If necessary, first sample of new grid is also taken +!***************************************************** + + if ((jtime.eq.loutend).and.(outnum.gt.0.)) then +! print*,'iout',iout,ipout,outgrid_option + if ((iout.le.3.).or.(iout.eq.5)) then + if(iout.ge.1) then + if (outgrid_option.eq.0) then + call concoutput_irreg(jtime,outnum,gridtotalunc, & + wetgridtotalunc,drygridtotalunc) + if (nested_output.eq.1) call concoutput_nest_irreg(jtime,outnum) + elseif (outgrid_option.eq.1) then + call concoutput_reg(jtime,outnum,gridtotalunc, & + wetgridtotalunc,drygridtotalunc) + if (nested_output.eq.1) call concoutput_nest_reg(jtime,outnum) + endif + endif + +! print*,'apres concout' +! if (nested_output.eq.1.and.iout.ge.1) +! + call concoutput_nest(jtime,outnum) + outnum=0. + endif + if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(jtime) + if (iflux.eq.1) call fluxoutput(jtime) + write(*,45) jtime,numpart,gridtotalunc,wetgridtotalunc, & + drygridtotalunc +45 format(i9,' SECONDS SIMULATED: ',i9, & + ' PARTICLES: Uncertainty: ',3f7.3) + if (ipout.ge.1) call partoutput(jtime) ! dump particle positions + loutnext=loutnext+loutstep + loutstart=loutnext-loutaver/2 + loutend=loutnext+loutaver/2 + if (jtime.eq.loutstart) then + weight=0.5 + outnum=outnum+weight + if(iout.ge.1) then + if (outgrid_option.eq.0) then + call conccalc_irreg(jtime,weight) + elseif (outgrid_option.eq.1) then + call conccalc_reg(jtime,weight) + endif + endif + 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*jtime.ge.ldirect*itsplit) then + n=numpart + do j=1,numpart + if (ldirect*jtime.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 + + + + +! Loop over all particles +!************************ + + +! chunksize=int(numpart/ntasks)+1 !if sent homogeneously + chunksize=int(numpart/ntasks) !if sent homogeneously +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) + +! print*,'processing time',ttime + if (option_verbose.eq.1) then + print*,'processing time',finish-start + endif + endif !over myid +!JB +! at this stage, I assume that each node has the same shared memory because they run getfields. +! now we need to split the trajectories into pieces for each node +! if (myid.eq.0) then + + if (jtime.eq.ideltas) exit + +! Compute interval since radioactive decay of deposited mass was computed +!************************************************************************ + + if (jtime.lt.loutnext) then + ldeltat=jtime-(loutnext-loutstep) + else ! first half of next interval + ldeltat=jtime-loutnext + endif + + + if (myid.eq.0) then +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + call cpu_time(start) + do ii=1,ntasks-1 + call MPI_SEND(chunksize,1, MPI_INTEGER, ii,3001, MPI_COMM_WORLD, ierr) + call MPI_SEND(numpart,1, MPI_INTEGER, ii,3002, MPI_COMM_WORLD, ierr) + enddo + else + call MPI_RECV(chunksize,1, MPI_INTEGER, 0,3001, MPI_COMM_WORLD,status, ierr) + call MPI_RECV(numpart,1, MPI_INTEGER, 0,3002, MPI_COMM_WORLD,status, ierr) + endif +! print*,'numpart',numpart +! chunksize2=chunksize +! print*,'chunksize 0',chunksize2,ntasks +!JB +! here I am going to send the infos to each slave nodes. + if (numpart.gt.0 .and. ntasks.gt.1 ) then + call MPI_BARRIER(MPI_COMM_WORLD,ierr) + + call sendint_mpi(1,numpart,chunksize,0) +! print*,'after npoint',myid,numpart,chunksize + call sendint_mpi(2,numpart,chunksize,0) +! print*,'after idt',myid,numpart,chunksize + call sendint_mpi(3,numpart,chunksize,0) +! print*,'after itra1',myid,numpart,chunksize + call sendreal_mpi(4,numpart,chunksize,0) +! print*,'after uap',myid,numpart,chunksize + call sendreal_mpi(5,numpart,chunksize,0) +! print*,'after ucp',myid,numpart,chunksize + call sendreal_mpi(6,numpart,chunksize,0) +! print*,'after uzp',myid,numpart,chunksize + call sendreal_mpi(7,numpart,chunksize,0) +! print*,'after us',myid,numpart,chunksize + call sendreal_mpi(8,numpart,chunksize,0) +! print*,'after vs',myid,numpart,chunksize + call sendreal_mpi(9,numpart,chunksize,0) +! print*,'after ws',myid,numpart,chunksize + call sendreal_mpi(10,numpart,chunksize,0) +! print*,'after ztra1',myid,numpart,chunksize + call senddouble_mpi(11,numpart,chunksize,0) +! print*,'after xtra1',myid,numpart,chunksize + call senddouble_mpi(12,numpart,chunksize,0) +! print*,'after ytra1',myid,numpart,chunksize + call sendint2_mpi(13,numpart,chunksize,0) +! print*,'after cbt',myid,numpart,chunksize + call sendint_mpi(14,numpart,chunksize,0) +! print*,'after itramem',myid,numpart,chunksize + call sendint_mpi(15,numpart,chunksize,0) +! print*,'after nclass',myid,numpart,chunksize + call sendreal2d_mpi(20,numpart,nspec,chunksize,0) +! print*,'after xmass1',myid,numpart,chunksize + if (myid.eq.0) then +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) + +! print*,'sending time',ttime + if (option_verbose.eq.1) then + print*,'sending time',finish-start + endif + else + chunksize2=chunksize + endif + endif !if statement on numpart et ntasks + +! print*,'debut chunksize',chunksize,chunksize2,myid +! sigw,dsigwdz,dsigw2dz,cpt(nbp),ompid) + +! initialize the temporary drydeposition grid + + if (DRYDEP.and.ldirect.gt.0) then + do ks=1,nspec + do kp=1,maxpointspec_act + do nage=1,nageclass + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + do l=1,nclassunc + drygridunc2(ix,jy,ks,kp,l,nage)=0. + end do + end do + end do + if (nested_output.eq.1) then + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + do l=1,nclassunc + drygriduncn2(ix,jy,ks,kp,l,nage)=0. + end do + end do + end do + endif + end do + end do + end do + endif + +! +!JB +! now we are entering the openmp zone. +! if (myid.eq.0) then +! print*,'itra11',numpart,itra1(numpart-2:numpart+2) +! print*,'itra12',chunksize2,mpi_itra1(chunksize2-2:chunksize2+1) +! else +! print*,'itra13',mpi_itra1(chunksize-2:chunksize+1) +! endif + +! print*,'continue',myid,chunksize2 +!!!$OMP PARALLEL NUM_THREADS(10) DEFAULT(SHARED) & +!$OMP PARALLEL DEFAULT(SHARED) & +!$OMP PRIVATE(jj, th_npoint, th_idt, th_uap, th_ucp, & +!$OMP th_uzp, th_us, th_vs, th_ws, th_xtra1, th_ytra1, th_ztra1,decfact, & +!$OMP th_cbt, xold, yold, zold, kp, itage, prob, nstop, xmassfract, & +!$OMP th_nclass,chunksize3,start,finish,ngrid,ompid,depoindicator,nbp, & +!$OMP indzindicator,cpttra,th_xmass1,th_itra1,th_itramem,drydeposit,n_threads) & +!$OMP SHARED(height,rho,tt,vsetaver,dquer,xtra1,ytra1,ztra1, & +!$OMP density,cunningham,itra1,ioutputforeachrelease,cbt,iflux, & +!$OMP uun,vvn,wwn,ustar,wstar,oli,uupol,vvpol,uu,vv,ww,drhodz,ptt,tke, & +!$OMP rhon,drhodzn,pttn,tken,vdep,vdepn,itramem,nageclass,lage, & +!$OMP jtime,ldirect,memind,nglobal,switchnorthg,m_x,m_y,m_xn,m_yn, & +!$OMP switchsouthg,numbnests,xln,xrn,yln,yrn,memtime,xresoln, & +!$OMP yresoln,hmix,hmixn,tropopause, & +!$OMP tropopausen,lsynctime,dxconst,dyconst,mdomainfill, & +!$OMP turb_option,turbswitch,ifine,chunksize,chunksize2, & +!!!maxrand, & +!$OMP xmass,xmass1,DRYDEP,DRYDEPSPEC,nspec,rannumb,uniform_rannumb,cpt, & +!$OMP lwindinterv,npart,npoint,idt,uap,ucp,uzp,us,vs,ws, & +!$OMP linit_cond,decay,ldeltat,nclass,nested_output,numpart, & +!$OMP mpi_npoint,mpi_idt, mpi_uap, mpi_ucp, mpi_uzp, mpi_us, mpi_vs, & +!$OMP mpi_ws, mpi_xtra1, mpi_ytra1, mpi_ztra1, & +!$OMP mpi_cbt,drygridunc2,drygriduncn2, & +!$OMP mpi_xmass1, mpi_itra1,myid,mpi_itramem,mpi_nclass, & +!$OMP mts) + +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + call cpu_time(start) +! chunksize3=int(chunksize2/omp_get_num_threads())+1 + n_threads=omp_get_num_threads() + +! ompid=omp_get_num_threads() + ompid=OMP_GET_THREAD_NUM() + chunksize3=int(real(chunksize2)/real(n_threads)/20.)+1 !more efficient + + if (ompid+1.gt.maxomp) then + print*,'problem with maxomp. modify par_mod.f90',maxomp,ompid+1 + stop + endif + cpttra=0 +! print*,'chunksi',chunksize2,chunksize3,myid + if (chunksize2.gt.0 .and. numpart.gt.0) then +! print*,'test rel2',npoint(5139),npoint(6002),npoint(100003) +!!!$OMP DO SCHEDULE(STATIC,10) +!$OMP DO SCHEDULE(STATIC,chunksize3) +!!!$OMP DO SCHEDULE(GUIDED,1) +!!!$OMP DO +! do jj=1,numpart +! do jj=numpart,1,-1 +! print*,jj + do jj=1,chunksize2 + +! If integration step is due, do it +!********************************** +!$OMP CRITICAL + if (ntasks.gt.1) then + th_itra1=mpi_itra1(jj) + th_itramem=mpi_itramem(jj) + th_npoint=mpi_npoint(jj) + else + th_itra1=itra1(jj) + th_itramem=itramem(jj) + th_npoint=npoint(jj) + endif + +!$OMP END CRITICAL +! if (th_itra1(jj).eq.jtime) then +! if (mod(jj,30000).eq.1) print*,'middle',jj,th_itra1,jtime +! if (th_itra1.lt.-9999) print*,'middle',jj,th_itra1,jtime +! if (th_itra1.eq.jtime) then +! if (th_itra1.eq.jtime .and. th_npoint.gt.0 .and. th_npoint.le.numpoint) then + if (th_itra1.eq.jtime ) then + cpttra=cpttra+1 + +! print*,'avant init',j +! Initialize newly released particle +!*********************************** +!$OMP CRITICAL + if (ntasks.eq.1) then +! th_npoint=npoint(jj) + th_idt=idt(jj) + th_uap=uap(jj) + th_ucp=ucp(jj) + th_uzp=uzp(jj) + th_us=us(jj) + th_vs=vs(jj) + th_ws=ws(jj) + th_xtra1=xtra1(jj) + th_ytra1=ytra1(jj) + th_ztra1=ztra1(jj) + th_nclass=nclass(jj) + th_cbt=cbt(jj) + do ks=1,nspec + th_xmass1(ks)=xmass1(jj,ks) + enddo + if (ioutputforeachrelease.eq.1) then + kp=npoint(jj) + else + kp=1 + endif + else +! th_npoint=mpi_npoint(jj) + th_idt=mpi_idt(jj) + th_uap=mpi_uap(jj) + th_ucp=mpi_ucp(jj) + th_uzp=mpi_uzp(jj) + th_us=mpi_us(jj) + th_vs=mpi_vs(jj) + th_ws=mpi_ws(jj) + th_xtra1=mpi_xtra1(jj) + th_ytra1=mpi_ytra1(jj) + th_ztra1=mpi_ztra1(jj) + th_nclass=mpi_nclass(jj) + th_cbt=mpi_cbt(jj) + do ks=1,nspec + th_xmass1(ks)=mpi_xmass1(jj,ks) + enddo + if (ioutputforeachrelease.eq.1) then + kp=mpi_npoint(jj) + else + kp=1 + endif + endif +!$OMP END CRITICAL + +! Determine age class of the particle +! itage=abs(itra1(jj)-itramem(jj)) + itage=abs(th_itra1-th_itramem) + do nage=1,nageclass + if (itage.lt.lage(nage)) exit + enddo +! if (jj.lt.5) print*,'xmass1',th_xmass1(1) +! ompid=OMP_GET_THREAD_NUM() + nbp=ompid+1 +! print*,th_npoint,jj,npoint(jj) +! print*,'befo',th_xtra1,th_ytra1,th_ztra1 +! iff=0 +! if ((itramem(jj).eq.jtime).or.(jtime.eq.0)) & + if ((th_itramem.eq.jtime).or.(jtime.eq.0)) then +! call initialize(jtime,idt(j),uap(j),ucp(j),uzp(j), & +! us(j),vs(j),ws(j),xtra1(j),ytra1(j),ztra1(j),cbt(j)) + call initialize(jtime,th_idt,th_uap,th_ucp,th_uzp, & + th_us,th_vs,th_ws,th_xtra1,th_ytra1,th_ztra1,th_cbt, & + ngrid,depoindicator,indzindicator,cpt(nbp),ompid,myid,n_threads,mts ) + endif + +! print*,'after',th_xtra1,th_ytra1,th_ztra1 +! Memorize particle positions +!**************************** +! if (mod(jj,100000).eq.1) print*,'middle',jj,myid,ompid +! xold=xtra1(j) +! yold=ytra1(j) +! zold=ztra1(j) + xold=th_xtra1 + yold=th_ytra1 + zold=th_ztra1 + +! Integrate Lagevin equation for lsynctime seconds +!************************************************* +! write(*,*)'numpart,jtime, particle #=',numpart,jtime,j + +! call advance(jtime,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)) +! if ( abs(xold).gt.1000. .or. xold.ne.xold .or. th_xtra1.ne.th_xtra1 ) & +! print*,'pb avant 0',xold,yold,th_itramem, & +! jtime,jj,chunksize2 +! print*,'npoint',mpi_npoint(jj),th_npoint,jj + call advance(jtime,th_npoint,th_idt,th_uap,th_ucp,th_uzp, & + th_us,th_vs,th_ws,nstop,th_xtra1,& + th_ytra1,th_ztra1,prob,th_cbt, & + ngrid,depoindicator,indzindicator,cpt(nbp),ompid,myid,n_threads,mts ) + +! if ( abs(xold).gt.1000. .or. xold.ne.xold .or. th_xtra1.ne.th_xtra1 ) & +! print*,'pb avant 1',xold,yold,th_itramem, & +! jtime,jj,chunksize2 +! Calculate the gross fluxes across layer interfaces +!*************************************************** + + + if (iflux.eq.1) call calcfluxes(nage,jj,xold,yold,zold) + +! if (jj.lt.5) print*,'coord after',myid,th_itra1,th_xmass1(1),DRYDEPSPEC(ks) + +! Determine, when next time step is due +! If trajectory is terminated, mark it +!************************************** +!!!$OMP CRITICAL + do ks=1,nspec + drydeposit(ks)=0. + enddo + if (nstop.gt.1) then + if (linit_cond.ge.1) call initial_cond_calc(jtime,jj) +! itra1(jj)=-999999999 + th_itra1=-999999999 + if (option_verbose.gt.1) print*,'out of domain',th_xtra1,th_ytra1,th_ztra1 + + else +! itra1(jj)=jtime+lsynctime + th_itra1=jtime+lsynctime + + +! if (jj.lt.5) print*,'coord after2',myid,th_itra1,th_xmass1(1),DRYDEPSPEC(ks) +! Dry deposition and radioactive decay for each species +!****************************************************** + 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 + drydeposit(ks)=th_xmass1(ks)*prob(ks)*decfact +! xmass1(j,ks)=xmass1(j,ks)*(1.-prob(ks))*decfact + th_xmass1(ks)=th_xmass1(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 + th_xmass1(ks)=th_xmass1(ks)*decfact + endif +! if (jj.lt.5) print*,'coord after3',myid,th_itra1,th_xmass1(1),DRYDEPSPEC(ks),xmass(th_npoint,1) + + if (mdomainfill.eq.0) then + if (xmass(th_npoint,ks).gt.0.) & +! xmassfract=max(xmassfract,real(npart(npoint(jj)))* & + xmassfract=max(xmassfract,real(npart(th_npoint))* & +! xmass1(j,ks)/xmass(npoint(j),ks)) + th_xmass1(ks)/xmass(th_npoint,ks)) + else + xmassfract=1. + endif + + end do + + if (ipin.eq.0 .and. xmassfract.lt.0.000001) then ! terminate all particles carrying less mass +! itra1(jj)=-999999999 + th_itra1=-999999999 + endif + + ! Sabine Eckhardt, June 2008 + ! don't create depofield for backward runs + if (DRYDEP.AND.(ldirect.eq.1)) then +! call drydepokernel(nclass(jj),drydeposit,real(xtra1(jj)), & + call drydepokernel(th_nclass,drydeposit,real(th_xtra1), & +! real(ytra1(jj)),nage,kp) + real(th_ytra1),itage,nage,kp) + if (nested_output.eq.1) call drydepokernel_nest( & +! nclass(jj),drydeposit,real(xtra1(jj)),real(ytra1(jj)), & + th_nclass,drydeposit,real(th_xtra1),real(th_ytra1), & + itage,nage,kp) + endif + + ! Terminate trajectories that are older than maximum allowed age + !*************************************************************** + +! if (abs(itra1(jj)-itramem(jj)).ge.lage(nageclass)) then + if (abs(th_itra1-th_itramem).ge.lage(nageclass)) then + if (linit_cond.ge.1) & + call initial_cond_calc(jtime+lsynctime,jj) +! itra1(jj)=-999999999 + th_itra1=-999999999 + endif + endif +!! print*,xtra1(j),th_xtra1,OMP_GET_THREAD_NUM() +!$OMP CRITICAL + if (ntasks.eq.1) then + npoint(jj)=th_npoint + idt(jj)=th_idt + uap(jj)=th_uap + ucp(jj)=th_ucp + uzp(jj)=th_uzp + us(jj)=th_us + vs(jj)=th_vs + ws(jj)=th_ws + xtra1(jj)=th_xtra1 + ytra1(jj)=th_ytra1 + ztra1(jj)=th_ztra1 + cbt(jj)=th_cbt + do ks=1,nspec + xmass1(jj,ks)=th_xmass1(ks) +! drydep1(jj,ks)=drydeposit(ks) + enddo +! itramem(jj)=th_itramem + itra1(jj)=th_itra1 + else + mpi_npoint(jj)=th_npoint + mpi_idt(jj)=th_idt + mpi_uap(jj)=th_uap + mpi_ucp(jj)=th_ucp + mpi_uzp(jj)=th_uzp + mpi_us(jj)=th_us + mpi_vs(jj)=th_vs + mpi_ws(jj)=th_ws + mpi_xtra1(jj)=th_xtra1 + mpi_ytra1(jj)=th_ytra1 + mpi_ztra1(jj)=th_ztra1 +! mpi_nclass(jj)=th_nclass + mpi_cbt(jj)=th_cbt + do ks=1,nspec + mpi_xmass1(jj,ks)=th_xmass1(ks) +! mpi_drydep1(jj,ks)=drydeposit(ks) + enddo +! mpi_itramem(jj)=th_itramem + mpi_itra1(jj)=th_itra1 + endif +! if (jj.lt.5) print*,'coord cont',th_itra1 + +!$OMP END CRITICAL + + endif + + end do !loop over particles +!$OMP END DO + endif +!!!$OMP +!!!$OMP FLUSH(npoint,idt,uap,ucp,uzp,us,vs,ws,xtra1,ytra1,ztra1,cbt,xmass1,itra1) +!!!$OMP FLUSH +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) +! print*,'time',ttime,cpttra,myid,OMP_GET_THREAD_NUM() + if (option_verbose.eq.1) then + print*,'time',finish-start,cpttra,myid,ompid + endif +!$OMP END PARALLEL +!JB +! the openmp is done. the output above gives how long it takes to finish the loop over the particles. good benchmark + +! here we use mpi to use the mpi_* arrays to update the big ones in the master +! thread + +! call MPI_REDUCE (mypi ,pi ,1, MPI_DOUBLE_PRECISION , MPI_SUM ,0, & +! MPI_COMM_WORLD , ierr ) +! print*,'after loop',myid,chunksize + if (chunksize.gt.0 .and. ntasks.gt.1) then + +!JB +! I need a barrier so each node is a the same place +! I am going to send the new results to the master thread now. + call MPI_BARRIER(MPI_COMM_WORLD,ierr) + if (myid.eq.0) then +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + call cpu_time(start) + endif + call sendint_mpi(1,numpart,chunksize,1) + call sendint_mpi(2,numpart,chunksize,1) + call sendint_mpi(3,numpart,chunksize,1) + call sendreal_mpi(4,numpart,chunksize,1) + call sendreal_mpi(5,numpart,chunksize,1) + call sendreal_mpi(6,numpart,chunksize,1) + call sendreal_mpi(7,numpart,chunksize,1) + call sendreal_mpi(8,numpart,chunksize,1) + call sendreal_mpi(9,numpart,chunksize,1) + call sendreal_mpi(10,numpart,chunksize,1) + call senddouble_mpi(11,numpart,chunksize,1) + call senddouble_mpi(12,numpart,chunksize,1) + call sendint2_mpi(13,numpart,chunksize,1) + call sendint_mpi(14,numpart,chunksize,1) +! call sendint_mpi(15,nclass(1:numpart),numpart,chunksize2,1) + call sendreal2d_mpi(99,numpart,nspec,chunksize,1) +! if (DRYDEP) call sendreal2d_mpi(21,numpart,nspec,chunksize,1) + if (DRYDEP.and.(ldirect.eq.1)) call senddrydep_mpi(numxgrid*numygrid) + if (DRYDEP.and.(ldirect.eq.1).and.nested_output.eq.1) & + call senddrydep_nest_mpi(numxgridn*numygridn) +! print*,'size of vector',chunksize,chunksize2,myid,numpart +! +! if (myid.eq.0) then +! print*,'itra1',numpart,itra1(numpart-2:numpart+2) +! print*,'itra2',chunksize2,mpi_itra1(chunksize2-2:chunksize2+1) +! else +! print*,'itra3',mpi_itra1(chunksize-2:chunksize+1) +! endif + if (myid.eq.0) then +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) +! print*,'receiving time',ttime + if (option_verbose.eq.1) then + print*,'receiving time',finish-start + endif + endif + endif !finish transfering between nodes + +! update the drydepo + if (DRYDEP.and.ldirect.gt.0) then + do ks=1,nspec + do kp=1,maxpointspec_act + do nage=1,nageclass + + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + do l=1,nclassunc + drygridunc(ix,jy,ks,kp,l,nage)=drygridunc(ix,jy,ks,kp,l,nage) & + +drygridunc2(ix,jy,ks,kp,l,nage) + end do + end do + end do + if (nested_output.eq.1) then + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + do l=1,nclassunc + drygriduncn(ix,jy,ks,kp,l,nage)=drygriduncn(ix,jy,ks,kp,l,nage) & + +drygriduncn2(ix,jy,ks,kp,l,nage) + end do + end do + end do + endif + end do + end do + end do + + endif + +! if (DRYDEP.AND.(ldirect.eq.1)) then +!! call drydepokernel(nclass(jj),drydeposit,real(xtra1(jj)), & +! call drydepokernel(th_nclass,drydeposit,real(th_xtra1), & +!! real(ytra1(jj)),nage,kp) +! real(th_ytra1),itage,nage,kp) +! if (nested_output.eq.1) call drydepokernel_nest( & +!! nclass(jj),drydeposit,real(xtra1(jj)),real(ytra1(jj)), & +! th_nclass,drydeposit,real(th_xtra1),real(th_ytra1), & +! itage,nage,kp) +! endif + + + end do !loop over time + + + ! Complete the calculation of initial conditions for particles not yet terminated + !***************************************************************************** + call MPI_BARRIER(MPI_COMM_WORLD,ierr) + + do j=1,numpart + if (linit_cond.ge.1) call initial_cond_calc(jtime,j) + end do + + if (ipout.eq.2) call partoutput(jtime) ! dump particle positions + + if (linit_cond.ge.1) call initial_cond_output(jtime) ! dump initial cond. field + + close(104) + + ! De-allocate memory and end + !*************************** + + if (iflux.eq.1) then + deallocate(flux) + endif + if (ntasks.gt.1) then +! print*,'before dealloc',myid + deallocate(mpi_npoint,mpi_idt,mpi_itra1) +! print*,'after dealloc, part1',myid + deallocate(mpi_uap,mpi_ucp,mpi_uzp) +! print*,'after dealloc, part12',myid + deallocate(mpi_us,mpi_vs,mpi_ws,mpi_ztra1) +! print*,'after dealloc, part2',myid + deallocate(mpi_xtra1,mpi_ytra1) +! print*,'after dealloc, part3',myid + deallocate(mpi_cbt) +! print*,'after dealloc, part4',myid +! deallocate(mpi_xmass1,mpi_drydep1,mpi_nclass) + deallocate(mpi_xmass1,mpi_nclass) +! print*,'after dealloc',myid + deallocate(dummyi2) + deallocate(dummyr2) + deallocate(dummyi22) + deallocate(dummyr22) + + endif + if (OHREA.eqv..TRUE.) then + deallocate(OH_field,OH_field_height) + endif + deallocate(gridunc) + deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmass) + deallocate(ireleasestart,ireleaseend,npart,kindz) +! deallocate(xmasssave) + if (myid.eq.0) then + if (nested_output.eq.1) then + deallocate(orooutn, arean, volumen) + if (ldirect.gt.0) then + deallocate(griduncn,drygriduncn,wetgriduncn,drygriduncn2) + endif + endif + if (ldirect.gt.0) then + if (allocated(drygridunc)) deallocate(drygridunc) + if (allocated(wetgridunc)) deallocate(wetgridunc) + if (allocated(drygridunc2)) deallocate(drygridunc2) + if (allocated(drygriduncn2)) deallocate(drygriduncn2) + endif + deallocate(outheight,outheighthalf) + deallocate(oroout, area, volume) + endif +end subroutine timemanager_mpi + + + diff --git a/src_flexwrf_v3.1/timemanager_serial.f90 b/src_flexwrf_v3.1/timemanager_serial.f90 new file mode 100644 index 0000000000000000000000000000000000000000..173791b53d920647580799c713f32083b8085dfd --- /dev/null +++ b/src_flexwrf_v3.1/timemanager_serial.f90 @@ -0,0 +1,769 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine timemanager(mts) + +!******************************************************************************* +! * +! 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 * +! * +! Dec 2005, J. Fast - Only call conccalc & concoutput when (iout.ge.1) * +! Aug 2007, W. Wang - call KFeta convection scheme (lconvection=2or3) +! Note, backward is unavailabe for lconvection=2 +! Mar 2012, J. Brioude: modifications to handle openmp and mpi * +!******************************************************************************* +! 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 * +! jtime [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 interpolation * +! xtra1(maxpart), ytra1(maxpart), ztra1(maxpart) = * +! spatial positions of trajectories * +! * +! Constants: * +! maxpart maximum number of trajectories * +! * +!******************************************************************************* + +! include 'includepar' +! include 'includecom' + 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 mt_stream + +! use ran_mod +! use interpol_mod + + implicit none + + + integer :: ix,jy,j,ks,kp,l,n,jtime,nstop,nstop1 +! integer :: ksp + integer :: loutnext,loutstart,loutend,jj,chunksize +!,chunksize2 + integer :: chunksize3,omp_get_num_threads + integer :: ldeltat,itage,nage,th_itra1,i + real :: outnum,weight,prob(maxspec),nrand,decfact +! real :: uap(maxpart),ucp(maxpart),uzp(maxpart) +! real :: us(maxpart),vs(maxpart),ws(maxpart) +! integer(kind=2) :: cbt(maxpart) +! real,allocatable, dimension (:) :: uap,ucp,uzp +! real,allocatable, dimension (:) :: us,vs,ws +! integer(kind=2),allocatable, dimension (:) :: cbt + real :: drydeposit(maxspec),gridtotalunc,wetgridtotalunc + real :: drygridtotalunc,xold,yold,zold,xmassfract +! integer j,k,l,n,jtime,nstop,nstop1 +! 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),cbt(maxpart) +! real drydeposit(maxspec),gridtotalunc,wetgridtotalunc +! real drygridtotalunc,xold,yold,zold +! real xm,xm1 + + + integer :: th_npoint,th_idt,th_itramem,jdeb,jfin,stat,th_nclass + integer,save :: cpt(maxomp)=0 +! integer,save :: cpt(24)=0 + real(kind=dp) :: th_xtra1,th_ytra1 + real :: th_ztra1,th_uap,th_ucp,th_uzp + real :: th_us,th_vs,th_ws,ran3 + integer(kind=2) :: th_cbt + integer :: from + + real :: p1,p2,p3,p4,ddx,ddy,rddx,rddy,dtt,dt1,dt2 + integer :: ixp,jyp,ngrid,indz,indzp,nbp,jj2,ii,offset + logical :: depoindicator(maxspec) + logical,save :: indzindicator(nzmax) + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz,th_xmass1(maxspec) + real :: start, finish + real :: uprof(nzmax),vprof(nzmax),wprof(nzmax) + real :: usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax) + real :: rhoprof(nzmax),rhogradprof(nzmax) + real :: tkeprof(nzmax),pttprof(nzmax) + real :: u,v,w,usig,vsig,wsig,pvi + integer*4 :: now(3) + integer :: ttime,cpttra +! integer, dimension(MPI_STATUS_SIZE) :: status + integer :: myid,ntasks,ierr,islave,tag2,ompid,n_threads,tag3,i_omp + type (mt_state) :: mts (0: MAX_STREAM) +!************************ + +!JB +! call MPI_COMM_RANK ( MPI_COMM_WORLD, myid, ierr ) +! call MPI_COMM_SIZE ( MPI_COMM_WORLD, ntasks, ierr ) +! myid gives the info on the node id + ntasks=1 + myid=0 + loutnext=loutstep/2 + outnum=0. + loutstart=loutnext-loutaver/2 + loutend=loutnext+loutaver/2 + +! if (myid.eq.0) then + allocate(uap(maxpart) ,stat=stat) + allocate(ucp(maxpart) ,stat=stat) + allocate(uzp(maxpart) ,stat=stat) + allocate(us(maxpart) ,stat=stat) + allocate(vs(maxpart) ,stat=stat) + allocate(ws(maxpart) ,stat=stat) + allocate(cbt(maxpart) ,stat=stat) +! endif + +!********************************************************************** +! Loop over the whole modelling period in time steps of mintime seconds +!********************************************************************** + +! print*,'time',myid,ideltas,lsynctime + do jtime=0,ideltas,lsynctime + + +! print*,'jtime',jtime +! Computation of wet deposition 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. jtime .ne. 0 .and. numpart .gt. 0) & + call wetdepo(jtime,lsynctime,loutnext) + + if (OHREA .and. jtime .ne. 0 .and. numpart .gt. 0) & + call ohreaction(jtime,lsynctime,loutnext) + +! compute convection for backward runs +!************************************* + +! if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(jtime.lt.0)) +! & call convmix(jtime) + + if ((ldirect.eq.-1).and.(jtime.lt.0)) then + if (lconvection .eq. 1) call convmix(jtime) + if (lconvection .eq. 2 .or. lconvection .eq. 3) & + call convmix_kfeta(jtime) + endif + +! Get necessary wind fields if not available +!******************************************* + +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + call cpu_time(start) + call getfields(jtime,nstop1) + if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE' +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) +! print*,'read wind time',ttime + +! Release particles +!****************** + +!JB + if (myid.eq.0) then ! I let only the master thread releasing the particles and calculate the output +! call itime(now) + call cpu_time(start) + if (mdomainfill.ge.1) then + if (jtime.eq.0) then + call init_domainfill() + else + call boundcond_domainfill(jtime,loutend) + endif + else + if (numpoint_option.eq.0) then + call releaseparticles_irreg(jtime) + elseif (numpoint_option.eq.1) then +! print*,'avant release' + call releaseparticles_reg(jtime) + endif + endif +! do i=1,numpart +! print*,'ipart 2',myid,i,ztra1(i) +! enddo +! print*,'test rel',npoint(1),npoint(2),npoint(3) + +! print*,'test rel1',npoint(5139),npoint(6002),npoint(100003) +! 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(jtime) + + if (ldirect.eq.1) then + if (lconvection.eq.1)call convmix(jtime) + if (lconvection.eq.2 .or. lconvection .eq. 3) & + call convmix_kfeta(jtime) + endif + +! If middle of averaging period of output fields is reached, accumulated +! deposited mass radioactively decays +!*********************************************************************** + + if (DEP.and.(jtime.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 (mod(jtime,loutsample).eq.0) then +! xm=0. +! xm1=0. +! do 247 j=1,numpart +!47 if (itra1(j).eq.jtime) xm1=xm1+xmass1(j,1) +! xm=xm1 +! do 248 nage=1,nageclass +! do 248 ix=0,numxgrid-1 +! do 248 jy=0,numygrid-1 +! do 248 l=1,nclassunc +!48 xm=xm+wetgridunc(ix,jy,1,l,nage)+drygridunc(ix,jy,1,l,nage) +! write(*,'(i6,4f10.3)') jtime,xm,xm1 +! endif +!!! CHANGE + + +! Check whether concentrations are to be calculated +!************************************************** + + if ((ldirect*jtime.ge.ldirect*loutstart).and. & + (ldirect*jtime.le.ldirect*loutend)) then ! add to grid + if (mod(jtime-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 ((jtime.eq.loutstart).or.(jtime.eq.loutend)) then + weight=0.5 + else + weight=1.0 + endif + outnum=outnum+weight + if(iout.ge.1) then + if (outgrid_option.eq.0) then + call conccalc_irreg(jtime,weight) + elseif (outgrid_option.eq.1) then + call conccalc_reg(jtime,weight) + endif + endif + endif + + +! if ((mquasilag.eq.1).and.(jtime.eq.(loutstart+loutend)/2)) & +! call partoutput_short(jtime) ! dump particle positions in extremely compressed format + + +! Output and reinitialization of grid +! If necessary, first sample of new grid is also taken +!***************************************************** + + if ((jtime.eq.loutend).and.(outnum.gt.0.)) then +! print*,'iout',iout,ipout,outgrid_option + if ((iout.le.3.).or.(iout.eq.5)) then + if(iout.ge.1) then + if (outgrid_option.eq.0) then + call concoutput_irreg(jtime,outnum,gridtotalunc, & + wetgridtotalunc,drygridtotalunc) + if (nested_output.eq.1) call concoutput_nest_irreg(jtime,outnum) + elseif (outgrid_option.eq.1) then + call concoutput_reg(jtime,outnum,gridtotalunc, & + wetgridtotalunc,drygridtotalunc) + if (nested_output.eq.1) call concoutput_nest_reg(jtime,outnum) + endif + endif + +! if (nested_output.eq.1.and.iout.ge.1) +! + call concoutput_nest(jtime,outnum) + outnum=0. + endif + if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(jtime) + if (iflux.eq.1) call fluxoutput(jtime) + write(*,45) jtime,numpart,gridtotalunc,wetgridtotalunc, & + drygridtotalunc +45 format(i9,' SECONDS SIMULATED: ',i9, & + ' PARTICLES: Uncertainty: ',3f7.3) + if (ipout.ge.1) call partoutput(jtime) ! dump particle positions + loutnext=loutnext+loutstep + loutstart=loutnext-loutaver/2 + loutend=loutnext+loutaver/2 + if (jtime.eq.loutstart) then + weight=0.5 + outnum=outnum+weight + if(iout.ge.1) then + if (outgrid_option.eq.0) then + call conccalc_irreg(jtime,weight) + elseif (outgrid_option.eq.1) then + call conccalc_reg(jtime,weight) + endif + endif + 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*jtime.ge.ldirect*itsplit) then + n=numpart + do j=1,numpart + if (ldirect*jtime.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 + + + + +! Loop over all particles +!************************ + + +! chunksize=int(numpart/ntasks)+1 !if sent homogeneously +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) + +! print*,'processing time',ttime + endif !over myid +!JB +! at this stage, I assume that each node has the same shared memory because they run getfields. +! now we need to split the trajectories into pieces for each node +! if (myid.eq.0) then + + if (jtime.eq.ideltas) exit + +! Compute interval since radioactive decay of deposited mass was computed +!************************************************************************ + + if (jtime.lt.loutnext) then + ldeltat=jtime-(loutnext-loutstep) + else ! first half of next interval + ldeltat=jtime-loutnext + endif + + +! if (myid.eq.0) then +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) +! do ii=1,ntasks-1 +! call MPI_SEND(chunksize,1, MPI_INTEGER, ii,3001, MPI_COMM_WORLD, ierr) +! call MPI_SEND(numpart,1, MPI_INTEGER, ii,3002, MPI_COMM_WORLD, ierr) +! enddo +! else +! call MPI_RECV(chunksize,1, MPI_INTEGER, 0,3001, MPI_COMM_WORLD,status, ierr) +! call MPI_RECV(numpart,1, MPI_INTEGER, 0,3002, MPI_COMM_WORLD,status, ierr) +! endif +! print*,'numpart',numpart + +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3) + +! initialize the temporary drydeposition grid + + if (DRYDEP.and.ldirect.gt.0) then + do ks=1,nspec + do kp=1,maxpointspec_act + do nage=1,nageclass + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + do l=1,nclassunc + drygridunc2(ix,jy,ks,kp,l,nage)=0. + end do + end do + end do + if (nested_output.eq.1) then + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + do l=1,nclassunc + drygriduncn2(ix,jy,ks,kp,l,nage)=0. + end do + end do + end do + endif + end do + end do + end do + endif + + + call cpu_time(start) +! chunksize3=int(chunksize2/omp_get_num_threads())+1 +! chunksize3=int(real(chunksize2)/real(omp_get_num_threads())/20.)+1 !more efficient + +! ompid=omp_get_num_threads() + ompid=0 + + cpttra=0 +! print*,'chunksi',chunksize2,myid + if (numpart.gt.0 ) then +! print*,'test rel2',npoint(5139),npoint(6002),npoint(100003) +! do jj=1,numpart +! do jj=numpart,1,-1 +! print*,jj + do jj=1,numpart + +! If integration step is due, do it +!********************************** + if (itra1(jj).eq.jtime) then + cpttra=cpttra+1 + if (ioutputforeachrelease.eq.1) then + kp=npoint(jj) + else + kp=1 + endif + +! Determine age class of the particle + itage=abs(itra1(jj)-itramem(jj)) + do nage=1,nageclass + if (itage.lt.lage(nage)) exit + enddo + + nbp=1 + if ((itramem(jj).eq.jtime).or.(jtime.eq.0)) & + call initialize(jtime,idt(jj),uap(jj),ucp(jj),uzp(jj), & + us(jj),vs(jj),ws(jj),xtra1(jj),ytra1(jj),ztra1(jj),cbt(jj), & +! call initialize(jtime,th_idt,th_uap,th_ucp,th_uzp, & +! th_us,th_vs,th_ws,th_xtra1,th_ytra1,th_ztra1,th_cbt, & + ngrid,depoindicator,indzindicator,cpt(nbp),ompid,myid,1,mts ) + +! print*,'after',th_xtra1,th_ytra1,th_ztra1 +! Memorize particle positions +!**************************** + + xold=xtra1(jj) + yold=ytra1(jj) + zold=ztra1(jj) +! xold=th_xtra1 +! yold=th_ytra1 +! zold=th_ztra1 +! Integrate Lagevin equation for lsynctime seconds +!************************************************* +! write(*,*)'numpart,jtime, particle #=',numpart,jtime,j + + call advance(jtime,npoint(jj),idt(jj),uap(jj),ucp(jj),uzp(jj),us(jj), & + vs(jj),ws(jj),nstop,xtra1(jj),ytra1(jj),ztra1(jj),prob,cbt(jj), & +! call advance(jtime,th_npoint,th_idt,th_uap,th_ucp,th_uzp, & +! th_us,th_vs,th_ws,nstop,th_xtra1,& +! th_ytra1,th_ztra1,prob,th_cbt, & + ngrid,depoindicator,indzindicator,cpt(nbp),ompid,myid,1,mts ) +! if (jj.eq.103) print*,'aft',th_xtra1,th_ytra1,th_ztra1 +! Calculate the gross fluxes across layer interfaces +!*************************************************** + + + if (iflux.eq.1) call calcfluxes(nage,jj,xold,yold,zold) + +! if (jj.lt.5) print*,'coord after',myid,th_itra1,th_xmass1(1),DRYDEPSPEC(ks) + +! 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(jtime,jj) + itra1(jj)=-999999999 +! th_itra1=-999999999 + else + itra1(jj)=jtime+lsynctime +! th_itra1=jtime+lsynctime + + +! if (jj.lt.5) print*,'coord after2',myid,th_itra1,th_xmass1(1),DRYDEPSPEC(ks) +! Dry deposition and radioactive decay for each species +!****************************************************** + 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(jj,ks)*prob(ks)*decfact +! drydeposit(ks)=th_xmass1(ks)*prob(ks)*decfact + xmass1(jj,ks)=xmass1(jj,ks)*(1.-prob(ks))*decfact +! th_xmass1(ks)=th_xmass1(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(jj,ks)=xmass1(jj,ks)*decfact +! th_xmass1(ks)=th_xmass1(ks)*decfact + endif +! if (jj.lt.5) print*,'coord after3',myid,th_itra1,th_xmass1(1),DRYDEPSPEC(ks),xmass(th_npoint,1) + + if (mdomainfill.eq.0) then + if (xmass(npoint(jj),ks).gt.0.) & + xmassfract=max(xmassfract,real(npart(npoint(jj)))* & +! xmassfract=max(xmassfract,real(npart(th_npoint))* & + xmass1(jj,ks)/xmass(npoint(jj),ks)) +! th_xmass1(ks)/xmass(th_npoint,ks)) + else + xmassfract=1. + endif + + end do + + if (xmassfract.lt.0.000001) then ! terminate all particles carrying less mass + itra1(jj)=-999999999 +! th_itra1=-999999999 + endif + + ! Sabine Eckhardt, June 2008 + ! don't create depofield for backward runs + if (DRYDEP.AND.(ldirect.eq.1)) then + call drydepokernel(nclass(jj),drydeposit,real(xtra1(jj)), & +! call drydepokernel(th_nclass,drydeposit,real(th_xtra1), & + real(ytra1(jj)),itage,nage,kp) +! real(th_ytra1),itage,nage,kp) + if (nested_output.eq.1) call drydepokernel_nest( & + nclass(jj),drydeposit,real(xtra1(jj)),real(ytra1(jj)), & +! th_nclass,drydeposit,real(th_xtra1),real(th_ytra1), & + itage,nage,kp) + endif + + ! Terminate trajectories that are older than maximum allowed age + !*************************************************************** + + if (abs(itra1(jj)-itramem(jj)).ge.lage(nageclass)) then +! if (abs(th_itra1-th_itramem).ge.lage(nageclass)) then + if (linit_cond.ge.1) & + call initial_cond_calc(jtime+lsynctime,jj) + itra1(jj)=-999999999 +! th_itra1=-999999999 + endif + endif +!! print*,xtra1(j),th_xtra1,OMP_GET_THREAD_NUM() + + endif + + end do !loop over particles + + endif + + + +! call itime(now) +! ttime=now(1)*3600+now(2)*60+now(3)-ttime + call cpu_time(finish) +! print*,'time',ttime,cpttra,myid,OMP_GET_THREAD_NUM() + if (option_verbose.eq.1) then + print*,'time',finish-start,cpttra,myid,ompid + endif + +! update the drydepo + if (DRYDEP.and.ldirect.gt.0) then + do ks=1,nspec + do kp=1,maxpointspec_act + do nage=1,nageclass + + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + do l=1,nclassunc + drygridunc(ix,jy,ks,kp,l,nage)=drygridunc(ix,jy,ks,kp,l,nage) & + +drygridunc2(ix,jy,ks,kp,l,nage) + end do + end do + end do + if (nested_output.eq.1) then + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + do l=1,nclassunc + drygriduncn(ix,jy,ks,kp,l,nage)=drygriduncn(ix,jy,ks,kp,l,nage) & + +drygriduncn2(ix,jy,ks,kp,l,nage) + end do + end do + end do + endif + end do + end do + end do + + endif + + end do !loop over time + + + ! Complete the calculation of initial conditions for particles not yet terminated + !***************************************************************************** + + do j=1,numpart + if (linit_cond.ge.1) call initial_cond_calc(jtime,j) + end do + + if (ipout.eq.2) call partoutput(jtime) ! dump particle positions + + if (linit_cond.ge.1) call initial_cond_output(jtime) ! 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 + deallocate(gridunc) + deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmass) + deallocate(ireleasestart,ireleaseend,npart,kindz) +! deallocate(xmasssave) + if (myid.eq.0) then + if (nested_output.eq.1) then + deallocate(orooutn, arean, volumen) + if (ldirect.gt.0) then + deallocate(griduncn,drygriduncn,wetgriduncn,drygriduncn2) + endif + endif + if (ldirect.gt.0) then + if (allocated(drygridunc)) deallocate(drygridunc) + if (allocated(wetgridunc)) deallocate(wetgridunc) + if (allocated(drygridunc2)) deallocate(drygridunc2) + if (allocated(drygriduncn2)) deallocate(drygriduncn2) + endif + deallocate(outheight,outheighthalf) + deallocate(oroout, area, volume) + endif +end subroutine timemanager + + + diff --git a/src_flexwrf_v3.1/tke_partition_hanna.f90 b/src_flexwrf_v3.1/tke_partition_hanna.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f47965d276cf29b899edfa67f88edd59ece7e3e2 --- /dev/null +++ b/src_flexwrf_v3.1/tke_partition_hanna.f90 @@ -0,0 +1,192 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine tke_partition_hanna(z, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,uprof,vprof,tkeprof,pttprof,indz,indzp) +! i +!******************************************************************************* +! * +! Computation of \sigma_u,v,w,dsigwdz, and dsigw2dz based on TKE from WRF * +! * +! 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 * +! * +!******************************************************************************* +! 12 JUNE 2007 compute sigu,sigv,sigw,dsigwdz, and dsigw2dz from TKE * +! fu2 fraction for u2 +! fv2 fraction for v2 +! fw2 fraction for w2 +! +! 25 JUNE 2007 merged from hanna_tke and tke_partition.f + +! include 'includepar' +! include 'includecom' +! include 'includehanna' +! include 'includeinterpol' + use par_mod + use com_mod +! use hanna_mod +! use interpol_mod + implicit none + real :: corr,z,zzz,hanna_sigu,hanna_sigv,hanna_sigw,dz,dz1,dz2 + real :: fu2(2),fv2(2),fw2(2) + real :: siguprof(2),sigvprof(2),sigwprof(2) + integer :: k,indz,indzp + real :: uprof(nzmax),vprof(nzmax),tkeprof(nzmax),pttprof(nzmax) + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + + do k=1,2 + fu2(k)=0.333 + fv2(k)=0.333 + fw2(k)=0.333 + siguprof(k)=0.0 + sigvprof(k)=0.0 + sigwprof(k)=0.0 + enddo + +! determine fraction + do k=1,2 ! k fraction +!********************** +! 1. Neutral conditions +!********************** + if (k .eq. 1) zzz=height(indz) + if (k .eq. 2) zzz=height(indzp) + if (h/abs(ol).lt.1.) then + ust=max(1.e-4,ust) + corr=height(indz+k-1)/ust + hanna_sigu=1.e-2+2.0*ust*exp(-3.e-4*corr) + hanna_sigw=1.e-2+1.3*ust*exp(-2.e-4*corr) + hanna_sigv=hanna_sigw + +!*********************** +! 2. Unstable conditions +!*********************** + + else if (ol.lt.0.) then + + +! Determine sigmas +!***************** + + hanna_sigu=1.e-2+ust*(12-0.5*h/ol)**0.33333 + hanna_sigv=hanna_sigu + hanna_sigw=sqrt(1.2*wst**2*(1.-.9*zeta)*height(indz+k-1)/h & + **0.66666+(1.8-1.4*height(k)/h)*ust**2)+1.e-2 + +!********************* +! 3. Stable conditions +!********************* + else + hanna_sigu=1.e-2+2.*ust*(1.-height(indz+k-1)/h) + hanna_sigv=1.e-2+1.3*ust*(1.-height(indz+k-1)/h) + hanna_sigw=hanna_sigv + endif + fu2(k)=hanna_sigu**2/(hanna_sigu**2+hanna_sigv**2+hanna_sigw**2) + fv2(k)=hanna_sigv**2/(hanna_sigu**2+hanna_sigv**2+hanna_sigw**2) + fw2(k)=hanna_sigw**2/(hanna_sigu**2+hanna_sigv**2+hanna_sigw**2) + enddo !k fraction + +!- compute sigu,v,w + do k=1,2 ! siguprof + siguprof(k)=max(sqrt(2.0*tkeprof(indz+k-1)*fu2(k)),1.e-2) + sigvprof(k)=max(sqrt(2.0*tkeprof(indz+k-1)*fv2(k)),1.e-2) + sigwprof(k)=max(sqrt(2.0*tkeprof(indz+k-1)*fw2(k)),1.e-2) +!C write(*,*)'z=',height(indz+k-1),'tke=', tkeprof(indz+k-1) + enddo ! siguprof +! write(*,*)'tkeprof=',(tkeprof(k),k=1,nz) +!- interpolate sigu,sigv, sigw + dz=1./(height(indzp)-height(indz)) + dz1=(z - height(indz))*dz + dz2=(height(indzp)-z)*dz + + sigu=dz1*siguprof(2)+dz2*siguprof(1) + sigv=dz1*sigvprof(2)+dz2*sigvprof(1) + sigw=dz1*sigwprof(2)+dz2*sigwprof(1) + + dsigwdz=max(1.e-10,(sigwprof(2)-sigwprof(1))*dz ) + dsigw2dz=max(1.e-10,(sigwprof(2)**2-sigwprof(1)**2)*dz ) + +!-- compute length scales based on hanna(1982) +!************************* +! 1. Neutral conditions +!********************** + + if (h/abs(ol).lt.1.) then + tlu=0.5*z/sigw/(1.+1.5e-3*corr) + tlv=tlu + tlw=tlu + +!*********************** +! 2. Unstable conditions +!*********************** + + else if (ol.lt.0.) then + +! 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 + 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 tke_partition_hanna diff --git a/src_flexwrf_v3.1/tke_partition_my.f90 b/src_flexwrf_v3.1/tke_partition_my.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5b759c64f4a9b2ee0b8b6a96f7f4145cbfc54f4d --- /dev/null +++ b/src_flexwrf_v3.1/tke_partition_my.f90 @@ -0,0 +1,239 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine tke_partition_my(z, & + ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw, & + sigw,dsigwdz,dsigw2dz,uprof,vprof,tkeprof,pttprof,indz,indzp) + +! i +!******************************************************************************* +! * +! Computation of \sigma_u,v,w,dsigwdz, and dsigw2dz based on TKE from WRF * +! * +! 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 * +! * +!******************************************************************************* +! 12 JUNE 2007 compute sigu,sigv,sigw,dsigwdz, and dsigw2dz from TKE * +! fu2 fraction for u2 +! fv2 fraction for v2 +! fw2 fraction for w2 +! +! 25 JUNE 2007 merged from hanna_tke and tke_partition.f +! 11 Sep 2007 implement different formulations for growing and decaying turbulences + +! include 'includepar' +! include 'includecom' +! include 'includehanna' +! include 'includeinterpol' + use par_mod + use com_mod +! use hanna_mod +! use interpol_mod + + implicit none + real :: z,zzz,zzz1,dz,dz1,dz2,tke_z,dpttdz + real :: fu2,fv2,fw2,ftotal,ygu,ygv,ygm,ygh,yl,ylmax,ysm,ysh + real :: siguprof(2),sigvprof(2),sigwprof(2) + real :: ya1 + real :: ya2 + real :: yb1 + real :: yb2 + real :: yc1 + real :: yse + real :: yap + real :: e1,e2,e3,e4,e5,rf,rfc,rf1,rf2,ch,cm + real :: er,smr,shr,dudz,dvdz,tke_mid + integer :: k,indz,indzp + real :: uprof(nzmax),vprof(nzmax),tkeprof(nzmax),pttprof(nzmax) + real :: ust,wst,ol,h,zeta,sigu,sigv,tlu,tlv,tlw + real :: sigw,dsigwdz,dsigw2dz + +! data ya1,ya2,yb1,yb2,yc1,yse,yap/ +! + 0.92,0.74,16.6,10.1,0.08,0.20,0.17/ + ya1=0.92 + ya2=0.74 + yb1=16.6 + yb2=10.1 + yc1=0.08 + yse=0.20 + yap=0.17 + +!- interpolate tke + dz=1./(height(indzp)-height(indz)) + dz1=(z - height(indz))*dz + dz2=(height(indzp)-z)*dz + + tke_z=max(0.01,dz1*tkeprof(indzp)+dz2*tkeprof(indz)) + +!- compute turbulent length scale +! yl -- turbulence length scale +! ylmax -- max yl + yl=0.01 + ylmax=0.01 + do k=1,nz-1 + zzz=0.5*(height(k)+height(k+1)) + zzz1=height(k+1)-height(k) + yl=yl+zzz*sqrt(0.5*(tkeprof(k)+tkeprof(k+1)))*zzz1 + ylmax=ylmax+zzz1*sqrt(0.5*(tkeprof(k)+tkeprof(k+1))) + enddo + ylmax=0.1*yl/ylmax + yl=0.4*(z+0.1)/(1.0+0.4*(z+0.1)/ylmax) + if (pttprof(indzp) .gt. pttprof(indz)) then + + dpttdz = (pttprof(indzp)-pttprof(indz))*dz + + yl=min(yl,0.75*sqrt(2.0*tke_z/(9.8/300.0)/dpttdz)) +! endif +!- compute nondimensional vertical gradients + dudz=(uprof(indzp)-uprof(indz))*dz + dvdz=(vprof(indzp)-vprof(indz))*dz + ygu=yl/sqrt(2.0*tke_z)*dudz + ygv=yl/sqrt(2.0*tke_z)*dvdz + ygm=ygu*ygu+ygv*ygv+0.001 ! in case of zero + ygh=-yl*yl/2.0/tke_z*dpttdz*9.8/300.0 + +!-- compute SM,SH +!- sm,sh nondimensional eddy diffusivities + + ysm=1.0-3.0*ya2*(7.0*ya1+yb2)*ygh+ & + 27.0*ya1*ya2*ya2*(4*ya1+yb2)*ygh*ygh+ & + 6.0*ya1*ya1*(1.0-3.0*ya2*(yb2-3.0*ya2)*ygh)*ygm + ysm=ya1*(1-3*yc1-3*ya2*(yb2*(1-3*yc1)-12*ya1*yc1-3*ya2) & + *ygh)/ysm + + ysh=ya2*(1-6*ya1*ysm*ygm)/(1-3*ya2*ygh*(4*ya1+yb2)) + + +! -- compute the equlibrium TKE, er + e1=yb1-6.0*ya1 + e2=12*ya1+yb1+3.0*yb2 + e3=yb1*(1.0-3.0*yc1)-6.0*ya1 + e4=yb1*(1.0-3.0*yc1)+12*ya1+9.0*ya2 + e5=yb1+3.0*ya1+3.0*yb2 + ch=ya2*e2/yb1 + cm=ya1*e4/ya2/e5 + rf1=e3/e4 + rf2=e1/e5 + rfc=e1/e2 + rf=-(ysh/ysm)*( ygh/ygm ) +! write(*,*)'ysh,ysm',ysh,ysm +! write(*,*)'ygh,ygm,dpttdz, ptt',ygh,ygm,dpttdz,pttprof(indzp) +! if (rf .le. 0) write(*,*)'aaaaaaaaaaaaaaa' + shr = 0.0 + if (rf .ge. rfc) then + shr=ch*1.0e-4 ! Ri > critical value, then = + elseif ((1.0-rf) .ne. 0.0) then + shr=ch*(rfc-rf)/(1.0-rf) + endif + + smr = 0.0 + if (rf .ge. rf1) then + smr=cm*shr*1.0e-4 + elseif((rf2-rf) .ne. 0.0 .and. rf .lt. rf2) then + smr=cm*(rf1-rf)/(rf2-rf)*shr + endif + + er=0.5*yb1*yl*yl*(smr*dudz*dudz*dvdz*dvdz- & + shr*dpttdz*9.8/300.0) + er=max(er,0.01) + if (tke_z .ge. er ) then ! decaying turbuelnce + tke_mid=tke_z + else + tke_mid=er + ysm=sqrt(tke_z/er)*smr + ysh=sqrt(tke_z/er)*shr + endif + +!- fractions of u2,v2,w2 +! print*,'in tke',tke_mid,ya1,ysm,ygm,ysh,ygh,ygu + fu2=0.333-2*ya1*(ysm*ygm+ysh*ygh)+6*ya1*ysm*ygu*ygu + fv2=0.333-2*ya1*(ysm*ygm+ysh*ygh)+6*ya1*ysm*ygv*ygv + fw2=0.333-2*ya1*(ysm*ygm+ysh*ygh)+6*ya1*ysh*ygh +! fw2=0.333-2*ya1*(ysm*ygm+ysh*ygh)+6*ya1*ysm*ygh*ygh +! fw2=fw2*0.5 + if(fu2*fv2*fw2 .le. 0.0) then + fu2=0.333 + fv2=0.333 + fw2=0.333 + endif + + else ! test on pttprof + + fu2=0.333 + fv2=0.333 + fw2=0.333 + tke_mid=tke_z + endif + !ftotal=(fu2+fv2+fw2) + !fu2=fu2/ftotal + !fv2=fv2/ftotal + !fw2=fw2/ftotal + +! JB: make the partitionning equal +! fu2=0.333 +! fv2=0.333 +! fw2=0.333 +! + sigu=sqrt(2.0*tke_mid*fu2) + sigv=sqrt(2.0*tke_mid*fv2) + sigw=sqrt(2.0*tke_mid*fw2) + + tlu=2.0*yl/sigu + tlv=2.0*yl/sigv + tlw=2.0*yl/sigw + + tlu=max(10.,tlu) + tlv=max(10.,tlv) + tlw=max(30.,tlw) + +!- dsigw/dz,dsigw2/dz ; assuming fraction is not changed + + dsigwdz=(sqrt(2.0*tkeprof(indzp)*fw2)- & + sqrt(2.0*tkeprof(indz)*fw2))*dz + dsigwdz=max(1.0e-10,dsigwdz) + + dsigw2dz=(2.0*tkeprof(indzp)*fw2-2.0*tkeprof(indz)*fw2)*dz + dsigw2dz=max(1.0e-10,dsigw2dz) + +! write(*,*)'tke=',tke_z, 'er=',er +! write(*,*)'rfc,rf1,rf2,rf=',rfc,rf1,rf2,rf +! write(*,*)'smr=',smr,'ysm=',ysm +! write(*,*)'shr=',shr,'ysh=',ysh +! write(*,*)'fu2,fv2,fw2=',fu2,fv2,fw2 +! write(*,*)'ftotal=',ftotal +! if (fu2*fv2*fw2 .le. 0) stop +end subroutine tke_partition_my diff --git a/src_flexwrf_v3.1/unc_mod.f90 b/src_flexwrf_v3.1/unc_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6b685ff95ed271e572fd6a668b8f605b460130ff --- /dev/null +++ b/src_flexwrf_v3.1/unc_mod.f90 @@ -0,0 +1,37 @@ +!********************************************************************** +! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010 * +! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa, * +! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann * +! * +! This file is part of FLEXPART. * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +module unc_mod + + implicit none + + real,allocatable, dimension (:,:,:,:,:,:,:) :: gridunc + real,allocatable, dimension (:,:,:,:,:,:,:) :: griduncn + real,allocatable, dimension (:,:,:,:,:,:) :: drygridunc + real,allocatable, dimension (:,:,:,:,:,:) :: drygriduncn + real,allocatable, dimension (:,:,:,:,:,:) :: drygridunc2 + real,allocatable, dimension (:,:,:,:,:,:) :: drygriduncn2 + real,allocatable, dimension (:,:,:,:,:,:) :: wetgridunc + real,allocatable, dimension (:,:,:,:,:,:) :: wetgriduncn + + real,allocatable, dimension (:,:,:,:,:) :: init_cond + +end module unc_mod diff --git a/src_flexwrf_v3.1/verttransform.f90 b/src_flexwrf_v3.1/verttransform.f90 new file mode 100644 index 0000000000000000000000000000000000000000..672ca9dc0630221342e9331811ee48f92650bf69 --- /dev/null +++ b/src_flexwrf_v3.1/verttransform.f90 @@ -0,0 +1,874 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + + subroutine verttransform(n,uuh,vvh,wwh,pvh,divh) +! 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. * +! * +! Note: This is the FLEXPART_WRF version of subroutine assignland. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 * +! * +! Oct-Nov 2005 - R. Easter - conversion to wrf * +! 17 Nov 2005 - R. Easter - terrain correction applied to ww. There are * +! now 3 options, controlled by "method_w_terrain_correction" * +! * +! 11 June 2007, conversion of tkeh to tke +! 25 June 2007 conversion of ptth to ptt +! Jan 2012, J Brioude: modified to handle different wind options and openmp +!******************************************************************************* +! * +! 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] * +! * +!******************************************************************************* + + use par_mod + use com_mod +! include 'includepar' +! include 'includecom' + + implicit none + + integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym +! CDA + integer :: icloudtop + + integer :: method_z_compute,aa + 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(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) + real(kind=4) :: divh(0:nxmax-1,0:nymax-1,nuvzmax) + +! real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax) +! real :: divh(0:nxmax-1,0:nymax-1,nuvzmax) + real :: div(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 :: wwh_svaa(nwzmax), wtc_stat(4,nzmax),u,v + real,parameter :: const=r_air/ga +! CDA cloud commented +! integer :: rain_cloud_above,kz_inv + + integer :: kz_inv + real :: f_qvsat,pressure +! CDA some new declarations and mods +! real :: rh,lsp,convp + real :: rh,lsp,convp,prec,rhmin + real,parameter :: precmin = 0.002 + + + + logical :: init = .true. +! CDA + logical :: lconvectprec = .true. + + + +! set method_w_terrain_correction & method_z_compute + method_w_terrain_correction = 20 + method_z_compute = 10 + aa=0 + do iz = 1, nz + do ix = 1, 4 + wtc_stat(ix,iz) = 0.0 + end do + end do + + +!************************************************************************* +! 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 +! +! FLEXPART_WRF - use grid point with highest surface pressure +!************************************************************************************** + + pint = -1.0 + ixm = -999888777 + jym = -999888777 + do jy=0,nymin1 + do ix=0,nxmin1 +! if (ps(ix,jy,1,n).gt.100000.) then + if (ps(ix,jy,1,n).gt.pint) then + pint = ps(ix,jy,1,n) + ixm=ix + jym=jy +! goto 3 + endif + enddo + enddo +3 continue +! write(*,'(/a,2i4,1pe11.2)') +! & 'verttransform -- ixm,jym,ps() =', ixm, jym, pint + + + 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 +! use pressure from wrf met file +! pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n) + pint=pph(ixm,jym,kz,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 + +! +! *** NOTE -- the doubled vertical resolution has not been tested in FLEXPART_WRF +! +! 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 + +! FLEXPART_WRF - get height from zzh + if (method_z_compute .eq. 10) then + if ((add_sfc_level .eq. 1) .and. (kz .eq. 2)) then + height(kz) = 0.5*(zzh(ixm,jym, 3,n)+zzh(ixm,jym, 1,n)) & + - zzh(ixm,jym,1,n) + else + height(kz) = 0.5*(zzh(ixm,jym,kz+1,n)+zzh(ixm,jym,kz,n)) & + - zzh(ixm,jym,1,n) + end if + end if + + tvold=tv + pold=pint + enddo + do kz=1,nz-1 + heightmid(kz)=0.5*(height(kz)+height(kz+1)) + enddo +! +! *** NOTE -- the doubled vertical resolution has not been tested in FLEXPART_WRF +! +! 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 +!************************* + +!!!$OMP PARALLEL DEFAULT(SHARED) & +!!!$OMP PRIVATE(ix,jy,ixm,jym,tvold,pold,pint,tv,rhoh,uvzlev,wzlev, & +!!!$OMP uvwzlev,pinmconv,kz,iz,kmin,dz1,dz2,dz,ix1,jy1,ixp,jyp, & +!!!$OMP dzdy,dzdx,aa,u,v,wwh_svaa ) +!!!$OMP DO + 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 +! use pressure from wrf met file +! pint=akz(kz)+bkz(kz)*ps(ix,jy,1,n) + pint=pph(ix,jy,kz,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) + +! FLEXPART_WRF - get uvzlev & wzlev from zzh + if (method_z_compute .eq. 10) then + do kz = 2, nuvz + if ((add_sfc_level .eq. 1) .and. (kz .eq. 2)) then + uvzlev(kz) = 0.5*(zzh(ix,jy, 3,n) + zzh(ix,jy, 1,n)) & + - zzh(ix,jy,1,n) + else + uvzlev(kz) = 0.5*(zzh(ix,jy,kz+1,n) + zzh(ix,jy,kz,n)) & + - zzh(ix,jy,1,n) + end if + end do + do kz = 2, nwz + wzlev(kz) = zzh(ix,jy,kz+add_sfc_level,n) & + - zzh(ix,jy,1,n) + end do + end if + + uvwzlev(ix,jy,1)=0.0 + do kz=2,nuvz + uvwzlev(ix,jy,kz)=uvzlev(kz) + end do + +! if ((ix .eq. ixm) .and. (jy .eq. jym)) then +! write(*,'(/a)') +! & 'kz, height, uvzlev, wzlev, zzh-zzh(1) at ixm,jym (in km)' +! write(*,'(i3,4f8.3)') (kz, height(kz)*1.0e-3, +! & uvzlev(kz)*1.0e-3, wzlev(kz)*1.0e-3, +! & (zzh(ix,jy,kz,n)-zzh(ix,jy,1,n))*1.0e-3, kz=nz,1,-1) +! ixm = -9 +! end if + +! 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) +! +! in flexpart_ecmwf, pinmconv is used to convert etadot to w +! in FLEXPART_WRF, vertical velocity is already m/s, so pinmconv=1.0 + + if (wind_option.le.0) then + pinmconv(1)=1.0 + do kz=2,nz-1 + pinmconv(kz)=1.0 + enddo + pinmconv(nz)=1.0 + elseif (wind_option.ge.1) then + +! pinmconv(1)=(uvzlev(1+add_sfc_level)-0.) & +! /(eta_u_wrf(1)-1.) + pinmconv(1)=(wzlev(2)-0.) & + /(eta_w_wrf(2)-1.) + do kz=2,nz-1 + +! pinmconv(kz)=(uvzlev(kz+add_sfc_level)-uvzlev(kz-1+add_sfc_level)) & +! /(eta_u_wrf(kz)-eta_u_wrf(kz-1)) +! /(pph(ix,jy,kz+add_sfc_level,n)-pph(ix,jy,kz-1+add_sfc_level,n)) & +! *(pph(ix,jy,1,n)-pph(ix,jy,nz,n)) +! *(ps(ix,jy,1,n)-p_top_wrf) + + pinmconv(kz)=(wzlev(kz+1)-wzlev(kz-1)) & + /(eta_w_wrf(kz+1)-eta_w_wrf(kz-1)) + enddo + + pinmconv(nwz)=pinmconv(nwz-1) ! + endif +! 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) + div(ix,jy,1)=divh(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) + tke(ix,jy,1,n)=tkeh(ix,jy,1,n) + tke(ix,jy,nz,n)=tkeh(ix,jy,nuvz,n) + ptt(ix,jy,1,n)=ptth(ix,jy,1,n) + ptt(ix,jy,nz,n)=ptth(ix,jy,nuvz,n) + + + kmin=2 + do iz=2,nz-1 + do kz=kmin,nuvz + if(heightmid(iz).gt.uvzlev(nuvz)) then + div(ix,jy,iz)=div(ix,jy,nz) + goto 230 + endif + if ((heightmid(iz).gt.uvzlev(kz-1)).and. & + (heightmid(iz).le.uvzlev(kz))) then + dz1=heightmid(iz)-uvzlev(kz-1) + dz2=uvzlev(kz)-heightmid(iz) + dz=dz1+dz2 + div(ix,jy,iz)=(divh(ix,jy,kz-1)*dz2+divh(ix,jy,kz)*dz1)/dz + kmin=kz + goto 230 + endif + end do +230 continue + end do + + 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) + tke(ix,jy,iz,n)=tke(ix,jy,nz,n) + ptt(ix,jy,iz,n)=ptt(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 + tke(ix,jy,iz,n)=(tkeh(ix,jy,kz-1,n)*dz2 & + +tkeh(ix,jy,kz,n)*dz1)/dz + ptt(ix,jy,iz,n)=(ptth(ix,jy,kz-1,n)*dz2 & + +ptth(ix,jy,kz,n)*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)*dz2*pinmconv(kz-1) +!! + +wwh(ix,jy,kz)*dz1*pinmconv(kz))/dz +! kmin=kz +! goto 40 +! endif +! end do +!40 continue +! end do + + if (method_w_terrain_correction .eq. 20) then +! apply w correction assuming that the WRF w is "absolute w"; +! apply it here to wwh; set wwh=0 at iz=1 +! do iz = 1, nz +! wtc_stat(1,iz) = wtc_stat(1,iz) + ww(ix,jy,iz,n) +! wtc_stat(2,iz) = wtc_stat(2,iz) + abs(ww(ix,jy,iz,n)) +! end do + +! if ((ix.eq.0) .and. (jy.eq.0)) write(*,*) +! & 'verttransform doing method_w_terrain_correction =', +! & method_w_terrain_correction + ix1 = max( ix-1, 0 ) + jy1 = max( jy-1, 0 ) + ixp = min( ix+1, nx-1 ) + jyp = min( jy+1, ny-1 ) + if (wind_option.eq.0) then + dzdx=(oro(ixp,jy) - oro(ix1,jy))/(dx*(ixp-ix1)*m_x(ix,jy,1)) + dzdy=(oro(ix,jyp) - oro(ix,jy1))/(dy*(jyp-jy1)*m_y(ix,jy,1)) + do kz = 1, nwz-1 + wwh_svaa(kz) = wwh(ix,jy,kz) + wwh(ix,jy,kz) = wwh(ix,jy,kz)*pinmconv(kz) & +! wwh(ix,jy,kz) = + - (uuh(ix,jy,kz)*dzdx + vvh(ix,jy,kz)*dzdy) !this is correct. term of variation of geopot not necessary + + if (kz .eq. 1) wwh(ix,jy,kz) = 0.0 + aa=aa+1 + end do + elseif (wind_option.ge.1) then + do kz = 2, nwz-1 + wwh_svaa(kz) = wwh(ix,jy,kz) +! dzdx=(zzh(ixp,jy,kz,n) - zzh(ix1,jy,kz,n)) +! + /(dx*(ixp-ix1)) +! dzdy=(zzh(ix,jyp,kz,n) - zzh(ix,jy1,kz,n)) +! + /(dy*(jyp-jy1)) +! dzdx=(zzh(ixp,jy,kz,n) - zzh(ix1,jy,kz,n)-zzh(ixp,jy,1,n) & +! +zzh(ix1,jy,1,n)) & +! /(dx*(ixp-ix1)*m_x(ix,jy,1)) +! dzdy=(zzh(ix,jyp,kz,n) - zzh(ix,jy1,kz,n)-zzh(ix,jyp,1,n) & +! +zzh(ix,jy1,1,n)) & +! /(dy*(jyp-jy1)*m_y(ix,jy,1)) + + dzdx=(zzh(ixp,jy,kz+add_sfc_level,n) - zzh(ix1,jy,kz+add_sfc_level,n) & + -zzh(ixp,jy,1,n)+zzh(ix1,jy,1,n))/(dx*(ixp-ix1)*m_x(ix,jy,1)) + dzdy=(zzh(ix,jyp,kz+add_sfc_level,n) - zzh(ix,jy1,kz+add_sfc_level,n) & + -zzh(ix,jyp,1,n)+zzh(ix,jy1,1,n))/(dy*(jyp-jy1)*m_y(ix,jy,1)) + u=0.5*(uuh(ix,jy,kz+add_sfc_level)+uuh(ix,jy,kz-1+add_sfc_level)) + v=0.5*(vvh(ix,jy,kz+add_sfc_level)+vvh(ix,jy,kz-1+add_sfc_level)) + wwh(ix,jy,kz) = wwh(ix,jy,kz)*pinmconv(kz) & + + (u*dzdx + v*dzdy) ! variation of geopot on sigma is necessary + +! wwh(ix,jy,kz) = wwh(ix,jy,kz)*pinmconv(kz) & +! + (uuh(ix,jy,kz)*dzdx + vvh(ix,jy,kz)*dzdy) ! variation of geopot on sigma is necessary +! if (kz .eq. 1) wwh(ix,jy,kz) = 0.0 + if (kz .eq. 1) wwh(ix,jy,kz) = wwh(ix,jy,kz)*pinmconv(kz) +! aa=aa+1 + end do + endif + if (wind_option.eq.-1) then +! ww(ix,jy,1,n)=wwh(ix,jy,1) + ww(ix,jy,1,n)=0. + do iz=2,nz + ww(ix,jy,iz,n)=ww(ix,jy,iz-1,n)-(height(iz)-height(iz-1))* & + div(ix,jy,iz-1) + enddo + else + + ww(ix,jy,1,n)=wwh(ix,jy,1) + ww(ix,jy,nz,n)=wwh(ix,jy,nwz) + 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)*dz2 & + +wwh(ix,jy,kz)*dz1) & + /dz + kmin=kz + goto 4000 + endif + end do +4000 continue + end do + endif + +! do kz = 1, nwz +! wwh(ix,jy,kz) = wwh_svaa(kz) +! end do + +! do iz = 1, nz +! wtc_stat(3,iz) = wtc_stat(3,iz) + ww(ix,jy,iz,n) +! wtc_stat(4,iz) = wtc_stat(4,iz) + abs(ww(ix,jy,iz,n)) +! end do + end if + +! 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 +!!!$OMP END DO +!!!$OMP END PARALLEL + +!**************************************************************** +! Compute slope of eta levels in windward direction and resulting +! vertical wind correction +! +! The ECMWF model uses a hybrid-pressure vertical coordinate, "eta" +! The "eta" coordinate transitions from terrain-following near +! the surface to constant pressure in the stratosphere. +! The vertical velocities in the ECMWF grib files are "eta_dot" +! FLEXPART uses a "height above ground" vertical coordinate +! which we will call "hag". +! The vertical velocity is uses (in ww array) is "hag_dot". +! Converting from eta_dot to hag_dot involves +! >> multiplying by pinmconv = [d(hag)/d(eta)] +! >> adding a term that accounts for the fact that +! "eta" varies on constant "hag" surfaces. +! This term is [u*d(hag)/dx + v*d(hag)/dy], with the +! partial derivatives taken with "eta" being constant +! +! The WRF model uses a similar (to ECMWF) vertical coordinate. +! HOWEVER, the vertical velocities in the WRF output files +! are the "true/absolute w" in m/s. (Is this true?) +! Converting from "absolute w" to hag_dot involves +! adding a term that accounts for the fact that +! "absolute z" varies on constant "hag" surfaces. +! This term is [- u*d(oro)/dx - v*d(oro)/dy] +! +! The FLEXPART code did not apply the terrain corrections +! at jy=0 & ny-1; ix=0 & nx-1; iz=1 & nz. +! FLEXPART_WRF applies the correction at all grid points +!**************************************************************** + + +! If north pole is in the domain, calculate wind velocities in polar +! stereographic coordinates +!******************************************************************* + + if (nglobal) then + write(*,*) + write(*,*) '*** stopping in verttransform ***' + write(*,*) ' the nglobal code section should not be active' + write(*,*) + stop +! do 74 jy=int(switchnorthg)-2,nymin1 +! ylat=ylat0+real(jy)*dy +! do 74 ix=0,nxmin1 +! xlon=xlon0+real(ix)*dx +! do 74 iz=1,nz +!74 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)) +! +! +! do 76 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 +! else +! ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ +! & vv(nx/2-1,nymin1,iz,n))-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 76 ix=0,nxmin1 +! uupol(ix,jy,iz,n)=uupolaux +! vvpol(ix,jy,iz,n)=vvpolaux +!76 continue +! +! +!* Fix: Set W at pole to the zonally averaged W of the next equator- +!* ward parallel of latitude +! +! do 85 iz=1,nz +! wdummy=0. +! jy=ny-2 +! do 80 ix=0,nxmin1 +!80 wdummy=wdummy+ww(ix,jy,iz,n) +! wdummy=wdummy/real(nx) +! jy=nymin1 +! do 85 ix=0,nxmin1 +!85 ww(ix,jy,iz,n)=wdummy + + endif + + +! If south pole is in the domain, calculate wind velocities in polar +! stereographic coordinates +!******************************************************************* + + if (sglobal) then + write(*,*) + write(*,*) '*** stopping in verttransform ***' + write(*,*) ' the sglobal code section should not be active' + write(*,*) + stop +! do 77 jy=0,int(switchsouthg)+3 +! ylat=ylat0+real(jy)*dy +! do 77 ix=0,nxmin1 +! xlon=xlon0+real(ix)*dx +! do 77 iz=1,nz +!77 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)) +! +! do 79 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 +! else +! ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ +! & vv(nx/2-1,0,iz,n))+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 79 ix=0,nxmin1 +! uupol(ix,jy,iz,n)=uupolaux +!79 vvpol(ix,jy,iz,n)=vvpolaux +! +! +!* Fix: Set W at pole to the zonally averaged W of the next equator- +!* ward parallel of latitude +! +! do 95 iz=1,nz +! wdummy=0. +! jy=1 +! do 90 ix=0,nxmin1 +!90 wdummy=wdummy+ww(ix,jy,iz,n) +! wdummy=wdummy/real(nx) +! jy=0 +! do 95 ix=0,nxmin1 +!95 ww(ix,jy,iz,n)=wdummy + endif + + !write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz^M + ! create a cloud and rainout/washout field, clouds occur where rh>80%^M + ! total cloudheight is stored at level 0^M + do 100 jy=0,nymin1 + do 100 ix=0,nxmin1 +! rain_cloud_above=0 + lsp=lsprec(ix,jy,1,n) + convp=convprec(ix,jy,1,n) +! cloudsh(ix,jy,n)=0 + + prec=lsp+convp + if (lsp.gt.convp) then ! prectype='lsp' + lconvectprec = .false. + else ! prectype='cp ' + lconvectprec = .true. + endif + rhmin = 0.90 ! standard condition for presence of clouds + +!CPS note that original by Sabine Eckhart was 80% +!CPS however, for T<-20 C we consider saturation over ice +!CPS so I think 90% should be enough + + + icloudbot(ix,jy,n)=icmv + icloudtop=icmv ! this is just a local variable +98 do kz=1,nz + 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)) +!cps if (prec.gt.0.01) print*,'relhum',prec,kz,rh,height(kz) + if (rh .gt. rhmin) then + if (icloudbot(ix,jy,n) .eq. icmv) then + icloudbot(ix,jy,n)=nint(height(kz)) + endif + icloudtop=nint(height(kz)) ! use int to save memory + endif + enddo + + +!CPS try to get a cloud thicker than 50 m +!CPS if there is at least .01 mm/h - changed to 0.002 and put into +!CPS parameter precpmin + if ((icloudbot(ix,jy,n) .eq. icmv .or. & + icloudtop-icloudbot(ix,jy,n) .lt. 50) .and. & + prec .gt. precmin) then + rhmin = rhmin - 0.05 + if (rhmin .ge. 0.30) goto 98 ! give up for <= 25% rel.hum. + endif +!CPS implement a rough fix for badly represented convection +!CPS is based on looking at a limited set of comparison data + if (lconvectprec .and. icloudtop .lt. 6000 .and. & + prec .gt. precmin) then + if (convp .lt. 0.1) then + icloudbot(ix,jy,n) = 500 + icloudtop = 8000 + else + icloudbot(ix,jy,n) = 0 + icloudtop = 10000 + endif + endif + if (icloudtop .ne. icmv) then + icloudthck(ix,jy,n) = icloudtop-icloudbot(ix,jy,n) + else + icloudthck(ix,jy,n) = icmv + endif +!CPS get rid of too thin clouds + if (icloudthck(ix,jy,n) .lt. 50) then + icloudbot(ix,jy,n)=icmv + icloudthck(ix,jy,n)=icmv + endif + +100 continue + + + + + + +! 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 diff --git a/src_flexwrf_v3.1/verttransform_nests.f90 b/src_flexwrf_v3.1/verttransform_nests.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6e3d82c1183c7edd731e4c69acad1f264d412901 --- /dev/null +++ b/src_flexwrf_v3.1/verttransform_nests.f90 @@ -0,0 +1,511 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** + subroutine verttransform_nests(n,uuhn,vvhn,wwhn,pvhn,divhn) +! i i i i i +!******************************************************************************* +! * +! Note: This is the FLEXPART_WRF version of subroutine verttransform_nests. * +! The computational grid is the WRF x-y grid rather than lat-lon. * +! * +! 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 * +! * +! 16 Nov 2005, R. Easter - changes for FLEXPART_WRF * +! 17 Nov 2005 - R. Easter - terrain correction applied to ww. There are * +! now 3 options, controlled by "method_w_terrain_correction" * +! * +! 11 June 2007 -- convert TKEhn to tken +! 25 June 2007 -- convert ptthn to pttn +! Jan 2012, J Brioude: modified to handle different wind options and openmp +!******************************************************************************* +! * +! 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 + +! include 'includepar' +! include 'includecom' + implicit none + integer :: ix,jy,kz,iz,n,l,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym + integer :: icloudtop + real :: rh,lsp,convp,prec,rhmin + integer :: method_z_compute,aa,dimx,dimy + real :: uvzlev(nuvzmax),wzlev(nwzmax),rhoh(nuvzmax),pinmconv(nzmax) + real :: uvwzlev(0:nxmaxn-1,0:nymaxn-1,nzmax) + real :: ew,pint,tv,tvold,pold,const,dz1,dz2,dz,ui,vi + real :: dzdx,dzdy + real :: dzdx1,dzdx2,dzdy1,dzdy2 + real :: pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real :: divn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real(kind=4) :: wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) + real(kind=4) :: divhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) + real :: wwhn_svaa(nwzmax),u,v + parameter(const=r_air/ga) +! integer :: rain_cloud_above,kz_inv + + real :: f_qvsat,pressure +! real :: rh,lsp,convp + real,parameter :: precmin = 0.002 + +! CDA + logical :: lconvectprec = .true. + + +! set method_z_compute + method_z_compute = 10 + + +! Loop over all nests +!******************** + + do l=1,numbnests + dimy=nyn(l)-1 + dimx=nxn(l)-1 +! print*,'start omp ' +! Loop over the whole grid +!************************* +!!!$OMP PARALLEL DEFAULT(SHARED) & +!!!$OMP PRIVATE(ix,jy,ixm,jym,tvold,pold,pint,tv,rhoh,uvzlev,wzlev, & +!!!$OMP uvwzlev,pinmconv,kz,iz,kmin,dz1,dz2,dz,ix1,jy1,ixp,jyp, & +!!!$OMP dzdy,dzdx,aa,u,v ) +!$OMP DO + do jy=0,dimy + do ix=0,dimx + + 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 +! FLEXPART_WRF - pphn hold pressure +! pint=akz(kz)+bkz(kz)*psn(ix,jy,1,n,l) + pint=pphn(ix,jy,kz,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 + + +! print*,'etap 1',ix,jy + + 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) + +! FLEXPART_WRF - get uvzlev & wzlev from zzh + if (method_z_compute .eq. 10) then + do kz = 2, nuvz + if ((add_sfc_level .eq. 1) .and. (kz .eq. 2)) then + uvzlev(kz) = 0.5*(zzhn(ix,jy,3,n,l) + & + zzhn(ix,jy,1,n,l)) & + - zzhn(ix,jy,1,n,l) + else + uvzlev(kz) = 0.5*(zzhn(ix,jy,kz+1,n,l) + & + zzhn(ix,jy,kz ,n,l)) & + - zzhn(ix,jy,1,n,l) + end if + end do + do kz = 2, nwz + wzlev(kz) = zzhn(ix,jy,kz+add_sfc_level,n,l) & + - zzhn(ix,jy,1,n,l) + end do + end if + +! print*,'etap 2',ix,jy +! 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 +! +! *** NOTE -- the doubled vertical resolution has not been tested in FLEXPART_WRF +!******************************************************************************* + uvwzlev(ix,jy,1)=0.0 + do kz=2,nuvz + uvwzlev(ix,jy,kz)=uvzlev(kz) + enddo +! Switch on following lines to use doubled vertical resolution +! Switch off the three lines above. +! +! *** NOTE -- the doubled vertical resolution has not been tested in FLEXPART_WRF +!************************************************************* +!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) +! +! in flexpart_ecmwf, pinmconv is used to convert etadot to w +! in FLEXPART_WRF, vertical velocity is already m/s, so pinmconv=1.0 +! +! 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))) + if (wind_option.eq.0) then + pinmconv(1)=1.0 + do kz=2,nz-1 + pinmconv(kz)=1.0 + enddo + pinmconv(nz)=1.0 + elseif (wind_option.eq.1) then +! pinmconv(1)=(uvzlev(2)-uvzlev(1)) & +! /(eta_u_wrf(1)-1.) + pinmconv(1)=(wzlev(2)-0.) & + /(eta_w_wrf(2)-1.) + do kz=2,nz-1 +! pinmconv(kz)=(uvzlev(kz)-uvzlev(kz-1)) & +! /(eta_u_wrf(kz)-eta_u_wrf(kz-1)) + pinmconv(kz)=(wzlev(kz+1)-wzlev(kz-1)) & + /(eta_w_wrf(kz+1)-eta_w_wrf(kz-1)) + enddo + pinmconv(nwz)=pinmconv(nwz-1) + endif + + +! print*,'etap 3',ix,jy + +! 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) + divn(ix,jy,1,l)=divhn(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) + tken(ix,jy,1,n,l)=tkehn(ix,jy,1,n,l) + tken(ix,jy,nz,n,l)=tkehn(ix,jy,nuvz,n,l) + pttn(ix,jy,1,n,l)=ptthn(ix,jy,1,n,l) + pttn(ix,jy,nz,n,l)=ptthn(ix,jy,nuvz,n,l) + + +! print*,'etap 3.5',ix,jy + kmin=2 + do iz=2,nz-1 + do kz=kmin,nuvz + if(heightmid(iz).gt.uvzlev(nuvz)) then + divn(ix,jy,iz,l)=divn(ix,jy,nz,l) + goto 230 + endif +!! print*,'etap 3.7',kz,iz,heightmid(iz),uvzlev(kz-1),uvzlev(kz) + if ((heightmid(iz).gt.uvzlev(kz-1)).and. & + (heightmid(iz).le.uvzlev(kz))) then + dz1=heightmid(iz)-uvzlev(kz-1) + dz2=uvzlev(kz)-heightmid(iz) + dz=dz1+dz2 + divn(ix,jy,iz,l)=(divhn(ix,jy,kz-1,l)*dz2+divhn(ix,jy,kz,l)*dz1)/dz + kmin=kz + goto 230 + endif + end do +230 continue + end do + +! print*,'etap 4',ix,jy + + 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) + tken(ix,jy,iz,n,l)=tken(ix,jy,nz,n,l) + pttn(ix,jy,iz,n,l)=pttn(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 + tken(ix,jy,iz,n,l)=(tkehn(ix,jy,kz-1,n,l)*dz2+ & + tkehn(ix,jy,kz,n,l)*dz1)/dz + pttn(ix,jy,iz,n,l)=(ptthn(ix,jy,kz-1,n,l)*dz2+ & + ptthn(ix,jy,kz,n,l)*dz1)/dz + + + kmin=kz + goto 30 + endif + end do +30 continue + end do + +! print*,'continue to ww in nests' +! Levels, where w is given +!************************* + + if (method_w_terrain_correction .eq. 20) then +! apply w correction assuming that the WRF w is "absolute w"; +! apply it here to wwh; set wwh=0 at iz=1 + ix1 = max( ix-1, 0 ) + jy1 = max( jy-1, 0 ) + ixp = min( ix+1, nxn(l)-1 ) + jyp = min( jy+1, nyn(l)-1 ) + if (wind_option.eq.0) then + dzdx=(oron(ixp,jy,l)-oron(ix1,jy,l))/(dxn(l)*(ixp-ix1)*m_xn(ix,jy,1,l)) + dzdy=(oron(ix,jyp,l)-oron(ix,jy1,l))/(dyn(l)*(jyp-jy1)*m_yn(ix,jy,1,l)) + + do kz = 1, nwz-1 +! wwhn_svaa(kz) = wwhn(ix,jy,kz,l) + wwhn(ix,jy,kz,l) = wwhn(ix,jy,kz,l) & + - (uuhn(ix,jy,kz,l)*dzdx + vvhn(ix,jy,kz,l)*dzdy) +! if (kz .eq. 1) wwhn(ix,jy,kz,l) = 0.0 + end do + elseif (wind_option.ge.1) then + do kz = 2, nwz-1 +! wwhn_svaa(kz) = wwhn(ix,jy,kz,l) + dzdx=(zzhn(ixp,jy,kz+add_sfc_level,n,l) - zzhn(ix1,jy,kz+add_sfc_level,n,l) & + -zzhn(ixp,jy,1,n,l) & + +zzhn(ix1,jy,1,n,l)) & + /(dxn(l)*(ixp-ix1)*m_xn(ix,jy,1,l)) + dzdy=(zzhn(ix,jyp,kz+add_sfc_level,n,l) - zzhn(ix,jy1,kz+add_sfc_level,n,l) & + -zzhn(ix,jyp,1,n,l) & + +zzhn(ix,jy1,1,n,l)) & + /(dyn(l)*(jyp-jy1)*m_yn(ix,jy,1,l)) + + dzdx=(zzhn(ixp,jy,kz+add_sfc_level,n,l) - zzhn(ix1,jy,kz+add_sfc_level,n,l) & + -zzhn(ixp,jy,1,n,l)+zzhn(ix1,jy,1,n,l))/(dxn(l)*(ixp-ix1)*m_xn(ix,jy,1,l)) + dzdy=(zzhn(ix,jyp,kz+add_sfc_level,n,l) - zzhn(ix,jy1,kz+add_sfc_level,n,l) & + -zzhn(ix,jyp,1,n,l)+zzhn(ix,jy1,1,n,l))/(dyn(l)*(jyp-jy1)*m_yn(ix,jy,1,l)) + u=0.5*(uuhn(ix,jy,kz+add_sfc_level,l)+uuhn(ix,jy,kz-1+add_sfc_level,l)) + v=0.5*(vvhn(ix,jy,kz+add_sfc_level,l)+vvhn(ix,jy,kz-1+add_sfc_level,l)) + + wwhn(ix,jy,kz,l) = wwhn(ix,jy,kz,l)*pinmconv(kz) & +! + (uuhn(ix,jy,kz,l)*dzdx + vvhn(ix,jy,kz,l)*dzdy) ! variation of geopot on sigma is necessary + + (u*dzdx + v*dzdy) ! variation of geopot on sigma is necessary + if (kz .eq. 1) wwhn(ix,jy,kz,l) = wwhn(ix,jy,kz,l)*pinmconv(kz) + +! if (kz .eq. 1) wwhn(ix,jy,kz,l) = 0.0 + end do + endif + if (wind_option.eq.-1) then +!! ww(ix,jy,1,n)=wwh(ix,jy,1) + wwn(ix,jy,1,n,l)=0. + do iz=2,nz + wwn(ix,jy,iz,n,l)=wwn(ix,jy,iz-1,n,l)-(height(iz)-height(iz-1))* & + divn(ix,jy,iz-1,l) + enddo + else +! print*,'converting ww in nest' + wwn(ix,jy,1,n,l)=wwhn(ix,jy,1,l) + wwn(ix,jy,nz,n,l)=wwhn(ix,jy,nwz,l) + 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)*dz2+ & + wwhn(ix,jy,kz,l)*dz1)/dz + kmin=kz + goto 40 + endif + end do +40 continue + end do + endif + +! if (method_w_terrain_correction .eq. 20) then +! do kz = 1, nwz +! wwhn(ix,jy,kz,l) = wwhn_svaa(kz) +! end do +! end if + end if + +! 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 +!!!$OMP END DO +!!!$OMP END PARALLEL + +! print*,'end of ww, now clouds, nests' +!**************************************************************** +! Compute slope of eta levels in windward direction and resulting +! vertical wind correction +! +! See notes in verttransform.f about the w correction done here. +!**************************************************************** + !write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz^M + ! create a cloud and rainout/washout field, clouds occur where rh>80%^M + ! total cloudheight is stored at level 0^M + + do 100 jy=0,nyn(l)-1 + do 100 ix=0,nxn(l)-1 +! rain_cloud_above=0 + lsp=lsprecn(ix,jy,1,n,l) + convp=convprecn(ix,jy,1,n,l) + +! cloudsh(ix,jy,n)=0 + + prec=lsp+convp + if (lsp.gt.convp) then ! prectype='lsp' + lconvectprec = .false. + else ! prectype='cp ' + lconvectprec = .true. + endif + rhmin = 0.90 ! standard condition for presence of clouds + +!CPS note that original by Sabine Eckhart was 80% +!CPS however, for T<-20 C we consider saturation over ice +!CPS so I think 90% should be enough + + icloudbotn(ix,jy,n,l)=icmv + icloudtop=icmv ! this is just a local variable +98 do kz=1,nz + 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)) +!cps if (prec.gt.0.01) print*,'relhum',prec,kz,rh,height(kz) + if (rh .gt. rhmin) then + if (icloudbotn(ix,jy,n,l) .eq. icmv) then + icloudbotn(ix,jy,n,l)=nint(height(kz)) + endif + icloudtop=nint(height(kz)) ! use int to save memory + endif + enddo + +!CPS try to get a cloud thicker than 50 m +!CPS if there is at least .01 mm/h - changed to 0.002 and put into +!CPS parameter precpmin + if ((icloudbotn(ix,jy,n,l) .eq. icmv .or. & + icloudtop-icloudbotn(ix,jy,n,l) .lt. 50) .and. & + prec .gt. precmin) then + rhmin = rhmin - 0.05 + if (rhmin .ge. 0.30) goto 98 ! give up for <= 25% rel.hum. + endif +!CPS implement a rough fix for badly represented convection +!CPS is based on looking at a limited set of comparison data + if (lconvectprec .and. icloudtop .lt. 6000 .and. & + prec .gt. precmin) then + if (convp .lt. 0.1) then + icloudbotn(ix,jy,n,l) = 500 + icloudtop = 8000 + else + icloudbotn(ix,jy,n,l) = 0 + icloudtop = 10000 + endif + endif + if (icloudtop .ne. icmv) then + icloudthckn(ix,jy,n,l) = icloudtop-icloudbotn(ix,jy,n,l) + else + icloudthckn(ix,jy,n,l) = icmv + endif +!CPS get rid of too thin clouds + if (icloudthckn(ix,jy,n,l) .lt. 50) then + icloudbotn(ix,jy,n,l)=icmv + icloudthckn(ix,jy,n,l)=icmv + endif + +100 continue + enddo ! nests + + return + end diff --git a/src_flexwrf_v3.1/wetdepo.f90 b/src_flexwrf_v3.1/wetdepo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..aebaab974a576467644b80b62110d79a62af6536 --- /dev/null +++ b/src_flexwrf_v3.1/wetdepo.f90 @@ -0,0 +1,406 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine 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! * + ! * + !* D Arnold 2012 01 25 implement patch developed by P.Seibert to avoid * + !* problems with cloud fraction * + !* set cloud cover to 1 when there is precip & use diagnosed clouds in * + !* vertransform* for in-cloud below-cloud scavenging * + !* Set fraction to max val from grid cells larger than 5 km. * + !* Missing: new fractions of grid cell affected by rain , coming from * + !* modelling studies with 150 km grid-sizes! * + !* precip interpolation is under check by developers * + !* modifications identified by "CDA" * +!* +!* Petra Seibert, 2011/2012: Fixing some deficiencies in this modification + !******************************************************************************** + !***************************************************************************** + ! * + ! 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 +! use ieee_arithmetic + implicit none + + integer :: jpart,itime,ltsample,loutnext,ldeltat,i,j,ix,jy +! integer :: ngrid,itage,nage,hz,il,interp_time, n, clouds_v + integer :: ngrid,itage,nage,kz,il,interp_time, n +! integer :: ks, kp + integer :: ks, kp, icbot,ictop, indcloud + + 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 :: xtn,ytn,lsp,convp,cc,fraction,prec,wetscav,precsub,f + real :: wetscavold +! real :: wetdeposit(maxspec),restmass + 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 (jpart.eq.103) print*,real(xtra1(jpart)),real(ytra1(jpart)),jpart + +! CDA part of the bug fix from P. Seiber includes modification of +! CDA interpol_rain routines. +! if (ieee_is_nan(xtra1(jpart))) then + if (xtra1(jpart).ne.xtra1(jpart)) then + print*,jpart,xtra1(jpart),ytra1(jpart),itra1(jpart) + endif + if (ngrid.eq.0) then +!CDA old code: +! 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) +!CDA new code: + + call interpol_rain(lsprec,convprec,tcc, & + icloudbot,icloudthck,nxmax,nymax,1,nx,ny, & +! memind,sngl(xtra1(jpart)),sngl(ytra1(jpart)),1,memtime(1), & + memind,real(xtra1(jpart)),real(ytra1(jpart)),1,memtime(1), & + memtime(2),interp_time,lsp,convp,cc,icbot,ictop,icmv) + + else +! CDA old code: +! 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) +! CDA new code: + call interpol_rain_nests(lsprecn,convprecn,tccn, & + icloudbotn,icloudthckn,nxmaxn,nymaxn,1,& + maxnests,ngrid,nxn,nyn, memind,xtn,ytn, & + 1,memtime(1), & + memtime(2),interp_time,lsp,convp,cc,icbot,ictop,icmv) + + endif + +! if ((lsp.lt.0.01).and.(convp.lt.0.01)) goto 20 + +!CPS 2012: subtract a small value, eg 0.01 mm/h, to remove spurious precip + prec = lsp+convp + precsub = 0.01 + if (prec .lt. precsub) then + goto 20 + else + f = (prec-precsub)/prec + lsp = f*lsp + convp = f*convp + endif + + + ! get the level were the actual particle is in + do il=2,nz + if (height(il).gt.ztra1(jpart)) then + kz=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 +! CDA PS part of fix + + if (ztra1(jpart) .le. float(ictop)) then + if (ztra1(jpart) .gt. float(icbot)) then + indcloud = 2 ! in-cloud + else + indcloud = 1 ! below-cloud + endif + elseif (ictop .eq. icmv) then + indcloud = 0 ! no cloud found, use old scheme + else + goto 20 ! above cloud + endif + +! 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 + + !CDA + ! if (dx.le.5000.) then + ! j=5 + ! i=5 + ! endif + ! for the moment i set all to 5 + i=5 + j=5 + !CDA + !CDA cc (coming from CLDFRA works as a mask for the precipitation + ! in vertransform* we diagnose the clouds. We consider not that + ! when there is precip, there is cloud as diagnosed in vertransform + ! this is the same approx used in other models HYSPLIT, for insance + ! set cc to 1 + cc=1. + + fraction=max(0.05,cc*(lsp*lfr(i)+convp*cfr(j))/(lsp+convp)) + + ! 2) Computation of precipitation rate in sub-grid cell + !****************************************************** + + prec=(lsp+convp)/fraction + + ! 3) Computation of scavenging coefficients for all species + ! Computation of wet deposition + !********************************************************** + + do 10 ks=1,nspec ! loop over species + wetdeposit(ks)=0. + + if (weta(ks).gt.0.) then + if (indcloud .eq. 1) then ! BELOW CLOUD SCAVENGING +!C for aerosols and not highliy soluble substances weta=5E-6 + wetscav=weta(ks)*prec**wetb(ks) ! scavenging coeff +!c write(*,*) 'bel. wetscav: ',wetscav + elseif (indcloud .eq. 2) then ! IN CLOUD SCAVENGING + if (ngrid.gt.0) then + act_temp=ttn(ix,jy,kz,n,ngrid) + else + act_temp=tt(ix,jy,kz,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/(ictop-icbot) ! 3.6e6 converts mm/h to m/s + wetscavold = 2.e-5*prec**0.8 ! 1.e-4*prec**0.62 + wetscav = min(0.1*wetscav,wetscavold) ! 0.1 is ASt current setting +!PS tihb new scheme +!PS tihc for no cloud, 1.e-5*prec**0.8 ! 1.e-4*prec**0.62 +!PS tihd limit to wetscavold= 1.e-4*prec**0.8 +!PS tihe mulitiply wetscav with .1 +!PS tihf set the wetscavold to 1.e-5prec**0.8 +!PS tihg set the wetscav & wetscavold to 2.e-5*prec**0.8 + weta=2.e-6 (instead of 1.e-6) + + else ! PS: no cloud diagnosed, old scheme, +!CPS using with fixed a,b for simplicity, one may wish to change!! +! wetscav = 1.e-4*prec**0.62 + wetscav = 2.e-5*prec**0.8 + endif + + wetdeposit(ks)=xmass1(jpart,ks)* & + (1.-exp(-wetscav*abs(ltsample)))*fraction ! wet deposition +! CDA test +! 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 +!cccccccccccccccc depostatistic +!c wetdepo_sum(ks,kp)=wetdepo_sum(ks,kp)+wetdeposit(ks) +!cccccccccccccccc depostatistic + else + xmass1(jpart,ks)=0. + endif +!C Correct deposited mass to the last time step when radioactive decay of +!C gridded deposited mass was calculated + if (decay(ks).gt.0.) then + wetdeposit(ks)=wetdeposit(ks)*exp(abs(ldeltat)*decay(ks)) + endif + else ! weta(k)<0 + wetdeposit(ks)=0. + endif +10 continue + + + + ! 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 +! print*,'kp',kp,jpart,npoint(jpart) + ! CDA added itage for the kernel not to be applied during the first hours + call wetdepokernel(nclass(jpart),wetdeposit,real(xtra1(jpart)), & + real(ytra1(jpart)),itage,nage,kp) + if (nested_output.eq.1) call wetdepokernel_nest(nclass(jpart), & + wetdeposit,real(xtra1(jpart)),real(ytra1(jpart)),itage, & + nage,kp) + endif + +20 continue + end do + +end subroutine wetdepo diff --git a/src_flexwrf_v3.1/wetdepokernel.f90 b/src_flexwrf_v3.1/wetdepokernel.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c7f3c84e65e1685998bd2e40c2255a878d33529d --- /dev/null +++ b/src_flexwrf_v3.1/wetdepokernel.f90 @@ -0,0 +1,147 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine wetdepokernel(nunc,deposit,x,y,itage,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 * + ! + ! D. Arnold: modification to skip the kernel the first 3 hours. + ! then, modification to a regular lat-lon. + !***************************************************************************** + ! * + ! 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 +! CDA new declarations + real :: rhoprof(2),rhoi,xlon,ylat,xl2,yl2 + integer :: itage +!JB + if (outgrid_option.eq.0) then +! CDA + xl=(x*dx+xoutshift)/dxout + yl=(y*dy+youtshift)/dyout + elseif (outgrid_option.eq.1) then +! CDA new code: + xl2=x*dx+xmet0 + yl2=y*dy+ymet0 + call xymeter_to_ll_wrf(xl2,yl2,xlon,ylat) + xl=(xlon-outlon0)/dxoutl + yl=(ylat-outlat0)/dyoutl + endif + + ix=int(xl) + jy=int(yl) +!JB I don't know what this thing is suppose to do, but I put it here in case it is necessary +! see for instance conccalc_reg.f90 +! ix=int(xl) +! if (xl.lt.0.) ix=ix-1 +! jy=int(yl) +! if (yl.lt.0.) jy=jy-1 +! + +! CDA skip kernelfor some hours to prevent smoothing close to source + if (itage.lt.7200) then ! no kernel, direct attribution to grid cell + do ks=1,nspec + if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. & + (jy.le.numygrid-1)) & + wetgridunc(ix,jy,ks,kp,nunc,nage)= & + wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks) + enddo + 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 + !********************************************** + + 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 + + endif ! Kernel +end subroutine wetdepokernel diff --git a/src_flexwrf_v3.1/wetdepokernel_nest.f90 b/src_flexwrf_v3.1/wetdepokernel_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a3d4f0673fc9556e0e938359445ed7bac4fc5f53 --- /dev/null +++ b/src_flexwrf_v3.1/wetdepokernel_nest.f90 @@ -0,0 +1,150 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine wetdepokernel_nest & + (nunc,deposit,x,y,itage,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. * + ! * + ! Dec 2012: modifications following wetdepokernel.f90 * + !***************************************************************************** + ! * + ! 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 +! CDA new declarations + real :: rhoprof(2),rhoi,xlon,ylat,xl2,yl2 + integer :: itage +! CDA + + +!JB + if (outgrid_option.eq.0) then +! CDA + xl=(x*dx+xoutshiftn)/dxoutn + yl=(y*dy+youtshiftn)/dyoutn + elseif (outgrid_option.eq.1) then +! CDA new code: + xl2=x*dx+xmet0 + yl2=y*dy+ymet0 + call xymeter_to_ll_wrf(xl2,yl2,xlon,ylat) + xl=(xlon-outlon0n)/dxoutln + yl=(ylat-outlat0n)/dyoutln + endif + + ix=int(xl) + jy=int(yl) + +! CDA skip kernelfor some hours to prevent smoothing close to source + if (itage.lt.7200) then ! no kernel, direct attribution to grid cell + do ks=1,nspec + if ((abs(deposit(ks)).gt.0).and.DRYDEPSPEC(ks)) then +! print*,ix,jy,ks,kp,nunc,nage + if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgridn-1).and. & + (jy.le.numygridn-1)) & + wetgriduncn(ix,jy,ks,kp,nunc,nage)= & + wetgriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks) + endif + enddo + 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 + !********************************************** + + 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 + endif !kernel + +end subroutine wetdepokernel_nest diff --git a/src_flexwrf_v3.1/windalign.f90 b/src_flexwrf_v3.1/windalign.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ba77f0728eaaa22a854f05b5c2423be680934fec --- /dev/null +++ b/src_flexwrf_v3.1/windalign.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +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 diff --git a/src_flexwrf_v3.1/wrf_map_utils_mod.f90 b/src_flexwrf_v3.1/wrf_map_utils_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..db39f38ceab6ee31f69d3a7caf48020bb1d004da --- /dev/null +++ b/src_flexwrf_v3.1/wrf_map_utils_mod.f90 @@ -0,0 +1,77 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF * +!* * +!* FLEXPART is free software: you can redistribute it and/or modify * +!* it under the terms of the GNU General Public License as published by* +!* the Free Software Foundation, either version 3 of the License, or * +!* (at your option) any later version. * +!* * +!* FLEXPART is distributed in the hope that it will be useful, * +!* but WITHOUT ANY WARRANTY; without even the implied warranty of * +!* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +!* GNU General Public License for more details. * +!* * +!* You should have received a copy of the GNU General Public License * +!* along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!*********************************************************************** +! file include_map_utils - created 22-nov-2005 +! +! this file contains the "module data" from +! file .../wrfsi2.1/src/mod/module_map_utils.F +!----------------------------------------------------------------------- + +module wrf_map_utils_mod + implicit none + + logical :: proj_init, proj_cyclic + + integer :: proj_code, proj_nx, proj_ny + integer :: proj_latlon, proj_merc, proj_lc, proj_ps, proj_rotlat + real :: proj_lat1, proj_lon1, proj_dx, & + proj_dlat, proj_dlon, proj_clat, proj_clon, & + proj_stdlon, proj_truelat1, proj_truelat2, & + proj_hemi, proj_cone, proj_polei, proj_polej, & + proj_rsw, proj_rebydx + real :: pi, deg_per_rad, rad_per_deg, earth_radius_m + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! ! define data structures to define various projections +! +! type proj_info +! +! logical proj_init ! flag to indicate if this struct is +! ! ready for use +! logical proj_cyclic ! flag indicating if this grid +! ! is cyclic in the longitudinal +! ! direction...happens with +! ! global lat/lon grids like gfs/avn +! integer proj_code ! integer code for projection type +! integer proj_nx +! integer proj_ny +! real proj_lat1 ! sw latitude (1,1) in degrees (-90->90n) +! real proj_lon1 ! sw longitude (1,1) in degrees (-180->180e) +! real proj_dx ! grid spacing in meters at truelats, used +! ! only for ps, lc, and merc projections +! real proj_dlat ! lat increment for lat/lon grids +! real proj_dlon ! lon increment for lat/lon grids +! real proj_clat ! center latitude of grid +! real proj_clon ! center longitude of grid +! real proj_stdlon ! longitude parallel to y-axis (-180->180e) +! real proj_truelat1 ! first true latitude (all projections) +! real proj_truelat2 ! second true lat (lc only) +! real proj_hemi ! 1 for nh, -1 for sh +! real proj_cone ! cone factor for lc projections +! real proj_polei ! computed i-location of pole point +! real proj_polej ! computed j-location of pole point +! real proj_rsw ! computed radius to sw corner +! real proj_rebydx ! earth radius divided by dx +! +! end type proj_info +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +end module wrf_map_utils_mod diff --git a/src_flexwrf_v3.1/write_ncconc.f90 b/src_flexwrf_v3.1/write_ncconc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..306c06626c508cbbf70e1e27a8e8499eddeb9ebe --- /dev/null +++ b/src_flexwrf_v3.1/write_ncconc.f90 @@ -0,0 +1,321 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* Adam Dingwell * +!* * +!* This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine write_ncconc(itime,outnum,ks,kp,nage,tot_mu_scalar,nesting_level) + + !***************************************************************************** + ! * + ! This routine writes concentration, mixing ratio and deposition fields * + ! to a netcdf file defined by flex_ncheader. * + ! * + ! flex_ncheader is called from within write_ncconc when it's time for a new * + ! output file. * + ! * + ! write_ncconc should be called by concoutput_irreg and concoutput_reg * + ! it is separate from the binary and ascii output routines to avoid mixing * + ! of sparse and full grid approaches. Netcdf will output the full grid. * + ! * + ! Author: A. Dingwell * + ! * + ! 29 May 2013 * + ! * + ! Modifications: * + ! June 5 2013: J. Brioude: compression using deflate level, optimization of * + ! the writing procedure. bug fixes for backtrajectory mode * + !***************************************************************************** + + use point_mod + use outg_mod + use par_mod + use com_mod + + implicit none + + include 'netcdf.inc' + + real :: outnum ! Number of samples for each concentration calculation + integer :: itime ! Current simulation time [s] + integer :: ks,kp,nage ! species, maxpointspec_act and nageclass indices resp. + real :: tot_mu_scalar ! total mass per source and species (backward) + ! or unity (forward). Should probably be sent as + ! tot_mu(ks,kp) from concoutput*.f90 + integer :: nesting_level ! 0 for main (mother) grid, 1 for nest (child) + + real(kind=dp) :: jul ! Julian date + integer :: jjjjmmdd,ihmmss ! date & time as integer + character :: adate*8,atime*6 ! date and time strings, used for filename + + integer :: ncid ! Pointer to netcdf file, depends on nesting level + integer :: grid_nx,grid_ny! outgrid dimensions, depend on the nesting level + integer :: ncret ! Netcdf: return code + integer :: ix,jy,kz ! iterators + character :: datestr*15 ! For the Times variable + integer :: deflate_level=5 ! compression level + + if (option_verbose.ge.1) then + write(*,*)'write_ncconc: writing netcdf output for: domain,kp,nage =',& + nesting_level+1,kp,nage + endif + + ! Determine which nest/outfile we are writing to + !*********************************************** + if (nesting_level.eq.0) then + ncid = ncout + grid_nx = numxgrid + grid_ny = numygrid + elseif (nesting_level.eq.1) then + ncid = ncoutn + grid_nx = numxgridn + grid_ny = numygridn + else + write(*,*) '***write_ncconc error: nesting level must be 0 or 1' + ! Note for future development: If additional output nests are to be + ! supported for netcdf output, modification must be made here as well as in + ! the respective nesting_level if-block in write_ncheader + endif + ! Update/Initialize record index + !******************************* + if ((ks.eq.1).and.(kp.eq.1).and.(nage.eq.1)) then +! print*,'ncirec',ncirec,ncnumrec + if (nesting_level.eq.0) then ! Only update for first domain + if (itime.eq.loutstep) then ! first output + ncirec = 1 ! initialize record index + elseif (ncirec.eq.ncnumrec) then ! new file +! print*,'file is closing' + ncirec = 1 ! reset record index + ncret=nf_close(ncid) ! close the old file + call check_ncerror(ncret) +! print*,'file is closed' + else + ncirec=ncirec+1 ! move on to next record + endif + endif +! print*,'ncirec',ncirec,ncnumrec + endif + + ! Check if it's time to create a new netcdf file + !*********************************************** + if (ncirec.eq.1) then ! First output in current file? +! write(*,*) 'itime=',itime + if ((ks.eq.1).and.(kp.eq.1).and.(nage.eq.1)) then +! if (itime.ne.loutstep) then ! Not the first output file? +! ncret=nf_close(ncid) ! close the old file +! call check_ncerror(ncret) +! print*,'file is closed' +! endif +! call write_ncheader(itime,nesting_level) ! Create new file + if (option_verbose.ge.1) & + write(*,*)'write_ncconc: calling write_ncinfo' + call write_ncinfo(itime,nesting_level) ! Create new file + ! Reassign file handle to the newly created file: + endif + if (nesting_level.eq.0) ncid=ncout + if (nesting_level.eq.1) ncid=ncoutn + endif + + if (option_verbose.ge.10) & + write(*,*) 'ncid,nccovid=',ncid,nccovid + + + ! Create output for the current record index + !******************************************* + jul=bdate+real(itime,kind=dp)/86400._dp + call caldate(jul,jjjjmmdd,ihmmss) + write(adate,'(i8.8)') jjjjmmdd + write(atime,'(i6.6)') ihmmss + + if ((ks.eq.1).and.(kp.eq.1).and.(nage.eq.1)) then + + if (option_verbose.ge.10) write(*,*)'write_ncconc: record index',ncirec + write(datestr,'(I8.8,A1,I6.6)') jjjjmmdd,'_',ihmmss + ncret = nf_put_vara_text(ncid,ncrecvid,(/1,ncirec/),(/15,1/),datestr) + call check_ncerror(ncret) + endif + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then ! concentration + if (option_verbose.ge.1) & + write(*,*)'write_ncconc: concentration output',kp,nage,ncirec,nccovid,ncid + + + do kz=1,numzgrid + do jy=0,grid_ny-1 + do ix=0,grid_nx-1 + grid2(ix,jy,kz,kp)= grid(ix,jy,kz)*factor3d(ix,jy,kz)/tot_mu_scalar + enddo ! ix=1,grid_nx-1 + enddo ! jy=1,grid_ny-1 + enddo ! kz=1,numzgrid + + if (kp.eq.maxpointspec_act) then + if (ldirect.eq.-1) then + ncret = nf_put_vara_real(ncid,nccovid, & + (/1,1,1,1,nage,ncirec/),(/grid_nx,grid_ny,numzgrid,kp,1,1/), & + grid2(0:grid_nx-1,0:grid_ny-1,1:numzgrid,1:kp)) + call check_ncerror(ncret) + else + if (kp.gt.1) then + ncret = nf_put_vara_real(ncid,nccovid, & + (/1,1,1,1,ks,nage,ncirec/),(/grid_nx,grid_ny,numzgrid,kp,1,1,1/), & + grid2(0:grid_nx-1,0:grid_ny-1,1:numzgrid,1:kp)) + else + ncret = nf_put_vara_real(ncid,nccovid, & + (/1,1,1,ks,nage,ncirec/),(/grid_nx,grid_ny,numzgrid,1,1,1/), & + grid2(0:grid_nx-1,0:grid_ny-1,1:numzgrid,1)) + endif + call check_ncerror(ncret) + endif + endif +! do kz=1,numzgrid +! do jy=0,grid_ny-1 +! do ix=0,grid_nx-1 +! ncret = nf_put_vara_real(ncid,nccovid, & +! (/ix+1,jy+1,kz,kp,nage,ncirec/),(/1,1,1,1,1,1/), & +! grid(ix,jy,kz)*factor3d(ix,jy,kz)/tot_mu_scalar) +! call check_ncerror(ncret) +! enddo ! ix=1,grid_nx-1 +! enddo ! jy=1,grid_ny-1 +! enddo ! kz=1,numzgrid + endif ! concentraion + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + if (option_verbose.ge.1)write(*,*)'write_ncconc: mixing ratio output' + do kz=1,numzgrid + do jy=0,grid_ny-1 + do ix=0,grid_nx-1 + grid3(ix,jy,kz,kp)= 1.e12*grid(ix,jy,kz)/volume(ix,jy,kz)/outnum* & + weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz) + enddo ! ix=1,grid_nx-1 + enddo ! jy=1,grid_ny-1 + enddo ! kz=1,numzgrid + if (kp.eq.maxpointspec_act) then + if (ldirect.eq.-1) then + ncret = nf_put_vara_real(ncid,ncravid, & + (/1,1,1,1,nage,ncirec/),(/grid_nx,grid_ny,numzgrid,kp,1,1/), & + grid3(0:grid_nx-1,0:grid_ny-1,1:numzgrid,1:kp)) + call check_ncerror(ncret) + else + if (kp.gt.1) then + ncret = nf_put_vara_real(ncid,ncravid, & + (/1,1,1,1,ks,nage,ncirec/),(/grid_nx,grid_ny,numzgrid,kp,1,1,1/), & + grid3(0:grid_nx-1,0:grid_ny-1,1:numzgrid,1:kp)) + else + ncret = nf_put_vara_real(ncid,ncravid, & + (/1,1,1,ks,nage,ncirec/),(/grid_nx,grid_ny,numzgrid,1,1,1/), & + grid3(0:grid_nx-1,0:grid_ny-1,1:numzgrid,1)) + endif + call check_ncerror(ncret) + endif + endif + +! do kz=1,numzgrid +! do jy=0,grid_ny-1 +! do ix=0,grid_nx-1 +! ncret = nf_put_vara_real(ncid,ncravid, & +! (/ix+1,jy+1,kz,kp,nage,ncirec/),(/1,1,1,1,1,1/), & +! 1.e12*grid(ix,jy,kz)/volume(ix,jy,kz)/outnum* & +! weightair/weightmolar(ks)/densityoutgrid(ix,jy,kz)) +! call check_ncerror(ncret) +! enddo ! ix=1,grid_nx-1 +! enddo ! jy=1,numygrid-1 +! enddo ! kz=1,numzgrid + endif ! mixing ratio + + if ((ldirect.eq.1).and.(WETDEP)) then ! WETDEP + if (option_verbose.ge.1)write(*,*)'write_ncconc: wet deposition output' + do jy=0,grid_ny-1 + do ix=0,grid_nx-1 + if (nesting_level.eq.0) wetgrid2(ix,jy,kp)=1.e12*wetgrid(ix,jy)/area(ix,jy) + if (nesting_level.eq.1) wetgrid2(ix,jy,kp)=1.e12*wetgrid(ix,jy)/arean(ix,jy) + enddo ! ix=1,grid_nx-1 + enddo ! jy=1,grid_ny-1 + if (kp.eq.maxpointspec_act) then + if (ldirect.eq.-1) then + ncret = nf_put_vara_real(ncid,ncwdvid, & + (/1,1,1,nage,ncirec/),(/grid_nx,grid_ny,kp,1,1/), & + wetgrid2(0:grid_nx-1,0:grid_ny-1,1:kp)) + call check_ncerror(ncret) + else + if (kp.gt.1) then + ncret = nf_put_vara_real(ncid,ncwdvid, & + (/1,1,1,ks,nage,ncirec/),(/grid_nx,grid_ny,kp,1,1,1/), & + wetgrid2(0:grid_nx-1,0:grid_ny-1,1:kp)) + else + ncret = nf_put_vara_real(ncid,ncwdvid, & + (/1,1,ks,nage,ncirec/),(/grid_nx,grid_ny,1,1,1/), & + wetgrid2(0:grid_nx-1,0:grid_ny-1,1)) + endif + call check_ncerror(ncret) + endif + endif +! do jy=0,grid_ny-1 +! do ix=0,grid_nx-1 +! ncret = nf_put_vara_real(ncid,ncwdvid, & +! (/ix+1,jy+1,kp,nage,ncirec/),(/1,1,1,1,1/), & +! 1.e12*wetgrid(ix,jy)/area(ix,jy)) +! call check_ncerror(ncret) +! enddo ! ix=1,grid_nx-1 +! enddo ! jy=1,numygrid-1 + endif ! WETDEP + + if ((ldirect.eq.1).and.(DRYDEP)) then ! DRYDEP + if (option_verbose.ge.1)write(*,*)'write_ncconc: dry deposition output' + do jy=0,grid_ny-1 + do ix=0,grid_nx-1 + if (nesting_level.eq.0) drygrid2(ix,jy,kp)=1.e12*drygrid(ix,jy)/area(ix,jy) + if (nesting_level.eq.1) drygrid2(ix,jy,kp)=1.e12*drygrid(ix,jy)/arean(ix,jy) + enddo ! ix=1,grid_nx-1 + enddo ! jy=1,grid_ny-1 + if (kp.eq.maxpointspec_act) then + if (ldirect.eq.-1) then + ncret = nf_put_vara_real(ncid,ncddvid, & + (/1,1,1,nage,ncirec/),(/grid_nx,grid_ny,kp,1,1/), & + drygrid2(0:grid_nx-1,0:grid_ny-1,1:kp)) + call check_ncerror(ncret) + else + if (kp.gt.1) then + ncret = nf_put_vara_real(ncid,ncddvid, & + (/1,1,1,ks,nage,ncirec/),(/grid_nx,grid_ny,kp,1,1,1/), & + drygrid2(0:grid_nx-1,0:grid_ny-1,1:kp)) + else + ncret = nf_put_vara_real(ncid,ncddvid, & + (/1,1,ks,nage,ncirec/),(/grid_nx,grid_ny,1,1,1/), & + drygrid2(0:grid_nx-1,0:grid_ny-1,1)) + endif + call check_ncerror(ncret) + endif + endif + +! do jy=0,grid_ny-1 +! do ix=0,grid_nx-1 +! ncret = nf_put_vara_real(ncid,ncddvid, & +! (/ix+1,jy+1,kp,nage,ncirec/),(/1,1,1,1,1/), & +! 1.e12*drygrid(ix,jy)/area(ix,jy)) +! call check_ncerror(ncret) +! enddo ! ix=1,grid_nx-1 +! enddo ! jy=1,numygrid-1 + endif ! DRYDEP + + ncret=nf_sync(ncid) + call check_ncerror(ncret) + +end subroutine write_ncconc diff --git a/src_flexwrf_v3.1/write_ncheader.f90 b/src_flexwrf_v3.1/write_ncheader.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a04a09402c5ad96ca93d4f62da7a59fd7ed58233 --- /dev/null +++ b/src_flexwrf_v3.1/write_ncheader.f90 @@ -0,0 +1,767 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* Adam Dingwell * +!* * +!* This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine write_ncheader(itime,nesting_level) + + !***************************************************************************** + ! * + ! This routine perdefines a netcdf ouput file with information on flexpart * + ! settings, releases and topography. * + ! * + ! Author: A. Dingwell * + ! * + ! 27 May 2013 * + ! * + ! Modifications * + ! June 5 2013: J. Brioude: generate a header*nc * + !***************************************************************************** + + use point_mod + use outg_mod + use com_mod + + implicit none + + include 'netcdf.inc' + + integer :: itime,stat ! seconds since simulation start + integer :: nesting_level ! 0 for main grid (mother) 1 for nest (child) + ! this is written to be easy to expand is additional + ! are desired in the future + + real(kind=dp) :: jul ! Julian date + integer :: jjjjmmdd,ihmmss ! date & time as integer + character :: adate*8,atime*6 ! date and time strings, used for filename + + ! Grid related variables + real :: xp1,yp1,xp2,yp2 ! temporary coordinates + real :: xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat,xl2,yl2 + integer :: ncgrid_nx,ncgrid_ny ! nx,ny of current grid + integer :: ncgrid_dx,ncgrid_dy ! dx,dy of current grid in m or latlon + real :: ncgrid_swlon,ncgrid_swlat ! SW corner of current grid in latlon + real :: ncgrid_nelon,ncgrid_nelat ! NE corner of current grid in latlon + real :: ncgrid_xm0,ncgrid_ym0 ! lower-left grid coord in metres + real :: ncgrid_lon0,ncgrid_lat0 ! lower-left grid coord in latlon + + ! Grid related 2D-variables (reassigning these here is a bit inefficient but + ! it lets us keep a consistent structure of the code, besides it's only once + ! per output + real,allocatable,dimension (:,:) :: ncgrid_oro,ncgrid_area ! of current grid + + ! Iterators + integer i,j,ix,jy + + ! NETCDF file related variables + integer nclvlid,nclonid,nclatid,ncrecid,ncspcid,ncageid !outgrid dimension ids + integer ncrelid,ncrseid ! release points dimension ids + integer ncrnvid,ncrmvid,ncspvid ! release points: number,mass,species ids + integer ncrtvid,ncrxvid,ncryvid,ncrzvid ! release points: t,x,y,z min/max limits + integer nctovid,ncarvid ! Topography and grid area variable-ids + integer ncstr1id,ncstr2id,ncstr3id ! decrtiption string length dimid + integer nclvlvid,nclonvid,nclatvid,ncspcvid,ncagevid ! outgrid dimension variables + integer nclonvid2,nclatvid2 + integer ncdimsid3(6),ncdimsid2(5) ! arrays of dimension ids for outgrid 3D & 2D + + ! NETCDF filename & attribute related variables + character descr*11,units*5,ncname*29,coord*11,coordxy*10 + integer coordxylen + character unit2d*10 ! unit for deposition fields + integer unit2dlen ! length of character string + + ! NETCDF misc variables + integer ncid ! local container for netcdf file-id (either ncout or ncoutn) + integer ncret ! Return-value of calls to nf_* utils + integer :: deflate_level=1 ! compression level + integer :: shuffle=1 ! shuffle +! integer :: chunks(2) ! shuffle + ! Attribute notation: + descr = 'description' + units = 'units' + coord = 'coordinates' + coordxy = 'XLONG XLAT' + coordxylen = 10 + + ! 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 header output file + !************************ +! write(ncname,'(A8,I2.2,A1,I8.8,A1,I6.6,A3)') & +! 'flxout_d',nesting_level+1,'_',jjjjmmdd,'_',ihmmss,'.nc' ! filename + write(ncname,'(A8,I2.2,A3)') & + 'header_d',nesting_level+1,'.nc' ! filename + + +! call nf_set_log_level(3) + if (option_verbose.ge.1) write(*,*) & + 'write_ncheader: creating file: ',path(1)(1:length(1))//ncname +! call nf_set_chunk_cache(32000000) +! ncret = nf_create(path(1)(1:length(1))//ncname, nf_clobber,ncid) + ncret = nf_create(path(1)(1:length(1))//ncname, NF_NETCDF4,ncid) + call check_ncerror(ncret) + + ! Determine which nest/outfile we just created so we can set up the grid + !*********************************************************************** + if (nesting_level.eq.0) then ! current grid is main grid + ncout = ncid ! copy current file handle to ncout + ncgrid_nx = numxgrid + ncgrid_ny = numygrid + ncgrid_nelon = outgrid_nelon + ncgrid_nelat = outgrid_nelat + ncgrid_swlon = outgrid_swlon + ncgrid_swlat = outgrid_swlat + allocate(ncgrid_oro(ncgrid_nx,ncgrid_ny),stat=stat) + allocate(ncgrid_area(ncgrid_nx,ncgrid_ny),stat=stat) + ncgrid_oro = oroout(0:ncgrid_nx-1,0:ncgrid_ny-1) + ncgrid_area = area(0:ncgrid_nx-1,0:ncgrid_ny-1) + if (outgrid_option.eq.1) then ! input was in latlon + ncgrid_dx = dxoutl + ncgrid_dy = dyoutl + ncgrid_lon0 = outlon0 + ncgrid_lat0 = outlat0 + else ! input was in metres + ncgrid_dx = dxout + ncgrid_dy = dyout + ncgrid_xm0 = out_xm0 + ncgrid_ym0 = out_ym0 + endif + elseif (nesting_level.eq.1) then ! current grid is nested + ncoutn = ncid ! copy current file handle to ncoutn + ncgrid_nx = numxgridn + ncgrid_ny = numygridn + ncgrid_nelon = outgridn_nelon + ncgrid_nelat = outgridn_nelat + ncgrid_swlon = outgridn_swlon + ncgrid_swlat = outgridn_swlat + allocate(ncgrid_oro(ncgrid_nx,ncgrid_ny),stat=stat) + allocate(ncgrid_area(ncgrid_nx,ncgrid_ny),stat=stat) + ncgrid_oro = orooutn(0:ncgrid_nx-1,0:ncgrid_ny-1) + ncgrid_area = arean(0:ncgrid_nx-1,0:ncgrid_ny-1) + if (outgrid_option.eq.1) then ! input was in latlon + ncgrid_dx = dxoutln + ncgrid_dy = dyoutln + ncgrid_lon0 = outlon0n + ncgrid_lat0 = outlat0n + else ! input was in metres + ncgrid_dx = dxoutn + ncgrid_dy = dyoutn + ncgrid_xm0 = out_xm0n + ncgrid_ym0 = out_ym0n + endif + endif + + if (option_verbose.ge.10) & + write(*,*) 'write_ncheader: ncout,ncoutn=',ncout,ncoutn + + ! Write the header information + !***************************** + + !ncret = nf_put_att_text(ncout,nf_global,'TITLE',20,version) + !call check_ncerror(ncret) + if (ldirect.eq.1) then ! Forward simulation + if (option_verbose.ge.10) write(*,10) 'forward simulation attributes' + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_DATE',nf_int,1,ibdate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_TIME',nf_int,1,ibtime) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_DATE',nf_int,1,iedate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_TIME',nf_int,1,ietime) + call check_ncerror(ncret) + else ! Backward simulation + if (option_verbose.ge.10) write(*,10) 'backward simulation attributes' + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_DATE',nf_int,1,iedate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_TIME',nf_int,1,ietime) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_DATE',nf_int,1,ibdate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_TIME',nf_int,1,ibtime) + call check_ncerror(ncret) + endif + + if (option_verbose.ge.10) write(*,10) 'map projection attributes' + if (outgrid_option .eq. 1) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',20,'Regular Latit/Longit') + call check_ncerror(ncret) + else + if (map_proj_id.eq.1) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',17,'Lambert conformal') + call check_ncerror(ncret) + elseif (map_proj_id.eq.2) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',13,'stereographic') + call check_ncerror(ncret) + elseif (map_proj_id.eq.3) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',8,'mercator') + call check_ncerror(ncret) + elseif (map_proj_id.eq.4) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',6,'global') + call check_ncerror(ncret) + endif + endif + + ! Write info common model settings + !********************************* + if (option_verbose.ge.10) write(*,10) 'common model attributes' + + if (option_verbose.ge.10) write(*,10) 'OUTPUT_INTERVAL' + ncret = nf_put_att_int(ncid,nf_global,'OUTPUT_INTERVAL',nf_int,1,loutstep) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'AVERAGING_TIME' + ncret = nf_put_att_int(ncid,nf_global,'AVERAGING_TIME',nf_int,1,loutaver) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'AVERAGE_SAMPLING' + ncret = nf_put_att_int(ncid,nf_global,'AVERAGE_SAMPLING',nf_int,1,loutsample) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'NSPEC',nf_int,1,nspec) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'NUMRECEPTOR',nf_int,1,numreceptor) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'NAGECLASS',nf_int,1,nageclass) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'NUMRELEASES',nf_int,1,numpoint) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'DISPERSION_METHOD',nf_int,1,method) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SUBGRID_TOPOGRAPHY',nf_int,1,lsubgrid) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'CONVECTION_PARAM',nf_int,1,lconvection) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SUBGRID_TOPOGRAPHY',nf_int,1,lsubgrid) + call check_ncerror(ncret) + + ! Write information on output grid setup + !*************************************** + if (option_verbose.ge.10) write(*,10) 'WEST-EAST_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'WEST-EAST_GRID_DIMENSION', & + nf_int,1,ncgrid_nx) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'SOUTH-NORTH_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'SOUTH-NORTH_GRID_DIMENSION', & + nf_int,1,ncgrid_ny) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'BOTTOM-TOP_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'BOTTOM-TOP_GRID_DIMENSION', & + nf_int,1,numzgrid) + + if (option_verbose.ge.10) write(*,10) 'DX and DY' + ncret = nf_put_att_int(ncid,nf_global,'DX',nf_int,1,ncgrid_dx) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'DY',nf_int,1,ncgrid_dy) + call check_ncerror(ncret) + + ! Set up netcdf dimensions + !************************* + if (option_verbose.ge.10) write(*,10) 'main grid dimensions' + + ncret = nf_def_dim(ncid,'Time',nf_unlimited,ncrecid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'DateStrLen',15,ncstr3id) !TODO: WRF format + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'west_east',ncgrid_nx,nclonid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'south_north',ncgrid_ny,nclatid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'bottom_top',numzgrid,nclvlid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'species',nspec,ncspcid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'SpeciesStrLen',10,ncstr1id) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ageclass',nageclass,ncageid) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'release point dimensions' + ncret = nf_def_dim(ncid,'releases',numpoint,ncrelid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ReleaseStrLen',45,ncstr2id) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ReleaseStartEnd',2,ncrseid) + call check_ncerror(ncret) + + ! Select which dimensions to use for main output grids + ncdimsid3(1) = nclonid ! X + ncdimsid3(2) = nclatid ! Y + ncdimsid3(3) = nclvlid ! Z + if (ldirect.eq.1) ncdimsid3(4) = ncspcid ! species + if (ldirect.eq.-1) ncdimsid3(4) = ncrelid ! points + ncdimsid3(5) = ncageid ! ageclass + ncdimsid3(6) = ncrecid ! t + + ncdimsid2(1) = nclonid ! X + ncdimsid2(2) = nclatid ! Y + if (ldirect.eq.1) ncdimsid2(3) = ncspcid ! species + if (ldirect.eq.-1) ncdimsid2(3) = ncrelid ! points + ncdimsid2(4) = ncageid ! ageclass + ncdimsid2(5) = ncrecid ! t + + ! Set up dimension variables + !*************************** + + ! XLONG + if (option_verbose.ge.10) write(*,10) 'XLONG dimension variable' + ncret = nf_def_var(ncid,'XLONG',nf_real,2,ncdimsid2(1:2),nclonvid) + +! Turn on deflate compression, fletcher32 checksum. + ncret = NF_DEF_VAR_deflate(ncid,nclonvid, shuffle, 1, deflate_level) +! if (ncret .ne. nf_noerr) call handle_err(retval) +! ncret = NF_DEF_VAR_FLETCHER32(ncid, nclonvid, NF_FLETCHER32) +! if (ncret .ne. nf_noerr) call handle_err(retval) + +! ncret = nf_def_var_deflate(ncid,'XLONG',nf_real,2,ncdimsid2(1:2),nclonvid,deflate_level=deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclonvid,descr,42,'Longitude of center grid, west is negative') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclonvid,units,11,'degree_east') + call check_ncerror(ncret) + + ncret = nf_def_var(ncid,'XLONG_CORNER',nf_real,2,ncdimsid2(1:2),nclonvid2) + ncret = NF_DEF_VAR_deflate(ncid,nclonvid2, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclonvid2,descr,57,'Longitude of lower left corner of grids, west is negative') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclonvid2,units,11,'degree_east') + call check_ncerror(ncret) + + ! XLAT + if (option_verbose.ge.10) write(*,10) 'XLAT dimension variable' + ncret = nf_def_var(ncid,'XLAT',nf_real,2,ncdimsid2(1:2),nclatvid) +! ncret = nf_def_var_deflate(ncid,'XLAT',nf_real,2,ncdimsid2(1:2),nclatvid,deflate_level=deflate_level) + ncret = NF_DEF_VAR_deflate(ncid,nclatvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclatvid,descr,42,'Latitude of center grid, south is negative') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclatvid,units,12,'degree_north') + call check_ncerror(ncret) + + ncret = nf_def_var(ncid,'XLAT_CORNER',nf_real,2,ncdimsid2(1:2),nclatvid2) + ncret = NF_DEF_VAR_deflate(ncid,nclatvid2, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclatvid2,descr,57,'Latitude of lower left corner of grids, south is negative') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclatvid2,units,12,'degree_north') + call check_ncerror(ncret) + + ! ZTOP + if (option_verbose.ge.10) write(*,10) 'ZTOP dimension variable' + ncret = nf_def_var(ncid,'ZTOP',nf_real,1,ncdimsid3(3),nclvlvid) + ncret = NF_DEF_VAR_deflate(ncid,nclvlvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclvlvid,descr,32, & + 'UPPER BOUNDARY OF MODEL LAYER') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclvlvid,units,1,'m') + call check_ncerror(ncret) + + ! SPECIES + if (option_verbose.ge.10) write(*,10) 'SPECIES dimension variable' + ncret = nf_def_var(ncid,'SPECIES',nf_char,2,(/ncstr1id,ncspcid/),ncspcvid) + ncret = NF_DEF_VAR_deflate(ncid,ncspcvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncspcvid,descr,15,'NAME OF SPECIES') + call check_ncerror(ncret) + + ! AGECLASSES + if (option_verbose.ge.10) write(*,10) 'AGECLASSES dimension variable' + ncret = nf_def_var(ncid,'AGECLASS',nf_int,1,ncageid,ncagevid) + ncret = NF_DEF_VAR_deflate(ncid,ncagevid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncagevid,descr,27,'MAX AGE OF SPECIES IN CLASS') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncagevid,units,1,'s') + call check_ncerror(ncret) + + ! TIMES + if (option_verbose.ge.10) write(*,10) 'TIMES dimension variable' + ncret = nf_def_var(ncid,'Times',nf_char,2,(/ncstr3id,ncrecid/),ncrecvid) + ncret = NF_DEF_VAR_deflate(ncid,ncrecvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrecvid,descr,42, & + 'TIME OF OUTPUT (END OF AVERAGING INTERVAL)') + + ! Release related variables + if (option_verbose.ge.10) write(*,10) 'ReleaseName variable' + ncret = nf_def_var(ncid,'ReleaseName',nf_char,2,(/ncstr2id,ncrelid/),ncrnvid) + ncret = NF_DEF_VAR_deflate(ncid,ncrnvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrnvid,descr,25,'RELEASE IDENTIFIER/COMMENT') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrnvid,units,1,'-') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseTstart_end variable' + ncret = nf_def_var(ncid,'ReleaseTstart_end', & + nf_int,2,(/ncrseid,ncrelid/),ncrtvid) + ncret = NF_DEF_VAR_deflate(ncid,ncrtvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrtvid,descr,32, & + 'BEGINNING/ENDING TIME OF RELEASE (SECONDS SINCE RUN START)') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrtvid,units,1,'s') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseXstart_end variable' + ncret = nf_def_var(ncid,'ReleaseXstart_end', & + nf_float,2,(/ncrseid,ncrelid/),ncrxvid) + ncret = NF_DEF_VAR_deflate(ncid,ncrxvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrxvid,descr,32, & + 'WEST/EAST BOUNDARIES OF SOURCE') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrxvid,units,12,'degree_north') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseYstart_end variable' + ncret = nf_def_var(ncid,'ReleaseYstart_end', & + nf_float,2,(/ncrseid,ncrelid/),ncryvid) + ncret = NF_DEF_VAR_deflate(ncid,ncryvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncryvid,descr,32, & + 'SOUTH/NORTH BOUNDARIES OF SOURCE') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncryvid,units,12,'degree_north') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseZstart_end variable' + ncret = nf_def_var(ncid,'ReleaseZstart_end', & + nf_float,2,(/ncrseid,ncrelid/),ncrzvid) + ncret = NF_DEF_VAR_deflate(ncid,ncrzvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrzvid,descr,31, & + 'BOTTOM/TOP BOUNDARIES OF SOURCE') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrzvid,units,1,'m') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseNP variable' + ncret = nf_def_var(ncid,'ReleaseNP',nf_int,1,ncrelid,ncspvid) + ncret = NF_DEF_VAR_deflate(ncid,ncspvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncspvid,descr,34, & + 'TOTAL NUMBER OF PARTICLES RELEASED') + ncret = nf_put_att_text(ncid,ncspvid,units,1,'-') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseXMass variable' + ncret = nf_def_var(ncid,'ReleaseXMass',nf_real,2,(/ncspcid,ncrelid/),ncrmvid) + ncret = NF_DEF_VAR_deflate(ncid,ncrmvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrmvid,descr,18,'TOTAL MASS RELEASED') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrmvid,units,2,'kg') + call check_ncerror(ncret) + + ! Since we need to exit define mode before we can insert + ! variable data, we will include the last file attributes and + ! define the last variables here. + + ! DIRECTION INDEPENDENT OUTPUT VARIABLES + if (option_verbose.ge.10) write(*,10) 'TOPOGRAPHY variable' + ncret = nf_def_var(ncid,'TOPOGRAPHY',NF_real,2,ncdimsid2(1:2),nctovid) +! ncret = nf_def_var_deflate(ncid,'TOPOGRAPHY',NF_real,2,ncdimsid2(1:2),nctovid,deflate_level=deflate_level) + ncret = NF_DEF_VAR_deflate(ncid,nctovid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nctovid,descr,33, & + 'TERRAIN ELEVATION ABOVE SEA LEVEL') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nctovid,units,1,'m') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nctovid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'GRIDAREA variable' + ncret = nf_def_var(ncid,'GRIDAREA',NF_real,2,ncdimsid2(1:2),ncarvid) +! ncret = nf_def_var_deflate(ncid,'GRIDAREA',NF_real,2,ncdimsid2(1:2),ncarvid,deflate_level=deflate_level) + ncret = NF_DEF_VAR_deflate(ncid,ncarvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncarvid,descr,30, & + 'SURFACE AREA OF EACH GRID CELL') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncarvid,units,2,'m2') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncarvid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + + ! MAIN OUTPUT VARIABLES +! if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then ! CONCENTRATION +! if (option_verbose.ge.10) write(*,10) 'CONC variable' +! ncret = nf_def_var(ncid,'CONC',NF_REAL,6,ncdimsid3,nccovid) +!! chunks(1) = ncgrid_nx +!! chunks(2) = ncgrid_ny +!!! ncret = NF_DEF_VAR_CHUNKING(ncid, nccovid, NF_CHUNKED, chunks) +!! if (ncret .ne. nf_noerr) call check_ncerror(ncret) +! ncret = NF_DEF_VAR_deflate(ncid,nccovid, shuffle, 1, deflate_level) +! +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nccovid,descr,33, & +! 'CONCENTRATION OF AIRBORNE SPECIES') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nccovid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! endif + +! if ((iout.eq.2).or.(iout.eq.3)) then ! MIXING RATIO +! if (option_verbose.ge.10) write(*,10) 'MIXINGRATIO variable' +! ncret = nf_def_var(ncid,'MIXINGRATIO',NF_REAL,6,ncdimsid3,ncravid) +! ncret = NF_DEF_VAR_deflate(ncid,ncravid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncravid,descr,37, & +! 'MASS MIXING RATIO OF AIRBORNE SPECIES') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncravid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! endif +! +! if (ldirect.eq.1) then ! Forward run +! unit2d = 'pg m-2' +! unit2dlen = 6 +! +! if (option_verbose.ge.10) write(*,10) 'DRYDEP variable' +! write(*,*) ncdimsid2 +! ncret = nf_def_var(ncid,'DRYDEP',NF_REAL,5,ncdimsid2,ncddvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncddvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncddvid,descr,32, & +! 'ACCUMULATED TOTAL DRY DEPOSITION') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncddvid,units,unit2dlen,unit2d) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncddvid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'WETDEP variable' +! ncret = nf_def_var(ncid,'WETDEP',NF_REAL,5,ncdimsid2,ncwdvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncwdvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncwdvid,descr,32, & +! 'ACCUMULATED TOTAL WET DEPOSITION') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncwdvid,units,unit2dlen,unit2d) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncwdvid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! +! ! Add unit attr to mixing ratio and concentration fields +! ncret = nf_put_att_text(ncid,nccovid,units,6,'ng m-3') !CONC +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncravid,units,3,'ppt') !MIX +! call check_ncerror(ncret) +! else ! Backward run +! if (ind_rel.eq.1) then ! release in mass +! write(*,*) 'A' +! !Concentration field should be in 's' (?) +! ncret = nf_put_att_text(ncid,nccovid,units,1,'s') !CONC +! !call check_ncerror(ncret) +! !Mixing ratio field should be in 's kg m-3' (?) +! !ncret = nf_put_att_text(ncid,ncravid,units,8,'s kg m-3') !RATIO +! !call check_ncerror(ncret) +! else ! release in mass mix +! !Concentration should be in 's m3 kg-1' (?) +! write(*,*) 'B' +! ncret = nf_put_att_text(ncid,nccovid,units,9,'s m3 kg-1') !CONC +! !call check_ncerror(ncret) +! !Mixing ratio should be in 's' (?) +! ncret = nf_put_att_text(ncid,ncravid,units,1,'s') !RATIO +! !call check_ncerror(ncret) +! endif +! endif ! Backward/Forward run + + ! EXIT DEFINE MODE, ENTER DATA MODE + ncret = nf_enddef(ncid) + call check_ncerror(ncret) + + ! DIMENSION VARIABLES + if (option_verbose.ge.10) write(*,10) 'ZTOP data' + ncret = nf_put_var_real(ncid,nclvlvid,outheight) + call check_ncerror(ncret) + + ! X,Y - Lon,Lat + if (option_verbose.ge.10) write(*,10) 'XLAT,XLONG data' + + if (outgrid_option.eq.0) then ! irregular + do jy=1,ncgrid_ny + do ix=1,ncgrid_nx + tmpx=ncgrid_xm0+(float(ix)-0.5)*ncgrid_dx + tmpy=ncgrid_ym0+(float(jy)-0.5)*ncgrid_dy + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + ncret = nf_put_vara_real(ncid,nclonvid,(/ix,jy/),(/1,1/),tmplon) + call check_ncerror(ncret) + ncret = nf_put_vara_real(ncid,nclatvid,(/ix,jy/),(/1,1/),tmplat) + call check_ncerror(ncret) + tmpx=ncgrid_xm0+(float(ix)-1.)*ncgrid_dx + tmpy=ncgrid_ym0+(float(jy)-1.)*ncgrid_dy + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + ncret = nf_put_vara_real(ncid,nclonvid2,(/ix,jy/),(/1,1/),tmplon) + call check_ncerror(ncret) + ncret = nf_put_vara_real(ncid,nclatvid2,(/ix,jy/),(/1,1/),tmplat) + call check_ncerror(ncret) + enddo + enddo + else + do jy=1,ncgrid_ny + do ix=1,ncgrid_nx + call ll_to_xymeter_wrf(ncgrid_swlon,ncgrid_swlat,xsw,ysw) + call ll_to_xymeter_wrf(ncgrid_nelon,ncgrid_nelat,xne,yne) + tmpx=xsw+(xne-xsw)*float(ix-1)/float(ncgrid_nx-1) + tmpy=ysw+(yne-ysw)*float(jy-1)/float(ncgrid_ny-1) + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + xl2=ncgrid_lon0+(float(ix)-0.5)*dxoutl !long + yl2=ncgrid_lat0+(float(jy)-0.5)*dyoutl !lat + ncret = nf_put_vara_real(ncid,nclonvid,(/ix,jy/),(/1,1/),xl2) + call check_ncerror(ncret) + ncret = nf_put_vara_real(ncid,nclatvid,(/ix,jy/),(/1,1/),yl2) + call check_ncerror(ncret) + xl2=ncgrid_lon0+(float(ix)-1.)*dxoutl !long + yl2=ncgrid_lat0+(float(jy)-1.)*dyoutl !lat + ncret = nf_put_vara_real(ncid,nclonvid2,(/ix,jy/),(/1,1/),xl2) + call check_ncerror(ncret) + ncret = nf_put_vara_real(ncid,nclatvid2,(/ix,jy/),(/1,1/),yl2) + call check_ncerror(ncret) + enddo + enddo + endif ! outgrid_option + + + ! Write information on release points: total number, then for each point: + ! start, end, coordinates, # of particles, name, mass + !************************************************************************ + do i=1,numpoint + xp1=xpoint1(i)*dx+xlon0 ! This is probably wrong, but it seems to be + yp1=ypoint1(i)*dy+ylat0 ! the same in writeheader*.f90, so I'll leave + xp2=xpoint2(i)*dx+xlon0 ! it for now... //AD + yp2=ypoint2(i)*dy+ylat0 ! + + if (option_verbose.ge.10) write(*,10) 'ReleaseTstart_end data' + ncret = nf_put_vara_int(ncid,ncrtvid, & ! ReleaseTstart_end + (/1,i/),(/2,1/),(/ireleasestart(i),ireleaseend(i)/)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseXstart_end data' + ncret = nf_put_vara_real(ncid,ncrxvid, & ! ReleaseXstart_end + (/1,i/),(/2,1/),(/xp1,xp2/)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseYstart_end data' + ncret = nf_put_vara_real(ncid,ncryvid, & !ReleaseYstart_end + (/1,i/),(/2,1/),(/yp1,yp2/)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseZstart_end data' + ncret = nf_put_vara_real(ncid,ncrzvid, & !ReleaseZstart_end + (/1,i/),(/2,1/),(/zpoint1(i),zpoint2(i)/)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseXMass data' + ncret = nf_put_vara_real(ncid,ncrmvid, & !ReleaseXMass + (/1,i/),(/nspec,1/),xmass(i,1:nspec)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseNP data' + ncret = nf_put_vara_int(ncid,ncspvid, & !ReleaseNP + i,1,npart(i)) + call check_ncerror(ncret) + + !Release Name/Comment + j=1 ! Find the length of each release point comment/name + do while( j.lt.45.and.compoint(i)(j+1:j+1).ne." ") + j=j+1 + enddo + if (option_verbose.ge.10) write(*,10) 'ReleaseName data' + ncret = nf_put_vara_text(ncid,ncrnvid,(/1,i/),(/j,1/),compoint(i)(1:j)) + call check_ncerror(ncret) + enddo + + ! Write age class information + !**************************** + if (option_verbose.ge.10) write(*,10) 'AGECLASSES data' + ncret = nf_put_var_int(ncid,ncagevid,lage(1:nageclass)) + call check_ncerror(ncret) + + ! Write topography to output file + !******************************** + if (option_verbose.ge.10) write(*,10) 'TOPOGRAPHY data' +! do ix=0,ncgrid_nx-1 + do ix=1,ncgrid_nx + ncret = nf_put_vara_real(ncid,nctovid, & +! (/ix+1,1/),(/1,ncgrid_ny/),ncgrid_oro(ix,0:ncgrid_ny-1)) + (/ix,1/),(/1,ncgrid_ny/),ncgrid_oro(ix,1:ncgrid_ny)) + call check_ncerror(ncret) + enddo + + ! Write grid cell surface area + !***************************** + if (option_verbose.ge.10) write(*,10) 'GRIDAREA data' +! do ix=0,ncgrid_nx-1 + do ix=1,ncgrid_nx + ncret = nf_put_vara_real(ncid,ncarvid, & +! (/ix+1,1/),(/1,ncgrid_ny/),ncgrid_area(ix,0:ncgrid_ny-1)) + (/ix,1/),(/1,ncgrid_ny/),ncgrid_area(ix,1:ncgrid_ny)) + call check_ncerror(ncret) + enddo + + ! SAVE CREATED NETCDF TO FILE + !**************************** + if (option_verbose.ge.1) write(*,*) 'write_ncheader: writing to disk' + ncret = nf_sync(ncid) + call check_ncerror(ncret) + + return + +10 format('write_ncheader: Setting up ',A) + + ncret=nf_close(ncid) + deallocate(ncgrid_oro,ncgrid_area) +end subroutine write_ncheader diff --git a/src_flexwrf_v3.1/write_ncheader_v3.f90 b/src_flexwrf_v3.1/write_ncheader_v3.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d9a508a94bd79bb88d246dd71454587b59a65f62 --- /dev/null +++ b/src_flexwrf_v3.1/write_ncheader_v3.f90 @@ -0,0 +1,768 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* Adam Dingwell * +!* * +!* This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine write_ncheader(itime,nesting_level) + + !***************************************************************************** + ! * + ! This routine perdefines a netcdf ouput file with information on flexpart * + ! settings, releases and topography. * + ! * + ! Author: A. Dingwell * + ! * + ! 27 May 2013 * + ! * + ! Modifications * + ! June 5 2013: J. Brioude: generate a header*nc * + !***************************************************************************** + + use point_mod + use outg_mod + use com_mod + + implicit none + + include 'netcdf.inc' + + integer :: itime,stat ! seconds since simulation start + integer :: nesting_level ! 0 for main grid (mother) 1 for nest (child) + ! this is written to be easy to expand is additional + ! are desired in the future + + real(kind=dp) :: jul ! Julian date + integer :: jjjjmmdd,ihmmss ! date & time as integer + character :: adate*8,atime*6 ! date and time strings, used for filename + + ! Grid related variables + real :: xp1,yp1,xp2,yp2 ! temporary coordinates + real :: xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat,xl2,yl2 + integer :: ncgrid_nx,ncgrid_ny ! nx,ny of current grid + integer :: ncgrid_dx,ncgrid_dy ! dx,dy of current grid in m or latlon + real :: ncgrid_swlon,ncgrid_swlat ! SW corner of current grid in latlon + real :: ncgrid_nelon,ncgrid_nelat ! NE corner of current grid in latlon + real :: ncgrid_xm0,ncgrid_ym0 ! lower-left grid coord in metres + real :: ncgrid_lon0,ncgrid_lat0 ! lower-left grid coord in latlon + + ! Grid related 2D-variables (reassigning these here is a bit inefficient but + ! it lets us keep a consistent structure of the code, besides it's only once + ! per output + real,allocatable,dimension (:,:) :: ncgrid_oro,ncgrid_area ! of current grid + + ! Iterators + integer i,j,ix,jy + + ! NETCDF file related variables + integer nclvlid,nclonid,nclatid,ncrecid,ncspcid,ncageid !outgrid dimension ids + integer ncrelid,ncrseid ! release points dimension ids + integer ncrnvid,ncrmvid,ncspvid ! release points: number,mass,species ids + integer ncrtvid,ncrxvid,ncryvid,ncrzvid ! release points: t,x,y,z min/max limits + integer nctovid,ncarvid ! Topography and grid area variable-ids + integer ncstr1id,ncstr2id,ncstr3id ! decrtiption string length dimid + integer nclvlvid,nclonvid,nclatvid,ncspcvid,ncagevid ! outgrid dimension variables + integer nclonvid2,nclatvid2 + integer ncdimsid3(6),ncdimsid2(5) ! arrays of dimension ids for outgrid 3D & 2D + + ! NETCDF filename & attribute related variables + character descr*11,units*5,ncname*29,coord*11,coordxy*10 + integer coordxylen + character unit2d*10 ! unit for deposition fields + integer unit2dlen ! length of character string + + ! NETCDF misc variables + integer ncid ! local container for netcdf file-id (either ncout or ncoutn) + integer ncret ! Return-value of calls to nf_* utils + integer :: deflate_level=1 ! compression level + integer :: shuffle=1 ! shuffle +! integer :: chunks(2) ! shuffle + ! Attribute notation: + descr = 'description' + units = 'units' + coord = 'coordinates' + coordxy = 'XLONG XLAT' + coordxylen = 10 + + ! 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 header output file + !************************ +! write(ncname,'(A8,I2.2,A1,I8.8,A1,I6.6,A3)') & +! 'flxout_d',nesting_level+1,'_',jjjjmmdd,'_',ihmmss,'.nc' ! filename + write(ncname,'(A8,I2.2,A3)') & + 'header_d',nesting_level+1,'.nc' ! filename + + +! call nf_set_log_level(3) + if (option_verbose.ge.1) write(*,*) & + 'write_ncheader: creating file: ',path(1)(1:length(1))//ncname +! call nf_set_chunk_cache(32000000) + ncret = nf_create(path(1)(1:length(1))//ncname, nf_clobber,ncid) +! ncret = nf_create(path(1)(1:length(1))//ncname, NF_NETCDF4,ncid) + call check_ncerror(ncret) + + ! Determine which nest/outfile we just created so we can set up the grid + !*********************************************************************** + if (nesting_level.eq.0) then ! current grid is main grid + ncout = ncid ! copy current file handle to ncout + ncgrid_nx = numxgrid + ncgrid_ny = numygrid + ncgrid_nelon = outgrid_nelon + ncgrid_nelat = outgrid_nelat + ncgrid_swlon = outgrid_swlon + ncgrid_swlat = outgrid_swlat + allocate(ncgrid_oro(ncgrid_nx,ncgrid_ny),stat=stat) + allocate(ncgrid_area(ncgrid_nx,ncgrid_ny),stat=stat) + ncgrid_oro = oroout(0:ncgrid_nx-1,0:ncgrid_ny-1) + ncgrid_area = area(0:ncgrid_nx-1,0:ncgrid_ny-1) + if (outgrid_option.eq.1) then ! input was in latlon + ncgrid_dx = dxoutl + ncgrid_dy = dyoutl + ncgrid_lon0 = outlon0 + ncgrid_lat0 = outlat0 + else ! input was in metres + ncgrid_dx = dxout + ncgrid_dy = dyout + ncgrid_xm0 = out_xm0 + ncgrid_ym0 = out_ym0 + endif + elseif (nesting_level.eq.1) then ! current grid is nested + ncoutn = ncid ! copy current file handle to ncoutn + ncgrid_nx = numxgridn + ncgrid_ny = numygridn + ncgrid_nelon = outgridn_nelon + ncgrid_nelat = outgridn_nelat + ncgrid_swlon = outgridn_swlon + ncgrid_swlat = outgridn_swlat + allocate(ncgrid_oro(ncgrid_nx,ncgrid_ny),stat=stat) + allocate(ncgrid_area(ncgrid_nx,ncgrid_ny),stat=stat) + ncgrid_oro = orooutn(0:ncgrid_nx-1,0:ncgrid_ny-1) + ncgrid_area = arean(0:ncgrid_nx-1,0:ncgrid_ny-1) + if (outgrid_option.eq.1) then ! input was in latlon + ncgrid_dx = dxoutln + ncgrid_dy = dyoutln + ncgrid_lon0 = outlon0n + ncgrid_lat0 = outlat0n + else ! input was in metres + ncgrid_dx = dxoutn + ncgrid_dy = dyoutn + ncgrid_xm0 = out_xm0n + ncgrid_ym0 = out_ym0n + endif + endif + + if (option_verbose.ge.10) & + write(*,*) 'write_ncheader: ncout,ncoutn=',ncout,ncoutn + + ! Write the header information + !***************************** + + !ncret = nf_put_att_text(ncout,nf_global,'TITLE',20,version) + !call check_ncerror(ncret) + if (ldirect.eq.1) then ! Forward simulation + if (option_verbose.ge.10) write(*,10) 'forward simulation attributes' + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_DATE',nf_int,1,ibdate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_TIME',nf_int,1,ibtime) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_DATE',nf_int,1,iedate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_TIME',nf_int,1,ietime) + call check_ncerror(ncret) + else ! Backward simulation + if (option_verbose.ge.10) write(*,10) 'backward simulation attributes' + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_DATE',nf_int,1,iedate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_TIME',nf_int,1,ietime) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_DATE',nf_int,1,ibdate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_TIME',nf_int,1,ibtime) + call check_ncerror(ncret) + endif + + if (option_verbose.ge.10) write(*,10) 'map projection attributes' + if (outgrid_option .eq. 1) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',20,'Regular Latit/Longit') + call check_ncerror(ncret) + else + if (map_proj_id.eq.1) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',17,'Lambert conformal') + call check_ncerror(ncret) + elseif (map_proj_id.eq.2) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',13,'stereographic') + call check_ncerror(ncret) + elseif (map_proj_id.eq.3) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',8,'mercator') + call check_ncerror(ncret) + elseif (map_proj_id.eq.4) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',6,'global') + call check_ncerror(ncret) + endif + endif + + ! Write info common model settings + !********************************* + if (option_verbose.ge.10) write(*,10) 'common model attributes' + + if (option_verbose.ge.10) write(*,10) 'OUTPUT_INTERVAL' + ncret = nf_put_att_int(ncid,nf_global,'OUTPUT_INTERVAL',nf_int,1,loutstep) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'AVERAGING_TIME' + ncret = nf_put_att_int(ncid,nf_global,'AVERAGING_TIME',nf_int,1,loutaver) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'AVERAGE_SAMPLING' + ncret = nf_put_att_int(ncid,nf_global,'AVERAGE_SAMPLING',nf_int,1,loutsample) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'NSPEC',nf_int,1,nspec) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'NUMRECEPTOR',nf_int,1,numreceptor) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'NAGECLASS',nf_int,1,nageclass) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'NUMRELEASES',nf_int,1,numpoint) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'DISPERSION_METHOD',nf_int,1,method) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SUBGRID_TOPOGRAPHY',nf_int,1,lsubgrid) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'CONVECTION_PARAM',nf_int,1,lconvection) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SUBGRID_TOPOGRAPHY',nf_int,1,lsubgrid) + call check_ncerror(ncret) + + ! Write information on output grid setup + !*************************************** + if (option_verbose.ge.10) write(*,10) 'WEST-EAST_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'WEST-EAST_GRID_DIMENSION', & + nf_int,1,ncgrid_nx) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'SOUTH-NORTH_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'SOUTH-NORTH_GRID_DIMENSION', & + nf_int,1,ncgrid_ny) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'BOTTOM-TOP_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'BOTTOM-TOP_GRID_DIMENSION', & + nf_int,1,numzgrid) + + if (option_verbose.ge.10) write(*,10) 'DX and DY' + ncret = nf_put_att_int(ncid,nf_global,'DX',nf_int,1,ncgrid_dx) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'DY',nf_int,1,ncgrid_dy) + call check_ncerror(ncret) + + ! Set up netcdf dimensions + !************************* + if (option_verbose.ge.10) write(*,10) 'main grid dimensions' + + ncret = nf_def_dim(ncid,'Time',nf_unlimited,ncrecid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'DateStrLen',15,ncstr3id) !TODO: WRF format + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'west_east',ncgrid_nx,nclonid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'south_north',ncgrid_ny,nclatid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'bottom_top',numzgrid,nclvlid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'species',nspec,ncspcid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'SpeciesStrLen',10,ncstr1id) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ageclass',nageclass,ncageid) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'release point dimensions' + ncret = nf_def_dim(ncid,'releases',numpoint,ncrelid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ReleaseStrLen',45,ncstr2id) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ReleaseStartEnd',2,ncrseid) + call check_ncerror(ncret) + + ! Select which dimensions to use for main output grids + ncdimsid3(1) = nclonid ! X + ncdimsid3(2) = nclatid ! Y + ncdimsid3(3) = nclvlid ! Z + if (ldirect.eq.1) ncdimsid3(4) = ncspcid ! species + if (ldirect.eq.-1) ncdimsid3(4) = ncrelid ! points + ncdimsid3(5) = ncageid ! ageclass + ncdimsid3(6) = ncrecid ! t + + ncdimsid2(1) = nclonid ! X + ncdimsid2(2) = nclatid ! Y + if (ldirect.eq.1) ncdimsid2(3) = ncspcid ! species + if (ldirect.eq.-1) ncdimsid2(3) = ncrelid ! points + ncdimsid2(4) = ncageid ! ageclass + ncdimsid2(5) = ncrecid ! t + + ! Set up dimension variables + !*************************** + + ! XLONG + if (option_verbose.ge.10) write(*,10) 'XLONG dimension variable' + ncret = nf_def_var(ncid,'XLONG',nf_real,2,ncdimsid2(1:2),nclonvid) + +! Turn on deflate compression, fletcher32 checksum. +! ncret = NF_DEF_VAR_deflate(ncid,nclonvid, shuffle, 1, deflate_level) +! if (ncret .ne. nf_noerr) call handle_err(retval) +! ncret = NF_DEF_VAR_FLETCHER32(ncid, nclonvid, NF_FLETCHER32) +! if (ncret .ne. nf_noerr) call handle_err(retval) + +! ncret = nf_def_var_deflate(ncid,'XLONG',nf_real,2,ncdimsid2(1:2),nclonvid,deflate_level=deflate_level) + + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclonvid,descr,42,'Longitude of center grid, west is negative') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclonvid,units,11,'degree_east') + call check_ncerror(ncret) + + ncret = nf_def_var(ncid,'XLONG_CORNER',nf_real,2,ncdimsid2(1:2),nclonvid2) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclonvid2,descr,57,'Longitude of lower left corner of grids, west is negative') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclonvid2,units,11,'degree_east') + call check_ncerror(ncret) + + + ! XLAT + if (option_verbose.ge.10) write(*,10) 'XLAT dimension variable' + ncret = nf_def_var(ncid,'XLAT',nf_real,2,ncdimsid2(1:2),nclatvid) +! ncret = nf_def_var_deflate(ncid,'XLAT',nf_real,2,ncdimsid2(1:2),nclatvid,deflate_level=deflate_level) +! ncret = NF_DEF_VAR_deflate(ncid,nclatvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclatvid,descr,42,'Latitude of center grid, south is negative') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclatvid,units,12,'degree_north') + call check_ncerror(ncret) + + ncret = nf_def_var(ncid,'XLAT_CORNER',nf_real,2,ncdimsid2(1:2),nclatvid2) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclatvid2,descr,57,'Latitude of lower left corner of grids, south is negative') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclatvid2,units,12,'degree_north') + call check_ncerror(ncret) + + ! ZTOP + if (option_verbose.ge.10) write(*,10) 'ZTOP dimension variable' + ncret = nf_def_var(ncid,'ZTOP',nf_real,1,ncdimsid3(3),nclvlvid) +! ncret = NF_DEF_VAR_deflate(ncid,nclvlvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclvlvid,descr,32, & + 'UPPER BOUNDARY OF MODEL LAYER') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nclvlvid,units,1,'m') + call check_ncerror(ncret) + + ! SPECIES + if (option_verbose.ge.10) write(*,10) 'SPECIES dimension variable' + ncret = nf_def_var(ncid,'SPECIES',nf_char,2,(/ncstr1id,ncspcid/),ncspcvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncspcvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncspcvid,descr,15,'NAME OF SPECIES') + call check_ncerror(ncret) + + ! AGECLASSES + if (option_verbose.ge.10) write(*,10) 'AGECLASSES dimension variable' + ncret = nf_def_var(ncid,'AGECLASS',nf_int,1,ncageid,ncagevid) +! ncret = NF_DEF_VAR_deflate(ncid,ncagevid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncagevid,descr,27,'MAX AGE OF SPECIES IN CLASS') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncagevid,units,1,'s') + call check_ncerror(ncret) + + ! TIMES + if (option_verbose.ge.10) write(*,10) 'TIMES dimension variable' + ncret = nf_def_var(ncid,'Times',nf_char,2,(/ncstr3id,ncrecid/),ncrecvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrecvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrecvid,descr,42, & + 'TIME OF OUTPUT (END OF AVERAGING INTERVAL)') + + ! Release related variables + if (option_verbose.ge.10) write(*,10) 'ReleaseName variable' + ncret = nf_def_var(ncid,'ReleaseName',nf_char,2,(/ncstr2id,ncrelid/),ncrnvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrnvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrnvid,descr,25,'RELEASE IDENTIFIER/COMMENT') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrnvid,units,1,'-') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseTstart_end variable' + ncret = nf_def_var(ncid,'ReleaseTstart_end', & + nf_int,2,(/ncrseid,ncrelid/),ncrtvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrtvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrtvid,descr,32, & + 'BEGINNING/ENDING TIME OF RELEASE (SECONDS SINCE RUN START)') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrtvid,units,1,'s') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseXstart_end variable' + ncret = nf_def_var(ncid,'ReleaseXstart_end', & + nf_float,2,(/ncrseid,ncrelid/),ncrxvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrxvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrxvid,descr,32, & + 'WEST/EAST BOUNDARIES OF SOURCE') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrxvid,units,12,'degree_north') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseYstart_end variable' + ncret = nf_def_var(ncid,'ReleaseYstart_end', & + nf_float,2,(/ncrseid,ncrelid/),ncryvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncryvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncryvid,descr,32, & + 'SOUTH/NORTH BOUNDARIES OF SOURCE') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncryvid,units,12,'degree_north') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseZstart_end variable' + ncret = nf_def_var(ncid,'ReleaseZstart_end', & + nf_float,2,(/ncrseid,ncrelid/),ncrzvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrzvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrzvid,descr,31, & + 'BOTTOM/TOP BOUNDARIES OF SOURCE') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrzvid,units,1,'m') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseNP variable' + ncret = nf_def_var(ncid,'ReleaseNP',nf_int,1,ncrelid,ncspvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncspvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncspvid,descr,34, & + 'TOTAL NUMBER OF PARTICLES RELEASED') + ncret = nf_put_att_text(ncid,ncspvid,units,1,'-') + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseXMass variable' + ncret = nf_def_var(ncid,'ReleaseXMass',nf_real,2,(/ncspcid,ncrelid/),ncrmvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrmvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrmvid,descr,18,'TOTAL MASS RELEASED') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrmvid,units,2,'kg') + call check_ncerror(ncret) + + ! Since we need to exit define mode before we can insert + ! variable data, we will include the last file attributes and + ! define the last variables here. + + ! DIRECTION INDEPENDENT OUTPUT VARIABLES + if (option_verbose.ge.10) write(*,10) 'TOPOGRAPHY variable' + ncret = nf_def_var(ncid,'TOPOGRAPHY',NF_real,2,ncdimsid2(1:2),nctovid) +! ncret = nf_def_var_deflate(ncid,'TOPOGRAPHY',NF_real,2,ncdimsid2(1:2),nctovid,deflate_level=deflate_level) +! ncret = NF_DEF_VAR_deflate(ncid,nctovid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nctovid,descr,33, & + 'TERRAIN ELEVATION ABOVE SEA LEVEL') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nctovid,units,1,'m') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nctovid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'GRIDAREA variable' + ncret = nf_def_var(ncid,'GRIDAREA',NF_real,2,ncdimsid2(1:2),ncarvid) +! ncret = nf_def_var_deflate(ncid,'GRIDAREA',NF_real,2,ncdimsid2(1:2),ncarvid,deflate_level=deflate_level) +! ncret = NF_DEF_VAR_deflate(ncid,ncarvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncarvid,descr,30, & + 'SURFACE AREA OF EACH GRID CELL') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncarvid,units,2,'m2') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncarvid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + + ! MAIN OUTPUT VARIABLES +! if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then ! CONCENTRATION +! if (option_verbose.ge.10) write(*,10) 'CONC variable' +! ncret = nf_def_var(ncid,'CONC',NF_REAL,6,ncdimsid3,nccovid) +!! chunks(1) = ncgrid_nx +!! chunks(2) = ncgrid_ny +!!! ncret = NF_DEF_VAR_CHUNKING(ncid, nccovid, NF_CHUNKED, chunks) +!! if (ncret .ne. nf_noerr) call check_ncerror(ncret) +! ncret = NF_DEF_VAR_deflate(ncid,nccovid, shuffle, 1, deflate_level) +! +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nccovid,descr,33, & +! 'CONCENTRATION OF AIRBORNE SPECIES') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nccovid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! endif + +! if ((iout.eq.2).or.(iout.eq.3)) then ! MIXING RATIO +! if (option_verbose.ge.10) write(*,10) 'MIXINGRATIO variable' +! ncret = nf_def_var(ncid,'MIXINGRATIO',NF_REAL,6,ncdimsid3,ncravid) +! ncret = NF_DEF_VAR_deflate(ncid,ncravid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncravid,descr,37, & +! 'MASS MIXING RATIO OF AIRBORNE SPECIES') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncravid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! endif +! +! if (ldirect.eq.1) then ! Forward run +! unit2d = 'pg m-2' +! unit2dlen = 6 +! +! if (option_verbose.ge.10) write(*,10) 'DRYDEP variable' +! write(*,*) ncdimsid2 +! ncret = nf_def_var(ncid,'DRYDEP',NF_REAL,5,ncdimsid2,ncddvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncddvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncddvid,descr,32, & +! 'ACCUMULATED TOTAL DRY DEPOSITION') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncddvid,units,unit2dlen,unit2d) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncddvid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'WETDEP variable' +! ncret = nf_def_var(ncid,'WETDEP',NF_REAL,5,ncdimsid2,ncwdvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncwdvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncwdvid,descr,32, & +! 'ACCUMULATED TOTAL WET DEPOSITION') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncwdvid,units,unit2dlen,unit2d) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncwdvid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! +! ! Add unit attr to mixing ratio and concentration fields +! ncret = nf_put_att_text(ncid,nccovid,units,6,'ng m-3') !CONC +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncravid,units,3,'ppt') !MIX +! call check_ncerror(ncret) +! else ! Backward run +! if (ind_rel.eq.1) then ! release in mass +! write(*,*) 'A' +! !Concentration field should be in 's' (?) +! ncret = nf_put_att_text(ncid,nccovid,units,1,'s') !CONC +! !call check_ncerror(ncret) +! !Mixing ratio field should be in 's kg m-3' (?) +! !ncret = nf_put_att_text(ncid,ncravid,units,8,'s kg m-3') !RATIO +! !call check_ncerror(ncret) +! else ! release in mass mix +! !Concentration should be in 's m3 kg-1' (?) +! write(*,*) 'B' +! ncret = nf_put_att_text(ncid,nccovid,units,9,'s m3 kg-1') !CONC +! !call check_ncerror(ncret) +! !Mixing ratio should be in 's' (?) +! ncret = nf_put_att_text(ncid,ncravid,units,1,'s') !RATIO +! !call check_ncerror(ncret) +! endif +! endif ! Backward/Forward run + + ! EXIT DEFINE MODE, ENTER DATA MODE + ncret = nf_enddef(ncid) + call check_ncerror(ncret) + + ! DIMENSION VARIABLES + if (option_verbose.ge.10) write(*,10) 'ZTOP data' + ncret = nf_put_var_real(ncid,nclvlvid,outheight) + call check_ncerror(ncret) + + ! X,Y - Lon,Lat + if (option_verbose.ge.10) write(*,10) 'XLAT,XLONG data' + + if (outgrid_option.eq.0) then ! irregular + do jy=1,ncgrid_ny + do ix=1,ncgrid_nx + tmpx=ncgrid_xm0+(float(ix)-0.5)*ncgrid_dx + tmpy=ncgrid_ym0+(float(jy)-0.5)*ncgrid_dy + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + ncret = nf_put_vara_real(ncid,nclonvid,(/ix,jy/),(/1,1/),tmplon) + call check_ncerror(ncret) + ncret = nf_put_vara_real(ncid,nclatvid,(/ix,jy/),(/1,1/),tmplat) + call check_ncerror(ncret) + tmpx=ncgrid_xm0+(float(ix)-1.)*ncgrid_dx + tmpy=ncgrid_ym0+(float(jy)-1.)*ncgrid_dy + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + ncret = nf_put_vara_real(ncid,nclonvid2,(/ix,jy/),(/1,1/),tmplon) + call check_ncerror(ncret) + ncret = nf_put_vara_real(ncid,nclatvid2,(/ix,jy/),(/1,1/),tmplat) + call check_ncerror(ncret) + enddo + enddo + else + do jy=1,ncgrid_ny + do ix=1,ncgrid_nx + call ll_to_xymeter_wrf(ncgrid_swlon,ncgrid_swlat,xsw,ysw) + call ll_to_xymeter_wrf(ncgrid_nelon,ncgrid_nelat,xne,yne) + tmpx=xsw+(xne-xsw)*float(ix-1)/float(ncgrid_nx-1) + tmpy=ysw+(yne-ysw)*float(jy-1)/float(ncgrid_ny-1) + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + xl2=ncgrid_lon0+(float(ix)-0.5)*dxoutl !long + yl2=ncgrid_lat0+(float(jy)-0.5)*dyoutl !lat + ncret = nf_put_vara_real(ncid,nclonvid,(/ix,jy/),(/1,1/),xl2) + call check_ncerror(ncret) + ncret = nf_put_vara_real(ncid,nclatvid,(/ix,jy/),(/1,1/),yl2) + call check_ncerror(ncret) + xl2=ncgrid_lon0+(float(ix)-1.)*dxoutl !long + yl2=ncgrid_lat0+(float(jy)-1.)*dyoutl !lat + ncret = nf_put_vara_real(ncid,nclonvid2,(/ix,jy/),(/1,1/),xl2) + call check_ncerror(ncret) + ncret = nf_put_vara_real(ncid,nclatvid2,(/ix,jy/),(/1,1/),yl2) + call check_ncerror(ncret) + + enddo + enddo + endif ! outgrid_option + + + ! Write information on release points: total number, then for each point: + ! start, end, coordinates, # of particles, name, mass + !************************************************************************ + do i=1,numpoint + xp1=xpoint1(i)*dx+xlon0 ! This is probably wrong, but it seems to be + yp1=ypoint1(i)*dy+ylat0 ! the same in writeheader*.f90, so I'll leave + xp2=xpoint2(i)*dx+xlon0 ! it for now... //AD + yp2=ypoint2(i)*dy+ylat0 ! + + if (option_verbose.ge.10) write(*,10) 'ReleaseTstart_end data' + ncret = nf_put_vara_int(ncid,ncrtvid, & ! ReleaseTstart_end + (/1,i/),(/2,1/),(/ireleasestart(i),ireleaseend(i)/)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseXstart_end data' + ncret = nf_put_vara_real(ncid,ncrxvid, & ! ReleaseXstart_end + (/1,i/),(/2,1/),(/xp1,xp2/)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseYstart_end data' + ncret = nf_put_vara_real(ncid,ncryvid, & !ReleaseYstart_end + (/1,i/),(/2,1/),(/yp1,yp2/)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseZstart_end data' + ncret = nf_put_vara_real(ncid,ncrzvid, & !ReleaseZstart_end + (/1,i/),(/2,1/),(/zpoint1(i),zpoint2(i)/)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseXMass data' + ncret = nf_put_vara_real(ncid,ncrmvid, & !ReleaseXMass + (/1,i/),(/nspec,1/),xmass(i,1:nspec)) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'ReleaseNP data' + ncret = nf_put_vara_int(ncid,ncspvid, & !ReleaseNP + i,1,npart(i)) + call check_ncerror(ncret) + + !Release Name/Comment + j=1 ! Find the length of each release point comment/name + do while( j.lt.45.and.compoint(i)(j+1:j+1).ne." ") + j=j+1 + enddo + if (option_verbose.ge.10) write(*,10) 'ReleaseName data' + ncret = nf_put_vara_text(ncid,ncrnvid,(/1,i/),(/j,1/),compoint(i)(1:j)) + call check_ncerror(ncret) + enddo + + ! Write age class information + !**************************** + if (option_verbose.ge.10) write(*,10) 'AGECLASSES data' + ncret = nf_put_var_int(ncid,ncagevid,lage(1:nageclass)) + call check_ncerror(ncret) + + ! Write topography to output file + !******************************** + if (option_verbose.ge.10) write(*,10) 'TOPOGRAPHY data' +! do ix=0,ncgrid_nx-1 + do ix=1,ncgrid_nx + ncret = nf_put_vara_real(ncid,nctovid, & +! (/ix+1,1/),(/1,ncgrid_ny/),ncgrid_oro(ix,0:ncgrid_ny-1)) + (/ix,1/),(/1,ncgrid_ny/),ncgrid_oro(ix,1:ncgrid_ny)) + call check_ncerror(ncret) + enddo + + ! Write grid cell surface area + !***************************** + if (option_verbose.ge.10) write(*,10) 'GRIDAREA data' +! do ix=0,ncgrid_nx-1 + do ix=1,ncgrid_nx + ncret = nf_put_vara_real(ncid,ncarvid, & +! (/ix+1,1/),(/1,ncgrid_ny/),ncgrid_area(ix,0:ncgrid_ny-1)) + (/ix,1/),(/1,ncgrid_ny/),ncgrid_area(ix,1:ncgrid_ny)) + call check_ncerror(ncret) + enddo + + ! SAVE CREATED NETCDF TO FILE + !**************************** + if (option_verbose.ge.1) write(*,*) 'write_ncheader: writing to disk' + ncret = nf_sync(ncid) + call check_ncerror(ncret) + + return + +10 format('write_ncheader: Setting up ',A) + + ncret=nf_close(ncid) + deallocate(ncgrid_oro,ncgrid_area) +end subroutine write_ncheader diff --git a/src_flexwrf_v3.1/write_ncinfo.f90 b/src_flexwrf_v3.1/write_ncinfo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..eb4d45f6805f1883bf675b2e95d2718465517c42 --- /dev/null +++ b/src_flexwrf_v3.1/write_ncinfo.f90 @@ -0,0 +1,786 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* Adam Dingwell * +!* * +!* This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine write_ncinfo(itime,nesting_level) + + !***************************************************************************** + ! * + ! This routine perdefines a netcdf ouput file with information on flexpart * + ! settings, releases and topography. * + ! * + ! Author: A. Dingwell * + ! * + ! 27 May 2013 * + ! * + ! Modifications: * + ! June 5 2013: J. Brioude: Create and write attributes to netcdf output only * + !***************************************************************************** + + use point_mod + use outg_mod + use com_mod + + implicit none + + include 'netcdf.inc' + + integer :: itime,stat ! seconds since simulation start + integer :: nesting_level ! 0 for main grid (mother) 1 for nest (child) + ! this is written to be easy to expand is additional + ! are desired in the future + + real(kind=dp) :: jul ! Julian date + integer :: jjjjmmdd,ihmmss ! date & time as integer + character :: adate*8,atime*6 ! date and time strings, used for filename + + ! Grid related variables + real :: xp1,yp1,xp2,yp2 ! temporary coordinates + real :: xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat,xl2,yl2 + integer :: ncgrid_nx,ncgrid_ny ! nx,ny of current grid + integer :: ncgrid_dx,ncgrid_dy ! dx,dy of current grid in m or latlon + real :: ncgrid_swlon,ncgrid_swlat ! SW corner of current grid in latlon + real :: ncgrid_nelon,ncgrid_nelat ! NE corner of current grid in latlon + real :: ncgrid_xm0,ncgrid_ym0 ! lower-left grid coord in metres + real :: ncgrid_lon0,ncgrid_lat0 ! lower-left grid coord in latlon + + ! Grid related 2D-variables (reassigning these here is a bit inefficient but + ! it lets us keep a consistent structure of the code, besides it's only once + ! per output +! real,allocatable,dimension (:,:) :: ncgrid_oro,ncgrid_area ! of current grid + + ! Iterators + integer i,j,ix,jy + + ! NETCDF file related variables + integer nclvlid,nclonid,nclatid,ncrecid,ncspcid,ncageid !outgrid dimension ids + integer ncrelid,ncrseid ! release points dimension ids + integer ncrnvid,ncrmvid,ncspvid ! release points: number,mass,species ids + integer ncrtvid,ncrxvid,ncryvid,ncrzvid ! release points: t,x,y,z min/max limits + integer nctovid,ncarvid ! Topography and grid area variable-ids + integer ncstr1id,ncstr2id,ncstr3id ! decrtiption string length dimid + integer nclvlvid,nclonvid,nclatvid,ncspcvid,ncagevid ! outgrid dimension variables + integer ncdimsid3(6),ncdimsid2(5) ! arrays of dimension ids for outgrid 3D & 2D + integer ncdimsid32(7),ncdimsid22(6) ! arrays of dimension ids for outgrid 3D & 2D + + ! NETCDF filename & attribute related variables + character descr*11,units*5,ncname*29,coord*11,coordxy*10 + integer coordxylen + character unit2d*10 ! unit for deposition fields + integer unit2dlen ! length of character string + + ! NETCDF misc variables + integer ncid ! local container for netcdf file-id (either ncout or ncoutn) + integer ncret ! Return-value of calls to nf_* utils + integer :: deflate_level=4 ! compression level + integer :: shuffle=0 ! shuffle +! integer :: chunks(2) ! shuffle + ! Attribute notation: + descr = 'description' + units = 'units' + coord = 'coordinates' + coordxy = 'XLONG XLAT' + coordxylen = 10 + + ! 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 header output file + !************************ + write(ncname,'(A8,I2.2,A1,I8.8,A1,I6.6,A3)') & + 'flxout_d',nesting_level+1,'_',jjjjmmdd,'_',ihmmss,'.nc' ! filename + +! print*,'step0',itime,jjjjmmdd,ihmmss + +! call nf_set_log_level(3) + if (option_verbose.ge.1) write(*,*) & + 'write_ncinfo: creating file: ',path(1)(1:length(1))//ncname +! call nf_set_chunk_cache(32000000) +! ncret = nf_create(path(1)(1:length(1))//ncname, nf_clobber,ncid) + ncret = nf_create(path(1)(1:length(1))//ncname, NF_NETCDF4,ncid) +! print*,'step1',ncret + call check_ncerror(ncret) + + + ! Determine which nest/outfile we just created so we can set up the grid + !*********************************************************************** + if (nesting_level.eq.0) then ! current grid is main grid + ncout = ncid ! copy current file handle to ncout + ncgrid_nx = numxgrid + ncgrid_ny = numygrid + ncgrid_nelon = outgrid_nelon + ncgrid_nelat = outgrid_nelat + ncgrid_swlon = outgrid_swlon + ncgrid_swlat = outgrid_swlat +! allocate(ncgrid_oro(ncgrid_nx,ncgrid_ny),stat=stat) +! allocate(ncgrid_area(ncgrid_nx,ncgrid_ny),stat=stat) +! ncgrid_oro = oroout(0:ncgrid_nx-1,0:ncgrid_ny-1) +! ncgrid_area = area(0:ncgrid_nx-1,0:ncgrid_ny-1) +! print*,'step2' + if (outgrid_option.eq.1) then ! input was in latlon + ncgrid_dx = dxoutl + ncgrid_dy = dyoutl + ncgrid_lon0 = outlon0 + ncgrid_lat0 = outlat0 + else ! input was in metres + ncgrid_dx = dxout + ncgrid_dy = dyout + ncgrid_xm0 = out_xm0 + ncgrid_ym0 = out_ym0 + endif + elseif (nesting_level.eq.1) then ! current grid is nested + ncoutn = ncid ! copy current file handle to ncoutn + ncgrid_nx = numxgridn + ncgrid_ny = numygridn + ncgrid_nelon = outgridn_nelon + ncgrid_nelat = outgridn_nelat + ncgrid_swlon = outgridn_swlon + ncgrid_swlat = outgridn_swlat +! allocate(ncgrid_oro(ncgrid_nx,ncgrid_ny),stat=stat) +! allocate(ncgrid_area(ncgrid_nx,ncgrid_ny),stat=stat) +! ncgrid_oro = orooutn(0:ncgrid_nx-1,0:ncgrid_ny-1) +! ncgrid_area = arean(0:ncgrid_nx-1,0:ncgrid_ny-1) + if (outgrid_option.eq.1) then ! input was in latlon + ncgrid_dx = dxoutln + ncgrid_dy = dyoutln + ncgrid_lon0 = outlon0n + ncgrid_lat0 = outlat0n + else ! input was in metres + ncgrid_dx = dxoutn + ncgrid_dy = dyoutn + ncgrid_xm0 = out_xm0n + ncgrid_ym0 = out_ym0n + endif + endif +! print*,'step3' + + if (option_verbose.ge.10) & + write(*,*) 'write_ncheader: ncout,ncoutn=',ncout,ncoutn + + ! Write the header information + !***************************** + + !ncret = nf_put_att_text(ncout,nf_global,'TITLE',20,version) + !call check_ncerror(ncret) +! print*,'continue' + if (ldirect.eq.1) then ! Forward simulation + if (option_verbose.ge.10) write(*,10) 'forward simulation attributes' + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_DATE',nf_int,1,ibdate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_TIME',nf_int,1,ibtime) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_DATE',nf_int,1,iedate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_TIME',nf_int,1,ietime) + call check_ncerror(ncret) + else ! Backward simulation + if (option_verbose.ge.10) write(*,10) 'backward simulation attributes' + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_DATE',nf_int,1,iedate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_TIME',nf_int,1,ietime) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_DATE',nf_int,1,ibdate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_TIME',nf_int,1,ibtime) + call check_ncerror(ncret) + endif + + if (option_verbose.ge.10) write(*,10) 'map projection attributes' + if (outgrid_option .eq. 1) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',20,'Regular Latit/Longit') + call check_ncerror(ncret) + else + if (map_proj_id.eq.1) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',17,'Lambert conformal') + call check_ncerror(ncret) + elseif (map_proj_id.eq.2) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',13,'stereographic') + call check_ncerror(ncret) + elseif (map_proj_id.eq.3) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',8,'mercator') + call check_ncerror(ncret) + elseif (map_proj_id.eq.4) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',6,'global') + call check_ncerror(ncret) + endif + endif + + ! Write info common model settings + !********************************* + if (option_verbose.ge.10) write(*,10) 'common model attributes' + + if (option_verbose.ge.10) write(*,10) 'OUTPUT_INTERVAL' + ncret = nf_put_att_int(ncid,nf_global,'OUTPUT_INTERVAL',nf_int,1,loutstep) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'AVERAGING_TIME' + ncret = nf_put_att_int(ncid,nf_global,'AVERAGING_TIME',nf_int,1,loutaver) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'AVERAGE_SAMPLING' + ncret = nf_put_att_int(ncid,nf_global,'AVERAGE_SAMPLING',nf_int,1,loutsample) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'NSPEC',nf_int,1,nspec) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'NUMRECEPTOR',nf_int,1,numreceptor) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'NAGECLASS',nf_int,1,nageclass) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'NUMRELEASES',nf_int,1,numpoint) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'DISPERSION_METHOD',nf_int,1,method) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SUBGRID_TOPOGRAPHY',nf_int,1,lsubgrid) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'CONVECTION_PARAM',nf_int,1,lconvection) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SUBGRID_TOPOGRAPHY',nf_int,1,lsubgrid) + call check_ncerror(ncret) + + ! Write information on output grid setup + !*************************************** + if (option_verbose.ge.10) write(*,10) 'WEST-EAST_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'WEST-EAST_GRID_DIMENSION', & + nf_int,1,ncgrid_nx) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'SOUTH-NORTH_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'SOUTH-NORTH_GRID_DIMENSION', & + nf_int,1,ncgrid_ny) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'BOTTOM-TOP_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'BOTTOM-TOP_GRID_DIMENSION', & + nf_int,1,numzgrid) + + if (option_verbose.ge.10) write(*,10) 'DX and DY' + ncret = nf_put_att_int(ncid,nf_global,'DX',nf_int,1,ncgrid_dx) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'DY',nf_int,1,ncgrid_dy) + call check_ncerror(ncret) + + ! Set up netcdf dimensions + !************************* + if (option_verbose.ge.10) write(*,10) 'main grid dimensions' + + ncret = nf_def_dim(ncid,'Time',nf_unlimited,ncrecid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'DateStrLen',15,ncstr3id) !TODO: WRF format + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'west_east',ncgrid_nx,nclonid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'south_north',ncgrid_ny,nclatid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'bottom_top',numzgrid,nclvlid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'species',nspec,ncspcid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'SpeciesStrLen',10,ncstr1id) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ageclass',nageclass,ncageid) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'release point dimensions' + ncret = nf_def_dim(ncid,'releases',numpoint,ncrelid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ReleaseStrLen',45,ncstr2id) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ReleaseStartEnd',2,ncrseid) + call check_ncerror(ncret) + + ! Select which dimensions to use for main output grids + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncdimsid32(1) = nclonid ! X + ncdimsid32(2) = nclatid ! Y + ncdimsid32(3) = nclvlid ! Z + ncdimsid32(4) = ncrelid ! points + ncdimsid32(5) = ncspcid ! species + ncdimsid32(6) = ncageid ! ageclass + ncdimsid32(7) = ncrecid ! t + + ncdimsid22(1) = nclonid ! X + ncdimsid22(2) = nclatid ! Y + ncdimsid22(3) = ncrelid ! points + ncdimsid22(4) = ncspcid ! species + ncdimsid22(5) = ncageid ! ageclass + ncdimsid22(6) = ncrecid ! t + + else + ncdimsid3(1) = nclonid ! X + ncdimsid3(2) = nclatid ! Y + ncdimsid3(3) = nclvlid ! Z + if (ldirect.eq.1) ncdimsid3(4) = ncspcid ! species + if (ldirect.eq.-1) ncdimsid3(4) = ncrelid ! points + ncdimsid3(5) = ncageid ! ageclass + ncdimsid3(6) = ncrecid ! t + + ncdimsid2(1) = nclonid ! X + ncdimsid2(2) = nclatid ! Y + if (ldirect.eq.1) ncdimsid2(3) = ncspcid ! species + if (ldirect.eq.-1) ncdimsid2(3) = ncrelid ! points + ncdimsid2(4) = ncageid ! ageclass + ncdimsid2(5) = ncrecid ! t + endif +! +! ! Set up dimension variables +! !*************************** +! +! ! XLONG +! if (option_verbose.ge.10) write(*,10) 'XLONG dimension variable' +! ncret = nf_def_var(ncid,'XLONG',nf_real,2,ncdimsid2(1:2),nclonvid) +! +!! Turn on deflate compression, fletcher32 checksum. +! ncret = NF_DEF_VAR_deflate(ncid,nclonvid, shuffle, 1, deflate_level) +!! if (ncret .ne. nf_noerr) call handle_err(retval) +!! ncret = NF_DEF_VAR_FLETCHER32(ncid, nclonvid, NF_FLETCHER32) +!! if (ncret .ne. nf_noerr) call handle_err(retval) +! +!! ncret = nf_def_var_deflate(ncid,'XLONG',nf_real,2,ncdimsid2(1:2),nclonvid,deflate_level=deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclonvid,descr,27,'LONGITUDE, WEST IS NEGATIVE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclonvid,units,11,'degree_east') +! call check_ncerror(ncret) +! +! ! XLAT +! if (option_verbose.ge.10) write(*,10) 'XLAT dimension variable' +! ncret = nf_def_var(ncid,'XLAT',nf_real,2,ncdimsid2(1:2),nclatvid) +!! ncret = nf_def_var_deflate(ncid,'XLAT',nf_real,2,ncdimsid2(1:2),nclatvid,deflate_level=deflate_level) +! ncret = NF_DEF_VAR_deflate(ncid,nclatvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclatvid,descr,27,'LATITUDE, SOUTH IS NEGATIVE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclatvid,units,12,'degree_north') +! call check_ncerror(ncret) +! +! ! ZTOP +! if (option_verbose.ge.10) write(*,10) 'ZTOP dimension variable' +! ncret = nf_def_var(ncid,'ZTOP',nf_real,1,ncdimsid3(3),nclvlvid) +! ncret = NF_DEF_VAR_deflate(ncid,nclvlvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclvlvid,descr,32, & +! 'UPPER BOUNDARY OF MODEL LAYER') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclvlvid,units,1,'m') +! call check_ncerror(ncret) +! +! ! SPECIES +! if (option_verbose.ge.10) write(*,10) 'SPECIES dimension variable' +! ncret = nf_def_var(ncid,'SPECIES',nf_char,2,(/ncstr1id,ncspcid/),ncspcvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncspcvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncspcvid,descr,15,'NAME OF SPECIES') +! call check_ncerror(ncret) +! +! ! AGECLASSES +! if (option_verbose.ge.10) write(*,10) 'AGECLASSES dimension variable' +! ncret = nf_def_var(ncid,'AGECLASS',nf_int,1,ncageid,ncagevid) +! ncret = NF_DEF_VAR_deflate(ncid,ncagevid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncagevid,descr,27,'MAX AGE OF SPECIES IN CLASS') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncagevid,units,1,'s') +! call check_ncerror(ncret) +! +! ! TIMES + if (option_verbose.ge.10) write(*,10) 'TIMES dimension variable' + ncret = nf_def_var(ncid,'Times',nf_char,2,(/ncstr3id,ncrecid/),ncrecvid) + ncret = NF_DEF_VAR_deflate(ncid,ncrecvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrecvid,descr,42, & + 'TIME OF OUTPUT (END OF AVERAGING INTERVAL)') +! +! ! Release related variables +! if (option_verbose.ge.10) write(*,10) 'ReleaseName variable' +! ncret = nf_def_var(ncid,'ReleaseName',nf_char,2,(/ncstr2id,ncrelid/),ncrnvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrnvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrnvid,descr,25,'RELEASE IDENTIFIER/COMMENT') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrnvid,units,1,'-') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseTstart_end variable' +! ncret = nf_def_var(ncid,'ReleaseTstart_end', & +! nf_int,2,(/ncrseid,ncrelid/),ncrtvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrtvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrtvid,descr,32, & +! 'BEGINNING/ENDING TIME OF RELEASE (SECONDS SINCE RUN START)') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrtvid,units,1,'s') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseXstart_end variable' +! ncret = nf_def_var(ncid,'ReleaseXstart_end', & +! nf_float,2,(/ncrseid,ncrelid/),ncrxvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrxvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrxvid,descr,32, & +! 'WEST/EAST BOUNDARIES OF SOURCE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrxvid,units,12,'degree_north') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseYstart_end variable' +! ncret = nf_def_var(ncid,'ReleaseYstart_end', & +! nf_float,2,(/ncrseid,ncrelid/),ncryvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncryvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncryvid,descr,32, & +! 'SOUTH/NORTH BOUNDARIES OF SOURCE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncryvid,units,12,'degree_north') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseZstart_end variable' +! ncret = nf_def_var(ncid,'ReleaseZstart_end', & +! nf_float,2,(/ncrseid,ncrelid/),ncrzvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrzvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrzvid,descr,31, & +! 'BOTTOM/TOP BOUNDARIES OF SOURCE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrzvid,units,1,'m') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseNP variable' +! ncret = nf_def_var(ncid,'ReleaseNP',nf_int,1,ncrelid,ncspvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncspvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncspvid,descr,34, & +! 'TOTAL NUMBER OF PARTICLES RELEASED') +! ncret = nf_put_att_text(ncid,ncspvid,units,1,'-') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseXMass variable' +! ncret = nf_def_var(ncid,'ReleaseXMass',nf_real,2,(/ncspcid,ncrelid/),ncrmvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrmvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrmvid,descr,18,'TOTAL MASS RELEASED') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrmvid,units,2,'kg') +! call check_ncerror(ncret) +! +! ! Since we need to exit define mode before we can insert +! ! variable data, we will include the last file attributes and +! ! define the last variables here. +! +! ! DIRECTION INDEPENDENT OUTPUT VARIABLES +! if (option_verbose.ge.10) write(*,10) 'TOPOGRAPHY variable' +! ncret = nf_def_var(ncid,'TOPOGRAPHY',NF_real,2,ncdimsid2(1:2),nctovid) +!! ncret = nf_def_var_deflate(ncid,'TOPOGRAPHY',NF_real,2,ncdimsid2(1:2),nctovid,deflate_level=deflate_level) +! ncret = NF_DEF_VAR_deflate(ncid,nctovid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nctovid,descr,33, & +! 'TERRAIN ELEVATION ABOVE SEA LEVEL') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nctovid,units,1,'m') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nctovid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'GRIDAREA variable' +! ncret = nf_def_var(ncid,'GRIDAREA',NF_real,2,ncdimsid2(1:2),ncarvid) +!! ncret = nf_def_var_deflate(ncid,'GRIDAREA',NF_real,2,ncdimsid2(1:2),ncarvid,deflate_level=deflate_level) +! ncret = NF_DEF_VAR_deflate(ncid,ncarvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncarvid,descr,30, & +! 'SURFACE AREA OF EACH GRID CELL') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncarvid,units,2,'m2') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncarvid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! + ! MAIN OUTPUT VARIABLES + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then ! CONCENTRATION + if (option_verbose.ge.10) write(*,10) 'CONC variable' +! print*,ncdimsid3 + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncret = nf_def_var(ncid,'CONC',NF_REAL,7,ncdimsid32,nccovid) + else + ncret = nf_def_var(ncid,'CONC',NF_REAL,6,ncdimsid3,nccovid) + endif +! chunks(1) = ncgrid_nx +! chunks(2) = ncgrid_ny +!! ncret = NF_DEF_VAR_CHUNKING(ncid, nccovid, NF_CHUNKED, chunks) + if (ncret .ne. nf_noerr) call check_ncerror(ncret) + ncret = NF_DEF_VAR_deflate(ncid,nccovid, shuffle, 1, deflate_level) + + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nccovid,descr,33, & + 'CONCENTRATION OF AIRBORNE SPECIES') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nccovid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + endif + + if ((iout.eq.2).or.(iout.eq.3)) then ! MIXING RATIO + if (option_verbose.ge.10) write(*,10) 'MIXINGRATIO variable' + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncret = nf_def_var(ncid,'MIXINGRATIO',NF_REAL,7,ncdimsid32,ncravid) + else + ncret = nf_def_var(ncid,'MIXINGRATIO',NF_REAL,6,ncdimsid3,ncravid) + endif + ncret = NF_DEF_VAR_deflate(ncid,ncravid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncravid,descr,37, & + 'MASS MIXING RATIO OF AIRBORNE SPECIES') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncravid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + endif + + if (ldirect.eq.1) then ! Forward run + unit2d = 'pg m-2' + unit2dlen = 6 + + if (option_verbose.ge.10) write(*,10) 'DRYDEP variable' +! write(*,*) ncdimsid2 + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncret = nf_def_var(ncid,'DRYDEP',NF_REAL,6,ncdimsid22,ncddvid) + else + ncret = nf_def_var(ncid,'DRYDEP',NF_REAL,5,ncdimsid2,ncddvid) + endif + ncret = NF_DEF_VAR_deflate(ncid,ncddvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncddvid,descr,32, & + 'ACCUMULATED TOTAL DRY DEPOSITION') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncddvid,units,unit2dlen,unit2d) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncddvid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'WETDEP variable' + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncret = nf_def_var(ncid,'WETDEP',NF_REAL,6,ncdimsid22,ncwdvid) + else + ncret = nf_def_var(ncid,'WETDEP',NF_REAL,5,ncdimsid2,ncwdvid) + endif + ncret = NF_DEF_VAR_deflate(ncid,ncwdvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncwdvid,descr,32, & + 'ACCUMULATED TOTAL WET DEPOSITION') +! call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncwdvid,units,unit2dlen,unit2d) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncwdvid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + + ! Add unit attr to mixing ratio and concentration fields + if (ind_samp.eq.0) then + ncret = nf_put_att_text(ncid,nccovid,units,6,'ng m-3') !CONC + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncravid,units,4,'ppt') !MIX + call check_ncerror(ncret) + else + ncret = nf_put_att_text(ncid,nccovid,units,11,'ppt by mass') !CONC + call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncravid,units,3,'???') !MIX +! call check_ncerror(ncret) + endif + else ! Backward run +! if ((ind_rel.eq.0).and.(ind_samp.eq.0) then ! release in mass +! write(*,*) 'A' + !Concentration field should be in 's' (?) + if ((ind_rel.eq.0).and.(ind_samp.eq.0)) ncret = nf_put_att_text(ncid,nccovid,units,1,'s') !CONC + if ((ind_rel.eq.0).and.(ind_samp.eq.-1)) ncret = nf_put_att_text(ncid,nccovid,units,9,'s m3 kg-1') !CONC + if ((ind_rel.eq.1).and.(ind_samp.eq.0)) ncret = nf_put_att_text(ncid,nccovid,units,8,'s kg m-3') !CONC + if ((ind_rel.eq.1).and.(ind_samp.eq.-1)) ncret = nf_put_att_text(ncid,nccovid,units,1,'s') !CONC + !call check_ncerror(ncret) + !Mixing ratio field should be in 's kg m-3' (?) + !ncret = nf_put_att_text(ncid,ncravid,units,8,'s kg m-3') !RATIO + !call check_ncerror(ncret) +! else ! release in mass mix + !Concentration should be in 's m3 kg-1' (?) +! write(*,*) 'B' +! ncret = nf_put_att_text(ncid,nccovid,units,9,'s m3 kg-1') !CONC + !call check_ncerror(ncret) + !Mixing ratio should be in 's' (?) + !ncret = nf_put_att_text(ncid,ncravid,units,1,'s') !RATIO + !call check_ncerror(ncret) +! endif + endif ! Backward/Forward run + + ! EXIT DEFINE MODE, ENTER DATA MODE + ncret = nf_enddef(ncid) + call check_ncerror(ncret) + + ! DIMENSION VARIABLES +! if (option_verbose.ge.10) write(*,10) 'ZTOP data' +! ncret = nf_put_var_real(ncid,nclvlvid,outheight) +! call check_ncerror(ncret) + +! ! X,Y - Lon,Lat +! if (option_verbose.ge.10) write(*,10) 'XLAT,XLONG data' +! +! if (outgrid_option.eq.0) then ! irregular +! do jy=1,ncgrid_ny +! do ix=1,ncgrid_nx +! tmpx=ncgrid_xm0+(float(ix)-0.5)*ncgrid_dx +! tmpy=ncgrid_ym0+(float(jy)-0.5)*ncgrid_dy +! call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) +! ncret = nf_put_vara_real(ncid,nclonvid,(/ix,jy/),(/1,1/),tmplon) +! call check_ncerror(ncret) +! ncret = nf_put_vara_real(ncid,nclatvid,(/ix,jy/),(/1,1/),tmplat) +! call check_ncerror(ncret) +! enddo +! enddo +! else +! do jy=1,ncgrid_ny +! do ix=1,ncgrid_nx +! call ll_to_xymeter_wrf(ncgrid_swlon,ncgrid_swlat,xsw,ysw) +! call ll_to_xymeter_wrf(ncgrid_nelon,ncgrid_nelat,xne,yne) +! tmpx=xsw+(xne-xsw)*float(ix-1)/float(ncgrid_nx-1) +! tmpy=ysw+(yne-ysw)*float(jy-1)/float(ncgrid_ny-1) +! call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) +! xl2=ncgrid_lon0+(float(ix)-0.5)*dxoutl !long +! yl2=ncgrid_lat0+(float(jy)-0.5)*dyoutl !lat +! ncret = nf_put_vara_real(ncid,nclonvid,(/ix,jy/),(/1,1/),xl2) +! call check_ncerror(ncret) +! ncret = nf_put_vara_real(ncid,nclatvid,(/ix,jy/),(/1,1/),yl2) +! call check_ncerror(ncret) +! enddo +! enddo +! endif ! outgrid_option + + +! ! Write information on release points: total number, then for each point: +! ! start, end, coordinates, # of particles, name, mass +! !************************************************************************ +! do i=1,numpoint +! xp1=xpoint1(i)*dx+xlon0 ! This is probably wrong, but it seems to be +! yp1=ypoint1(i)*dy+ylat0 ! the same in writeheader*.f90, so I'll leave +! xp2=xpoint2(i)*dx+xlon0 ! it for now... //AD +! yp2=ypoint2(i)*dy+ylat0 ! +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseTstart_end data' +! ncret = nf_put_vara_int(ncid,ncrtvid, & ! ReleaseTstart_end +! (/1,i/),(/2,1/),(/ireleasestart(i),ireleaseend(i)/)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseXstart_end data' +! ncret = nf_put_vara_real(ncid,ncrxvid, & ! ReleaseXstart_end +! (/1,i/),(/2,1/),(/xp1,xp2/)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseYstart_end data' +! ncret = nf_put_vara_real(ncid,ncryvid, & !ReleaseYstart_end +! (/1,i/),(/2,1/),(/yp1,yp2/)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseZstart_end data' +! ncret = nf_put_vara_real(ncid,ncrzvid, & !ReleaseZstart_end +! (/1,i/),(/2,1/),(/zpoint1(i),zpoint2(i)/)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseXMass data' +! ncret = nf_put_vara_real(ncid,ncrmvid, & !ReleaseXMass +! (/1,i/),(/nspec,1/),xmass(i,1:nspec)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseNP data' +! ncret = nf_put_vara_int(ncid,ncspvid, & !ReleaseNP +! i,1,npart(i)) +! call check_ncerror(ncret) +! +! !Release Name/Comment +! j=1 ! Find the length of each release point comment/name +! do while( j.lt.45.and.compoint(i)(j+1:j+1).ne." ") +! j=j+1 +! enddo +! if (option_verbose.ge.10) write(*,10) 'ReleaseName data' +! ncret = nf_put_vara_text(ncid,ncrnvid,(/1,i/),(/j,1/),compoint(i)(1:j)) +! call check_ncerror(ncret) +! enddo +! +! ! Write age class information +! !**************************** +! if (option_verbose.ge.10) write(*,10) 'AGECLASSES data' +! ncret = nf_put_var_int(ncid,ncagevid,lage(1:nageclass)) +! call check_ncerror(ncret) +! +! ! Write topography to output file +! !******************************** +! if (option_verbose.ge.10) write(*,10) 'TOPOGRAPHY data' +!! do ix=0,ncgrid_nx-1 +! do ix=1,ncgrid_nx +! ncret = nf_put_vara_real(ncid,nctovid, & +!! (/ix+1,1/),(/1,ncgrid_ny/),ncgrid_oro(ix,0:ncgrid_ny-1)) +! (/ix,1/),(/1,ncgrid_ny/),ncgrid_oro(ix,1:ncgrid_ny)) +! call check_ncerror(ncret) +! enddo +! +! ! Write grid cell surface area +! !***************************** +! if (option_verbose.ge.10) write(*,10) 'GRIDAREA data' +!! do ix=0,ncgrid_nx-1 +! do ix=1,ncgrid_nx +! ncret = nf_put_vara_real(ncid,ncarvid, & +!! (/ix+1,1/),(/1,ncgrid_ny/),ncgrid_area(ix,0:ncgrid_ny-1)) +! (/ix,1/),(/1,ncgrid_ny/),ncgrid_area(ix,1:ncgrid_ny)) +! call check_ncerror(ncret) +! enddo +! +! ! SAVE CREATED NETCDF TO FILE +! !**************************** +! if (option_verbose.ge.1) write(*,*) 'write_ncheader: writing to disk' +! ncret = nf_sync(ncid) +! call check_ncerror(ncret) + + return + +10 format('write_ncheader: Setting up ',A) + +! deallocate(ncgrid_oro,ncgrid_area) +end subroutine write_ncinfo diff --git a/src_flexwrf_v3.1/write_ncinfo_v3.f90 b/src_flexwrf_v3.1/write_ncinfo_v3.f90 new file mode 100644 index 0000000000000000000000000000000000000000..832bf6f6b09bd909ad351a9f10e63216594c2a98 --- /dev/null +++ b/src_flexwrf_v3.1/write_ncinfo_v3.f90 @@ -0,0 +1,774 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* Adam Dingwell * +!* * +!* This file is part of FLEXPART WRF * +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine write_ncinfo(itime,nesting_level) + + !***************************************************************************** + ! * + ! This routine perdefines a netcdf ouput file with information on flexpart * + ! settings, releases and topography. * + ! * + ! Author: A. Dingwell * + ! * + ! 27 May 2013 * + ! * + ! Modifications: * + ! June 5 2013: J. Brioude: Create and write attributes to netcdf output only * + !***************************************************************************** + + use point_mod + use outg_mod + use com_mod + + implicit none + + include 'netcdf.inc' + + integer :: itime,stat ! seconds since simulation start + integer :: nesting_level ! 0 for main grid (mother) 1 for nest (child) + ! this is written to be easy to expand is additional + ! are desired in the future + + real(kind=dp) :: jul ! Julian date + integer :: jjjjmmdd,ihmmss ! date & time as integer + character :: adate*8,atime*6 ! date and time strings, used for filename + + ! Grid related variables + real :: xp1,yp1,xp2,yp2 ! temporary coordinates + real :: xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat,xl2,yl2 + integer :: ncgrid_nx,ncgrid_ny ! nx,ny of current grid + integer :: ncgrid_dx,ncgrid_dy ! dx,dy of current grid in m or latlon + real :: ncgrid_swlon,ncgrid_swlat ! SW corner of current grid in latlon + real :: ncgrid_nelon,ncgrid_nelat ! NE corner of current grid in latlon + real :: ncgrid_xm0,ncgrid_ym0 ! lower-left grid coord in metres + real :: ncgrid_lon0,ncgrid_lat0 ! lower-left grid coord in latlon + + ! Grid related 2D-variables (reassigning these here is a bit inefficient but + ! it lets us keep a consistent structure of the code, besides it's only once + ! per output +! real,allocatable,dimension (:,:) :: ncgrid_oro,ncgrid_area ! of current grid + + ! Iterators + integer i,j,ix,jy + + ! NETCDF file related variables + integer nclvlid,nclonid,nclatid,ncrecid,ncspcid,ncageid !outgrid dimension ids + integer ncrelid,ncrseid ! release points dimension ids + integer ncrnvid,ncrmvid,ncspvid ! release points: number,mass,species ids + integer ncrtvid,ncrxvid,ncryvid,ncrzvid ! release points: t,x,y,z min/max limits + integer nctovid,ncarvid ! Topography and grid area variable-ids + integer ncstr1id,ncstr2id,ncstr3id ! decrtiption string length dimid + integer nclvlvid,nclonvid,nclatvid,ncspcvid,ncagevid ! outgrid dimension variables + integer ncdimsid3(6),ncdimsid2(5) ! arrays of dimension ids for outgrid 3D & 2D + integer ncdimsid32(7),ncdimsid22(6) ! arrays of dimension ids for outgrid 3D & 2D + + ! NETCDF filename & attribute related variables + character descr*11,units*5,ncname*29,coord*11,coordxy*10 + integer coordxylen + character unit2d*10 ! unit for deposition fields + integer unit2dlen ! length of character string + + ! NETCDF misc variables + integer ncid ! local container for netcdf file-id (either ncout or ncoutn) + integer ncret ! Return-value of calls to nf_* utils + integer :: deflate_level=4 ! compression level + integer :: shuffle=0 ! shuffle +! integer :: chunks(2) ! shuffle + ! Attribute notation: + descr = 'description' + units = 'units' + coord = 'coordinates' + coordxy = 'XLONG XLAT' + coordxylen = 10 + + ! 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 header output file + !************************ + write(ncname,'(A8,I2.2,A1,I8.8,A1,I6.6,A3)') & + 'flxout_d',nesting_level+1,'_',jjjjmmdd,'_',ihmmss,'.nc' ! filename + +! print*,'step0',itime,jjjjmmdd,ihmmss + +! call nf_set_log_level(3) + if (option_verbose.ge.1) write(*,*) & + 'write_ncinfo: creating file: ',path(1)(1:length(1))//ncname +! call nf_set_chunk_cache(32000000) + ncret = nf_create(path(1)(1:length(1))//ncname, nf_clobber,ncid) +! ncret = nf_create(path(1)(1:length(1))//ncname, NF_NETCDF4,ncid) +! print*,'step1',ncret + call check_ncerror(ncret) + + + ! Determine which nest/outfile we just created so we can set up the grid + !*********************************************************************** + if (nesting_level.eq.0) then ! current grid is main grid + ncout = ncid ! copy current file handle to ncout + ncgrid_nx = numxgrid + ncgrid_ny = numygrid + ncgrid_nelon = outgrid_nelon + ncgrid_nelat = outgrid_nelat + ncgrid_swlon = outgrid_swlon + ncgrid_swlat = outgrid_swlat +! allocate(ncgrid_oro(ncgrid_nx,ncgrid_ny),stat=stat) +! allocate(ncgrid_area(ncgrid_nx,ncgrid_ny),stat=stat) +! ncgrid_oro = oroout(0:ncgrid_nx-1,0:ncgrid_ny-1) +! ncgrid_area = area(0:ncgrid_nx-1,0:ncgrid_ny-1) +! print*,'step2' + if (outgrid_option.eq.1) then ! input was in latlon + ncgrid_dx = dxoutl + ncgrid_dy = dyoutl + ncgrid_lon0 = outlon0 + ncgrid_lat0 = outlat0 + else ! input was in metres + ncgrid_dx = dxout + ncgrid_dy = dyout + ncgrid_xm0 = out_xm0 + ncgrid_ym0 = out_ym0 + endif + elseif (nesting_level.eq.1) then ! current grid is nested + ncoutn = ncid ! copy current file handle to ncoutn + ncgrid_nx = numxgridn + ncgrid_ny = numygridn + ncgrid_nelon = outgridn_nelon + ncgrid_nelat = outgridn_nelat + ncgrid_swlon = outgridn_swlon + ncgrid_swlat = outgridn_swlat +! allocate(ncgrid_oro(ncgrid_nx,ncgrid_ny),stat=stat) +! allocate(ncgrid_area(ncgrid_nx,ncgrid_ny),stat=stat) +! ncgrid_oro = orooutn(0:ncgrid_nx-1,0:ncgrid_ny-1) +! ncgrid_area = arean(0:ncgrid_nx-1,0:ncgrid_ny-1) + if (outgrid_option.eq.1) then ! input was in latlon + ncgrid_dx = dxoutln + ncgrid_dy = dyoutln + ncgrid_lon0 = outlon0n + ncgrid_lat0 = outlat0n + else ! input was in metres + ncgrid_dx = dxoutn + ncgrid_dy = dyoutn + ncgrid_xm0 = out_xm0n + ncgrid_ym0 = out_ym0n + endif + endif +! print*,'step3' + + if (option_verbose.ge.10) & + write(*,*) 'write_ncheader: ncout,ncoutn=',ncout,ncoutn + + ! Write the header information + !***************************** + + !ncret = nf_put_att_text(ncout,nf_global,'TITLE',20,version) + !call check_ncerror(ncret) +! print*,'continue' + if (ldirect.eq.1) then ! Forward simulation + if (option_verbose.ge.10) write(*,10) 'forward simulation attributes' + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_DATE',nf_int,1,ibdate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_TIME',nf_int,1,ibtime) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_DATE',nf_int,1,iedate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_TIME',nf_int,1,ietime) + call check_ncerror(ncret) + else ! Backward simulation + if (option_verbose.ge.10) write(*,10) 'backward simulation attributes' + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_DATE',nf_int,1,iedate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_START_TIME',nf_int,1,ietime) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_DATE',nf_int,1,ibdate) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'SIMULATION_END_TIME',nf_int,1,ibtime) + call check_ncerror(ncret) + endif + + if (option_verbose.ge.10) write(*,10) 'map projection attributes' + if (outgrid_option .eq. 1) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',20,'Regular Latit/Longit') + call check_ncerror(ncret) + else + if (map_proj_id.eq.1) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',17,'Lambert conformal') + call check_ncerror(ncret) + elseif (map_proj_id.eq.2) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',13,'stereographic') + call check_ncerror(ncret) + elseif (map_proj_id.eq.3) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',8,'mercator') + call check_ncerror(ncret) + elseif (map_proj_id.eq.4) then + ncret = & + nf_put_att_text(ncid,nf_global,'OUTPUT_PROJECTION',6,'global') + call check_ncerror(ncret) + endif + endif + + ! Write info common model settings + !********************************* + if (option_verbose.ge.10) write(*,10) 'common model attributes' + + if (option_verbose.ge.10) write(*,10) 'OUTPUT_INTERVAL' + ncret = nf_put_att_int(ncid,nf_global,'OUTPUT_INTERVAL',nf_int,1,loutstep) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'AVERAGING_TIME' + ncret = nf_put_att_int(ncid,nf_global,'AVERAGING_TIME',nf_int,1,loutaver) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'AVERAGE_SAMPLING' + ncret = nf_put_att_int(ncid,nf_global,'AVERAGE_SAMPLING',nf_int,1,loutsample) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'NSPEC',nf_int,1,nspec) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'NUMRECEPTOR',nf_int,1,numreceptor) + call check_ncerror(ncret) + ncret = nf_put_att_int(ncid,nf_global,'NAGECLASS',nf_int,1,nageclass) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'NUMRELEASES',nf_int,1,numpoint) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'DISPERSION_METHOD',nf_int,1,method) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SUBGRID_TOPOGRAPHY',nf_int,1,lsubgrid) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'CONVECTION_PARAM',nf_int,1,lconvection) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'SUBGRID_TOPOGRAPHY',nf_int,1,lsubgrid) + call check_ncerror(ncret) + + ! Write information on output grid setup + !*************************************** + if (option_verbose.ge.10) write(*,10) 'WEST-EAST_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'WEST-EAST_GRID_DIMENSION', & + nf_int,1,ncgrid_nx) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'SOUTH-NORTH_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'SOUTH-NORTH_GRID_DIMENSION', & + nf_int,1,ncgrid_ny) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'BOTTOM-TOP_GRID_DIMENSION' + ncret = nf_put_att_int(ncid,nf_global,'BOTTOM-TOP_GRID_DIMENSION', & + nf_int,1,numzgrid) + + if (option_verbose.ge.10) write(*,10) 'DX and DY' + ncret = nf_put_att_int(ncid,nf_global,'DX',nf_int,1,ncgrid_dx) + call check_ncerror(ncret) + + ncret = nf_put_att_int(ncid,nf_global,'DY',nf_int,1,ncgrid_dy) + call check_ncerror(ncret) + + ! Set up netcdf dimensions + !************************* + if (option_verbose.ge.10) write(*,10) 'main grid dimensions' + + ncret = nf_def_dim(ncid,'Time',nf_unlimited,ncrecid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'DateStrLen',15,ncstr3id) !TODO: WRF format + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'west_east',ncgrid_nx,nclonid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'south_north',ncgrid_ny,nclatid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'bottom_top',numzgrid,nclvlid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'species',nspec,ncspcid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'SpeciesStrLen',10,ncstr1id) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ageclass',nageclass,ncageid) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'release point dimensions' + ncret = nf_def_dim(ncid,'releases',numpoint,ncrelid) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ReleaseStrLen',45,ncstr2id) + call check_ncerror(ncret) + + ncret = nf_def_dim(ncid,'ReleaseStartEnd',2,ncrseid) + call check_ncerror(ncret) + + ! Select which dimensions to use for main output grids + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncdimsid32(1) = nclonid ! X + ncdimsid32(2) = nclatid ! Y + ncdimsid32(3) = nclvlid ! Z + ncdimsid32(4) = ncrelid ! points + ncdimsid32(5) = ncspcid ! species + ncdimsid32(6) = ncageid ! ageclass + ncdimsid32(7) = ncrecid ! t + + ncdimsid22(1) = nclonid ! X + ncdimsid22(2) = nclatid ! Y + ncdimsid22(3) = ncrelid ! points + ncdimsid22(4) = ncspcid ! species + ncdimsid22(5) = ncageid ! ageclass + ncdimsid22(6) = ncrecid ! t + + else + ncdimsid3(1) = nclonid ! X + ncdimsid3(2) = nclatid ! Y + ncdimsid3(3) = nclvlid ! Z + if (ldirect.eq.1) ncdimsid3(4) = ncspcid ! species + if (ldirect.eq.-1) ncdimsid3(4) = ncrelid ! points + ncdimsid3(5) = ncageid ! ageclass + ncdimsid3(6) = ncrecid ! t + + ncdimsid2(1) = nclonid ! X + ncdimsid2(2) = nclatid ! Y + if (ldirect.eq.1) ncdimsid2(3) = ncspcid ! species + if (ldirect.eq.-1) ncdimsid2(3) = ncrelid ! points + ncdimsid2(4) = ncageid ! ageclass + ncdimsid2(5) = ncrecid ! t + endif +! +! ! Set up dimension variables +! !*************************** +! +! ! XLONG +! if (option_verbose.ge.10) write(*,10) 'XLONG dimension variable' +! ncret = nf_def_var(ncid,'XLONG',nf_real,2,ncdimsid2(1:2),nclonvid) +! +!! Turn on deflate compression, fletcher32 checksum. +! ncret = NF_DEF_VAR_deflate(ncid,nclonvid, shuffle, 1, deflate_level) +!! if (ncret .ne. nf_noerr) call handle_err(retval) +!! ncret = NF_DEF_VAR_FLETCHER32(ncid, nclonvid, NF_FLETCHER32) +!! if (ncret .ne. nf_noerr) call handle_err(retval) +! +!! ncret = nf_def_var_deflate(ncid,'XLONG',nf_real,2,ncdimsid2(1:2),nclonvid,deflate_level=deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclonvid,descr,27,'LONGITUDE, WEST IS NEGATIVE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclonvid,units,11,'degree_east') +! call check_ncerror(ncret) +! +! ! XLAT +! if (option_verbose.ge.10) write(*,10) 'XLAT dimension variable' +! ncret = nf_def_var(ncid,'XLAT',nf_real,2,ncdimsid2(1:2),nclatvid) +!! ncret = nf_def_var_deflate(ncid,'XLAT',nf_real,2,ncdimsid2(1:2),nclatvid,deflate_level=deflate_level) +! ncret = NF_DEF_VAR_deflate(ncid,nclatvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclatvid,descr,27,'LATITUDE, SOUTH IS NEGATIVE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclatvid,units,12,'degree_north') +! call check_ncerror(ncret) +! +! ! ZTOP +! if (option_verbose.ge.10) write(*,10) 'ZTOP dimension variable' +! ncret = nf_def_var(ncid,'ZTOP',nf_real,1,ncdimsid3(3),nclvlvid) +! ncret = NF_DEF_VAR_deflate(ncid,nclvlvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclvlvid,descr,32, & +! 'UPPER BOUNDARY OF MODEL LAYER') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nclvlvid,units,1,'m') +! call check_ncerror(ncret) +! +! ! SPECIES +! if (option_verbose.ge.10) write(*,10) 'SPECIES dimension variable' +! ncret = nf_def_var(ncid,'SPECIES',nf_char,2,(/ncstr1id,ncspcid/),ncspcvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncspcvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncspcvid,descr,15,'NAME OF SPECIES') +! call check_ncerror(ncret) +! +! ! AGECLASSES +! if (option_verbose.ge.10) write(*,10) 'AGECLASSES dimension variable' +! ncret = nf_def_var(ncid,'AGECLASS',nf_int,1,ncageid,ncagevid) +! ncret = NF_DEF_VAR_deflate(ncid,ncagevid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncagevid,descr,27,'MAX AGE OF SPECIES IN CLASS') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncagevid,units,1,'s') +! call check_ncerror(ncret) +! +! ! TIMES + if (option_verbose.ge.10) write(*,10) 'TIMES dimension variable' + ncret = nf_def_var(ncid,'Times',nf_char,2,(/ncstr3id,ncrecid/),ncrecvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrecvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncrecvid,descr,42, & + 'TIME OF OUTPUT (END OF AVERAGING INTERVAL)') +! +! ! Release related variables +! if (option_verbose.ge.10) write(*,10) 'ReleaseName variable' +! ncret = nf_def_var(ncid,'ReleaseName',nf_char,2,(/ncstr2id,ncrelid/),ncrnvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrnvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrnvid,descr,25,'RELEASE IDENTIFIER/COMMENT') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrnvid,units,1,'-') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseTstart_end variable' +! ncret = nf_def_var(ncid,'ReleaseTstart_end', & +! nf_int,2,(/ncrseid,ncrelid/),ncrtvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrtvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrtvid,descr,32, & +! 'BEGINNING/ENDING TIME OF RELEASE (SECONDS SINCE RUN START)') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrtvid,units,1,'s') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseXstart_end variable' +! ncret = nf_def_var(ncid,'ReleaseXstart_end', & +! nf_float,2,(/ncrseid,ncrelid/),ncrxvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrxvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrxvid,descr,32, & +! 'WEST/EAST BOUNDARIES OF SOURCE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrxvid,units,12,'degree_north') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseYstart_end variable' +! ncret = nf_def_var(ncid,'ReleaseYstart_end', & +! nf_float,2,(/ncrseid,ncrelid/),ncryvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncryvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncryvid,descr,32, & +! 'SOUTH/NORTH BOUNDARIES OF SOURCE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncryvid,units,12,'degree_north') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseZstart_end variable' +! ncret = nf_def_var(ncid,'ReleaseZstart_end', & +! nf_float,2,(/ncrseid,ncrelid/),ncrzvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrzvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrzvid,descr,31, & +! 'BOTTOM/TOP BOUNDARIES OF SOURCE') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrzvid,units,1,'m') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseNP variable' +! ncret = nf_def_var(ncid,'ReleaseNP',nf_int,1,ncrelid,ncspvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncspvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncspvid,descr,34, & +! 'TOTAL NUMBER OF PARTICLES RELEASED') +! ncret = nf_put_att_text(ncid,ncspvid,units,1,'-') +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseXMass variable' +! ncret = nf_def_var(ncid,'ReleaseXMass',nf_real,2,(/ncspcid,ncrelid/),ncrmvid) +! ncret = NF_DEF_VAR_deflate(ncid,ncrmvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrmvid,descr,18,'TOTAL MASS RELEASED') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncrmvid,units,2,'kg') +! call check_ncerror(ncret) +! +! ! Since we need to exit define mode before we can insert +! ! variable data, we will include the last file attributes and +! ! define the last variables here. +! +! ! DIRECTION INDEPENDENT OUTPUT VARIABLES +! if (option_verbose.ge.10) write(*,10) 'TOPOGRAPHY variable' +! ncret = nf_def_var(ncid,'TOPOGRAPHY',NF_real,2,ncdimsid2(1:2),nctovid) +!! ncret = nf_def_var_deflate(ncid,'TOPOGRAPHY',NF_real,2,ncdimsid2(1:2),nctovid,deflate_level=deflate_level) +! ncret = NF_DEF_VAR_deflate(ncid,nctovid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nctovid,descr,33, & +! 'TERRAIN ELEVATION ABOVE SEA LEVEL') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nctovid,units,1,'m') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,nctovid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'GRIDAREA variable' +! ncret = nf_def_var(ncid,'GRIDAREA',NF_real,2,ncdimsid2(1:2),ncarvid) +!! ncret = nf_def_var_deflate(ncid,'GRIDAREA',NF_real,2,ncdimsid2(1:2),ncarvid,deflate_level=deflate_level) +! ncret = NF_DEF_VAR_deflate(ncid,ncarvid, shuffle, 1, deflate_level) +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncarvid,descr,30, & +! 'SURFACE AREA OF EACH GRID CELL') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncarvid,units,2,'m2') +! call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncarvid,coord,coordxylen,coordxy) +! call check_ncerror(ncret) +! + ! MAIN OUTPUT VARIABLES + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then ! CONCENTRATION + if (option_verbose.ge.10) write(*,10) 'CONC variable' +! print*,ncdimsid3 + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncret = nf_def_var(ncid,'CONC',NF_REAL,7,ncdimsid32,nccovid) + else + ncret = nf_def_var(ncid,'CONC',NF_REAL,6,ncdimsid3,nccovid) + endif +! chunks(1) = ncgrid_nx +! chunks(2) = ncgrid_ny +!! ncret = NF_DEF_VAR_CHUNKING(ncid, nccovid, NF_CHUNKED, chunks) + if (ncret .ne. nf_noerr) call check_ncerror(ncret) +! ncret = NF_DEF_VAR_deflate(ncid,nccovid, shuffle, 1, deflate_level) + + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nccovid,descr,33, & + 'CONCENTRATION OF AIRBORNE SPECIES') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,nccovid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + endif + + if ((iout.eq.2).or.(iout.eq.3)) then ! MIXING RATIO + if (option_verbose.ge.10) write(*,10) 'MIXINGRATIO variable' + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncret = nf_def_var(ncid,'MIXINGRATIO',NF_REAL,7,ncdimsid32,ncravid) + else + ncret = nf_def_var(ncid,'MIXINGRATIO',NF_REAL,6,ncdimsid3,ncravid) + endif +! ncret = NF_DEF_VAR_deflate(ncid,ncravid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncravid,descr,37, & + 'MASS MIXING RATIO OF AIRBORNE SPECIES') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncravid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + endif + + if (ldirect.eq.1) then ! Forward run + unit2d = 'pg m-2' + unit2dlen = 6 + + if (option_verbose.ge.10) write(*,10) 'DRYDEP variable' +! write(*,*) ncdimsid2 + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncret = nf_def_var(ncid,'DRYDEP',NF_REAL,6,ncdimsid22,ncddvid) + else + ncret = nf_def_var(ncid,'DRYDEP',NF_REAL,5,ncdimsid2,ncddvid) + endif +! ncret = NF_DEF_VAR_deflate(ncid,ncddvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncddvid,descr,32, & + 'ACCUMULATED TOTAL DRY DEPOSITION') + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncddvid,units,unit2dlen,unit2d) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncddvid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + + if (option_verbose.ge.10) write(*,10) 'WETDEP variable' + if ((ldirect.eq.1).and.(maxpointspec_act.gt.1)) then + ncret = nf_def_var(ncid,'WETDEP',NF_REAL,6,ncdimsid22,ncwdvid) + else + ncret = nf_def_var(ncid,'WETDEP',NF_REAL,5,ncdimsid2,ncwdvid) + endif +! ncret = NF_DEF_VAR_deflate(ncid,ncwdvid, shuffle, 1, deflate_level) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncwdvid,descr,32, & + 'ACCUMULATED TOTAL WET DEPOSITION') +! call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncwdvid,units,unit2dlen,unit2d) + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncwdvid,coord,coordxylen,coordxy) + call check_ncerror(ncret) + + ! Add unit attr to mixing ratio and concentration fields + if (ind_samp.eq.0) then + ncret = nf_put_att_text(ncid,nccovid,units,6,'ng m-3') !CONC + call check_ncerror(ncret) + ncret = nf_put_att_text(ncid,ncravid,units,4,'ppt') !MIX + call check_ncerror(ncret) + else + ncret = nf_put_att_text(ncid,nccovid,units,11,'ppt by mass') !CONC + call check_ncerror(ncret) +! ncret = nf_put_att_text(ncid,ncravid,units,3,'???') !MIX +! call check_ncerror(ncret) + endif + else ! Backward run +! if ((ind_rel.eq.0).and.(ind_samp.eq.0) then ! release in mass +! write(*,*) 'A' + !Concentration field should be in 's' (?) + if ((ind_rel.eq.0).and.(ind_samp.eq.0)) ncret = nf_put_att_text(ncid,nccovid,units,1,'s') !CONC + if ((ind_rel.eq.0).and.(ind_samp.eq.-1)) ncret = nf_put_att_text(ncid,nccovid,units,9,'s m3 kg-1') !CONC + if ((ind_rel.eq.1).and.(ind_samp.eq.0)) ncret = nf_put_att_text(ncid,nccovid,units,8,'s kg m-3') !CONC + if ((ind_rel.eq.1).and.(ind_samp.eq.-1)) ncret = nf_put_att_text(ncid,nccovid,units,1,'s') !CONC + + endif ! Backward/Forward run + + ! EXIT DEFINE MODE, ENTER DATA MODE + ncret = nf_enddef(ncid) + call check_ncerror(ncret) + + ! DIMENSION VARIABLES +! if (option_verbose.ge.10) write(*,10) 'ZTOP data' +! ncret = nf_put_var_real(ncid,nclvlvid,outheight) +! call check_ncerror(ncret) + +! ! X,Y - Lon,Lat +! if (option_verbose.ge.10) write(*,10) 'XLAT,XLONG data' +! +! if (outgrid_option.eq.0) then ! irregular +! do jy=1,ncgrid_ny +! do ix=1,ncgrid_nx +! tmpx=ncgrid_xm0+(float(ix)-0.5)*ncgrid_dx +! tmpy=ncgrid_ym0+(float(jy)-0.5)*ncgrid_dy +! call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) +! ncret = nf_put_vara_real(ncid,nclonvid,(/ix,jy/),(/1,1/),tmplon) +! call check_ncerror(ncret) +! ncret = nf_put_vara_real(ncid,nclatvid,(/ix,jy/),(/1,1/),tmplat) +! call check_ncerror(ncret) +! enddo +! enddo +! else +! do jy=1,ncgrid_ny +! do ix=1,ncgrid_nx +! call ll_to_xymeter_wrf(ncgrid_swlon,ncgrid_swlat,xsw,ysw) +! call ll_to_xymeter_wrf(ncgrid_nelon,ncgrid_nelat,xne,yne) +! tmpx=xsw+(xne-xsw)*float(ix-1)/float(ncgrid_nx-1) +! tmpy=ysw+(yne-ysw)*float(jy-1)/float(ncgrid_ny-1) +! call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) +! xl2=ncgrid_lon0+(float(ix)-0.5)*dxoutl !long +! yl2=ncgrid_lat0+(float(jy)-0.5)*dyoutl !lat +! ncret = nf_put_vara_real(ncid,nclonvid,(/ix,jy/),(/1,1/),xl2) +! call check_ncerror(ncret) +! ncret = nf_put_vara_real(ncid,nclatvid,(/ix,jy/),(/1,1/),yl2) +! call check_ncerror(ncret) +! enddo +! enddo +! endif ! outgrid_option + + +! ! Write information on release points: total number, then for each point: +! ! start, end, coordinates, # of particles, name, mass +! !************************************************************************ +! do i=1,numpoint +! xp1=xpoint1(i)*dx+xlon0 ! This is probably wrong, but it seems to be +! yp1=ypoint1(i)*dy+ylat0 ! the same in writeheader*.f90, so I'll leave +! xp2=xpoint2(i)*dx+xlon0 ! it for now... //AD +! yp2=ypoint2(i)*dy+ylat0 ! +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseTstart_end data' +! ncret = nf_put_vara_int(ncid,ncrtvid, & ! ReleaseTstart_end +! (/1,i/),(/2,1/),(/ireleasestart(i),ireleaseend(i)/)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseXstart_end data' +! ncret = nf_put_vara_real(ncid,ncrxvid, & ! ReleaseXstart_end +! (/1,i/),(/2,1/),(/xp1,xp2/)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseYstart_end data' +! ncret = nf_put_vara_real(ncid,ncryvid, & !ReleaseYstart_end +! (/1,i/),(/2,1/),(/yp1,yp2/)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseZstart_end data' +! ncret = nf_put_vara_real(ncid,ncrzvid, & !ReleaseZstart_end +! (/1,i/),(/2,1/),(/zpoint1(i),zpoint2(i)/)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseXMass data' +! ncret = nf_put_vara_real(ncid,ncrmvid, & !ReleaseXMass +! (/1,i/),(/nspec,1/),xmass(i,1:nspec)) +! call check_ncerror(ncret) +! +! if (option_verbose.ge.10) write(*,10) 'ReleaseNP data' +! ncret = nf_put_vara_int(ncid,ncspvid, & !ReleaseNP +! i,1,npart(i)) +! call check_ncerror(ncret) +! +! !Release Name/Comment +! j=1 ! Find the length of each release point comment/name +! do while( j.lt.45.and.compoint(i)(j+1:j+1).ne." ") +! j=j+1 +! enddo +! if (option_verbose.ge.10) write(*,10) 'ReleaseName data' +! ncret = nf_put_vara_text(ncid,ncrnvid,(/1,i/),(/j,1/),compoint(i)(1:j)) +! call check_ncerror(ncret) +! enddo +! +! ! Write age class information +! !**************************** +! if (option_verbose.ge.10) write(*,10) 'AGECLASSES data' +! ncret = nf_put_var_int(ncid,ncagevid,lage(1:nageclass)) +! call check_ncerror(ncret) +! +! ! Write topography to output file +! !******************************** +! if (option_verbose.ge.10) write(*,10) 'TOPOGRAPHY data' +!! do ix=0,ncgrid_nx-1 +! do ix=1,ncgrid_nx +! ncret = nf_put_vara_real(ncid,nctovid, & +!! (/ix+1,1/),(/1,ncgrid_ny/),ncgrid_oro(ix,0:ncgrid_ny-1)) +! (/ix,1/),(/1,ncgrid_ny/),ncgrid_oro(ix,1:ncgrid_ny)) +! call check_ncerror(ncret) +! enddo +! +! ! Write grid cell surface area +! !***************************** +! if (option_verbose.ge.10) write(*,10) 'GRIDAREA data' +!! do ix=0,ncgrid_nx-1 +! do ix=1,ncgrid_nx +! ncret = nf_put_vara_real(ncid,ncarvid, & +!! (/ix+1,1/),(/1,ncgrid_ny/),ncgrid_area(ix,0:ncgrid_ny-1)) +! (/ix,1/),(/1,ncgrid_ny/),ncgrid_area(ix,1:ncgrid_ny)) +! call check_ncerror(ncret) +! enddo +! +! ! SAVE CREATED NETCDF TO FILE +! !**************************** +! if (option_verbose.ge.1) write(*,*) 'write_ncheader: writing to disk' +! ncret = nf_sync(ncid) +! call check_ncerror(ncret) + + return + +10 format('write_ncheader: Setting up ',A) + +! deallocate(ncgrid_oro,ncgrid_area) +end subroutine write_ncinfo diff --git a/src_flexwrf_v3.1/writeheader.f90 b/src_flexwrf_v3.1/writeheader.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d2635c71aa06005eee2f0c8d6f372df6e6aedf26 --- /dev/null +++ b/src_flexwrf_v3.1/writeheader.f90 @@ -0,0 +1,220 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine 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 + real :: xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat,xl2,yl2 + + + !************************ + ! Open header output file + !************************ + + open(unitheader,file=path(1)(1:length(1))//'header', & + form='unformatted',err=998) + + + ! Write the header information + !***************************** + + if (ldirect.eq.1) then +! write(unitheader) ibdate,ibtime,'FLEXWRF V2.1' + if (outgrid_option .eq. 1) then + write(unitheader) ibdate,ibtime,'FLEXWRF lalo ' + else + if (map_proj_id.eq.1) write(unitheader) ibdate,ibtime,'FLEXWRF lamb ' + if (map_proj_id.eq.2) write(unitheader) ibdate,ibtime,'FLEXWRF ster ' + if (map_proj_id.eq.3) write(unitheader) ibdate,ibtime,'FLEXWRF merc ' + if (map_proj_id.eq.4) write(unitheader) ibdate,ibtime,'FLEXWRF glob ' + endif + else + if (outgrid_option .eq. 1) then + write(unitheader) iedate,ietime,'FLEXWRF lalo ' + else + if (map_proj_id.eq.1) write(unitheader) iedate,ietime,'FLEXWRF lamb ' + if (map_proj_id.eq.2) write(unitheader) iedate,ietime,'FLEXWRF ster ' + if (map_proj_id.eq.3) write(unitheader) iedate,ietime,'FLEXWRF merc ' + if (map_proj_id.eq.4) write(unitheader) iedate,ietime,'FLEXWRF glob ' + endif + endif + + ! Write info on output interval, averaging time, sampling time + !************************************************************* + + write(unitheader) loutstep,loutaver,loutsample + + ! Write information on output grid setup + !*************************************** + + if (outgrid_option .eq. 1) then + write(unitheader) outlon0,outlat0,numxgrid,numygrid, & + dxoutl,dyoutl + else + write(unitheader) outlon0,outlat0,numxgrid,numygrid, & + dxout,dyout + endif + 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.2000) then + write(unitheader) compoint(i) + else + write(unitheader) compoint(2001) + 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) + + + open(53,file=path(1)(1:length(1))//'latlon.txt',form='formatted') + open(54,file=path(1)(1:length(1))//'latlon_corner.txt' & + ,form='formatted') + + if (outgrid_option.eq.0) then ! irregular + call ll_to_xymeter_wrf(outgrid_swlon,outgrid_swlat,xsw,ysw) + call ll_to_xymeter_wrf(outgrid_nelon,outgrid_nelat,xne,yne) + do jy=1,numygrid + do ix=1,numxgrid + tmpx=out_xm0+(float(ix)-0.5)*dxout + tmpy=out_ym0+(float(jy)-0.5)*dyout + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + write(53,*) tmplon,tmplat + tmpx=out_xm0+(float(ix)-1.)*dxout + tmpy=out_ym0+(float(jy)-1.)*dyout + call xymeter_to_ll_wrf_out(tmpx,tmpy,tmplon,tmplat) + write(54,*) tmplon,tmplat + enddo + enddo + else ! regular + call ll_to_xymeter_wrf(outgrid_swlon,outgrid_swlat,xsw,ysw) + call ll_to_xymeter_wrf(outgrid_nelon,outgrid_nelat,xne,yne) + do jy=1,numygrid + do ix=1,numxgrid + tmpx=xsw+(xne-xsw)*float(ix-1)/float(numxgrid-1) + tmpy=ysw+(yne-ysw)*float(jy-1)/float(numygrid-1) + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + xl2=outlon0+(float(ix)-0.5)*dxoutl !long + yl2=outlat0+(float(jy)-0.5)*dyoutl !lat + write(53,*) xl2,yl2 + xl2=outlon0+float(ix-1)*dxoutl !long + yl2=outlat0+float(jy-1)*dyoutl !lat + write(54,*) xl2,yl2 + enddo + enddo + endif + + + close(53) + close(54) + + return + +998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(1)(1:length(1))//'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 diff --git a/src_flexwrf_v3.1/writeheader_nest.f90 b/src_flexwrf_v3.1/writeheader_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..33b9acd5926f6dc69dbe3c173bcb7fd40c4c447c --- /dev/null +++ b/src_flexwrf_v3.1/writeheader_nest.f90 @@ -0,0 +1,220 @@ +!*********************************************************************** +!* Copyright 2012,2013 * +!* Jerome Brioude, Delia Arnold, Andreas Stohl, Wayne Angevine, * +!* John Burkhart, Massimo Cassiani, Adam Dingwell, Richard C Easter, Sabine Eckhardt,* +!* Stephanie Evan, Jerome D Fast, Don Morton, Ignacio Pisso, * +!* Petra Seibert, Gerard Wotawa, Caroline Forster, Harald Sodemann, * +!* * +!* This file is part of FLEXPART WRF +! * +! FLEXPART is free software: you can redistribute it and/or modify * +! it under the terms of the GNU General Public License as published by* +! the Free Software Foundation, either version 3 of the License, or * +! (at your option) any later version. * +! * +! FLEXPART is distributed in the hope that it will be useful, * +! but WITHOUT ANY WARRANTY; without even the implied warranty of * +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * +! GNU General Public License for more details. * +! * +! You should have received a copy of the GNU General Public License * +! along with FLEXPART. If not, see <http://www.gnu.org/licenses/>. * +!********************************************************************** + +subroutine 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 + real :: xsw,xne,ysw,yne,tmpx,tmpy,tmplon,tmplat,xl2,yl2 + + + !************************ + ! Open header output file + !************************ + + open(unitheader,file=path(1)(1:length(1))//'header_nest', & + form='unformatted',err=998) + + + ! Write the header information + !***************************** + + if (ldirect.eq.1) then +! write(unitheader) ibdate,ibtime,'FLEXWRF V2.1' + if (outgrid_option .eq. 1) then + write(unitheader) ibdate,ibtime,'FLEXWRF lalo ' + else + if (map_proj_id.eq.1) write(unitheader) ibdate,ibtime,'FLEXWRF lamb ' + if (map_proj_id.eq.2) write(unitheader) ibdate,ibtime,'FLEXWRF ster ' + if (map_proj_id.eq.3) write(unitheader) ibdate,ibtime,'FLEXWRF merc ' + if (map_proj_id.eq.4) write(unitheader) ibdate,ibtime,'FLEXWRF glob ' + endif + + else +! write(unitheader) iedate,ietime,'FLEXWRF V2.1' + if (outgrid_option .eq. 1) then + write(unitheader) iedate,ietime,'FLEXWRF lalo ' + else + if (map_proj_id.eq.1) write(unitheader) iedate,ietime,'FLEXWRF lamb ' + if (map_proj_id.eq.2) write(unitheader) iedate,ietime,'FLEXWRF ster ' + if (map_proj_id.eq.3) write(unitheader) iedate,ietime,'FLEXWRF merc ' + if (map_proj_id.eq.4) write(unitheader) iedate,ietime,'FLEXWRF glob ' + endif + + 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.2000) then + write(unitheader) compoint(i) + else + write(unitheader) compoint(2001) + 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) + + open(53,file=path(1)(1:length(1))//'latlon_nest.txt' & + ,form='formatted') + open(54,file=path(1)(1:length(1))//'latlon_corner_nest.txt' & + ,form='formatted') + + if (outgrid_option.eq.0) then ! irregular + call ll_to_xymeter_wrf(outgridn_swlon,outgridn_swlat,xsw,ysw) + call ll_to_xymeter_wrf(outgridn_nelon,outgridn_nelat,xne,yne) + do jy=1,numygridn + do ix=1,numxgridn + tmpx=out_xm0n+(float(ix)-0.5)*dxoutn + tmpy=out_ym0n+(float(jy)-0.5)*dyoutn + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + write(53,*) tmplon,tmplat + tmpx=out_xm0n+(float(ix)-1.)*dxoutn + tmpy=out_ym0n+(float(jy)-1.)*dyoutn + call xymeter_to_ll_wrf_out(tmpx,tmpy,tmplon,tmplat) + write(54,*) tmplon,tmplat + enddo + enddo + else ! regular + call ll_to_xymeter_wrf(outgridn_swlon,outgridn_swlat,xsw,ysw) + call ll_to_xymeter_wrf(outgridn_nelon,outgridn_nelat,xne,yne) + do jy=1,numygridn + do ix=1,numxgridn + tmpx=xsw+(xne-xsw)*float(ix-1)/float(numxgridn-1) + tmpy=ysw+(yne-ysw)*float(jy-1)/float(numygridn-1) + call xymeter_to_ll_wrf(tmpx,tmpy,tmplon,tmplat) + xl2=outlon0n+(float(ix)-0.5)*dxoutln !long + yl2=outlat0n+(float(jy)-0.5)*dyoutln !lat + write(53,*) xl2,yl2 + xl2=outlon0n+float(ix-1)*dxoutln !long + yl2=outlat0n+float(jy-1)*dyoutln !lat + write(54,*) xl2,yl2 + enddo + enddo + endif + + + close(53) + close(54) + + + return + + +998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(1)(1:length(1))//'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 diff --git a/src_flexwrf_v3.1/xmass_mod.f90 b/src_flexwrf_v3.1/xmass_mod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d97c63bc2cd5e0da00cec349e4fdf196ae747541 --- /dev/null +++ b/src_flexwrf_v3.1/xmass_mod.f90 @@ -0,0 +1,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 <http://www.gnu.org/licenses/>. * +!********************************************************************** + +module xmass_mod + + implicit none + + real,allocatable, dimension (:) :: xmasssave + +end module xmass_mod