Ticket #277: init_domainfill.f90

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