source: flexpart.git/src/releaseparticles_mpi.f90 @ 8a65cb0

10.4.1_peseiGFS_025bugfixes+enhancementsdevrelease-10release-10.4.1scaling-bugunivie
Last change on this file since 8a65cb0 was 8a65cb0, checked in by Espen Sollum ATMOS <espen@…>, 9 years ago

Added code, makefile for dev branch

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