source: flexpart.git/src/init_domainfill.f90 @ 0a94e13

10.4.1_peseiGFS_025bugfixes+enhancementsdevrelease-10release-10.4.1scaling-bug
Last change on this file since 0a94e13 was 0a94e13, checked in by Espen Sollum ATMOS <eso@…>, 5 years ago

Added ipout=3 option for time averaged particle output

  • Property mode set to 100644
File size: 15.8 KB
Line 
1!**********************************************************************
2! Copyright 1998,1999,2000,2001,2002,2005,2007,2008,2009,2010         *
3! Andreas Stohl, Petra Seibert, A. Frank, Gerhard Wotawa,             *
4! Caroline Forster, Sabine Eckhardt, John Burkhart, Harald Sodemann   *
5!                                                                     *
6! This file is part of FLEXPART.                                      *
7!                                                                     *
8! FLEXPART is free software: you can redistribute it and/or modify    *
9! it under the terms of the GNU General Public License as published by*
10! the Free Software Foundation, either version 3 of the License, or   *
11! (at your option) any later version.                                 *
12!                                                                     *
13! FLEXPART is distributed in the hope that it will be useful,         *
14! but WITHOUT ANY WARRANTY; without even the implied warranty of      *
15! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the       *
16! GNU General Public License for more details.                        *
17!                                                                     *
18! You should have received a copy of the GNU General Public License   *
19! along with FLEXPART.  If not, see <http://www.gnu.org/licenses/>.   *
20!**********************************************************************
21
22subroutine init_domainfill
23!
24!*****************************************************************************
25!                                                                            *
26! Initializes particles equally distributed over the first release location  *
27! specified in file RELEASES. This box is assumed to be the domain for doing *
28! domain-filling trajectory calculations.                                    *
29! All particles carry the same amount of mass which alltogether comprises the*
30! mass of air within the box.                                                *
31!                                                                            *
32!     Author: A. Stohl                                                       *
33!                                                                            *
34!     15 October 2002                                                        *
35!                                                                            *
36!*****************************************************************************
37!                                                                            *
38! Variables:                                                                 *
39!                                                                            *
40! numparticlecount    consecutively counts the number of particles released  *
41! nx_we(2)       grid indices for western and eastern boundary of domain-    *
42!                filling trajectory calculations                             *
43! ny_sn(2)       grid indices for southern and northern boundary of domain-  *
44!                filling trajectory calculations                             *
45!                                                                            *
46!*****************************************************************************
47
48  use point_mod
49  use par_mod
50  use com_mod
51  use random_mod
52
53  implicit none
54
55  integer :: j,ix,jy,kz,ncolumn,numparttot
56  real :: gridarea(0:nymax-1),pp(nzmax),ylat,ylatp,ylatm,hzone
57  real :: cosfactm,cosfactp,deltacol,dz1,dz2,dz,pnew,fractus
58  real,parameter :: pih=pi/180.
59  real :: colmass(0:nxmax-1,0:nymax-1),colmasstotal,zposition
60
61  integer :: ixm,ixp,jym,jyp,indzm,indzp,in,indzh,i,jj
62  real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2)
63
64  integer :: idummy = -11
65
66
67! Determine the release region (only full grid cells), over which particles
68! shall be initialized
69! Use 2 fields for west/east and south/north boundary
70!**************************************************************************
71
72  nx_we(1)=max(int(xpoint1(1)),0)
73  nx_we(2)=min((int(xpoint2(1))+1),nxmin1)
74  ny_sn(1)=max(int(ypoint1(1)),0)
75  ny_sn(2)=min((int(ypoint2(1))+1),nymin1)
76
77! For global simulations (both global wind data and global domain-filling),
78! set a switch, such that no boundary conditions are used
79!**************************************************************************
80  if (xglobal.and.sglobal.and.nglobal) then
81    if ((nx_we(1).eq.0).and.(nx_we(2).eq.nxmin1).and. &
82         (ny_sn(1).eq.0).and.(ny_sn(2).eq.nymin1)) then
83      gdomainfill=.true.
84    else
85      gdomainfill=.false.
86    endif
87  endif
88
89! Exit here if resuming a run from particle dump
90!***********************************************
91  if (gdomainfill.and.ipin.ne.0) return
92
93! Do not release particles twice (i.e., not at both in the leftmost and rightmost
94! grid cell) for a global domain
95!*****************************************************************************
96  if (xglobal) nx_we(2)=min(nx_we(2),nx-2)
97
98
99! Calculate area of grid cell with formula M=2*pi*R*h*dx/360,
100! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90
101!************************************************************
102
103  do jy=ny_sn(1),ny_sn(2)      ! loop about latitudes
104    ylat=ylat0+real(jy)*dy
105    ylatp=ylat+0.5*dy
106    ylatm=ylat-0.5*dy
107    if ((ylatm.lt.0).and.(ylatp.gt.0.)) then
108      hzone=1./dyconst
109    else
110      cosfactp=cos(ylatp*pih)*r_earth
111      cosfactm=cos(ylatm*pih)*r_earth
112      if (cosfactp.lt.cosfactm) then
113        hzone=sqrt(r_earth**2-cosfactp**2)- &
114             sqrt(r_earth**2-cosfactm**2)
115      else
116        hzone=sqrt(r_earth**2-cosfactm**2)- &
117             sqrt(r_earth**2-cosfactp**2)
118      endif
119    endif
120    gridarea(jy)=2.*pi*r_earth*hzone*dx/360.
121  end do
122
123! Do the same for the south pole
124
125  if (sglobal) then
126    ylat=ylat0
127    ylatp=ylat+0.5*dy
128    ylatm=ylat
129    cosfactm=0.
130    cosfactp=cos(ylatp*pih)*r_earth
131    hzone=sqrt(r_earth**2-cosfactm**2)- &
132         sqrt(r_earth**2-cosfactp**2)
133    gridarea(0)=2.*pi*r_earth*hzone*dx/360.
134  endif
135
136! Do the same for the north pole
137
138  if (nglobal) then
139    ylat=ylat0+real(nymin1)*dy
140    ylatp=ylat
141    ylatm=ylat-0.5*dy
142    cosfactp=0.
143    cosfactm=cos(ylatm*pih)*r_earth
144    hzone=sqrt(r_earth**2-cosfactp**2)- &
145         sqrt(r_earth**2-cosfactm**2)
146    gridarea(nymin1)=2.*pi*r_earth*hzone*dx/360.
147  endif
148
149
150! Calculate total mass of each grid column and of the whole atmosphere
151!*********************************************************************
152
153  colmasstotal=0.
154  do jy=ny_sn(1),ny_sn(2)          ! loop about latitudes
155    do ix=nx_we(1),nx_we(2)      ! loop about longitudes
156      pp(1)=rho(ix,jy,1,1)*r_air*tt(ix,jy,1,1)
157      pp(nz)=rho(ix,jy,nz,1)*r_air*tt(ix,jy,nz,1)
158      colmass(ix,jy)=(pp(1)-pp(nz))/ga*gridarea(jy)
159      colmasstotal=colmasstotal+colmass(ix,jy)
160    end do
161  end do
162
163  write(*,*) 'Atm. mass: ',colmasstotal
164
165
166  if (ipin.eq.0) numpart=0
167
168! Determine the particle positions
169!*********************************
170
171  numparttot=0
172  numcolumn=0
173  do jy=ny_sn(1),ny_sn(2)      ! loop about latitudes
174    ylat=ylat0+real(jy)*dy
175    do ix=nx_we(1),nx_we(2)      ! loop about longitudes
176      ncolumn=nint(0.999*real(npart(1))*colmass(ix,jy)/ &
177           colmasstotal)
178      if (ncolumn.eq.0) goto 30
179      if (ncolumn.gt.numcolumn) numcolumn=ncolumn
180
181! Calculate pressure at the altitudes of model surfaces, using the air density
182! information, which is stored as a 3-d field
183!*****************************************************************************
184
185      do kz=1,nz
186        pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
187      end do
188
189
190      deltacol=(pp(1)-pp(nz))/real(ncolumn)
191      pnew=pp(1)+deltacol/2.
192      jj=0
193      do j=1,ncolumn
194        jj=jj+1
195
196
197! For columns with many particles (i.e. around the equator), distribute
198! the particles equally, for columns with few particles (i.e. around the
199! poles), distribute the particles randomly
200!***********************************************************************
201
202
203        if (ncolumn.gt.20) then
204          pnew=pnew-deltacol
205        else
206          pnew=pp(1)-ran1(idummy)*(pp(1)-pp(nz))
207        endif
208
209        do kz=1,nz-1
210          if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
211            dz1=pp(kz)-pnew
212            dz2=pnew-pp(kz+1)
213            dz=1./(dz1+dz2)
214
215! Assign particle position
216!*************************
217! Do the following steps only if particles are not read in from previous model run
218!*****************************************************************************
219            if (ipin.eq.0) then
220              xtra1(numpart+jj)=real(ix)-0.5+ran1(idummy)
221              if (ix.eq.0) xtra1(numpart+jj)=ran1(idummy)
222              if (ix.eq.nxmin1) xtra1(numpart+jj)= &
223                   real(nxmin1)-ran1(idummy)
224              ytra1(numpart+jj)=real(jy)-0.5+ran1(idummy)
225              ztra1(numpart+jj)=(height(kz)*dz2+height(kz+1)*dz1)*dz
226              if (ztra1(numpart+jj).gt.height(nz)-0.5) &
227                   ztra1(numpart+jj)=height(nz)-0.5
228
229
230! Interpolate PV to the particle position
231!****************************************
232              ixm=int(xtra1(numpart+jj))
233              jym=int(ytra1(numpart+jj))
234              ixp=ixm+1
235              jyp=jym+1
236              ddx=xtra1(numpart+jj)-real(ixm)
237              ddy=ytra1(numpart+jj)-real(jym)
238              rddx=1.-ddx
239              rddy=1.-ddy
240              p1=rddx*rddy
241              p2=ddx*rddy
242              p3=rddx*ddy
243              p4=ddx*ddy
244              do i=2,nz
245                if (height(i).gt.ztra1(numpart+jj)) then
246                  indzm=i-1
247                  indzp=i
248                  goto 6
249                endif
250              end do
2516             continue
252              dz1=ztra1(numpart+jj)-height(indzm)
253              dz2=height(indzp)-ztra1(numpart+jj)
254              dz=1./(dz1+dz2)
255              do in=1,2
256                indzh=indzm+in-1
257                y1(in)=p1*pv(ixm,jym,indzh,1) &
258                     +p2*pv(ixp,jym,indzh,1) &
259                     +p3*pv(ixm,jyp,indzh,1) &
260                     +p4*pv(ixp,jyp,indzh,1)
261              end do
262              pvpart=(dz2*y1(1)+dz1*y1(2))*dz
263              if (ylat.lt.0.) pvpart=-1.*pvpart
264
265
266! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere
267!*****************************************************************************
268
269              if (((ztra1(numpart+jj).gt.3000.).and. &
270                   (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then
271
272! Assign certain properties to the particle
273!******************************************
274                nclass(numpart+jj)=min(int(ran1(idummy)* &
275                     real(nclassunc))+1,nclassunc)
276                numparticlecount=numparticlecount+1
277                npoint(numpart+jj)=numparticlecount
278                idt(numpart+jj)=mintime
279                itra1(numpart+jj)=0
280                itramem(numpart+jj)=0
281                itrasplit(numpart+jj)=itra1(numpart+jj)+ldirect* &
282                     itsplit
283                xmass1(numpart+jj,1)=colmass(ix,jy)/real(ncolumn)
284                if (mdomainfill.eq.2) xmass1(numpart+jj,1)= &
285                     xmass1(numpart+jj,1)*pvpart*48./29.*ozonescale/10.**9
286              else
287                jj=jj-1
288              endif
289            endif
290          endif
291        end do
292      end do
293      numparttot=numparttot+ncolumn
294      if (ipin.eq.0) numpart=numpart+jj
29530    continue
296    end do
297  end do
298
299
300! Check whether numpart is really smaller than maxpart
301!*****************************************************
302
303! ESO :TODO: this warning need to be moved further up, else out-of-bounds error earlier
304  if (numpart.gt.maxpart) then
305    write(*,*) 'numpart too large: change source in init_atm_mass.f'
306    write(*,*) 'numpart: ',numpart,' maxpart: ',maxpart
307  endif
308
309
310  xmassperparticle=colmasstotal/real(numparttot)
311
312
313! Make sure that all particles are within domain
314!***********************************************
315
316  do j=1,numpart
317    if ((xtra1(j).lt.0.).or.(xtra1(j).ge.real(nxmin1)).or. &
318         (ytra1(j).lt.0.).or.(ytra1(j).ge.real(nymin1))) then
319      itra1(j)=-999999999
320    endif
321  end do
322
323
324
325
326! For boundary conditions, we need fewer particle release heights per column,
327! because otherwise it takes too long until enough mass has accumulated to
328! release a particle at the boundary (would take dx/u seconds), leading to
329! relatively large position errors of the order of one grid distance.
330! It's better to release fewer particles per column, but to do so more often.
331! Thus, use on the order of nz starting heights per column.
332! We thus repeat the above to determine fewer starting heights, that are
333! used furtheron in subroutine boundcond_domainfill.f.
334!****************************************************************************
335
336  fractus=real(numcolumn)/real(nz)
337  write(*,*) 'Total number of particles at model start: ',numpart
338  write(*,*) 'Maximum number of particles per column: ',numcolumn
339  write(*,*) 'If ',fractus,' <1, better use more particles'
340  fractus=sqrt(max(fractus,1.))/2.
341
342  do jy=ny_sn(1),ny_sn(2)      ! loop about latitudes
343    do ix=nx_we(1),nx_we(2)      ! loop about longitudes
344      ncolumn=nint(0.999/fractus*real(npart(1))*colmass(ix,jy) &
345           /colmasstotal)
346      if (ncolumn.gt.maxcolumn) stop 'maxcolumn too small'
347      if (ncolumn.eq.0) goto 80
348
349
350! Memorize how many particles per column shall be used for all boundaries
351! This is further used in subroutine boundcond_domainfill.f
352! Use 2 fields for west/east and south/north boundary
353!************************************************************************
354
355      if (ix.eq.nx_we(1)) numcolumn_we(1,jy)=ncolumn
356      if (ix.eq.nx_we(2)) numcolumn_we(2,jy)=ncolumn
357      if (jy.eq.ny_sn(1)) numcolumn_sn(1,ix)=ncolumn
358      if (jy.eq.ny_sn(2)) numcolumn_sn(2,ix)=ncolumn
359
360! Calculate pressure at the altitudes of model surfaces, using the air density
361! information, which is stored as a 3-d field
362!*****************************************************************************
363
364      do kz=1,nz
365        pp(kz)=rho(ix,jy,kz,1)*r_air*tt(ix,jy,kz,1)
366      end do
367
368! Determine the reference starting altitudes
369!*******************************************
370
371      deltacol=(pp(1)-pp(nz))/real(ncolumn)
372      pnew=pp(1)+deltacol/2.
373      do j=1,ncolumn
374        pnew=pnew-deltacol
375        do kz=1,nz-1
376          if ((pp(kz).ge.pnew).and.(pp(kz+1).lt.pnew)) then
377            dz1=pp(kz)-pnew
378            dz2=pnew-pp(kz+1)
379            dz=1./(dz1+dz2)
380            zposition=(height(kz)*dz2+height(kz+1)*dz1)*dz
381            if (zposition.gt.height(nz)-0.5) zposition=height(nz)-0.5
382
383! Memorize vertical positions where particles are introduced
384! This is further used in subroutine boundcond_domainfill.f
385!***********************************************************
386
387            if (ix.eq.nx_we(1)) zcolumn_we(1,jy,j)=zposition
388            if (ix.eq.nx_we(2)) zcolumn_we(2,jy,j)=zposition
389            if (jy.eq.ny_sn(1)) zcolumn_sn(1,ix,j)=zposition
390            if (jy.eq.ny_sn(2)) zcolumn_sn(2,ix,j)=zposition
391
392! Initialize mass that has accumulated at boundary to zero
393!*********************************************************
394
395            acc_mass_we(1,jy,j)=0.
396            acc_mass_we(2,jy,j)=0.
397            acc_mass_sn(1,jy,j)=0.
398            acc_mass_sn(2,jy,j)=0.
399          endif
400        end do
401      end do
40280    continue
403    end do
404  end do
405
406! Reduce numpart if invalid particles at end of arrays
407  do i=numpart, 1, -1
408      if (itra1(i).eq.-999999999) then
409        numpart=numpart-1
410      else
411        exit
412      end if
413    end do
414
415! If particles shall be read in to continue an existing run,
416! then the accumulated masses at the domain boundaries must be read in, too.
417! This overrides any previous calculations.
418!***************************************************************************
419
420  if ((ipin.eq.1).and.(.not.gdomainfill)) then
421    open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', &
422         form='unformatted')
423    read(unitboundcond) numcolumn_we,numcolumn_sn, &
424         zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn
425    close(unitboundcond)
426  endif
427
428
429end subroutine init_domainfill
Note: See TracBrowser for help on using the repository browser.
hosted by ZAMG