source: flexpart.git/src/releaseparticles_mpi.f90

10.4.1_peseiGFS_025bugfixes+enhancementsdevrelease-10release-10.4.1scaling-bug
Last change on this file was 92fab65, checked in by Ignacio Pisso <ip@…>, 4 years ago

add SPDX-License-Identifier to all .f90 files

  • Property mode set to 100644
File size: 16.7 KB
Line 
1! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt
2! SPDX-License-Identifier: GPL-3.0-or-later
3
4subroutine releaseparticles(itime)
5!                              o
6!*****************************************************************************
7!                                                                            *
8!     This subroutine releases particles from the release locations.         *
9!                                                                            *
10!     It searches for a "vacant" storage space and assigns all particle      *
11!     information to that space. A space is vacant either when no particle   *
12!     is yet assigned to it, or when it's particle is expired and, thus,     *
13!     the storage space is made available to a new particle.                 *
14!                                                                            *
15!     Author: A. Stohl                                                       *
16!                                                                            *
17!     29 June 2002                                                           *
18!                                                                            *
19!   CHANGES                                                                  *
20!     12/2014 eso: MPI version                                               *
21!                                                                            *
22!*****************************************************************************
23!                                                                            *
24! Variables:                                                                 *
25! itime [s]            current time                                          *
26! ireleasestart, ireleaseend          start and end times of all releases    *
27! npart(maxpoint)      number of particles to be released in total           *
28! numrel               number of particles to be released during this time   *
29!                      step                                                  *
30! addone               extra particle assigned to MPI process if             *
31!                      mod(npart(i),mp_partgroup_np) .ne. 0)                 *
32!*****************************************************************************
33
34  use point_mod
35  use xmass_mod
36  use par_mod
37  use com_mod
38  use random_mod, only: ran1
39  use mpi_mod, only: mp_partid, maxpart_mpi, mp_partgroup_np, mp_seed, mpif_mpi_barrier
40
41  implicit none
42
43!real xaux,yaux,zaux,ran1,rfraction,xmasssave(maxpoint)
44  real :: xaux,yaux,zaux,rfraction
45  real :: topo,rhoaux(2),r,t,rhoout,ddx,ddy,rddx,rddy,p1,p2,p3,p4
46  real :: dz1,dz2,dz,xtn,ytn,xlonav,timecorrect(maxspec),press,pressold
47  real :: presspart,average_timecorrect
48  integer :: itime,numrel,i,j,k,n,ix,jy,ixp,jyp,ipart,minpart,ii,addone
49  integer :: indz,indzp,kz,ngrid
50  integer :: nweeks,ndayofweek,nhour,jjjjmmdd,ihmmss,mm
51  real(kind=dp) :: juldate,julmonday,jul,jullocal,juldiff
52  real,parameter :: eps=nxmax/3.e5,eps2=1.e-6
53  integer :: mind2
54! mind2        eso: pointer to 2nd windfield in memory
55
56  integer :: idummy = -7
57!save idummy,xmasssave
58!data idummy/-7/,xmasssave/maxpoint*0./
59
60  logical :: first_call=.true.
61
62! Use different seed for each process.
63!****************************************************************************
64  if (first_call) then
65    idummy=idummy+mp_seed
66    first_call=.false.
67  end if
68
69  mind2=memind(2)
70
71! Determine the actual date and time in Greenwich (i.e., UTC + correction for daylight savings time)
72!*****************************************************************************
73
74  julmonday=juldate(19000101,0)          ! this is a Monday
75  jul=bdate+real(itime,kind=dp)/86400._dp    ! this is the current day
76  call caldate(jul,jjjjmmdd,ihmmss)
77  mm=(jjjjmmdd-10000*(jjjjmmdd/10000))/100
78  if ((mm.ge.4).and.(mm.le.9)) jul=jul+1._dp/24._dp   ! daylight savings time in summer
79
80
81! For every release point, check whether we are in the release time interval
82!***************************************************************************
83
84  minpart=1
85  do i=1,numpoint
86    if ((itime.ge.ireleasestart(i)).and. &! are we within release interval?
87         (itime.le.ireleaseend(i))) then
88
89! Determine the local day and time
90!*********************************
91
92      xlonav=xlon0+(xpoint2(i)+xpoint1(i))/2.*dx  ! longitude needed to determine local time
93      if (xlonav.lt.-180.) xlonav=xlonav+360.
94      if (xlonav.gt.180.) xlonav=xlonav-360.
95      jullocal=jul+real(xlonav,kind=dp)/360._dp   ! correct approximately for time zone to obtain local time
96
97      juldiff=jullocal-julmonday
98      nweeks=int(juldiff/7._dp)
99      juldiff=juldiff-real(nweeks,kind=dp)*7._dp
100      ndayofweek=int(juldiff)+1              ! this is the current day of week, starting with Monday
101      nhour=nint((juldiff-real(ndayofweek-1,kind=dp))*24._dp)    ! this is the current hour
102      if (nhour.eq.0) then
103        nhour=24
104        ndayofweek=ndayofweek-1
105        if (ndayofweek.eq.0) ndayofweek=7
106      endif
107
108! Calculate a species- and time-dependent correction factor, distinguishing between
109! area (those with release starting at surface) and point (release starting above surface) sources
110! Also, calculate an average time correction factor (species independent)
111!*****************************************************************************
112      average_timecorrect=0.
113      do k=1,nspec
114        if (zpoint1(i).gt.0.5) then      ! point source
115          timecorrect(k)=point_hour(k,nhour)*point_dow(k,ndayofweek)
116        else                             ! area source
117          timecorrect(k)=area_hour(k,nhour)*area_dow(k,ndayofweek)
118        endif
119        average_timecorrect=average_timecorrect+timecorrect(k)
120      end do
121      average_timecorrect=average_timecorrect/real(nspec)
122
123! Determine number of particles to be released this time; at start and at end of release,
124! only half the particles are released
125!*****************************************************************************
126
127      if (ireleasestart(i).ne.ireleaseend(i)) then
128        rfraction=abs(real(npart(i))*real(lsynctime)/ &
129             real(ireleaseend(i)-ireleasestart(i)))
130        if ((itime.eq.ireleasestart(i)).or. &
131             (itime.eq.ireleaseend(i))) rfraction=rfraction/2.
132
133! Take the species-average time correction factor in order to scale the
134! number of particles released this time
135! Also scale by number of MPI processes
136!**********************************************************************
137
138        rfraction=rfraction*average_timecorrect
139
140        rfraction=rfraction+xmasssave(i)  ! number to be released at this time
141
142! number to be released for one process
143        if (mp_partid.lt.mod(int(rfraction),mp_partgroup_np)) then
144          addone=1
145        else
146          addone=0
147        end if
148
149        numrel=int(rfraction/mp_partgroup_np) + addone
150
151        xmasssave(i)=rfraction-int(rfraction)
152
153      else
154! All particles are released in this time interval
155! ************************************************
156        if (mp_partid.lt.mod(npart(i),mp_partgroup_np)) then
157          addone=1
158        else
159          addone=0
160        end if
161
162        numrel=npart(i)/mp_partgroup_np+addone
163      endif
164
165      xaux=xpoint2(i)-xpoint1(i)
166      yaux=ypoint2(i)-ypoint1(i)
167      zaux=zpoint2(i)-zpoint1(i)
168      do j=1,numrel                       ! loop over particles to be released this time
169        do ipart=minpart,maxpart_mpi     ! search for free storage space
170
171! If a free storage space is found, attribute everything to this array element
172!*****************************************************************************
173
174          if (itra1(ipart).ne.itime) then
175
176! Particle coordinates are determined by using a random position within the release volume
177!*****************************************************************************
178
179! Determine horizontal particle position
180!***************************************
181
182            xtra1(ipart)=xpoint1(i)+ran1(idummy)*xaux
183            if (xglobal) then
184              if (xtra1(ipart).gt.real(nxmin1)) xtra1(ipart)= &
185                   xtra1(ipart)-real(nxmin1)
186              if (xtra1(ipart).lt.0.) xtra1(ipart)= &
187                   xtra1(ipart)+real(nxmin1)
188            endif
189            ytra1(ipart)=ypoint1(i)+ran1(idummy)*yaux
190
191! Assign mass to particle: Total mass divided by total number of particles.
192! Time variation has partly been taken into account already by a species-average
193! correction factor, by which the number of particles released this time has been
194! scaled. Adjust the mass per particle by the species-dependent time correction factor
195! divided by the species-average one
196!*****************************************************************************
197            do k=1,nspec
198              xmass1(ipart,k)=xmass(i,k)/real(npart(i)) &
199                   *timecorrect(k)/average_timecorrect
200              if (DRYBKDEP.or.WETBKDEP) then ! if there is no scavenging in wetdepo it will be set to 0
201!              if ( henry(k).gt.0 .or. &
202!                   crain_aero(k).gt.0. .or. csnow_aero(k).gt.0. .or. &
203!                   ccn_aero(k).gt.0. .or. in_aero(k).gt.0. )  then
204                xscav_frac1(ipart,k)=-1.
205               endif
206! Assign certain properties to particle
207!**************************************
208            end do
209            nclass(ipart)=min(int(ran1(idummy)*real(nclassunc))+1, &
210                 nclassunc)
211            numparticlecount=numparticlecount+1
212            if (mquasilag.eq.0) then
213              npoint(ipart)=i
214            else
215              npoint(ipart)=numparticlecount
216            endif
217            idt(ipart)=mintime               ! first time step
218            itra1(ipart)=itime
219            itramem(ipart)=itra1(ipart)
220            itrasplit(ipart)=itra1(ipart)+ldirect*itsplit
221
222
223! Determine vertical particle position
224!*************************************
225
226            ztra1(ipart)=zpoint1(i)+ran1(idummy)*zaux
227
228! Interpolation of topography and density
229!****************************************
230
231! Determine the nest we are in
232!*****************************
233
234            ngrid=0
235            do k=numbnests,1,-1
236              if ((xtra1(ipart).gt.xln(k)+eps).and. &
237                   (xtra1(ipart).lt.xrn(k)-eps).and. &
238                   (ytra1(ipart).gt.yln(k)+eps).and. &
239                   (ytra1(ipart).lt.yrn(k)-eps)) then
240                ngrid=k
241                goto 43
242              endif
243            end do
24443          continue
245
246! Determine (nested) grid coordinates and auxiliary parameters used for interpolation
247!*****************************************************************************
248
249            if (ngrid.gt.0) then
250              xtn=(xtra1(ipart)-xln(ngrid))*xresoln(ngrid)
251              ytn=(ytra1(ipart)-yln(ngrid))*yresoln(ngrid)
252              ix=int(xtn)
253              jy=int(ytn)
254              ddy=ytn-real(jy)
255              ddx=xtn-real(ix)
256            else
257              ix=int(xtra1(ipart))
258              jy=int(ytra1(ipart))
259              ddy=ytra1(ipart)-real(jy)
260              ddx=xtra1(ipart)-real(ix)
261            endif
262            ixp=ix+1
263            jyp=jy+1
264            rddx=1.-ddx
265            rddy=1.-ddy
266            p1=rddx*rddy
267            p2=ddx*rddy
268            p3=rddx*ddy
269            p4=ddx*ddy
270
271            if (ngrid.gt.0) then
272              topo=p1*oron(ix ,jy ,ngrid) &
273                   + p2*oron(ixp,jy ,ngrid) &
274                   + p3*oron(ix ,jyp,ngrid) &
275                   + p4*oron(ixp,jyp,ngrid)
276            else
277              topo=p1*oro(ix ,jy) &
278                   + p2*oro(ixp,jy) &
279                   + p3*oro(ix ,jyp) &
280                   + p4*oro(ixp,jyp)
281            endif
282
283! If starting height is in pressure coordinates, retrieve pressure profile and convert zpart1 to meters
284!*****************************************************************************
285            if (kindz(i).eq.3) then
286              presspart=ztra1(ipart)
287              do kz=1,nz
288                if (ngrid.gt.0) then
289                  r=p1*rhon(ix ,jy ,kz,mind2,ngrid) &
290                       +p2*rhon(ixp,jy ,kz,mind2,ngrid) &
291                       +p3*rhon(ix ,jyp,kz,mind2,ngrid) &
292                       +p4*rhon(ixp,jyp,kz,mind2,ngrid)
293                  t=p1*ttn(ix ,jy ,kz,mind2,ngrid) &
294                       +p2*ttn(ixp,jy ,kz,mind2,ngrid) &
295                       +p3*ttn(ix ,jyp,kz,mind2,ngrid) &
296                       +p4*ttn(ixp,jyp,kz,mind2,ngrid)
297                else
298                  r=p1*rho(ix ,jy ,kz,mind2) &
299                       +p2*rho(ixp,jy ,kz,mind2) &
300                       +p3*rho(ix ,jyp,kz,mind2) &
301                       +p4*rho(ixp,jyp,kz,mind2)
302                  t=p1*tt(ix ,jy ,kz,mind2) &
303                       +p2*tt(ixp,jy ,kz,mind2) &
304                       +p3*tt(ix ,jyp,kz,mind2) &
305                       +p4*tt(ixp,jyp,kz,mind2)
306                endif
307                press=r*r_air*t/100.
308                if (kz.eq.1) pressold=press
309
310                if (press.lt.presspart) then
311                  if (kz.eq.1) then
312                    ztra1(ipart)=height(1)/2.
313                  else
314                    dz1=pressold-presspart
315                    dz2=presspart-press
316                    ztra1(ipart)=(height(kz-1)*dz2+height(kz)*dz1) &
317                         /(dz1+dz2)
318                  endif
319                  goto 71
320                endif
321                pressold=press
322              end do
32371            continue
324            endif
325
326! If release positions are given in meters above sea level, subtract the
327! topography from the starting height
328!***********************************************************************
329
330            if (kindz(i).eq.2) ztra1(ipart)=ztra1(ipart)-topo
331            if (ztra1(ipart).lt.eps2) ztra1(ipart)=eps2   ! Minimum starting height is eps2
332            if (ztra1(ipart).gt.height(nz)-0.5) ztra1(ipart)= &
333                 height(nz)-0.5 ! Maximum starting height is uppermost level - 0.5 meters
334
335
336
337! For special simulations, multiply particle concentration air density;
338! Simply take the 2nd field in memory to do this (accurate enough)
339!***********************************************************************
340!AF IND_SOURCE switches between different units for concentrations at the source
341!Af    NOTE that in backward simulations the release of particles takes place at the
342!Af         receptor and the sampling at the source.
343!Af          1="mass"
344!Af          2="mass mixing ratio"
345!Af IND_RECEPTOR switches between different units for concentrations at the receptor
346!Af          1="mass"
347!Af          2="mass mixing ratio"
348
349!Af switches for the releasefile:
350!Af IND_REL =  1 : xmass * rho
351!Af IND_REL =  0 : xmass * 1
352
353!Af ind_rel is defined in readcommand.f
354
355            if ((ind_rel .eq. 1).or.(ind_rel .eq. 3).or.(ind_rel .eq. 4)) then
356
357! Interpolate the air density
358!****************************
359
360              do ii=2,nz
361                if (height(ii).gt.ztra1(ipart)) then
362                  indz=ii-1
363                  indzp=ii
364                  goto 6
365                endif
366              end do
3676             continue
368
369              dz1=ztra1(ipart)-height(indz)
370              dz2=height(indzp)-ztra1(ipart)
371              dz=1./(dz1+dz2)
372
373              if (ngrid.gt.0) then
374                do n=1,2
375                  rhoaux(n)=p1*rhon(ix ,jy ,indz+n-1,mind2,ngrid) &
376                       +p2*rhon(ixp,jy ,indz+n-1,mind2,ngrid) &
377                       +p3*rhon(ix ,jyp,indz+n-1,mind2,ngrid) &
378                       +p4*rhon(ixp,jyp,indz+n-1,mind2,ngrid)
379                end do
380              else
381                do n=1,2
382                  rhoaux(n)=p1*rho(ix ,jy ,indz+n-1,mind2) &
383                       +p2*rho(ixp,jy ,indz+n-1,mind2) &
384                       +p3*rho(ix ,jyp,indz+n-1,mind2) &
385                       +p4*rho(ixp,jyp,indz+n-1,mind2)
386                end do
387              endif
388              rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz
389              rho_rel(i)=rhoout
390
391
392! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density
393!********************************************************************
394
395              do k=1,nspec
396                xmass1(ipart,k)=xmass1(ipart,k)*rhoout
397              end do
398            endif
399
400
401            numpart=max(numpart,ipart)
402            goto 34      ! Storage space has been found, stop searching
403          endif
404        end do
405        if (ipart.gt.maxpart_mpi) goto 996
406
40734      minpart=ipart+1
408      end do
409    endif
410  end do
411
412
413  return
414
415996 continue
416  write(*,*) '#####################################################'
417  write(*,*) '#### FLEXPART MODEL SUBROUTINE RELEASEPARTICLES: ####'
418  write(*,*) '####                                             ####'
419  write(*,*) '#### ERROR - TOTAL NUMBER OF PARTICLES REQUIRED  ####'
420  write(*,*) '#### EXCEEDS THE MAXIMUM ALLOWED NUMBER. REDUCE  ####'
421  write(*,*) '#### EITHER NUMBER OF PARTICLES PER RELEASE POINT####'
422  write(*,*) '#### OR REDUCE NUMBER OF RELEASE POINTS.         ####'
423  write(*,*) '#####################################################'
424  stop
425
426end subroutine releaseparticles
Note: See TracBrowser for help on using the repository browser.
hosted by ZAMG