diff --git a/src/adv_adv_above_pbl.f90 b/src/adv_adv_above_pbl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..24b38829ea3a00d33b437b25f2faaa1dc1ad348e --- /dev/null +++ b/src/adv_adv_above_pbl.f90 @@ -0,0 +1,118 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine adv_above_pbl(itime,itimec,dxsave,dysave,ux,vy,tropop,nrand,ipart) + + implicit none + integer, intent(in) :: & + itime, & ! time index + ipart ! particle index + integer, intent(inout) :: & + itimec, & ! next timestep + nrand ! random number used for turbulence + real, intent(in) :: & + tropop ! height of troposphere + real, intent(inout) :: & + ux,vy, & ! random turbulent velocities above PBL + dxsave,dysave ! accumulated displacement in long and lat + real :: & + dt, & ! real(ldt) + xts,yts,zts,ztseta, & ! local 'real' copy of the particle position + weta_settling, & ! settling velocity in eta coordinates + wp ! random turbulence velocities + integer :: & + insp,nsp ! loop variables for number of species + + zts=real(part(ipart)%z) + ztseta=real(part(ipart)%zeta) + xts=real(part(ipart)%xlon) + yts=real(part(ipart)%ylat) + if (lsettling) part(ipart)%settling=0. + + call interpol_wind(itime,xts,yts,zts,ztseta,ipart) + + ! 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) + !****************************************************************** + + part(ipart)%idt=abs(lsynctime-itimec+itime) + dt=real(part(ipart)%idt) + + if (.not.turboff) then + call turb_stratosph(dt,nrand,ux,vy,wp,tropop,zts) + else + !sec switch off turbulence + ux=0.0 + vy=0.0 + wp=0.0 + endif + + ! If particle represents only a single species, add gravitational settling + ! velocity. The settling velocity is zero for gases + !************************************************************************* + ! Does not work in eta coordinates yet + if (mdomainfill.eq.0) then + if (lsettling) then + if ((ipin.ne.3).and.(ipin.ne.4)) then + do insp=1,nspec + nsp=insp + if (xmass(part(ipart)%npoint,nsp).gt.eps3) exit + end do + else + nsp=1 + endif + ! LB change to eta coords? + if (density(nsp).gt.0.) then + call get_settling(itime,xts,yts,zts,nsp,part(ipart)%settling) + select case (wind_coord_type) + case ('ETA') + call update_zeta_to_z(itime,ipart) + call w_to_weta(itime,dt,part(ipart)%xlon,part(ipart)%ylat, & + part(ipart)%z,part(ipart)%zeta,part(ipart)%settling,weta_settling) + weta=weta+weta_settling + case ('METER') + w=w+part(ipart)%settling + case default + w=w+part(ipart)%settling + end select + end if + endif + end if + + ! Calculate position at time step itime+lsynctime + !************************************************ + dxsave=dxsave+(u+ux)*dt + dysave=dysave+(v+vy)*dt + + select case (wind_coord_type) + + case ('ETA') + + if (wp.ne.0.) then + call update_zeta_to_z(itime,ipart) + call update_z(ipart,wp*dt*real(ldirect)) + if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) + ! if particle below ground -> reflection + call update_z_to_zeta(itime,ipart) + endif + call update_zeta(ipart,weta*dt*real(ldirect)) + if (part(ipart)%zeta.ge.1.) call set_zeta(ipart,1.-(part(ipart)%zeta-1.)) + if (part(ipart)%zeta.eq.1.) call update_zeta(ipart,-eps_eta) + + case ('METER') + + call update_z(ipart,(w+wp)*dt*real(ldirect)) + if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) + + case default + + call update_z(ipart,(w+wp)*dt*real(ldirect)) + if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) + + end select + +end subroutine adv_above_pbl diff --git a/src/adv_adv_in_pbl.f90 b/src/adv_adv_in_pbl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c30bdd059a3abaa345b728492424cd24e28962b4 --- /dev/null +++ b/src/adv_adv_in_pbl.f90 @@ -0,0 +1,204 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine adv_in_pbl(itime,itimec, dxsave,dysave,dawsave,dcwsave, abovePBL, & + nrand,ipart,thread) + + use drydepo_mod, only: drydepo_probability + + implicit none + + logical, intent(inout) :: & + abovePBL + ! flag will be set to 'true' if computation needs to be completed above PBL + integer, intent(in) :: & + itime, & ! time index + ipart, & ! particle index + thread ! number of the omp thread + real, intent(inout) :: & + dxsave,dysave, & ! accumulated displacement in long and lat + dawsave,dcwsave ! accumulated displacement in wind directions + integer, intent(inout) :: & + itimec, & ! next timestep + nrand ! random number used for turbulence + real :: & + dt, & ! real(ldt) + xts,yts,zts,ztseta, & ! local 'real' copy of the particle position + rhoa, & ! air density, used in CBL + rhograd ! vertical gradient of air density, used in CBL + integer :: & + loop, & ! loop variable for time in the PBL + nsp,insp ! loop variable for species + real :: vdepo(maxspec) ! deposition velocities for all species + + eps=nxmax/3.e5 + if (lsettling) part(ipart)%settling=0. + + ! BEGIN TIME LOOP + !================ + ! For wind_coord_type=ETA: + ! Within this loop, only METER coordinates are used, and the new z value will + ! be updated to ETA coordinates at the end + !**************************************************************************** + + call update_zeta_to_z(itime,ipart) + + loop=0 + pbl_loop: do + + loop=loop+1 + if (method.eq.1) then + part(ipart)%idt=min(part(ipart)%idt,abs(lsynctime-itimec+itime)) + itimec=itimec+part(ipart)%idt*ldirect + else + part(ipart)%idt=abs(lsynctime) + itimec=itime+lsynctime + endif + dt=real(part(ipart)%idt) + xts=real(part(ipart)%xlon) + yts=real(part(ipart)%ylat) + zts=real(part(ipart)%z) + + zeta=zts/h + if (loop.eq.1) then ! Temporal interpolation only for the first iteration + + if (ngrid.le.0) then + xts=real(part(ipart)%xlon) + yts=real(part(ipart)%ylat) + call interpol_pbl(itime,xts,yts,zts,real(part(ipart)%zeta)) + else + call interpol_pbl(itime,xtn,ytn,zts,real(part(ipart)%zeta)) + endif + + else + + ! Determine the level below the current position for u,v,rho + !*********************************************************** + call find_z_level_meters(zts) + + ! If one of the levels necessary is not yet available, + ! calculate it + !***************************************************** + call interpol_pbl_misslev() + + endif + + ! 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 + !**************************************************************** + + call interpol_pbl_short(zts,rhoa,rhograd) ! Vertical interpolation + + ! Compute the turbulent disturbances + ! Determine the sigmas and the timescales + !**************************************** + + if (.not.turboff) then + call turb_pbl(ipart,nrand,dt,zts,rhoa,rhograd,thread) + ! Note: zts and nrand get updated + + ! Determine time step for next integration + !***************************************** + if (turbswitch) then + part(ipart)%idt = int( & + min( tlw, & + h/max( 2.*abs(part(ipart)%turbvel%w*sigw), 1.e-5 ), & + 0.5/abs(dsigwdz) & + ) *ctl) + else + part(ipart)%idt = int( & + min( tlw, & + h/max( 2.*abs(part(ipart)%turbvel%w), 1.e-5) & + ) *ctl) + endif + else + part(ipart)%turbvel%u=0. + part(ipart)%turbvel%v=0. + part(ipart)%turbvel%w=0. + endif + + part(ipart)%idt=max(part(ipart)%idt,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 + if (lsettling) then + if ((ipin.ne.3).and.(ipin.ne.4)) then + do insp=1,nspec + nsp=insp + if (xmass(part(ipart)%npoint,nsp).gt.eps3) exit + end do + else + nsp=1 + endif + if (density(nsp).gt.0.) then + call get_settling(itime,xts,yts,zts,nsp,part(ipart)%settling) !bugfix + w=w+part(ipart)%settling + end if + end if + 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 + dysave=dysave+v*dt + dawsave=dawsave+part(ipart)%turbvel%u*dt + dcwsave=dcwsave+part(ipart)%turbvel%v*dt + ! How can I change the w to w(eta) efficiently? + + select case (wind_coord_type) + + case ('ETA') + + call update_z(ipart,w*dt*real(ldirect)) + zts=real(part(ipart)%z) + ! HSO/AL: Particle managed to go over highest level -> interpolation + ! error in goto 700 + ! alias interpol_wind (division by zero) + if (zts.ge.height(nz)) call set_z(ipart,height(nz)-100.*eps) + ! Manually for z instead + + case ('METER') + + call update_z(ipart,w*dt*real(ldirect)) + call pushpartdown(ipart) + + end select + zts=real(part(ipart)%z) + + if (zts.gt.h) then + call update_z_to_zeta(itime,ipart) + if (itimec.ne.itime+lsynctime) abovePBL=.true. + ! complete the current interval above PBL + return + endif + + ! Determine probability of deposition + !************************************ + call drydepo_probability(part(ipart)%prob,dt,zts,vdepo) + + if (zts.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) + ! if particle below ground -> reflection + + if (itimec.eq.(itime+lsynctime)) then + ! Convert z position that changed by turbulent motions to eta coords + call update_z_to_zeta(itime,ipart) + return ! finished + endif + + end do pbl_loop + + call update_z_to_zeta(itime,ipart) + +end subroutine adv_in_pbl diff --git a/src/adv_advance.f90 b/src/adv_advance.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4c3e398e3e022c110576c078d77a3d2445a72ada --- /dev/null +++ b/src/adv_advance.f90 @@ -0,0 +1,293 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine advance(itime,ipart,thread) + + !***************************************************************************** + ! * + ! 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 'interpol_mod'. The following * + ! interpolation routines are used: * + ! * + ! interpol_all(_nest) interpolates everything (called inside the PBL) * + ! interpol_misslev(_nest) if a particle moves vertically in the PBL, * + ! additional parameters are interpolated if it * + ! crosses a model level * + ! interpol_wind(_nest) interpolates the wind and determines the * + ! standard deviation of the wind (called outside * + ! PBL) also interpolates potential vorticity * + ! interpol_wind_short(_nest) only interpolates the wind (needed for the * + ! Petterssen scheme) * + ! interpol_vdep(_nest) interpolates deposition velocities * + ! * + ! * + ! Author: A. Stohl * + ! * + ! 16 December 1997 * + ! * + ! Changes: * + ! * + ! 8 April 2000: Deep convection parameterization * + ! * + ! May 2002: Petterssen scheme introduced * + ! * + ! 2021, L. Bakels: * + ! - Separated PBL and above PBL computations in different * + ! subroutines * + ! - Moved all turbulence computations to turbulence_mod.f90 * + !***************************************************************************** + ! * + ! Variables: * + ! icbt 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 * + ! xt,yt,zt Particle position * + ! * + !***************************************************************************** + + ! openmp change + use omp_lib, only: OMP_GET_THREAD_NUM + ! openmp change end + + implicit none + integer, intent(in) :: & + itime, & ! time index + ipart, & ! particle index + thread ! OMP thread + integer :: & + itimec, & + i,j,k, & ! loop variables + nrand, & ! random number used for turbulence + memindnext, & ! seems useless + ngr, & ! temporary new grid index of moved particle + nsp ! loop variables for number of species + real :: & + ux,vy, & ! random turbulent velocities above PBL + weta_settling, & ! Settling velocity in eta coordinates + tropop, & ! height of troposphere + dxsave,dysave, & ! accumulated displacement in long and lat + dawsave,dcwsave ! accumulated displacement in wind directions + logical :: & + abovePBL + ! flag will be set to 'true' if computation needs to be completed above PBL + + eps=nxmax/3.e5 + + part(ipart)%nstop=.false. + do i=1,nmixz + indzindicator(i)=.true. + end do + + if (DRYDEP) then ! reset probability for deposition + depoindicator=.true. + part(ipart)%prob=0. + endif + + if (lsettling) part(ipart)%settling=0. + + !if (ipart.eq.1) write(*,*) 'Mass: ', part(ipart)%mass(:), itime + dxsave=0. ! reset position displacements + dysave=0. ! due to mean wind + dawsave=0. ! and turbulent wind + dcwsave=0. + + itimec=itime + + nrand=int(ran3(iseed1(thread),thread)*real(maxrand-1))+1 + + ! Determine whether lat/long grid or polarstereographic projection + ! is to be used + ! Furthermore, determine which nesting level to be used + !***************************************************************** + call find_ngrid(part(ipart)%xlon,part(ipart)%ylat) + + !*************************** + ! Interpolate necessary data + !*************************** + + if (abs(itime-memtime(1)).lt.abs(itime-memtime(2))) then + memindnext=1 + else + memindnext=2 + endif + + ! Convert z(eta) to z(m) for the turbulence scheme, w(m/s) + ! is computed in verttransform_ecmwf.f90 + + call update_zeta_to_z(itime,ipart) + + ! Determine nested grid coordinates + ! Determine the lower left corner and its distance to the current position + ! Calculate variables for time interpolation + !******************************************* + call init_interpol(itime, & + real(part(ipart)%xlon),real(part(ipart)%ylat),& + real(part(ipart)%z), real(part(ipart)%zeta)) + + ! Compute maximum mixing height around particle position + !******************************************************* + + ! Compute height of troposphere and PBL at x-y location of particle + call interpol_htropo_hmix(tropop,h) + zeta=real(part(ipart)%z)/h + + !************************************************************* + ! If particle is in the PBL, interpolate once and then make a + ! time loop until end of interval is reached + !************************************************************* + ! In the PBL we use meters instead of eta coordinates for vertical transport + + abovePBL=.true. + if (zeta.le.1.) then + + abovePBL=.false. + call adv_in_pbl(itime,itimec,& + dxsave,dysave,dawsave,dcwsave,abovePBL,nrand,ipart,thread) + if (wind_coord_type.eq.'ETA' .and. lsettling) then + call w_to_weta(itime,real(part(ipart)%idt),part(ipart)%xlon, & + part(ipart)%ylat,part(ipart)%z,part(ipart)%zeta, & + part(ipart)%settling,weta_settling) + weta=weta+weta_settling + endif + + 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 + !********************* + + if (abovePBL) call adv_above_pbl(itime,itimec,dxsave,dysave, & + ux,vy,tropop,nrand,ipart) + ! Above PBL computation + + !**************************************************************** + ! 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 fturbmeso. + ! The autocorrelation time constant is taken as half the + ! time interval between wind fields + !**************************************************************** + + if (.not. turboff) then + ! mesoscale turbulence is found to give issues, so turned off + if (lmesoscale_turb) then + call interpol_mesoscale(itime, & + real(part(ipart)%xlon),real(part(ipart)%ylat), & + real(part(ipart)%z),real(part(ipart)%zeta)) + call turb_mesoscale(nrand,dxsave,dysave,ipart, & + usig,vsig,wsig,wsigeta,eps_eta) + endif + + !************************************************************* + ! 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 + ! comment by MC: comment this line to stop particles horizontally for tests + dysave=dysave+vy + endif + + call update_xy(dxsave,dysave,ipart) + if (part(ipart)%nstop) return + + ! If particle above highest model level, set it back into the domain + !******************************************************************* + call pushpartdown(ipart) + + !************************************************************************ + ! 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 (part(ipart)%idt .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+part(ipart)%idt*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 + !***************************************************************************** + ! ngr = ngrid + ! call find_ngrid(part(ipart)%xlon,part(ipart)%ylat) + + if (nglobal .and. real(part(ipart)%ylat).gt.switchnorthg) then + ngr=-1 + else if (sglobal.and. real(part(ipart)%ylat).lt.switchsouthg) then + ngr=-2 + else + ngr=0 + ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) + do j=numbnests,1,-1 + if (real(part(ipart)%xlon).gt.xln(j)+dxn(j) .and. & + real(part(ipart)%xlon).lt.xrn(j)-dxn(j) .and. & + real(part(ipart)%ylat).gt.yln(j)+dyn(j) .and. & + real(part(ipart)%ylat).lt.yrn(j)-dyn(j)) then + ngr=j + exit + endif + end do + endif + + if (ngr.ne.ngrid) return + + call petterson_corr(itime,ipart) + +end subroutine advance diff --git a/src/adv_petterson_corr.f90 b/src/adv_petterson_corr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b1c11a0fd31104142d840578ff034ab7619c9cf2 --- /dev/null +++ b/src/adv_petterson_corr.f90 @@ -0,0 +1,131 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine petterson_corr(itime,ipart) + + implicit none + + integer, intent(in) :: & + itime, & ! time index + ipart ! particle index + integer :: & + nsp,insp ! loop variables for number of species + real :: & + xts,yts,zts,ztseta, & ! local 'real' copy of the particle position + uold,vold,wold,woldeta, & + weta_settling + real(kind=dp) :: & + ztemp ! temporarily storing z position + + + xts=real(part(ipart)%xlon) + yts=real(part(ipart)%ylat) + zts=real(part(ipart)%z) + ztseta=real(part(ipart)%zeta) + if (lsettling) part(ipart)%settling=0. + + ! Memorize the old wind + !********************** + + uold=u + vold=v + + select case (wind_coord_type) + case ('ETA') + woldeta=weta + case ('METER') + wold=w + case default + wold=w + end select + + ! Interpolate wind at new position and time + !****************************************** + call interpol_wind_short(itime+part(ipart)%idt*ldirect,xts,yts,zts,ztseta) + + if (mdomainfill.eq.0) then + if (lsettling) then + if ((ipin.ne.3).and.(ipin.ne.4)) then + do insp=1,nspec + nsp=insp + if (xmass(part(ipart)%npoint,nsp).gt.eps3) exit + end do + else + nsp=1 + endif + if (density(nsp).gt.0.) then + select case (wind_coord_type) + + case ('ETA') + + call update_zeta_to_z(itime+part(ipart)%idt,ipart) + call update_z_to_zeta(itime+part(ipart)%idt,ipart) + zts=real(part(ipart)%z) + call get_settling( & + itime+part(ipart)%idt,xts,yts,zts,nsp,part(ipart)%settling) !bugfix + call w_to_weta( & + itime+part(ipart)%idt, real(part(ipart)%idt), part(ipart)%xlon, & + part(ipart)%ylat, part(ipart)%z, part(ipart)%zeta, & + part(ipart)%settling, weta_settling) + weta=weta+weta_settling + !woldeta= + !real(part(ipart)%zeta-part(ipart)%zeta_prev)/real(part(ipart)%idt*ldirect) + + case ('METER') + + call get_settling( & + itime+part(ipart)%idt,xts,yts,zts,nsp,part(ipart)%settling) + w=w+part(ipart)%settling + + case default + + call get_settling( & + itime+part(ipart)%idt,xts,yts,zts,nsp,part(ipart)%settling) + w=w+part(ipart)%settling + + end select + end if + endif + end if + + ! Determine the difference vector between new and old wind + ! (use half of it to correct position according to Petterssen) + !************************************************************* + + u=(u-uold)*0.5 + v=(v-vold)*0.5 + + select case (wind_coord_type) + + case ('ETA') + + weta=(weta-woldeta)/2. + call update_zeta(ipart,weta*real(part(ipart)%idt*ldirect)) + if (part(ipart)%zeta.ge.1.) call set_zeta(ipart,1.-(part(ipart)%zeta-1.)) + if (part(ipart)%zeta.eq.1.) call update_zeta(ipart,-eps_eta) + + case ('METER') + + w=(w-wold)/2. + call update_z(ipart,w*real(part(ipart)%idt*ldirect)) + if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) ! if particle below ground -> reflection + + case default + + w=(w-wold)/2. + call update_z(ipart,w*real(part(ipart)%idt*ldirect)) + if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) + + end select + + ! Finally, correct the old position + !********************************** + + call update_xy(u*part(ipart)%idt,v*part(ipart)%idt,ipart) + + ! If particle above highest model level, set it back into the domain + !******************************************************************* + + call pushpartdown(ipart) + +end subroutine petterson_corr diff --git a/src/adv_pushpartdown.f90 b/src/adv_pushpartdown.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1bb8238675ab17f9bf23891158f7a13121922bcc --- /dev/null +++ b/src/adv_pushpartdown.f90 @@ -0,0 +1,32 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine pushpartdown(ipart) + + implicit none + + integer, intent(in) :: & + ipart ! particle index + + eps=nxmax/3.e5 + + select case (wind_coord_type) + + case ('ETA') + + if (part(ipart)%zeta.le.real(uvheight(nz),kind=dp)) & + call set_zeta(ipart,uvheight(nz)+eps_eta) + + case ('METER') + + if (part(ipart)%z.ge.real(height(nz),kind=dp)) & + call set_z(ipart,height(nz)-100.*eps) + + case default + + if (part(ipart)%z.ge.real(height(nz),kind=dp)) & + call set_z(ipart,height(nz)-100.*eps) + + end select + +end subroutine pushpartdown diff --git a/src/adv_update_xy.f90 b/src/adv_update_xy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4803d57ca57129334261057f4c7950efff486b88 --- /dev/null +++ b/src/adv_update_xy.f90 @@ -0,0 +1,97 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine update_xy(xchange,ychange,ipart) + + implicit none + + integer, intent(in) :: & + ipart ! particle number + real, intent(in) :: & + xchange,ychange ! change in position + real :: & + xlon,ylat,xpol,ypol, & ! temporarily storing new particle positions + gridsize,cosfact ! used to compute new positions of particles + + eps=nxmax/3.e5 + + if (ngrid.ge.0) then + + cosfact=dxconst/cos((real(part(ipart)%ylat)*dy+ylat0)*pi180) + call update_xlon(ipart,real(xchange*cosfact*real(ldirect),kind=dp)) + call update_ylat(ipart,real(ychange*dyconst*real(ldirect),kind=dp)) + + else if (ngrid.eq.-1) then ! around north pole + + xlon=xlon0+real(part(ipart)%xlon)*dx !comment by MC: compute old part pos. + ylat=ylat0+real(part(ipart)%ylat)*dy + call cll2xy(northpolemap,ylat,xlon,xpol,ypol) + !convert old particle position in polar stereographic + gridsize=1000.*cgszll(northpolemap,ylat,xlon) + !calculate size in m of grid element in polar stereographic coordinate + xpol=xpol+xchange/gridsize*real(ldirect) + !position in grid unit polar stereographic + ypol=ypol+ychange/gridsize*real(ldirect) + call cxy2ll(northpolemap,xpol,ypol,ylat,xlon) + !convert to lat long coordinate + call set_xlon(ipart,real((xlon-xlon0)/dx,kind=dp)) + !convert to grid units in lat long coordinate, comment by mc + call set_ylat(ipart,real((ylat-ylat0)/dy,kind=dp)) + + else if (ngrid.eq.-2) then ! around south pole + + xlon=xlon0+real(part(ipart)%xlon)*dx + ylat=ylat0+real(part(ipart)%ylat)*dy + call cll2xy(southpolemap,ylat,xlon,xpol,ypol) + gridsize=1000.*cgszll(southpolemap,ylat,xlon) + xpol=xpol+xchange/gridsize*real(ldirect) + ypol=ypol+ychange/gridsize*real(ldirect) + call cxy2ll(southpolemap,xpol,ypol,ylat,xlon) + call set_xlon(ipart,real((xlon-xlon0)/dx,kind=dp)) + call set_ylat(ipart,real((ylat-ylat0)/dy,kind=dp)) + + endif + + ! If global data are available, use cyclic boundary condition + !************************************************************ + + if (xglobal) then + if (part(ipart)%xlon .ge. real(nxmin1, kind=dp)) & + call update_xlon(ipart,-real(nxmin1, kind=dp)) + if (part(ipart)%xlon .lt. 0.) call update_xlon(ipart,real(nxmin1, kind=dp)) + if (part(ipart)%xlon .le. real(eps, kind=dp)) & + call set_xlon(ipart,real(eps, kind=dp)) + if (abs( part(ipart)%xlon - real(nxmin1, kind=dp)) .le. eps) & + call set_xlon(ipart,real(nxmin1-eps,kind=dp)) + endif + + ! HSO/AL: Prevent particles from disappearing at the pole + !****************************************************************** + if (sglobal .and. part(ipart)%ylat.lt.0. ) then + call set_xlon(ipart, & + mod( part(ipart)%xlon + real(nxmin1*0.5, kind=dp), real(nxmin1, kind=dp))) + call set_ylat(ipart,-part(ipart)%ylat) + ! In extremely rare cases, the ylat exceeds the bounds, + ! so we set it back into the domain here + if ( part(ipart)%ylat.gt.real(nymin1,kind=dp) ) & + call set_ylat(ipart, & + real(nymin1, kind=dp) - mod( part(ipart)%ylat, real(nymin1, kind=dp))) + else if (nglobal .and. part(ipart)%ylat .gt. real(nymin1, kind=dp) ) then + call set_xlon(ipart, & + mod( part(ipart)%xlon + real(nxmin1*0.5, kind=dp), real(nxmin1, kind=dp))) + call set_ylat(ipart,2.*real(nymin1,kind=dp) - part(ipart)%ylat) + endif + + ! Check position: If trajectory outside model domain, terminate it + !***************************************************************** + ! Not necessary to check when using global domain, but some problems in the + ! meteo data could cause particles to go crazy. + ! if (gdomainfill) return + + if (part(ipart)%xlon.lt.0. .or. part(ipart)%xlon.ge.real(nxmin1,kind=dp) & + .or. part(ipart)%ylat.lt.0. .or. part(ipart)%ylat.gt.real(nymin1,kind=dp)) then + part(ipart)%nstop=.true. + return + endif + +end subroutine update_xy diff --git a/src/advance_mod.f90 b/src/advance_mod.f90 index 2cb3a8e9e2c00df906967320c6af04b21d9c221a..cd8300720d542c11bb8a63b13afa15e024ff7272 100644 --- a/src/advance_mod.f90 +++ b/src/advance_mod.f90 @@ -20,7 +20,7 @@ module advance_mod use turbulence_mod use settling_mod - implicit none + implicit none real, parameter :: & eps2=1.e-9, & eps3=tiny(1.0), & @@ -29,868 +29,17 @@ module advance_mod eps private :: adv_above_pbl, adv_in_pbl, petterson_corr, update_xy, pushpartdown contains - -subroutine advance(itime,ipart,thread) - - !***************************************************************************** - ! * - ! 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 'interpol_mod'. The following * - ! interpolation routines are used: * - ! * - ! interpol_all(_nest) interpolates everything (called inside the PBL) * - ! interpol_misslev(_nest) if a particle moves vertically in the PBL, * - ! additional parameters are interpolated if it * - ! crosses a model level * - ! interpol_wind(_nest) interpolates the wind and determines the * - ! standard deviation of the wind (called outside * - ! PBL) also interpolates potential vorticity * - ! interpol_wind_short(_nest) only interpolates the wind (needed for the * - ! Petterssen scheme) * - ! interpol_vdep(_nest) interpolates deposition velocities * - ! * - ! * - ! Author: A. Stohl * - ! * - ! 16 December 1997 * - ! * - ! Changes: * - ! * - ! 8 April 2000: Deep convection parameterization * - ! * - ! May 2002: Petterssen scheme introduced * - ! * - ! 2021, L. Bakels: * - ! - Separated PBL and above PBL computations in different * - ! subroutines * - ! - Moved all turbulence computations to turbulence_mod.f90 * - !***************************************************************************** - ! * - ! Variables: * - ! icbt 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 * - ! xt,yt,zt Particle position * - ! * - !***************************************************************************** - - ! openmp change - use omp_lib, only: OMP_GET_THREAD_NUM - ! openmp change end - - implicit none - integer, intent(in) :: & - itime, & ! time index - ipart, & ! particle index - thread ! OMP thread - integer :: & - itimec, & - i,j,k, & ! loop variables - nrand, & ! random number used for turbulence - memindnext, & ! seems useless - ngr, & ! temporary new grid index of moved particle - nsp ! loop variables for number of species - real :: & - ux,vy, & ! random turbulent velocities above PBL - weta_settling, & ! Settling velocity in eta coordinates - tropop, & ! height of troposphere - dxsave,dysave, & ! accumulated displacement in long and lat - dawsave,dcwsave ! accumulated displacement in wind directions - logical :: & - abovePBL - ! flag will be set to 'true' if computation needs to be completed above PBL - - eps=nxmax/3.e5 - - part(ipart)%nstop=.false. - do i=1,nmixz - indzindicator(i)=.true. - end do - - if (DRYDEP) then ! reset probability for deposition - depoindicator=.true. - part(ipart)%prob=0. - endif - - if (lsettling) part(ipart)%settling=0. - - !if (ipart.eq.1) write(*,*) 'Mass: ', part(ipart)%mass(:), itime - dxsave=0. ! reset position displacements - dysave=0. ! due to mean wind - dawsave=0. ! and turbulent wind - dcwsave=0. - - itimec=itime - - nrand=int(ran3(iseed1(thread),thread)*real(maxrand-1))+1 - - ! Determine whether lat/long grid or polarstereographic projection - ! is to be used - ! Furthermore, determine which nesting level to be used - !***************************************************************** - call find_ngrid(part(ipart)%xlon,part(ipart)%ylat) - - !*************************** - ! Interpolate necessary data - !*************************** - - if (abs(itime-memtime(1)).lt.abs(itime-memtime(2))) then - memindnext=1 - else - memindnext=2 - endif - - ! Convert z(eta) to z(m) for the turbulence scheme, w(m/s) - ! is computed in verttransform_ecmwf.f90 - - call update_zeta_to_z(itime,ipart) - - ! Determine nested grid coordinates - ! Determine the lower left corner and its distance to the current position - ! Calculate variables for time interpolation - !******************************************* - call init_interpol(itime, & - real(part(ipart)%xlon),real(part(ipart)%ylat),& - real(part(ipart)%z), real(part(ipart)%zeta)) - - ! Compute maximum mixing height around particle position - !******************************************************* - - ! Compute height of troposphere and PBL at x-y location of particle - call interpol_htropo_hmix(tropop,h) - zeta=real(part(ipart)%z)/h - - !************************************************************* - ! If particle is in the PBL, interpolate once and then make a - ! time loop until end of interval is reached - !************************************************************* - ! In the PBL we use meters instead of eta coordinates for vertical transport - - abovePBL=.true. - if (zeta.le.1.) then - - abovePBL=.false. - call adv_in_pbl(itime,itimec,& - dxsave,dysave,dawsave,dcwsave,abovePBL,nrand,ipart,thread) - if (wind_coord_type.eq.'ETA' .and. lsettling) then - call w_to_weta(itime,real(part(ipart)%idt),part(ipart)%xlon, & - part(ipart)%ylat,part(ipart)%z,part(ipart)%zeta, & - part(ipart)%settling,weta_settling) - weta=weta+weta_settling - endif - - 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 - !********************* - - if (abovePBL) call adv_above_pbl(itime,itimec,dxsave,dysave, & - ux,vy,tropop,nrand,ipart) - ! Above PBL computation - - !**************************************************************** - ! 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 fturbmeso. - ! The autocorrelation time constant is taken as half the - ! time interval between wind fields - !**************************************************************** - - if (.not. turboff) then - ! mesoscale turbulence is found to give issues, so turned off - if (lmesoscale_turb) then - call interpol_mesoscale(itime, & - real(part(ipart)%xlon),real(part(ipart)%ylat), & - real(part(ipart)%z),real(part(ipart)%zeta)) - call turb_mesoscale(nrand,dxsave,dysave,ipart, & - usig,vsig,wsig,wsigeta,eps_eta) - endif - - !************************************************************* - ! 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 - ! comment by MC: comment this line to stop particles horizontally for tests - dysave=dysave+vy - endif - - call update_xy(dxsave,dysave,ipart) - if (part(ipart)%nstop) return - - ! If particle above highest model level, set it back into the domain - !******************************************************************* - call pushpartdown(ipart) - - !************************************************************************ - ! 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 (part(ipart)%idt .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+part(ipart)%idt*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 - !***************************************************************************** - ! ngr = ngrid - ! call find_ngrid(part(ipart)%xlon,part(ipart)%ylat) - - if (nglobal .and. real(part(ipart)%ylat).gt.switchnorthg) then - ngr=-1 - else if (sglobal.and. real(part(ipart)%ylat).lt.switchsouthg) then - ngr=-2 - else - ngr=0 - ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) - do j=numbnests,1,-1 - if (real(part(ipart)%xlon).gt.xln(j)+dxn(j) .and. & - real(part(ipart)%xlon).lt.xrn(j)-dxn(j) .and. & - real(part(ipart)%ylat).gt.yln(j)+dyn(j) .and. & - real(part(ipart)%ylat).lt.yrn(j)-dyn(j)) then - ngr=j - exit - endif - end do - endif - - if (ngr.ne.ngrid) return - - call petterson_corr(itime,ipart) - -end subroutine advance - -subroutine adv_above_pbl(itime,itimec,dxsave,dysave,ux,vy,tropop,nrand,ipart) - - implicit none - integer, intent(in) :: & - itime, & ! time index - ipart ! particle index - integer, intent(inout) :: & - itimec, & ! next timestep - nrand ! random number used for turbulence - real, intent(in) :: & - tropop ! height of troposphere - real, intent(inout) :: & - ux,vy, & ! random turbulent velocities above PBL - dxsave,dysave ! accumulated displacement in long and lat - real :: & - dt, & ! real(ldt) - xts,yts,zts,ztseta, & ! local 'real' copy of the particle position - weta_settling, & ! settling velocity in eta coordinates - wp ! random turbulence velocities - integer :: & - insp,nsp ! loop variables for number of species - - zts=real(part(ipart)%z) - ztseta=real(part(ipart)%zeta) - xts=real(part(ipart)%xlon) - yts=real(part(ipart)%ylat) - if (lsettling) part(ipart)%settling=0. - - call interpol_wind(itime,xts,yts,zts,ztseta,ipart) - - ! 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) - !****************************************************************** - - part(ipart)%idt=abs(lsynctime-itimec+itime) - dt=real(part(ipart)%idt) - - if (.not.turboff) then - call turb_stratosph(dt,nrand,ux,vy,wp,tropop,zts) - else - !sec switch off turbulence - ux=0.0 - vy=0.0 - wp=0.0 - endif - - ! If particle represents only a single species, add gravitational settling - ! velocity. The settling velocity is zero for gases - !************************************************************************* - ! Does not work in eta coordinates yet - if (mdomainfill.eq.0) then - if (lsettling) then - if ((ipin.ne.3).and.(ipin.ne.4)) then - do insp=1,nspec - nsp=insp - if (xmass(part(ipart)%npoint,nsp).gt.eps3) exit - end do - else - nsp=1 - endif - ! LB change to eta coords? - if (density(nsp).gt.0.) then - call get_settling(itime,xts,yts,zts,nsp,part(ipart)%settling) - select case (wind_coord_type) - case ('ETA') - call update_zeta_to_z(itime,ipart) - call w_to_weta(itime,dt,part(ipart)%xlon,part(ipart)%ylat, & - part(ipart)%z,part(ipart)%zeta,part(ipart)%settling,weta_settling) - weta=weta+weta_settling - case ('METER') - w=w+part(ipart)%settling - case default - w=w+part(ipart)%settling - end select - end if - endif - end if - - ! Calculate position at time step itime+lsynctime - !************************************************ - dxsave=dxsave+(u+ux)*dt - dysave=dysave+(v+vy)*dt - - select case (wind_coord_type) - - case ('ETA') - - if (wp.ne.0.) then - call update_zeta_to_z(itime,ipart) - call update_z(ipart,wp*dt*real(ldirect)) - if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) - ! if particle below ground -> reflection - call update_z_to_zeta(itime,ipart) - endif - call update_zeta(ipart,weta*dt*real(ldirect)) - if (part(ipart)%zeta.ge.1.) call set_zeta(ipart,1.-(part(ipart)%zeta-1.)) - if (part(ipart)%zeta.eq.1.) call update_zeta(ipart,-eps_eta) - - case ('METER') - - call update_z(ipart,(w+wp)*dt*real(ldirect)) - if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) - - case default - - call update_z(ipart,(w+wp)*dt*real(ldirect)) - if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) - - end select - -end subroutine adv_above_pbl - -subroutine adv_in_pbl(itime,itimec, dxsave,dysave,dawsave,dcwsave, abovePBL, & - nrand,ipart,thread) - - use drydepo_mod, only: drydepo_probability - - implicit none - - logical, intent(inout) :: & - abovePBL - ! flag will be set to 'true' if computation needs to be completed above PBL - integer, intent(in) :: & - itime, & ! time index - ipart, & ! particle index - thread ! number of the omp thread - real, intent(inout) :: & - dxsave,dysave, & ! accumulated displacement in long and lat - dawsave,dcwsave ! accumulated displacement in wind directions - integer, intent(inout) :: & - itimec, & ! next timestep - nrand ! random number used for turbulence - real :: & - dt, & ! real(ldt) - xts,yts,zts,ztseta, & ! local 'real' copy of the particle position - rhoa, & ! air density, used in CBL - rhograd ! vertical gradient of air density, used in CBL - integer :: & - loop, & ! loop variable for time in the PBL - nsp,insp ! loop variable for species - real :: vdepo(maxspec) ! deposition velocities for all species - - eps=nxmax/3.e5 - if (lsettling) part(ipart)%settling=0. - - ! BEGIN TIME LOOP - !================ - ! For wind_coord_type=ETA: - ! Within this loop, only METER coordinates are used, and the new z value will - ! be updated to ETA coordinates at the end - !**************************************************************************** - - call update_zeta_to_z(itime,ipart) - - loop=0 - pbl_loop: do - - loop=loop+1 - if (method.eq.1) then - part(ipart)%idt=min(part(ipart)%idt,abs(lsynctime-itimec+itime)) - itimec=itimec+part(ipart)%idt*ldirect - else - part(ipart)%idt=abs(lsynctime) - itimec=itime+lsynctime - endif - dt=real(part(ipart)%idt) - xts=real(part(ipart)%xlon) - yts=real(part(ipart)%ylat) - zts=real(part(ipart)%z) - - zeta=zts/h - if (loop.eq.1) then ! Temporal interpolation only for the first iteration - - if (ngrid.le.0) then - xts=real(part(ipart)%xlon) - yts=real(part(ipart)%ylat) - call interpol_pbl(itime,xts,yts,zts,real(part(ipart)%zeta)) - else - call interpol_pbl(itime,xtn,ytn,zts,real(part(ipart)%zeta)) - endif - - else - - ! Determine the level below the current position for u,v,rho - !*********************************************************** - call find_z_level_meters(zts) - - ! If one of the levels necessary is not yet available, - ! calculate it - !***************************************************** - call interpol_pbl_misslev() - - endif - - ! 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 - !**************************************************************** - - call interpol_pbl_short(zts,rhoa,rhograd) ! Vertical interpolation - - ! Compute the turbulent disturbances - ! Determine the sigmas and the timescales - !**************************************** - - if (.not.turboff) then - call turb_pbl(ipart,nrand,dt,zts,rhoa,rhograd,thread) - ! Note: zts and nrand get updated - - ! Determine time step for next integration - !***************************************** - if (turbswitch) then - part(ipart)%idt = int( & - min( tlw, & - h/max( 2.*abs(part(ipart)%turbvel%w*sigw), 1.e-5 ), & - 0.5/abs(dsigwdz) & - ) *ctl) - else - part(ipart)%idt = int( & - min( tlw, & - h/max( 2.*abs(part(ipart)%turbvel%w), 1.e-5) & - ) *ctl) - endif - else - part(ipart)%turbvel%u=0. - part(ipart)%turbvel%v=0. - part(ipart)%turbvel%w=0. - endif - - part(ipart)%idt=max(part(ipart)%idt,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 - if (lsettling) then - if ((ipin.ne.3).and.(ipin.ne.4)) then - do insp=1,nspec - nsp=insp - if (xmass(part(ipart)%npoint,nsp).gt.eps3) exit - end do - else - nsp=1 - endif - if (density(nsp).gt.0.) then - call get_settling(itime,xts,yts,zts,nsp,part(ipart)%settling) !bugfix - w=w+part(ipart)%settling - end if - end if - 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 - dysave=dysave+v*dt - dawsave=dawsave+part(ipart)%turbvel%u*dt - dcwsave=dcwsave+part(ipart)%turbvel%v*dt - ! How can I change the w to w(eta) efficiently? - - select case (wind_coord_type) - - case ('ETA') - - call update_z(ipart,w*dt*real(ldirect)) - zts=real(part(ipart)%z) - ! HSO/AL: Particle managed to go over highest level -> interpolation - ! error in goto 700 - ! alias interpol_wind (division by zero) - if (zts.ge.height(nz)) call set_z(ipart,height(nz)-100.*eps) - ! Manually for z instead - - case ('METER') - - call update_z(ipart,w*dt*real(ldirect)) - call pushpartdown(ipart) - - end select - zts=real(part(ipart)%z) - - if (zts.gt.h) then - call update_z_to_zeta(itime,ipart) - if (itimec.ne.itime+lsynctime) abovePBL=.true. - ! complete the current interval above PBL - return - endif - - ! Determine probability of deposition - !************************************ - call drydepo_probability(part(ipart)%prob,dt,zts,vdepo) - - if (zts.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) - ! if particle below ground -> reflection - - if (itimec.eq.(itime+lsynctime)) then - ! Convert z position that changed by turbulent motions to eta coords - call update_z_to_zeta(itime,ipart) - return ! finished - endif - - end do pbl_loop - - call update_z_to_zeta(itime,ipart) - -end subroutine adv_in_pbl - -subroutine petterson_corr(itime,ipart) - - implicit none - - integer, intent(in) :: & - itime, & ! time index - ipart ! particle index - integer :: & - nsp,insp ! loop variables for number of species - real :: & - xts,yts,zts,ztseta, & ! local 'real' copy of the particle position - uold,vold,wold,woldeta, & - weta_settling - real(kind=dp) :: & - ztemp ! temporarily storing z position - - - xts=real(part(ipart)%xlon) - yts=real(part(ipart)%ylat) - zts=real(part(ipart)%z) - ztseta=real(part(ipart)%zeta) - if (lsettling) part(ipart)%settling=0. - - ! Memorize the old wind - !********************** - - uold=u - vold=v - - select case (wind_coord_type) - case ('ETA') - woldeta=weta - case ('METER') - wold=w - case default - wold=w - end select - - ! Interpolate wind at new position and time - !****************************************** - call interpol_wind_short(itime+part(ipart)%idt*ldirect,xts,yts,zts,ztseta) - - if (mdomainfill.eq.0) then - if (lsettling) then - if ((ipin.ne.3).and.(ipin.ne.4)) then - do insp=1,nspec - nsp=insp - if (xmass(part(ipart)%npoint,nsp).gt.eps3) exit - end do - else - nsp=1 - endif - if (density(nsp).gt.0.) then - select case (wind_coord_type) - - case ('ETA') - - call update_zeta_to_z(itime+part(ipart)%idt,ipart) - call update_z_to_zeta(itime+part(ipart)%idt,ipart) - zts=real(part(ipart)%z) - call get_settling( & - itime+part(ipart)%idt,xts,yts,zts,nsp,part(ipart)%settling) !bugfix - call w_to_weta( & - itime+part(ipart)%idt, real(part(ipart)%idt), part(ipart)%xlon, & - part(ipart)%ylat, part(ipart)%z, part(ipart)%zeta, & - part(ipart)%settling, weta_settling) - weta=weta+weta_settling - !woldeta= - !real(part(ipart)%zeta-part(ipart)%zeta_prev)/real(part(ipart)%idt*ldirect) - - case ('METER') - - call get_settling( & - itime+part(ipart)%idt,xts,yts,zts,nsp,part(ipart)%settling) - w=w+part(ipart)%settling - - case default - - call get_settling( & - itime+part(ipart)%idt,xts,yts,zts,nsp,part(ipart)%settling) - w=w+part(ipart)%settling - - end select - end if - endif - end if - - ! Determine the difference vector between new and old wind - ! (use half of it to correct position according to Petterssen) - !************************************************************* - - u=(u-uold)*0.5 - v=(v-vold)*0.5 - - select case (wind_coord_type) - - case ('ETA') - - weta=(weta-woldeta)/2. - call update_zeta(ipart,weta*real(part(ipart)%idt*ldirect)) - if (part(ipart)%zeta.ge.1.) call set_zeta(ipart,1.-(part(ipart)%zeta-1.)) - if (part(ipart)%zeta.eq.1.) call update_zeta(ipart,-eps_eta) - - case ('METER') - - w=(w-wold)/2. - call update_z(ipart,w*real(part(ipart)%idt*ldirect)) - if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) ! if particle below ground -> reflection - - case default - - w=(w-wold)/2. - call update_z(ipart,w*real(part(ipart)%idt*ldirect)) - if (part(ipart)%z.lt.0.) call set_z(ipart,min(h-eps2,-1.*part(ipart)%z)) - - end select - - ! Finally, correct the old position - !********************************** - - call update_xy(u*part(ipart)%idt,v*part(ipart)%idt,ipart) - - ! If particle above highest model level, set it back into the domain - !******************************************************************* - - call pushpartdown(ipart) - -end subroutine petterson_corr - -subroutine update_xy(xchange,ychange,ipart) - - implicit none - - integer, intent(in) :: & - ipart ! particle number - real, intent(in) :: & - xchange,ychange ! change in position - real :: & - xlon,ylat,xpol,ypol, & ! temporarily storing new particle positions - gridsize,cosfact ! used to compute new positions of particles - - eps=nxmax/3.e5 - - if (ngrid.ge.0) then - - cosfact=dxconst/cos((real(part(ipart)%ylat)*dy+ylat0)*pi180) - call update_xlon(ipart,real(xchange*cosfact*real(ldirect),kind=dp)) - call update_ylat(ipart,real(ychange*dyconst*real(ldirect),kind=dp)) - - else if (ngrid.eq.-1) then ! around north pole - - xlon=xlon0+real(part(ipart)%xlon)*dx !comment by MC: compute old part pos. - ylat=ylat0+real(part(ipart)%ylat)*dy - call cll2xy(northpolemap,ylat,xlon,xpol,ypol) - !convert old particle position in polar stereographic - gridsize=1000.*cgszll(northpolemap,ylat,xlon) - !calculate size in m of grid element in polar stereographic coordinate - xpol=xpol+xchange/gridsize*real(ldirect) - !position in grid unit polar stereographic - ypol=ypol+ychange/gridsize*real(ldirect) - call cxy2ll(northpolemap,xpol,ypol,ylat,xlon) - !convert to lat long coordinate - call set_xlon(ipart,real((xlon-xlon0)/dx,kind=dp)) - !convert to grid units in lat long coordinate, comment by mc - call set_ylat(ipart,real((ylat-ylat0)/dy,kind=dp)) - - else if (ngrid.eq.-2) then ! around south pole - - xlon=xlon0+real(part(ipart)%xlon)*dx - ylat=ylat0+real(part(ipart)%ylat)*dy - call cll2xy(southpolemap,ylat,xlon,xpol,ypol) - gridsize=1000.*cgszll(southpolemap,ylat,xlon) - xpol=xpol+xchange/gridsize*real(ldirect) - ypol=ypol+ychange/gridsize*real(ldirect) - call cxy2ll(southpolemap,xpol,ypol,ylat,xlon) - call set_xlon(ipart,real((xlon-xlon0)/dx,kind=dp)) - call set_ylat(ipart,real((ylat-ylat0)/dy,kind=dp)) - - endif - - ! If global data are available, use cyclic boundary condition - !************************************************************ - - if (xglobal) then - if (part(ipart)%xlon .ge. real(nxmin1, kind=dp)) & - call update_xlon(ipart,-real(nxmin1, kind=dp)) - if (part(ipart)%xlon .lt. 0.) call update_xlon(ipart,real(nxmin1, kind=dp)) - if (part(ipart)%xlon .le. real(eps, kind=dp)) & - call set_xlon(ipart,real(eps, kind=dp)) - if (abs( part(ipart)%xlon - real(nxmin1, kind=dp)) .le. eps) & - call set_xlon(ipart,real(nxmin1-eps,kind=dp)) - endif - - ! HSO/AL: Prevent particles from disappearing at the pole - !****************************************************************** - if (sglobal .and. part(ipart)%ylat.lt.0. ) then - call set_xlon(ipart, & - mod( part(ipart)%xlon + real(nxmin1*0.5, kind=dp), real(nxmin1, kind=dp))) - call set_ylat(ipart,-part(ipart)%ylat) - ! In extremely rare cases, the ylat exceeds the bounds, - ! so we set it back into the domain here - if ( part(ipart)%ylat.gt.real(nymin1,kind=dp) ) & - call set_ylat(ipart, & - real(nymin1, kind=dp) - mod( part(ipart)%ylat, real(nymin1, kind=dp))) - else if (nglobal .and. part(ipart)%ylat .gt. real(nymin1, kind=dp) ) then - call set_xlon(ipart, & - mod( part(ipart)%xlon + real(nxmin1*0.5, kind=dp), real(nxmin1, kind=dp))) - call set_ylat(ipart,2.*real(nymin1,kind=dp) - part(ipart)%ylat) - endif - - ! Check position: If trajectory outside model domain, terminate it - !***************************************************************** - ! Not necessary to check when using global domain, but some problems in the - ! meteo data could cause particles to go crazy. - ! if (gdomainfill) return - - if (part(ipart)%xlon.lt.0. .or. part(ipart)%xlon.ge.real(nxmin1,kind=dp) & - .or. part(ipart)%ylat.lt.0. .or. part(ipart)%ylat.gt.real(nymin1,kind=dp)) then - part(ipart)%nstop=.true. - return - endif - -end subroutine update_xy - -subroutine pushpartdown(ipart) - - implicit none - - integer, intent(in) :: & - ipart ! particle index - eps=nxmax/3.e5 +#include "adv_advance.f90" - select case (wind_coord_type) - - case ('ETA') - - if (part(ipart)%zeta.le.real(uvheight(nz),kind=dp)) & - call set_zeta(ipart,uvheight(nz)+eps_eta) +#include "adv_adv_above_pbl.f90" - case ('METER') - - if (part(ipart)%z.ge.real(height(nz),kind=dp)) & - call set_z(ipart,height(nz)-100.*eps) +#include "adv_adv_in_pbl.f90" - case default +#include "adv_petterson_corr.f90" - if (part(ipart)%z.ge.real(height(nz),kind=dp)) & - call set_z(ipart,height(nz)-100.*eps) +#include "adv_update_xy.f90" - end select - -end subroutine pushpartdown +#include "adv_pushpartdown.f90" end module advance_mod diff --git a/src/bin_concoutput.f90 b/src/bin_concoutput.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e534902abd7ed9257f5268e361b81cd38d65fb10 --- /dev/null +++ b/src/bin_concoutput.f90 @@ -0,0 +1,644 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput(itime,outnum,gridtotalunc,wetgridtotalunc, & + drygridtotalunc) + ! i i o o + ! o + !***************************************************************************** + ! * + ! 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 * + ! * + !***************************************************************************** + ! * + ! 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 mean_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 + ! RLT + real :: densitydryrecept(maxreceptor) + real :: factor_dryrecept(maxreceptor) + + real(dep_prec) :: auxgrid(nclassunc) + real(sp) :: gridtotal,gridsigmatotal,gridtotalunc + real(dep_prec) :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc + real(dep_prec) :: drygridtotal,drygridsigmatotal,drygridtotalunc + 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 + logical :: sp_zer + logical,save :: init=.true. + character :: adate*8,atime*6 + character(len=3) :: anspec + integer :: mind + character(LEN=8),save :: file_stat='REPLACE' + logical :: ldates_file + logical :: lexist + integer :: ierr + character(LEN=100) :: dates_char + + ! 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 + + ! Overwrite existing dates file on first call, later append to it + ! This fixes a bug where the dates file kept growing across multiple runs + + ! If 'dates' file exists in output directory, make a backup + inquire(file=path(2)(1:length(2))//'dates', exist=ldates_file) + if (ldates_file.and.init) then + open(unit=unitdates, file=path(2)(1:length(2))//'dates',form='formatted', & + &access='sequential', status='old', action='read', iostat=ierr) + open(unit=unittmp, file=path(2)(1:length(2))//'dates.bak', access='sequential', & + &status='replace', action='write', form='formatted', iostat=ierr) + do while (.true.) + read(unitdates, '(a)', iostat=ierr) dates_char + if (ierr.ne.0) exit + write(unit=unittmp, fmt='(a)', iostat=ierr, advance='yes') trim(dates_char) + end do + close(unit=unitdates) + close(unit=unittmp) + end if + + open(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND', STATUS=file_stat) + write(unitdates,'(a)') adate//atime + close(unitdates) + + ! Overwrite existing dates file on first call, later append to it + ! This fixes a bug where the dates file kept growing across multiple runs + IF (init) THEN + file_stat='OLD' + init=.false. + END IF + + + ! 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 + !******************************************************************* + + mind=memind(2) + 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=(xl-xlon0)/dx + yl=(yl-ylat0)/dy !v9.1.1 + 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 + densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,mind)*dz1+ & + rho(iix,jjy,kzz-1,mind)*dz2)/dz + ! RLT + densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,mind)*dz1+ & + rho_dry(iix,jjy,kzz-1,mind)*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) + densityoutrecept(i)=rho(iix,jjy,1,mind) + ! RLT + densitydryrecept(i)=rho_dry(iix,jjy,1,mind) + end do + + ! RLT + ! conversion factor for output relative to dry air + factor_drygrid=densityoutgrid/densitydrygrid + factor_dryrecept=densityoutrecept/densitydryrecept + + ! 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. + + do ks=1,nspec + + write(anspec,'(i3.3)') ks + + if (DRYBKDEP.or.WETBKDEP) then !scavdep output + if (DRYBKDEP) & + open(unitoutgrid,file=path(2)(1:length(2))//'grid_drydep_'//adate// & + atime//'_'//anspec,form='unformatted') + if (WETBKDEP) & + open(unitoutgrid,file=path(2)(1:length(2))//'grid_wetdep_'//adate// & + atime//'_'//anspec,form='unformatted') + write(unitoutgrid) itime + else + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + if (ldirect.eq.1) then + open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//adate// & + atime//'_'//anspec,form='unformatted') + else + open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// & + atime//'_'//anspec,form='unformatted') + endif + write(unitoutgrid) itime + endif + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//adate// & + atime//'_'//anspec,form='unformatted') + write(unitoutgridppt) itime + endif + endif ! if deposition output + + 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)) + 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 + !******************************************************************* + + ! 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) + 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) + + ! 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) + 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) + + + + ! 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 + if (lparticlecountoutput) then + sparse_dump_r(sp_count_r)= & + sp_fact* & + grid(ix,jy,kz) + else + sparse_dump_r(sp_count_r)= & + sp_fact* & + grid(ix,jy,kz)* & + factor3d(ix,jy,kz)/tot_mu(ks,kp) + end if + + 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) + + + + 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) + 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) + + + ! 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) + 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) + + + ! 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) + 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) + + endif ! output for ppt + + end do + end do + + close(unitoutgridppt) + close(unitoutgrid) + + end do + + ! RLT Aug 2017 + ! Write out conversion factor for dry air + inquire(file=path(2)(1:length(2))//'factor_drygrid',exist=lexist) + if (lexist) then + ! open and append + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& + status='old',action='write',access='append') + else + ! create new + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& + status='new',action='write') + endif + 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 (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then + if (sp_zer.eqv..true.) then ! first value not equal to one + 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*factor_drygrid(ix,jy,kz) + else ! factor is one + sp_zer=.true. + endif + end do + end do + end do + write(unitoutfactor) sp_count_i + write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) + write(unitoutfactor) sp_count_r + write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) + close(unitoutfactor) + + + 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 + + ! RLT Aug 2017 + ! Write out conversion factor for dry air + if (numreceptor.gt.0) then + inquire(file=path(2)(1:length(2))//'factor_dryreceptor',exist=lexist) + if (lexist) then + ! open and append + open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& + status='old',action='write',access='append') + else + ! create new + open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& + status='new',action='write') + endif + write(unitoutfactor) itime + write(unitoutfactor) (factor_dryrecept(i),i=1,numreceptor) + close(unitoutfactor) + endif + + creceptor(:,:)=0. + gridunc(:,:,:,:,:,:,:)=0. +end subroutine concoutput diff --git a/src/bin_concoutput_inv.f90 b/src/bin_concoutput_inv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8c9266ba86181d68369cfb12e2b41e268045d956 --- /dev/null +++ b/src/bin_concoutput_inv.f90 @@ -0,0 +1,611 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput_inv(itime,outnum,gridtotalunc,wetgridtotalunc, & + drygridtotalunc) + ! i i o o + ! o + !***************************************************************************** + ! * + ! 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 * + ! + ! January 2017, Separate files by release but include all timesteps + ! * + !***************************************************************************** + ! * + ! 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 mean_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 + ! RLT + real :: densitydryrecept(maxreceptor) + real :: factor_dryrecept(maxreceptor) + + + real(dep_prec) :: auxgrid(nclassunc) + real(sp) :: gridtotal,gridsigmatotal,gridtotalunc + real(dep_prec) :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc + real(dep_prec) :: drygridtotal,drygridsigmatotal,drygridtotalunc + 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 + logical :: sp_zer + character :: adate*8,atime*6 + character(len=3) :: anspec + logical :: lexist + character :: areldate*8,areltime*6 + logical,save :: lstart=.true. + logical,save,allocatable,dimension(:) :: lstartrel + integer :: ierr + character(LEN=100) :: dates_char + integer, parameter :: unitrelnames=654 + + + if(lstart) then + allocate(lstartrel(maxpointspec_act)) + lstartrel(:)=.true. + endif + print*, 'lstartrel = ',lstartrel + + if (verbosity.eq.1) then + print*,'inside concoutput_inv ' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + + ! Determine current calendar date + !********************************************************** + + jul=bdate+real(itime,kind=dp)/86400._dp + call caldate(jul,jjjjmmdd,ihmmss) + write(adate,'(i8.8)') jjjjmmdd + write(atime,'(i6.6)') ihmmss + + + ! Prepare output files for dates + !********************************************************** + + ! Overwrite existing dates file on first call, later append to it + ! If 'dates' file exists in output directory, copy to new file dates.old + inquire(file=path(2)(1:length(2))//'dates', exist=lexist) + if (lexist.and.lstart) then + ! copy contents of existing dates file to dates.old + print*, 'warning: replacing old dates file' + open(unit=unitdates, file=path(2)(1:length(2))//'dates',form='formatted', & + &access='sequential', status='old', action='read', iostat=ierr) + open(unit=unittmp, file=path(2)(1:length(2))//'dates.old', access='sequential', & + &status='replace', action='write', form='formatted', iostat=ierr) + do while (.true.) + read(unitdates, '(a)', iostat=ierr) dates_char + if (ierr.ne.0) exit + write(unit=unittmp, fmt='(a)', iostat=ierr, advance='yes') trim(dates_char) + end do + close(unit=unitdates) + close(unit=unittmp) + ! create new dates file + open(unit=unitdates, file=path(2)(1:length(2))//'dates',form='formatted', & + &access='sequential', status='replace', iostat=ierr) + close(unit=unitdates) + endif + + open(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND') + write(unitdates,'(a)') adate//atime + close(unitdates) + + !CGZ: Make a filename with names of releases + if (lstart) then + open(unit=unitrelnames, file=path(2)(1:length(2))//'releases_out',form='formatted', & + &access='sequential', status='replace', iostat=ierr) + close(unitrelnames) + endif + + print*, 'after creating dates files: lstart = ',lstart + ! print*, 'outnum:',outnum + ! print*, 'datetime:',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 + + + if (verbosity.eq.1) then + print*,'concoutput_inv 2' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + 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=(xl-xlon0)/dx + yl=(yl-ylat0)/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 + ! RLT + densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ & + rho_dry(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) + ! RLT + densitydryrecept(i)=rho_dry(iix,jjy,1,2) + end do + + ! RLT + ! conversion factor for output relative to dry air + factor_drygrid=densityoutgrid/densitydrygrid + factor_dryrecept=densityoutrecept/densitydryrecept + + ! 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 + !********************************************************************* + + if (verbosity.eq.1) then + print*,'concoutput_inv 3 (sd)' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + gridtotal=0. + gridsigmatotal=0. + gridtotalunc=0. + wetgridtotal=0. + wetgridsigmatotal=0. + wetgridtotalunc=0. + drygridtotal=0. + drygridsigmatotal=0. + drygridtotalunc=0. + + do ks=1,nspec + + write(anspec,'(i3.3)') ks + + ! loop over releases + do kp=1,maxpointspec_act + + print*, 'itime = ',itime + !print*, 'lage(1) = ',lage(1) + print*, 'ireleasestart(kp) = ',ireleasestart(kp) + print*, 'ireleaseend(kp) = ',ireleaseend(kp) + + ! check itime is within release and backward trajectory length + if (nageclass.eq.1) then + if ((itime.gt.ireleaseend(kp)).or.(itime.lt.(ireleasestart(kp)-lage(1)))) then + go to 10 + endif + endif + + ! calculate date of release for filename + jul=bdate+real(ireleasestart(kp),kind=dp)/86400._dp ! this is the current day + call caldate(jul,jjjjmmdd,ihmmss) + write(areldate,'(i8.8)') jjjjmmdd + write(areltime,'(i6.6)') ihmmss + print*, 'areldate/areltime = ',areldate//areltime + + ! calculate date of field + jul=bdate+real(itime,kind=dp)/86400._dp + call caldate(jul,jjjjmmdd,ihmmss) + write(adate,'(i8.8)') jjjjmmdd + write(atime,'(i6.6)') ihmmss + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + if (ldirect.eq.1) then + ! concentrations + inquire(file=path(2)(1:length(2))//'grid_conc_'//areldate// & + areltime//'_'//anspec,exist=lexist) + if(lexist.and..not.lstartrel(kp)) then + ! open and append to existing file + open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') + else + ! open new file + open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='replace',action='write') + endif + else + ! residence times + inquire(file=path(2)(1:length(2))//'grid_time_'//areldate// & + areltime//'_'//anspec,exist=lexist) + if(lexist.and..not.lstartrel(kp)) then + ! open and append to existing file + open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') + else + ! open new file + open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='replace',action='write') + ! add part of the filename to a file (similar to dates) for easier post-processing + open(unit=unitrelnames, file=path(2)(1:length(2))//'releases_out',form='formatted', & + & access='APPEND', iostat=ierr) + write(unitrelnames,'(a)') areldate//areltime//'_'//anspec + close(unitrelnames) + endif + endif + write(unitoutgrid) jjjjmmdd + write(unitoutgrid) ihmmss + endif + + if ((iout.eq.2).or.(iout.eq.3)) then + ! mixing ratio + inquire(file=path(2)(1:length(2))//'grid_pptv_'//areldate// & + areltime//'_'//anspec,exist=lexist) + if(lexist.and..not.lstartrel(kp)) then + ! open and append to existing file + open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') + else + ! open new file + open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='replace',action='write') + endif + write(unitoutgridppt) jjjjmmdd + write(unitoutgridppt) ihmmss + endif + + lstartrel(kp)=.false. + + do nage=1,nageclass + + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + + ! 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 (verbosity.eq.1) then + print*,'concoutput_inv 4 (output)' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + + ! Concentration output + !********************* + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + + if (verbosity.eq.1) then + print*,'concoutput_inv (Wet deposition)' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + + if (verbosity.eq.1) then + print*,'concoutput_inv (Concentrations)' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + + ! Concentrations + + ! surf_only write only 1st layer + + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + 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) + sparse_dump_u(sp_count_r)= & + gridsigma(ix,jy,kz)* & + factor3d(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) + + endif ! concentration output + + ! Mixing ratio output + !******************** + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + + ! Mixing ratios + + ! surf_only write only 1st layer + + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + 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)/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) + + endif ! output for ppt + + end do ! nageclass + + close(unitoutgridppt) + close(unitoutgrid) + + ! itime is outside range +10 continue + + end do ! maxpointspec_act + + end do ! nspec + + ! RLT Aug 2017 + ! Write out conversion factor for dry air + inquire(file=path(2)(1:length(2))//'factor_drygrid',exist=lexist) + if (lexist.and..not.lstart) then + ! open and append + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& + status='old',action='write',access='append') + else + ! create new + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& + status='replace',action='write') + endif + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then + if (sp_zer.eqv..true.) then ! first value not equal to one + 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*factor_drygrid(ix,jy,kz) + else ! factor is one + sp_zer=.true. + endif + end do + end do + end do + write(unitoutfactor) sp_count_i + write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) + write(unitoutfactor) sp_count_r + write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) + close(unitoutfactor) + + + if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal + + ! 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 + + ! RLT Aug 2017 + ! Write out conversion factor for dry air + if (numreceptor.gt.0) then + inquire(file=path(2)(1:length(2))//'factor_dryreceptor',exist=lexist) + if (lexist.and..not.lstart) then + ! open and append + open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& + status='old',action='write',access='append') + else + ! create new + open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& + status='replace',action='write') + endif + write(unitoutfactor) itime + write(unitoutfactor) (factor_dryrecept(i),i=1,numreceptor) + close(unitoutfactor) + endif + + ! reset lstart + if (lstart) then + lstart=.false. + endif + print*, 'after writing output files: lstart = ',lstart + + + ! 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,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_inv diff --git a/src/bin_concoutput_inv_nest.f90 b/src/bin_concoutput_inv_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6fb2175d07c52f44a25f46fee1a8577aa4e86fb4 --- /dev/null +++ b/src/bin_concoutput_inv_nest.f90 @@ -0,0 +1,468 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput_inv_nest(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 * + ! + ! January 2017, Separate files by release but include all timesteps * + ! * + !***************************************************************************** + ! * + ! 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 mean_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 + ! RLT + real :: densitydryrecept(maxreceptor) + real :: factor_dryrecept(maxreceptor) + + real(dep_prec) :: 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 + logical :: sp_zer + logical,save :: lnstart=.true. + logical,save,allocatable,dimension(:) :: lnstartrel + character :: adate*8,atime*6 + character(len=3) :: anspec + logical :: lexist + character :: areldate*8,areltime*6 + + if(lnstart) then + allocate(lnstartrel(maxpointspec_act)) + lnstartrel(:)=.true. + endif + print*, 'lnstartrel = ',lnstartrel + + ! 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 + + print*, 'outnum:',outnum + print*, 'datetime:',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,numygridn-1 + do ix=0,numxgridn-1 + xl=outlon0n+real(ix)*dxoutn + yl=outlat0n+real(jy)*dyoutn + xl=(xl-xlon0)/dx + yl=(yl-ylat0)/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 + ! RLT + densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ & + rho_dry(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) + ! RLT + densitydryrecept(i)=rho_dry(iix,jjy,1,2) + end do + + ! RLT + ! conversion factor for output relative to dry air + factor_drygrid=densityoutgrid/densitydrygrid + factor_dryrecept=densityoutrecept/densitydryrecept + + ! 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 + + do kp=1,maxpointspec_act + + print*, 'itime = ',itime + print*, 'lage(1) = ',lage(1) + print*, 'ireleasestart(kp) = ',ireleasestart(kp) + print*, 'ireleaseend(kp) = ',ireleaseend(kp) + + ! check itime is within release and backward trajectory length + if (nageclass.eq.1) then + if ((itime.gt.ireleaseend(kp)).or.(itime.lt.(ireleasestart(kp)-lage(1)))) then + go to 10 + endif + endif + + ! calculate date of release + jul=bdate+real(ireleasestart(kp),kind=dp)/86400._dp ! this is the current day + call caldate(jul,jjjjmmdd,ihmmss) + write(areldate,'(i8.8)') jjjjmmdd + write(areltime,'(i6.6)') ihmmss + print*, areldate//areltime + + ! calculate date of field + jul=bdate+real(itime,kind=dp)/86400._dp + call caldate(jul,jjjjmmdd,ihmmss) + write(adate,'(i8.8)') jjjjmmdd + write(atime,'(i6.6)') ihmmss + print*, adate//atime + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + if (ldirect.eq.1) then + ! concentrations + inquire(file=path(2)(1:length(2))//'grid_conc_nest_'//areldate// & + areltime//'_'//anspec,exist=lexist) + if(lexist.and..not.lnstartrel(kp)) then + ! open and append to existing file + open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') + else + ! open new file + open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='replace',action='write') + endif + else + ! residence times + inquire(file=path(2)(1:length(2))//'grid_time_nest_'//areldate// & + areltime//'_'//anspec,exist=lexist) + if(lexist.and..not.lnstartrel(kp)) then + ! open and append to existing file + open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') + else + ! open new file + open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='replace',action='write') + endif + endif + write(unitoutgrid) jjjjmmdd + write(unitoutgrid) ihmmss + endif + + if ((iout.eq.2).or.(iout.eq.3)) then + ! mixing ratio + inquire(file=path(2)(1:length(2))//'grid_pptv_nest_'//areldate// & + areltime//'_'//anspec,exist=lexist) + if(lexist.and..not.lnstartrel(kp)) then + ! open and append to existing file + open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') + else + ! open new file + open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='replace',action='write') + endif + write(unitoutgridppt) jjjjmmdd + write(unitoutgridppt) ihmmss + endif + + lnstartrel(kp)=.false. + + do nage=1,nageclass + + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + + ! 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 + !******************************************************************* + + ! Concentration output + !********************* + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + + ! Concentrations + + ! surf_only write only 1st layer + + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + 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)* & + factor3d(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) + + endif ! concentration output + + ! Mixing ratio output + !******************** + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + + + ! Mixing ratios + + ! surf_only write only 1st layer + + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + 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)/volumen(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) + + endif ! output for ppt + + end do ! nageclass + + close(unitoutgridppt) + close(unitoutgrid) + + ! itime is outside range +10 continue + + end do ! maxpointspec_act + + end do ! nspec + + + ! RLT Aug 2017 + ! Write out conversion factor for dry air + inquire(file=path(2)(1:length(2))//'factor_drygrid_nest',exist=lexist) + if (lexist.and..not.lnstart) then + ! open and append + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& + status='old',action='write',access='append') + else + ! create new + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& + status='replace',action='write') + endif + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then + if (sp_zer.eqv..true.) then ! first value not equal to one + 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*factor_drygrid(ix,jy,kz) + else ! factor is one + sp_zer=.true. + endif + end do + end do + end do + write(unitoutfactor) sp_count_i + write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) + write(unitoutfactor) sp_count_r + write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) + close(unitoutfactor) + + ! reset lnstart + if (lnstart) then + lnstart=.false. + endif + + ! 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_inv_nest diff --git a/src/bin_concoutput_nest.f90 b/src/bin_concoutput_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..edfd98621c4bc0b21ad0cf64b8e863b90bc38f04 --- /dev/null +++ b/src/bin_concoutput_nest.f90 @@ -0,0 +1,586 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput_nest(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 * + ! * + !***************************************************************************** + ! * + ! 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 mean_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 + ! RLT + real :: densitydryrecept(maxreceptor) + real :: factor_dryrecept(maxreceptor) + + !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(dep_prec) :: 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 + logical :: sp_zer + character :: adate*8,atime*6 + character(len=3) :: anspec + logical :: lexist + integer :: mind + + + ! 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 + !******************************************************************* + + mind=memind(2) + 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=outlon0n+real(ix)*dxoutn + yl=outlat0n+real(jy)*dyoutn + xl=(xl-xlon0)/dx + yl=(yl-ylat0)/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 + densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,mind)*dz1+ & + rho(iix,jjy,kzz-1,mind)*dz2)/dz + ! RLT + densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,mind)*dz1+ & + rho_dry(iix,jjy,kzz-1,mind)*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) + densityoutrecept(i)=rho(iix,jjy,1,mind) + ! RLT + densitydryrecept(i)=rho_dry(iix,jjy,1,mind) + end do + + ! RLT + ! conversion factor for output relative to dry air + factor_drygrid=densityoutgrid/densitydrygrid + factor_dryrecept=densityoutrecept/densitydryrecept + + ! 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 (DRYBKDEP.or.WETBKDEP) then !scavdep output + if (DRYBKDEP) & + open(unitoutgrid,file=path(2)(1:length(2))//'grid_drydep_nest_'//adate// & + atime//'_'//anspec,form='unformatted') + if (WETBKDEP) & + open(unitoutgrid,file=path(2)(1:length(2))//'grid_wetdep_nest_'//adate// & + atime//'_'//anspec,form='unformatted') + write(unitoutgrid) itime + else + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + if (ldirect.eq.1) then + open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + else + open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + endif + write(unitoutgrid) itime + endif + endif + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + + 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 + !******************************************************************* + + ! 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 + 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,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 + 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,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 + 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,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 + 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,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 + 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,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 + 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 + + end do + end do + + close(unitoutgridppt) + close(unitoutgrid) + + end do + + ! RLT Aug 2017 + ! Write out conversion factor for dry air + inquire(file=path(2)(1:length(2))//'factor_drygrid_nest',exist=lexist) + if (lexist) then + ! open and append + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& + status='old',action='write',access='append') + else + ! create new + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& + status='new',action='write') + endif + 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 (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then + if (sp_zer.eqv..true.) then ! first value not equal to one + 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*factor_drygrid(ix,jy,kz) + else ! factor is one + sp_zer=.true. + endif + end do + end do + end do + write(unitoutfactor) sp_count_i + write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) + write(unitoutfactor) sp_count_r + write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) + close(unitoutfactor) + + creceptor(:,:)=0. + griduncn(:,:,:,:,:,:,:)=0. +end subroutine concoutput_nest diff --git a/src/bin_concoutput_sfc.f90 b/src/bin_concoutput_sfc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..257e46601f83f9e2ef22115829194793a6fe2864 --- /dev/null +++ b/src/bin_concoutput_sfc.f90 @@ -0,0 +1,666 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput_sfc(itime,outnum,gridtotalunc,wetgridtotalunc, & + drygridtotalunc) + ! i i o o + ! o + !***************************************************************************** + ! * + ! 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 * + ! * + !***************************************************************************** + ! * + ! 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 mean_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 + ! RLT + real :: densitydryrecept(maxreceptor) + real :: factor_dryrecept(maxreceptor) + + real(dep_prec) :: auxgrid(nclassunc) + real(sp) :: gridtotal,gridsigmatotal,gridtotalunc + real(dep_prec) :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc + real(dep_prec) :: drygridtotal,drygridsigmatotal,drygridtotalunc + 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 + logical :: sp_zer + character :: adate*8,atime*6 + character(len=3) :: anspec + logical :: lexist + + + if (verbosity.eq.1) then + print*,'inside concoutput_sfc ' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + + ! 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(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND') + write(unitdates,'(a)') adate//atime + close(unitdates) + + ! 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 + + + if (verbosity.eq.1) then + print*,'concoutput_sfc 2' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + 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=(xl-xlon0)/dx + yl=(yl-ylat0)/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 + ! RLT + densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ & + rho_dry(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) + ! RLT + densitydryrecept(i)=rho_dry(iix,jjy,1,2) + end do + + ! RLT + ! conversion factor for output relative to dry air + factor_drygrid=densityoutgrid/densitydrygrid + factor_dryrecept=densityoutrecept/densitydryrecept + + ! 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 + !********************************************************************* + + if (verbosity.eq.1) then + print*,'concoutput_sfc 3 (sd)' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + gridtotal=0. + gridsigmatotal=0. + gridtotalunc=0. + wetgridtotal=0. + wetgridsigmatotal=0. + wetgridtotalunc=0. + drygridtotal=0. + drygridsigmatotal=0. + drygridtotalunc=0. + + 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 + open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//adate// & + atime//'_'//anspec,form='unformatted') + else + open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// & + atime//'_'//anspec,form='unformatted') + endif + write(unitoutgrid) itime + endif + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//adate// & + atime//'_'//anspec,form='unformatted') + + 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 (verbosity.eq.1) then + print*,'concoutput_sfc 4 (output)' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + + ! Concentration output + !********************* + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + + if (verbosity.eq.1) then + print*,'concoutput_sfc (Wet deposition)' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + + ! 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)/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) + + if (verbosity.eq.1) then + print*,'concoutput_sfc (Dry deposition)' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + ! 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)/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) + + if (verbosity.eq.1) then + print*,'concoutput_sfc (Concentrations)' + CALL SYSTEM_CLOCK(count_clock) + WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 + endif + + ! Concentrations + + ! surf_only write only 1st layer + + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + 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) + sparse_dump_u(sp_count_r)= & + gridsigma(ix,jy,kz)* & + factor3d(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) + 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)/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) + + ! 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)/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) + + ! Mixing ratios + + ! surf_only write only 1st layer + + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + 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)/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) + endif ! output for ppt + + end do + end do + + close(unitoutgridppt) + close(unitoutgrid) + + end do + + ! RLT Aug 2017 + ! Write out conversion factor for dry air + inquire(file=path(2)(1:length(2))//'factor_drygrid',exist=lexist) + if (lexist) then + ! open and append + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& + status='old',action='write',access='append') + else + ! create new + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& + status='new',action='write') + endif + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then + if (sp_zer.eqv..true.) then ! first value not equal to one + 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*factor_drygrid(ix,jy,kz) + else ! factor is one + sp_zer=.true. + endif + end do + end do + end do + write(unitoutfactor) sp_count_i + write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) + write(unitoutfactor) sp_count_r + write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) + close(unitoutfactor) + + + 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 + + ! RLT Aug 2017 + ! Write out conversion factor for dry air + if (numreceptor.gt.0) then + inquire(file=path(2)(1:length(2))//'factor_dryreceptor',exist=lexist) + if (lexist) then + ! open and append + open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& + status='old',action='write',access='append') + else + ! create new + open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& + status='new',action='write') + endif + write(unitoutfactor) itime + write(unitoutfactor) (factor_dryrecept(i),i=1,numreceptor) + close(unitoutfactor) + endif + + ! 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,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_sfc diff --git a/src/bin_concoutput_sfc_nest.f90 b/src/bin_concoutput_sfc_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cd2d81e18a6f06afd6ffba1e35f7ad219d3d849f --- /dev/null +++ b/src/bin_concoutput_sfc_nest.f90 @@ -0,0 +1,641 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput_sfc_nest(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 * + ! * + !***************************************************************************** + ! * + ! 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 mean_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 + ! RLT + real :: densitydryrecept(maxreceptor) + real :: factor_dryrecept(maxreceptor) + + real(dep_prec) :: 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 + logical :: sp_zer + character :: adate*8,atime*6 + character(len=3) :: anspec + logical :: lexist + + ! 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=outlon0n+real(ix)*dxoutn + yl=outlat0n+real(jy)*dyoutn + xl=(xl-xlon0)/dx + yl=(yl-ylat0)/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 + ! RLT + densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ & + rho_dry(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) + ! RLT + densitydryrecept(i)=rho_dry(iix,jjy,1,2) + end do + + ! RLT + ! conversion factor for output relative to dry air + factor_drygrid=densityoutgrid/densitydrygrid + factor_dryrecept=densityoutrecept/densitydryrecept + + ! 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 + open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + else + open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + endif + write(unitoutgrid) itime + endif + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_' & + //adate// & + atime//'_'//anspec,form='unformatted') + + 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 + !******************************************************************* + + ! 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)/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) + ! 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)/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) + + ! Concentrations + + ! if surf_only write only 1st layer + + if(surf_only.eq.1) then + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + 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)* & + factor3d(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) + else + + ! write full vertical resolution + + 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) + sparse_dump_u(sp_count_r)= & + gridsigma(ix,jy,kz)* & + factor3d(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) + endif ! surf_only + + + 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)/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) + + ! 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)/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) + + ! Mixing ratios + + ! if surf_only write only 1st layer + + if(surf_only.eq.1) then + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + 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)/volumen(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) + else + + ! write full vertical resolution + + 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)/volumen(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) + endif ! surf_only + + endif ! output for ppt + + end do + end do + + close(unitoutgridppt) + close(unitoutgrid) + + end do + + ! RLT Aug 2017 + ! Write out conversion factor for dry air + inquire(file=path(2)(1:length(2))//'factor_drygrid_nest',exist=lexist) + if (lexist) then + ! open and append + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& + status='old',action='write',access='append') + else + ! create new + open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& + status='new',action='write') + endif + sp_count_i=0 + sp_count_r=0 + sp_fact=-1. + sp_zer=.true. + do kz=1,1 + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then + if (sp_zer.eqv..true.) then ! first value not equal to one + 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*factor_drygrid(ix,jy,kz) + else ! factor is one + sp_zer=.true. + endif + end do + end do + end do + write(unitoutfactor) sp_count_i + write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) + write(unitoutfactor) sp_count_r + write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) + close(unitoutfactor) + + + + ! 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_sfc_nest diff --git a/src/bin_initcond_output.f90 b/src/bin_initcond_output.f90 new file mode 100644 index 0000000000000000000000000000000000000000..81caa203f2a0664953518625f80c9f7a08e32d59 --- /dev/null +++ b/src/bin_initcond_output.f90 @@ -0,0 +1,127 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine initcond_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 + + 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(2)(1:length(2))//'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 initcond_output diff --git a/src/bin_initcond_output_inv.f90 b/src/bin_initcond_output_inv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..65dd799b19e2e6cea66115fec7c08087de515865 --- /dev/null +++ b/src/bin_initcond_output_inv.f90 @@ -0,0 +1,158 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine initcond_output_inv(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 + + implicit none + + integer :: itime,i,ix,jy,kz,ks,kp,sp_count_i,sp_count_r + integer :: jjjjmmdd, ihmmss + real(kind=dp) :: jul + real :: sp_fact,fact_recept + real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled + logical :: sp_zer,lexist + logical,save :: listart=.true. + logical,save,allocatable,dimension(:) :: listartrel + character :: adate*8,atime*6 + character :: areldate*8,areltime*6 + character(len=3) :: anspec + + if(listart) then + allocate(listartrel(maxpointspec_act)) + listartrel(:)=.true. + endif + print*, 'listartrel = ',listartrel + + !********************************************************************* + ! 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 + + do kp=1,maxpointspec_act + + ! calculate date of release + jul=bdate+real(ireleasestart(kp),kind=dp)/86400._dp ! this is the current day + call caldate(jul,jjjjmmdd,ihmmss) + write(areldate,'(i8.8)') jjjjmmdd + write(areltime,'(i6.6)') ihmmss + print*, areldate//areltime + + ! calculate date of field + jul=bdate+real(itime,kind=dp)/86400._dp + call caldate(jul,jjjjmmdd,ihmmss) + write(adate,'(i8.8)') jjjjmmdd + write(atime,'(i6.6)') ihmmss + print*, adate//atime + + inquire(file=path(2)(1:length(2))//'grid_initial_'//areldate// & + areltime//'_'//anspec,exist=lexist) + if(lexist.and..not.listartrel(kp)) then + ! open and append to existing file + open(97,file=path(2)(1:length(2))//'grid_initial_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') + else + ! open new file + open(97,file=path(2)(1:length(2))//'grid_initial_'//areldate// & + areltime//'_'//anspec,form='unformatted',status='replace',action='write') + endif + write(97) jjjjmmdd + write(97) ihmmss + + listartrel(kp)=.false. + + 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 + + ! 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) + + close(97) + + end do + + end do + + ! reset listart + if (listart) then + listart=.false. + endif +end subroutine initcond_output_inv diff --git a/src/bin_openreceptors.f90 b/src/bin_openreceptors.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3d8dc7e62efedcd4a0f838b5e28f82b46251aa02 --- /dev/null +++ b/src/bin_openreceptors.f90 @@ -0,0 +1,72 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 * + ! * + !***************************************************************************** + ! * + ! 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 + + ! 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 + + ! Concentration output + !********************* + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + open(unitoutrecept,file=path(2)(1:length(2))//'receptor_conc', & + form='unformatted',err=997) + write(unitoutrecept) (receptorname(j),j=1,numreceptor) + write(unitoutrecept) (xreceptor(j)*dx+xlon0, & + yreceptor(j)*dy+ylat0,j=1,numreceptor) + endif + + ! Mixing ratio output + !******************** + + if ((iout.eq.2).or.(iout.eq.3)) then + open(unitoutreceptppt,file=path(2)(1:length(2))//'receptor_pptv', & + form='unformatted',err=998) + write(unitoutreceptppt) (receptorname(j),j=1,numreceptor) + write(unitoutreceptppt) (xreceptor(j)*dx+xlon0, & + yreceptor(j)*dy+ylat0,j=1,numreceptor) + 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/bin_writeheader_bin.f90 b/src/bin_writeheader_bin.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1eba0fafcd119ec4b816dc07095a81e94dffd4f9 --- /dev/null +++ b/src/bin_writeheader_bin.f90 @@ -0,0 +1,146 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine writeheader_bin + + !***************************************************************************** + ! * + ! 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 * + ! * + !***************************************************************************** + ! * + ! Modified to remove TRIM around the output of flexversion so that * + ! it will be a constant length (defined in com_mod.f90) in output header * + ! * + ! Don Morton, Boreal Scientific Computing * + ! 07 May 2017 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! xlon longitude * + ! xl model x coordinate * + ! ylat latitude * + ! yl model y coordinate * + ! * + !***************************************************************************** + + use point_mod + use prepoutgrid_mod + use par_mod + use com_mod + + implicit none + + integer :: jjjjmmdd,ihmmss,i,ix,jy,j + real :: xp1,yp1,xp2,yp2 + + + !************************ + ! Open header output file + !************************ + + open(unitheader,file=path(2)(1:length(2))//'header', & + form='unformatted',err=998) + + + ! Write the header information + !***************************** + + if (ldirect.eq.1) then + write(unitheader) ibdate,ibtime, flexversion + else + write(unitheader) iedate,ietime, flexversion + endif + + ! Write info on output interval, averaging time, sampling time + !************************************************************* + + write(unitheader) loutstep,loutaver,loutsample + + ! Write information on output grid setup + !*************************************** + + write(unitheader) outlon0,outlat0,numxgrid,numygrid, & + dxout,dyout + 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.1000) then + write(unitheader) compoint(i) + else + write(unitheader) compoint(1001) + 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) + + return + + +998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(2)(1:length(2))//'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_bin diff --git a/src/bin_writeheader_bin_nest.f90 b/src/bin_writeheader_bin_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6e4a59421c024ca30faa8bedb6c54f1116b9127e --- /dev/null +++ b/src/bin_writeheader_bin_nest.f90 @@ -0,0 +1,141 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine writeheader_bin_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 * + ! * + !***************************************************************************** + ! * + ! Modified to remove TRIM around the output of flexversion so that * + ! it will be a constant length (defined in com_mod.f90) in output header * + ! * + ! Don Morton, Boreal Scientific Computing * + ! 07 May 2017 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! xlon longitude * + ! xl model x coordinate * + ! ylat latitude * + ! yl model y coordinate * + ! * + !***************************************************************************** + + implicit none + + integer :: jjjjmmdd,ihmmss,i,ix,jy,j + real :: xp1,yp1,xp2,yp2 + + + !************************ + ! Open header output file + !************************ + + open(unitheader,file=path(2)(1:length(2))//'header_nest', & + form='unformatted',err=998) + + + ! Write the header information + !***************************** + + if (ldirect.eq.1) then + write(unitheader) ibdate,ibtime, flexversion + else + write(unitheader) iedate,ietime, flexversion + 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.1000) then + write(unitheader) compoint(i) + else + write(unitheader) compoint(1001) + 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) + + return + + +998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(2)(1:length(2))//'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_bin_nest diff --git a/src/bin_writeheader_bin_sfc.f90 b/src/bin_writeheader_bin_sfc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..de2ecab7110961427013e3600f6fa5962e65d0fc --- /dev/null +++ b/src/bin_writeheader_bin_sfc.f90 @@ -0,0 +1,141 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine writeheader_bin_sfc + + !***************************************************************************** + ! * + ! 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 * + ! * + !***************************************************************************** + ! * + ! Modified to remove TRIM around the output of flexversion so that * + ! it will be a constant length (defined in com_mod.f90) in output header * + ! * + ! Don Morton, Boreal Scientific Computing * + ! 07 May 2017 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! xlon longitude * + ! xl model x coordinate * + ! ylat latitude * + ! yl model y coordinate * + ! * + !***************************************************************************** + + implicit none + + integer :: jjjjmmdd,ihmmss,i,ix,jy,j + real :: xp1,yp1,xp2,yp2 + + + !************************ + ! Open header output file + !************************ + + open(unitheader,file=path(2)(1:length(2))//'header_grid_time', & + form='unformatted',err=998) + + + ! Write the header information + !***************************** + + if (ldirect.eq.1) then + write(unitheader) ibdate,ibtime, flexversion + else + write(unitheader) iedate,ietime, flexversion + endif + + ! Write info on output interval, averaging time, sampling time + !************************************************************* + + write(unitheader) loutstep,loutaver,loutsample + + ! Write information on output grid setup + !*************************************** + + write(unitheader) outlon0,outlat0,numxgrid,numygrid, & + dxout,dyout + write(unitheader) 1,(outheight(1),i=1,1) + + 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) 1,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.1000) then + write(unitheader) compoint(i) + else + write(unitheader) compoint(1001) + 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) + + return + + +998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(2)(1:length(2))//'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_bin_sfc diff --git a/src/bin_writeheader_bin_sfc_nest.f90 b/src/bin_writeheader_bin_sfc_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..169248883a0477332ae6e1284fe2df52d92ab654 --- /dev/null +++ b/src/bin_writeheader_bin_sfc_nest.f90 @@ -0,0 +1,141 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine writeheader_bin_sfc_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 * + ! * + !***************************************************************************** + ! * + ! Modified to remove TRIM around the output of flexversion so that * + ! it will be a constant length (defined in com_mod.f90) in output header * + ! * + ! Don Morton, Boreal Scientific Computing * + ! 07 May 2017 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! xlon longitude * + ! xl model x coordinate * + ! ylat latitude * + ! yl model y coordinate * + ! * + !***************************************************************************** + + implicit none + + integer :: jjjjmmdd,ihmmss,i,ix,jy,j + real :: xp1,yp1,xp2,yp2 + + + !************************ + ! Open header output file + !************************ + + open(unitheader,file=path(2)(1:length(2))//'header_nest_grid_time', & + form='unformatted',err=998) + + + ! Write the header information + !***************************** + + if (ldirect.eq.1) then + write(unitheader) ibdate,ibtime,flexversion + else + write(unitheader) iedate,ietime,flexversion + 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) 1,(outheight(1),i=1,1) + + 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) 1,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.1000) then + write(unitheader) compoint(i) + else + write(unitheader) compoint(1001) + 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) + + return + + +998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(2)(1:length(2))//'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_bin_sfc_nest diff --git a/src/binary_output_mod.f90 b/src/binary_output_mod.f90 index 0a194f56e9786d8f4dec1d2a3e8c5bb1bad66fa5..174e62933c7a6caafafbc29b3b242ee31aeb9987 100644 --- a/src/binary_output_mod.f90 +++ b/src/binary_output_mod.f90 @@ -13,7 +13,7 @@ ! L. Bakels 2022 * ! * !***************************************************************************** - + module binary_output_mod use point_mod @@ -27,4521 +27,31 @@ module binary_output_mod contains -subroutine writeheader_bin - - !***************************************************************************** - ! * - ! 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 * - ! * - !***************************************************************************** - ! * - ! Modified to remove TRIM around the output of flexversion so that * - ! it will be a constant length (defined in com_mod.f90) in output header * - ! * - ! Don Morton, Boreal Scientific Computing * - ! 07 May 2017 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! xlon longitude * - ! xl model x coordinate * - ! ylat latitude * - ! yl model y coordinate * - ! * - !***************************************************************************** - - use point_mod - use prepoutgrid_mod - use par_mod - use com_mod - - implicit none - - integer :: jjjjmmdd,ihmmss,i,ix,jy,j - real :: xp1,yp1,xp2,yp2 - - - !************************ - ! Open header output file - !************************ - - open(unitheader,file=path(2)(1:length(2))//'header', & - form='unformatted',err=998) - - - ! Write the header information - !***************************** - - if (ldirect.eq.1) then - write(unitheader) ibdate,ibtime, flexversion - else - write(unitheader) iedate,ietime, flexversion - endif - - ! Write info on output interval, averaging time, sampling time - !************************************************************* - - write(unitheader) loutstep,loutaver,loutsample - - ! Write information on output grid setup - !*************************************** - - write(unitheader) outlon0,outlat0,numxgrid,numygrid, & - dxout,dyout - 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.1000) then - write(unitheader) compoint(i) - else - write(unitheader) compoint(1001) - 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) - - return - - -998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' - write(*,*) ' #### '//path(2)(1:length(2))//'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_bin - -subroutine writeheader_bin_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 * - ! * - !***************************************************************************** - ! * - ! Modified to remove TRIM around the output of flexversion so that * - ! it will be a constant length (defined in com_mod.f90) in output header * - ! * - ! Don Morton, Boreal Scientific Computing * - ! 07 May 2017 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! xlon longitude * - ! xl model x coordinate * - ! ylat latitude * - ! yl model y coordinate * - ! * - !***************************************************************************** - - implicit none - - integer :: jjjjmmdd,ihmmss,i,ix,jy,j - real :: xp1,yp1,xp2,yp2 - - - !************************ - ! Open header output file - !************************ - - open(unitheader,file=path(2)(1:length(2))//'header_nest', & - form='unformatted',err=998) - - - ! Write the header information - !***************************** - - if (ldirect.eq.1) then - write(unitheader) ibdate,ibtime, flexversion - else - write(unitheader) iedate,ietime, flexversion - 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.1000) then - write(unitheader) compoint(i) - else - write(unitheader) compoint(1001) - 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) - - return - - -998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' - write(*,*) ' #### '//path(2)(1:length(2))//'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_bin_nest - -subroutine writeheader_bin_sfc_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 * - ! * - !***************************************************************************** - ! * - ! Modified to remove TRIM around the output of flexversion so that * - ! it will be a constant length (defined in com_mod.f90) in output header * - ! * - ! Don Morton, Boreal Scientific Computing * - ! 07 May 2017 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! xlon longitude * - ! xl model x coordinate * - ! ylat latitude * - ! yl model y coordinate * - ! * - !***************************************************************************** - - implicit none - - integer :: jjjjmmdd,ihmmss,i,ix,jy,j - real :: xp1,yp1,xp2,yp2 - - - !************************ - ! Open header output file - !************************ - - open(unitheader,file=path(2)(1:length(2))//'header_nest_grid_time', & - form='unformatted',err=998) - - - ! Write the header information - !***************************** - - if (ldirect.eq.1) then - write(unitheader) ibdate,ibtime,flexversion - else - write(unitheader) iedate,ietime,flexversion - 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) 1,(outheight(1),i=1,1) - - 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) 1,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.1000) then - write(unitheader) compoint(i) - else - write(unitheader) compoint(1001) - 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) - - return - - -998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' - write(*,*) ' #### '//path(2)(1:length(2))//'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_bin_sfc_nest - -subroutine writeheader_bin_sfc - - !***************************************************************************** - ! * - ! 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 * - ! * - !***************************************************************************** - ! * - ! Modified to remove TRIM around the output of flexversion so that * - ! it will be a constant length (defined in com_mod.f90) in output header * - ! * - ! Don Morton, Boreal Scientific Computing * - ! 07 May 2017 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! xlon longitude * - ! xl model x coordinate * - ! ylat latitude * - ! yl model y coordinate * - ! * - !***************************************************************************** - - implicit none - - integer :: jjjjmmdd,ihmmss,i,ix,jy,j - real :: xp1,yp1,xp2,yp2 - - - !************************ - ! Open header output file - !************************ - - open(unitheader,file=path(2)(1:length(2))//'header_grid_time', & - form='unformatted',err=998) - - - ! Write the header information - !***************************** - - if (ldirect.eq.1) then - write(unitheader) ibdate,ibtime, flexversion - else - write(unitheader) iedate,ietime, flexversion - endif - - ! Write info on output interval, averaging time, sampling time - !************************************************************* - - write(unitheader) loutstep,loutaver,loutsample - - ! Write information on output grid setup - !*************************************** - - write(unitheader) outlon0,outlat0,numxgrid,numygrid, & - dxout,dyout - write(unitheader) 1,(outheight(1),i=1,1) - - 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) 1,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.1000) then - write(unitheader) compoint(i) - else - write(unitheader) compoint(1001) - 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) - - return - - -998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' - write(*,*) ' #### '//path(2)(1:length(2))//'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_bin_sfc - -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 * - ! * - !***************************************************************************** - ! * - ! 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 - - ! 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 - - ! Concentration output - !********************* - - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - open(unitoutrecept,file=path(2)(1:length(2))//'receptor_conc', & - form='unformatted',err=997) - write(unitoutrecept) (receptorname(j),j=1,numreceptor) - write(unitoutrecept) (xreceptor(j)*dx+xlon0, & - yreceptor(j)*dy+ylat0,j=1,numreceptor) - endif - - ! Mixing ratio output - !******************** - - if ((iout.eq.2).or.(iout.eq.3)) then - open(unitoutreceptppt,file=path(2)(1:length(2))//'receptor_pptv', & - form='unformatted',err=998) - write(unitoutreceptppt) (receptorname(j),j=1,numreceptor) - write(unitoutreceptppt) (xreceptor(j)*dx+xlon0, & - yreceptor(j)*dy+ylat0,j=1,numreceptor) - 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 - - -subroutine concoutput(itime,outnum,gridtotalunc,wetgridtotalunc, & - drygridtotalunc) - ! i i o o - ! o - !***************************************************************************** - ! * - ! 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 * - ! * - !***************************************************************************** - ! * - ! 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 mean_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 - ! RLT - real :: densitydryrecept(maxreceptor) - real :: factor_dryrecept(maxreceptor) - - real(dep_prec) :: auxgrid(nclassunc) - real(sp) :: gridtotal,gridsigmatotal,gridtotalunc - real(dep_prec) :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc - real(dep_prec) :: drygridtotal,drygridsigmatotal,drygridtotalunc - 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 - logical :: sp_zer - logical,save :: init=.true. - character :: adate*8,atime*6 - character(len=3) :: anspec - integer :: mind - character(LEN=8),save :: file_stat='REPLACE' - logical :: ldates_file - logical :: lexist - integer :: ierr - character(LEN=100) :: dates_char - - ! 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 - - ! Overwrite existing dates file on first call, later append to it - ! This fixes a bug where the dates file kept growing across multiple runs - - ! If 'dates' file exists in output directory, make a backup - inquire(file=path(2)(1:length(2))//'dates', exist=ldates_file) - if (ldates_file.and.init) then - open(unit=unitdates, file=path(2)(1:length(2))//'dates',form='formatted', & - &access='sequential', status='old', action='read', iostat=ierr) - open(unit=unittmp, file=path(2)(1:length(2))//'dates.bak', access='sequential', & - &status='replace', action='write', form='formatted', iostat=ierr) - do while (.true.) - read(unitdates, '(a)', iostat=ierr) dates_char - if (ierr.ne.0) exit - write(unit=unittmp, fmt='(a)', iostat=ierr, advance='yes') trim(dates_char) - end do - close(unit=unitdates) - close(unit=unittmp) - end if - - open(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND', STATUS=file_stat) - write(unitdates,'(a)') adate//atime - close(unitdates) - - ! Overwrite existing dates file on first call, later append to it - ! This fixes a bug where the dates file kept growing across multiple runs - IF (init) THEN - file_stat='OLD' - init=.false. - END IF - - - ! 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 - !******************************************************************* - - mind=memind(2) - 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=(xl-xlon0)/dx - yl=(yl-ylat0)/dy !v9.1.1 - 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 - densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,mind)*dz1+ & - rho(iix,jjy,kzz-1,mind)*dz2)/dz - ! RLT - densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,mind)*dz1+ & - rho_dry(iix,jjy,kzz-1,mind)*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) - densityoutrecept(i)=rho(iix,jjy,1,mind) - ! RLT - densitydryrecept(i)=rho_dry(iix,jjy,1,mind) - end do - - ! RLT - ! conversion factor for output relative to dry air - factor_drygrid=densityoutgrid/densitydrygrid - factor_dryrecept=densityoutrecept/densitydryrecept - - ! 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. - - do ks=1,nspec - - write(anspec,'(i3.3)') ks - - if (DRYBKDEP.or.WETBKDEP) then !scavdep output - if (DRYBKDEP) & - open(unitoutgrid,file=path(2)(1:length(2))//'grid_drydep_'//adate// & - atime//'_'//anspec,form='unformatted') - if (WETBKDEP) & - open(unitoutgrid,file=path(2)(1:length(2))//'grid_wetdep_'//adate// & - atime//'_'//anspec,form='unformatted') - write(unitoutgrid) itime - else - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - if (ldirect.eq.1) then - open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//adate// & - atime//'_'//anspec,form='unformatted') - else - open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// & - atime//'_'//anspec,form='unformatted') - endif - write(unitoutgrid) itime - endif - if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio - open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//adate// & - atime//'_'//anspec,form='unformatted') - write(unitoutgridppt) itime - endif - endif ! if deposition output - - 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)) - 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 - !******************************************************************* - - ! 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) - 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) - - ! 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) - 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) - - - - ! 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 - if (lparticlecountoutput) then - sparse_dump_r(sp_count_r)= & - sp_fact* & - grid(ix,jy,kz) - else - sparse_dump_r(sp_count_r)= & - sp_fact* & - grid(ix,jy,kz)* & - factor3d(ix,jy,kz)/tot_mu(ks,kp) - end if - - 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) - - - - 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) - 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) - - - ! 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) - 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) - - - ! 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) - 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) - - endif ! output for ppt - - end do - end do - - close(unitoutgridppt) - close(unitoutgrid) - - end do - - ! RLT Aug 2017 - ! Write out conversion factor for dry air - inquire(file=path(2)(1:length(2))//'factor_drygrid',exist=lexist) - if (lexist) then - ! open and append - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& - status='old',action='write',access='append') - else - ! create new - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& - status='new',action='write') - endif - 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 (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then - if (sp_zer.eqv..true.) then ! first value not equal to one - 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*factor_drygrid(ix,jy,kz) - else ! factor is one - sp_zer=.true. - endif - end do - end do - end do - write(unitoutfactor) sp_count_i - write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) - write(unitoutfactor) sp_count_r - write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) - close(unitoutfactor) - - - 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 - - ! RLT Aug 2017 - ! Write out conversion factor for dry air - if (numreceptor.gt.0) then - inquire(file=path(2)(1:length(2))//'factor_dryreceptor',exist=lexist) - if (lexist) then - ! open and append - open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& - status='old',action='write',access='append') - else - ! create new - open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& - status='new',action='write') - endif - write(unitoutfactor) itime - write(unitoutfactor) (factor_dryrecept(i),i=1,numreceptor) - close(unitoutfactor) - endif - - creceptor(:,:)=0. - gridunc(:,:,:,:,:,:,:)=0. -end subroutine concoutput - -subroutine concoutput_nest(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 * - ! * - !***************************************************************************** - ! * - ! 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 mean_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 - ! RLT - real :: densitydryrecept(maxreceptor) - real :: factor_dryrecept(maxreceptor) - - !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(dep_prec) :: 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 - logical :: sp_zer - character :: adate*8,atime*6 - character(len=3) :: anspec - logical :: lexist - integer :: mind - - - ! 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 - !******************************************************************* - - mind=memind(2) - 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=outlon0n+real(ix)*dxoutn - yl=outlat0n+real(jy)*dyoutn - xl=(xl-xlon0)/dx - yl=(yl-ylat0)/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 - densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,mind)*dz1+ & - rho(iix,jjy,kzz-1,mind)*dz2)/dz - ! RLT - densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,mind)*dz1+ & - rho_dry(iix,jjy,kzz-1,mind)*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) - densityoutrecept(i)=rho(iix,jjy,1,mind) - ! RLT - densitydryrecept(i)=rho_dry(iix,jjy,1,mind) - end do - - ! RLT - ! conversion factor for output relative to dry air - factor_drygrid=densityoutgrid/densitydrygrid - factor_dryrecept=densityoutrecept/densitydryrecept - - ! 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 (DRYBKDEP.or.WETBKDEP) then !scavdep output - if (DRYBKDEP) & - open(unitoutgrid,file=path(2)(1:length(2))//'grid_drydep_nest_'//adate// & - atime//'_'//anspec,form='unformatted') - if (WETBKDEP) & - open(unitoutgrid,file=path(2)(1:length(2))//'grid_wetdep_nest_'//adate// & - atime//'_'//anspec,form='unformatted') - write(unitoutgrid) itime - else - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - if (ldirect.eq.1) then - open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_' & - //adate// & - atime//'_'//anspec,form='unformatted') - else - open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' & - //adate// & - atime//'_'//anspec,form='unformatted') - endif - write(unitoutgrid) itime - endif - endif - - if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio - open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_' & - //adate// & - atime//'_'//anspec,form='unformatted') - - 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 - !******************************************************************* - - ! 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 - 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,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 - 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,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 - 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,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 - 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,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 - 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,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 - 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 - - end do - end do - - close(unitoutgridppt) - close(unitoutgrid) - - end do - - ! RLT Aug 2017 - ! Write out conversion factor for dry air - inquire(file=path(2)(1:length(2))//'factor_drygrid_nest',exist=lexist) - if (lexist) then - ! open and append - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& - status='old',action='write',access='append') - else - ! create new - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& - status='new',action='write') - endif - 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 (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then - if (sp_zer.eqv..true.) then ! first value not equal to one - 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*factor_drygrid(ix,jy,kz) - else ! factor is one - sp_zer=.true. - endif - end do - end do - end do - write(unitoutfactor) sp_count_i - write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) - write(unitoutfactor) sp_count_r - write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) - close(unitoutfactor) - - creceptor(:,:)=0. - griduncn(:,:,:,:,:,:,:)=0. -end subroutine concoutput_nest - -subroutine concoutput_inv(itime,outnum,gridtotalunc,wetgridtotalunc, & - drygridtotalunc) - ! i i o o - ! o - !***************************************************************************** - ! * - ! 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 * - ! - ! January 2017, Separate files by release but include all timesteps - ! * - !***************************************************************************** - ! * - ! 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 mean_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 - ! RLT - real :: densitydryrecept(maxreceptor) - real :: factor_dryrecept(maxreceptor) - - - real(dep_prec) :: auxgrid(nclassunc) - real(sp) :: gridtotal,gridsigmatotal,gridtotalunc - real(dep_prec) :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc - real(dep_prec) :: drygridtotal,drygridsigmatotal,drygridtotalunc - 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 - logical :: sp_zer - character :: adate*8,atime*6 - character(len=3) :: anspec - logical :: lexist - character :: areldate*8,areltime*6 - logical,save :: lstart=.true. - logical,save,allocatable,dimension(:) :: lstartrel - integer :: ierr - character(LEN=100) :: dates_char - integer, parameter :: unitrelnames=654 - - - if(lstart) then - allocate(lstartrel(maxpointspec_act)) - lstartrel(:)=.true. - endif - print*, 'lstartrel = ',lstartrel - - if (verbosity.eq.1) then - print*,'inside concoutput_inv ' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - - ! Determine current calendar date - !********************************************************** - - jul=bdate+real(itime,kind=dp)/86400._dp - call caldate(jul,jjjjmmdd,ihmmss) - write(adate,'(i8.8)') jjjjmmdd - write(atime,'(i6.6)') ihmmss - - - ! Prepare output files for dates - !********************************************************** - - ! Overwrite existing dates file on first call, later append to it - ! If 'dates' file exists in output directory, copy to new file dates.old - inquire(file=path(2)(1:length(2))//'dates', exist=lexist) - if (lexist.and.lstart) then - ! copy contents of existing dates file to dates.old - print*, 'warning: replacing old dates file' - open(unit=unitdates, file=path(2)(1:length(2))//'dates',form='formatted', & - &access='sequential', status='old', action='read', iostat=ierr) - open(unit=unittmp, file=path(2)(1:length(2))//'dates.old', access='sequential', & - &status='replace', action='write', form='formatted', iostat=ierr) - do while (.true.) - read(unitdates, '(a)', iostat=ierr) dates_char - if (ierr.ne.0) exit - write(unit=unittmp, fmt='(a)', iostat=ierr, advance='yes') trim(dates_char) - end do - close(unit=unitdates) - close(unit=unittmp) - ! create new dates file - open(unit=unitdates, file=path(2)(1:length(2))//'dates',form='formatted', & - &access='sequential', status='replace', iostat=ierr) - close(unit=unitdates) - endif - - open(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND') - write(unitdates,'(a)') adate//atime - close(unitdates) - - !CGZ: Make a filename with names of releases - if (lstart) then - open(unit=unitrelnames, file=path(2)(1:length(2))//'releases_out',form='formatted', & - &access='sequential', status='replace', iostat=ierr) - close(unitrelnames) - endif - - print*, 'after creating dates files: lstart = ',lstart - ! print*, 'outnum:',outnum - ! print*, 'datetime:',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 - - - if (verbosity.eq.1) then - print*,'concoutput_inv 2' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - 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=(xl-xlon0)/dx - yl=(yl-ylat0)/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 - ! RLT - densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ & - rho_dry(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) - ! RLT - densitydryrecept(i)=rho_dry(iix,jjy,1,2) - end do - - ! RLT - ! conversion factor for output relative to dry air - factor_drygrid=densityoutgrid/densitydrygrid - factor_dryrecept=densityoutrecept/densitydryrecept - - ! 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 - !********************************************************************* - - if (verbosity.eq.1) then - print*,'concoutput_inv 3 (sd)' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - gridtotal=0. - gridsigmatotal=0. - gridtotalunc=0. - wetgridtotal=0. - wetgridsigmatotal=0. - wetgridtotalunc=0. - drygridtotal=0. - drygridsigmatotal=0. - drygridtotalunc=0. - - do ks=1,nspec - - write(anspec,'(i3.3)') ks - - ! loop over releases - do kp=1,maxpointspec_act - - print*, 'itime = ',itime - !print*, 'lage(1) = ',lage(1) - print*, 'ireleasestart(kp) = ',ireleasestart(kp) - print*, 'ireleaseend(kp) = ',ireleaseend(kp) - - ! check itime is within release and backward trajectory length - if (nageclass.eq.1) then - if ((itime.gt.ireleaseend(kp)).or.(itime.lt.(ireleasestart(kp)-lage(1)))) then - go to 10 - endif - endif - - ! calculate date of release for filename - jul=bdate+real(ireleasestart(kp),kind=dp)/86400._dp ! this is the current day - call caldate(jul,jjjjmmdd,ihmmss) - write(areldate,'(i8.8)') jjjjmmdd - write(areltime,'(i6.6)') ihmmss - print*, 'areldate/areltime = ',areldate//areltime - - ! calculate date of field - jul=bdate+real(itime,kind=dp)/86400._dp - call caldate(jul,jjjjmmdd,ihmmss) - write(adate,'(i8.8)') jjjjmmdd - write(atime,'(i6.6)') ihmmss - - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - if (ldirect.eq.1) then - ! concentrations - inquire(file=path(2)(1:length(2))//'grid_conc_'//areldate// & - areltime//'_'//anspec,exist=lexist) - if(lexist.and..not.lstartrel(kp)) then - ! open and append to existing file - open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') - else - ! open new file - open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='replace',action='write') - endif - else - ! residence times - inquire(file=path(2)(1:length(2))//'grid_time_'//areldate// & - areltime//'_'//anspec,exist=lexist) - if(lexist.and..not.lstartrel(kp)) then - ! open and append to existing file - open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') - else - ! open new file - open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='replace',action='write') - ! add part of the filename to a file (similar to dates) for easier post-processing - open(unit=unitrelnames, file=path(2)(1:length(2))//'releases_out',form='formatted', & - & access='APPEND', iostat=ierr) - write(unitrelnames,'(a)') areldate//areltime//'_'//anspec - close(unitrelnames) - endif - endif - write(unitoutgrid) jjjjmmdd - write(unitoutgrid) ihmmss - endif - - if ((iout.eq.2).or.(iout.eq.3)) then - ! mixing ratio - inquire(file=path(2)(1:length(2))//'grid_pptv_'//areldate// & - areltime//'_'//anspec,exist=lexist) - if(lexist.and..not.lstartrel(kp)) then - ! open and append to existing file - open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') - else - ! open new file - open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='replace',action='write') - endif - write(unitoutgridppt) jjjjmmdd - write(unitoutgridppt) ihmmss - endif - - lstartrel(kp)=.false. - - do nage=1,nageclass - - do jy=0,numygrid-1 - do ix=0,numxgrid-1 - - ! 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 (verbosity.eq.1) then - print*,'concoutput_inv 4 (output)' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - - ! Concentration output - !********************* - - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - - if (verbosity.eq.1) then - print*,'concoutput_inv (Wet deposition)' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - - if (verbosity.eq.1) then - print*,'concoutput_inv (Concentrations)' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - - ! Concentrations - - ! surf_only write only 1st layer - - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - 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) - sparse_dump_u(sp_count_r)= & - gridsigma(ix,jy,kz)* & - factor3d(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) - - endif ! concentration output - - ! Mixing ratio output - !******************** - - if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio - - ! Mixing ratios - - ! surf_only write only 1st layer - - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - 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)/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) - - endif ! output for ppt - - end do ! nageclass - - close(unitoutgridppt) - close(unitoutgrid) - - ! itime is outside range -10 continue - - end do ! maxpointspec_act - - end do ! nspec - - ! RLT Aug 2017 - ! Write out conversion factor for dry air - inquire(file=path(2)(1:length(2))//'factor_drygrid',exist=lexist) - if (lexist.and..not.lstart) then - ! open and append - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& - status='old',action='write',access='append') - else - ! create new - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& - status='replace',action='write') - endif - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - do jy=0,numygrid-1 - do ix=0,numxgrid-1 - if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then - if (sp_zer.eqv..true.) then ! first value not equal to one - 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*factor_drygrid(ix,jy,kz) - else ! factor is one - sp_zer=.true. - endif - end do - end do - end do - write(unitoutfactor) sp_count_i - write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) - write(unitoutfactor) sp_count_r - write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) - close(unitoutfactor) - - - if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal - - ! 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 - - ! RLT Aug 2017 - ! Write out conversion factor for dry air - if (numreceptor.gt.0) then - inquire(file=path(2)(1:length(2))//'factor_dryreceptor',exist=lexist) - if (lexist.and..not.lstart) then - ! open and append - open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& - status='old',action='write',access='append') - else - ! create new - open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& - status='replace',action='write') - endif - write(unitoutfactor) itime - write(unitoutfactor) (factor_dryrecept(i),i=1,numreceptor) - close(unitoutfactor) - endif - - ! reset lstart - if (lstart) then - lstart=.false. - endif - print*, 'after writing output files: lstart = ',lstart - - - ! 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,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_inv - -subroutine concoutput_inv_nest(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 * - ! - ! January 2017, Separate files by release but include all timesteps * - ! * - !***************************************************************************** - ! * - ! 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 mean_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 - ! RLT - real :: densitydryrecept(maxreceptor) - real :: factor_dryrecept(maxreceptor) - - real(dep_prec) :: 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 - logical :: sp_zer - logical,save :: lnstart=.true. - logical,save,allocatable,dimension(:) :: lnstartrel - character :: adate*8,atime*6 - character(len=3) :: anspec - logical :: lexist - character :: areldate*8,areltime*6 - - if(lnstart) then - allocate(lnstartrel(maxpointspec_act)) - lnstartrel(:)=.true. - endif - print*, 'lnstartrel = ',lnstartrel - - ! 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 - - print*, 'outnum:',outnum - print*, 'datetime:',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,numygridn-1 - do ix=0,numxgridn-1 - xl=outlon0n+real(ix)*dxoutn - yl=outlat0n+real(jy)*dyoutn - xl=(xl-xlon0)/dx - yl=(yl-ylat0)/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 - ! RLT - densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ & - rho_dry(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) - ! RLT - densitydryrecept(i)=rho_dry(iix,jjy,1,2) - end do - - ! RLT - ! conversion factor for output relative to dry air - factor_drygrid=densityoutgrid/densitydrygrid - factor_dryrecept=densityoutrecept/densitydryrecept - - ! 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 - - do kp=1,maxpointspec_act - - print*, 'itime = ',itime - print*, 'lage(1) = ',lage(1) - print*, 'ireleasestart(kp) = ',ireleasestart(kp) - print*, 'ireleaseend(kp) = ',ireleaseend(kp) - - ! check itime is within release and backward trajectory length - if (nageclass.eq.1) then - if ((itime.gt.ireleaseend(kp)).or.(itime.lt.(ireleasestart(kp)-lage(1)))) then - go to 10 - endif - endif - - ! calculate date of release - jul=bdate+real(ireleasestart(kp),kind=dp)/86400._dp ! this is the current day - call caldate(jul,jjjjmmdd,ihmmss) - write(areldate,'(i8.8)') jjjjmmdd - write(areltime,'(i6.6)') ihmmss - print*, areldate//areltime - - ! calculate date of field - jul=bdate+real(itime,kind=dp)/86400._dp - call caldate(jul,jjjjmmdd,ihmmss) - write(adate,'(i8.8)') jjjjmmdd - write(atime,'(i6.6)') ihmmss - print*, adate//atime - - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - if (ldirect.eq.1) then - ! concentrations - inquire(file=path(2)(1:length(2))//'grid_conc_nest_'//areldate// & - areltime//'_'//anspec,exist=lexist) - if(lexist.and..not.lnstartrel(kp)) then - ! open and append to existing file - open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') - else - ! open new file - open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='replace',action='write') - endif - else - ! residence times - inquire(file=path(2)(1:length(2))//'grid_time_nest_'//areldate// & - areltime//'_'//anspec,exist=lexist) - if(lexist.and..not.lnstartrel(kp)) then - ! open and append to existing file - open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') - else - ! open new file - open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='replace',action='write') - endif - endif - write(unitoutgrid) jjjjmmdd - write(unitoutgrid) ihmmss - endif - - if ((iout.eq.2).or.(iout.eq.3)) then - ! mixing ratio - inquire(file=path(2)(1:length(2))//'grid_pptv_nest_'//areldate// & - areltime//'_'//anspec,exist=lexist) - if(lexist.and..not.lnstartrel(kp)) then - ! open and append to existing file - open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') - else - ! open new file - open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='replace',action='write') - endif - write(unitoutgridppt) jjjjmmdd - write(unitoutgridppt) ihmmss - endif - - lnstartrel(kp)=.false. - - do nage=1,nageclass - - do jy=0,numygridn-1 - do ix=0,numxgridn-1 - - ! 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 - !******************************************************************* - - ! Concentration output - !********************* - - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - - ! Concentrations - - ! surf_only write only 1st layer - - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - 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)* & - factor3d(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) - - endif ! concentration output - - ! Mixing ratio output - !******************** - - if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio - - - ! Mixing ratios - - ! surf_only write only 1st layer - - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - 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)/volumen(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) - - endif ! output for ppt - - end do ! nageclass - - close(unitoutgridppt) - close(unitoutgrid) - - ! itime is outside range -10 continue - - end do ! maxpointspec_act - - end do ! nspec - - - ! RLT Aug 2017 - ! Write out conversion factor for dry air - inquire(file=path(2)(1:length(2))//'factor_drygrid_nest',exist=lexist) - if (lexist.and..not.lnstart) then - ! open and append - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& - status='old',action='write',access='append') - else - ! create new - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& - status='replace',action='write') - endif - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - do jy=0,numygridn-1 - do ix=0,numxgridn-1 - if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then - if (sp_zer.eqv..true.) then ! first value not equal to one - 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*factor_drygrid(ix,jy,kz) - else ! factor is one - sp_zer=.true. - endif - end do - end do - end do - write(unitoutfactor) sp_count_i - write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) - write(unitoutfactor) sp_count_r - write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) - close(unitoutfactor) - - ! reset lnstart - if (lnstart) then - lnstart=.false. - endif - - ! 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_inv_nest - -subroutine concoutput_sfc(itime,outnum,gridtotalunc,wetgridtotalunc, & - drygridtotalunc) - ! i i o o - ! o - !***************************************************************************** - ! * - ! 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 * - ! * - !***************************************************************************** - ! * - ! 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 mean_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 - ! RLT - real :: densitydryrecept(maxreceptor) - real :: factor_dryrecept(maxreceptor) - - real(dep_prec) :: auxgrid(nclassunc) - real(sp) :: gridtotal,gridsigmatotal,gridtotalunc - real(dep_prec) :: wetgridtotal,wetgridsigmatotal,wetgridtotalunc - real(dep_prec) :: drygridtotal,drygridsigmatotal,drygridtotalunc - 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 - logical :: sp_zer - character :: adate*8,atime*6 - character(len=3) :: anspec - logical :: lexist - - - if (verbosity.eq.1) then - print*,'inside concoutput_sfc ' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - - ! 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(unitdates,file=path(2)(1:length(2))//'dates', ACCESS='APPEND') - write(unitdates,'(a)') adate//atime - close(unitdates) - - ! 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 - - - if (verbosity.eq.1) then - print*,'concoutput_sfc 2' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - 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=(xl-xlon0)/dx - yl=(yl-ylat0)/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 - ! RLT - densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ & - rho_dry(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) - ! RLT - densitydryrecept(i)=rho_dry(iix,jjy,1,2) - end do - - ! RLT - ! conversion factor for output relative to dry air - factor_drygrid=densityoutgrid/densitydrygrid - factor_dryrecept=densityoutrecept/densitydryrecept - - ! 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 - !********************************************************************* - - if (verbosity.eq.1) then - print*,'concoutput_sfc 3 (sd)' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - gridtotal=0. - gridsigmatotal=0. - gridtotalunc=0. - wetgridtotal=0. - wetgridsigmatotal=0. - wetgridtotalunc=0. - drygridtotal=0. - drygridsigmatotal=0. - drygridtotalunc=0. - - 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 - open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_'//adate// & - atime//'_'//anspec,form='unformatted') - else - open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_'//adate// & - atime//'_'//anspec,form='unformatted') - endif - write(unitoutgrid) itime - endif - - if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio - open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_'//adate// & - atime//'_'//anspec,form='unformatted') - - 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 (verbosity.eq.1) then - print*,'concoutput_sfc 4 (output)' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - - ! Concentration output - !********************* - - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - - if (verbosity.eq.1) then - print*,'concoutput_sfc (Wet deposition)' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - - ! 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)/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) - - if (verbosity.eq.1) then - print*,'concoutput_sfc (Dry deposition)' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - ! 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)/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) - - if (verbosity.eq.1) then - print*,'concoutput_sfc (Concentrations)' - CALL SYSTEM_CLOCK(count_clock) - WRITE(*,*) 'SYSTEM_CLOCK',count_clock - count_clock0 - endif - - ! Concentrations - - ! surf_only write only 1st layer - - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - 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) - sparse_dump_u(sp_count_r)= & - gridsigma(ix,jy,kz)* & - factor3d(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) - 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)/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) - - ! 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)/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) - - ! Mixing ratios - - ! surf_only write only 1st layer - - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - 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)/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) - endif ! output for ppt - - end do - end do - - close(unitoutgridppt) - close(unitoutgrid) - - end do - - ! RLT Aug 2017 - ! Write out conversion factor for dry air - inquire(file=path(2)(1:length(2))//'factor_drygrid',exist=lexist) - if (lexist) then - ! open and append - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& - status='old',action='write',access='append') - else - ! create new - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid',form='unformatted',& - status='new',action='write') - endif - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - do jy=0,numygrid-1 - do ix=0,numxgrid-1 - if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then - if (sp_zer.eqv..true.) then ! first value not equal to one - 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*factor_drygrid(ix,jy,kz) - else ! factor is one - sp_zer=.true. - endif - end do - end do - end do - write(unitoutfactor) sp_count_i - write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) - write(unitoutfactor) sp_count_r - write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) - close(unitoutfactor) - - - 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 - - ! RLT Aug 2017 - ! Write out conversion factor for dry air - if (numreceptor.gt.0) then - inquire(file=path(2)(1:length(2))//'factor_dryreceptor',exist=lexist) - if (lexist) then - ! open and append - open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& - status='old',action='write',access='append') - else - ! create new - open(unitoutfactor,file=path(2)(1:length(2))//'factor_dryreceptor',form='unformatted',& - status='new',action='write') - endif - write(unitoutfactor) itime - write(unitoutfactor) (factor_dryrecept(i),i=1,numreceptor) - close(unitoutfactor) - endif - - ! 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,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_sfc - -subroutine concoutput_sfc_nest(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 * - ! * - !***************************************************************************** - ! * - ! 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 mean_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 - ! RLT - real :: densitydryrecept(maxreceptor) - real :: factor_dryrecept(maxreceptor) - - real(dep_prec) :: 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 - logical :: sp_zer - character :: adate*8,atime*6 - character(len=3) :: anspec - logical :: lexist - - ! 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=outlon0n+real(ix)*dxoutn - yl=outlat0n+real(jy)*dyoutn - xl=(xl-xlon0)/dx - yl=(yl-ylat0)/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 - ! RLT - densitydrygrid(ix,jy,kz)=(rho_dry(iix,jjy,kzz,2)*dz1+ & - rho_dry(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) - ! RLT - densitydryrecept(i)=rho_dry(iix,jjy,1,2) - end do - - ! RLT - ! conversion factor for output relative to dry air - factor_drygrid=densityoutgrid/densitydrygrid - factor_dryrecept=densityoutrecept/densitydryrecept - - ! 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 - open(unitoutgrid,file=path(2)(1:length(2))//'grid_conc_nest_' & - //adate// & - atime//'_'//anspec,form='unformatted') - else - open(unitoutgrid,file=path(2)(1:length(2))//'grid_time_nest_' & - //adate// & - atime//'_'//anspec,form='unformatted') - endif - write(unitoutgrid) itime - endif - - if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio - open(unitoutgridppt,file=path(2)(1:length(2))//'grid_pptv_nest_' & - //adate// & - atime//'_'//anspec,form='unformatted') - - 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 - !******************************************************************* - - ! 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)/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) - ! 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)/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) - - ! Concentrations - - ! if surf_only write only 1st layer - - if(surf_only.eq.1) then - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - 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)* & - factor3d(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) - else - - ! write full vertical resolution - - 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) - sparse_dump_u(sp_count_r)= & - gridsigma(ix,jy,kz)* & - factor3d(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) - endif ! surf_only - - - 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)/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) - - ! 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)/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) - - ! Mixing ratios - - ! if surf_only write only 1st layer - - if(surf_only.eq.1) then - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - 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)/volumen(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) - else - - ! write full vertical resolution - - 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)/volumen(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) - endif ! surf_only - - endif ! output for ppt - - end do - end do - - close(unitoutgridppt) - close(unitoutgrid) - - end do - - ! RLT Aug 2017 - ! Write out conversion factor for dry air - inquire(file=path(2)(1:length(2))//'factor_drygrid_nest',exist=lexist) - if (lexist) then - ! open and append - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& - status='old',action='write',access='append') - else - ! create new - open(unitoutfactor,file=path(2)(1:length(2))//'factor_drygrid_nest',form='unformatted',& - status='new',action='write') - endif - sp_count_i=0 - sp_count_r=0 - sp_fact=-1. - sp_zer=.true. - do kz=1,1 - do jy=0,numygridn-1 - do ix=0,numxgridn-1 - if (factor_drygrid(ix,jy,kz).gt.(1.+smallnum).or.factor_drygrid(ix,jy,kz).lt.(1.-smallnum)) then - if (sp_zer.eqv..true.) then ! first value not equal to one - 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*factor_drygrid(ix,jy,kz) - else ! factor is one - sp_zer=.true. - endif - end do - end do - end do - write(unitoutfactor) sp_count_i - write(unitoutfactor) (sparse_dump_i(i),i=1,sp_count_i) - write(unitoutfactor) sp_count_r - write(unitoutfactor) (sparse_dump_r(i),i=1,sp_count_r) - close(unitoutfactor) - - - - ! 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_sfc_nest - -subroutine initcond_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 - - 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(2)(1:length(2))//'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 initcond_output - -subroutine initcond_output_inv(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 - - implicit none - - integer :: itime,i,ix,jy,kz,ks,kp,sp_count_i,sp_count_r - integer :: jjjjmmdd, ihmmss - real(kind=dp) :: jul - real :: sp_fact,fact_recept - real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled - logical :: sp_zer,lexist - logical,save :: listart=.true. - logical,save,allocatable,dimension(:) :: listartrel - character :: adate*8,atime*6 - character :: areldate*8,areltime*6 - character(len=3) :: anspec - - if(listart) then - allocate(listartrel(maxpointspec_act)) - listartrel(:)=.true. - endif - print*, 'listartrel = ',listartrel - - !********************************************************************* - ! 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 +#include "bin_writeheader_bin.f90" - do kp=1,maxpointspec_act +#include "bin_writeheader_bin_nest.f90" - ! calculate date of release - jul=bdate+real(ireleasestart(kp),kind=dp)/86400._dp ! this is the current day - call caldate(jul,jjjjmmdd,ihmmss) - write(areldate,'(i8.8)') jjjjmmdd - write(areltime,'(i6.6)') ihmmss - print*, areldate//areltime +#include "bin_writeheader_bin_sfc_nest.f90" - ! calculate date of field - jul=bdate+real(itime,kind=dp)/86400._dp - call caldate(jul,jjjjmmdd,ihmmss) - write(adate,'(i8.8)') jjjjmmdd - write(atime,'(i6.6)') ihmmss - print*, adate//atime +#include "bin_writeheader_bin_sfc.f90" - inquire(file=path(2)(1:length(2))//'grid_initial_'//areldate// & - areltime//'_'//anspec,exist=lexist) - if(lexist.and..not.listartrel(kp)) then - ! open and append to existing file - open(97,file=path(2)(1:length(2))//'grid_initial_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='old',action='write',access='append') - else - ! open new file - open(97,file=path(2)(1:length(2))//'grid_initial_'//areldate// & - areltime//'_'//anspec,form='unformatted',status='replace',action='write') - endif - write(97) jjjjmmdd - write(97) ihmmss +#include "bin_openreceptors.f90" - listartrel(kp)=.false. - if (ind_rel.eq.1) then - fact_recept=rho_rel(kp) - else - fact_recept=1. - endif +#include "bin_concoutput.f90" - !******************************************************************* - ! 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 - !******************************************************************* +#include "bin_concoutput_nest.f90" - ! Write out dummy "wet and dry deposition" fields, to keep same format - ! as for concentration output +#include "bin_concoutput_inv.f90" - ! 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) +#include "bin_concoutput_inv_nest.f90" - close(97) +#include "bin_concoutput_sfc.f90" - end do +#include "bin_concoutput_sfc_nest.f90" - end do +#include "bin_initcond_output.f90" - ! reset listart - if (listart) then - listart=.false. - endif -end subroutine initcond_output_inv +#include "bin_initcond_output_inv.f90" end module binary_output_mod diff --git a/src/cbl_cbl.f90 b/src/cbl_cbl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..55a8b25b79b081cc616d17379d366ad201f9c378 --- /dev/null +++ b/src/cbl_cbl.f90 @@ -0,0 +1,216 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 i o + + use par_mod, only:pi + use com_mod, only:ldirect + + implicit none + +!******************************************************************************* +! CBL skewed vertical profiles and formulation of LHH 1996 with profile of w^3 +! from LHB 2000 +! LHH formulation has been modified to account for variable density profiles +! and backward in time or forward in time simulations +! see Cassiani et al. BLM 2014 doi for explanations and references +!******************************************************************************* + + real :: usurad2,usurad2p,C0,costluar4,eps + parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=3,costluar4=0.66667,eps=0.000001) + + + integer :: flagrein + 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 ::z0,ol,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 !put to 1 for test constant density simulation + ddens=rhograd !put to 0 for test constant density simulation + + + timedir=ldirect !ldirect contains direction of time forward (1) or backward(-1) + ! assegnazione z + z=(zp/h) + + ! stability transition function see Cassiani et al(2015) BLM + 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 + + ! momento secondo + + w2=(sigmaw*sigmaw) + dw2=(2.*sigmaw*dsigmawdz) + + + !=================== dissipazione ======================================= + + alfa=2.*w2/(C0*tlw) + + !======================================================================== + + wold=timedir*wp + + !========================================================================= + !------------------------------ momento terzo ============================ + + 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)) !skew**(1./3.) + 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) !----> r^1/2 + + 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 + + if (abs(deltawa).gt.6.*sigmawa.and.abs(deltawb).gt.6.*sigmawb) flagrein=1 + + pa=(usurad2p*(1./sigmawa))*(exp(-(0.5*((deltawa/sigmawa)**2.)))) + pb=(usurad2p*(1./sigmawb))*(exp(-(0.5*((deltawb/sigmawb)**2.)))) + + ptot=dens*aluarw*pa+dens*bluarw*pb + + aperfa=deltawa*usurad2/sigmawa + aperfb=deltawb*usurad2/sigmawb + + 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) + bth=sqrt(C0*alfa) + !bth=sngl(sigmaw*sqrt(2.*tlw)) + + return +end subroutine cbl diff --git a/src/cbl_cuberoot.f90 b/src/cbl_cuberoot.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8593e590f23d5de0cff06455697782ae38aeddbc --- /dev/null +++ b/src/cbl_cuberoot.f90 @@ -0,0 +1,13 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +function cuberoot(x) result(y) + + implicit none + + real, intent(in) :: x + real :: y + real, parameter :: third=0.333333333 + + y=sign((abs(x))**third,x) +end function cuberoot diff --git a/src/cbl_init_cbl_vel.f90 b/src/cbl_init_cbl_vel.f90 new file mode 100644 index 0000000000000000000000000000000000000000..069c71f56688c63f5d601878cea8aac210d0d1cd --- /dev/null +++ b/src/cbl_init_cbl_vel.f90 @@ -0,0 +1,86 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine init_cbl_vel(idum,zp,ust,wst,h,sigmaw,wp,ol,ithread) + ! i/o i i i i i o i + + use par_mod, only:pi + use com_mod, only:ldirect + use random_mod, only: gasdev, ran3 + + implicit none + !=============================================================================== + ! 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 + ! see Cassiani et al. BLM 2014 doi for explanations and references + !=============================================================================== + + integer,intent(in) :: ithread + real :: usurad2,usurad2p,C0,costluar4,eps + parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=2,costluar4=0.66667,eps=0.000001) + + + 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 + integer :: idum + + !--------------------------------------------------------------------------- + timedir=ldirect !direction of time forward (1) or backward(-1) + z=zp/h + + + transition=1. + if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5 !see also in cbl.f90 + + w2=sigmaw*sigmaw + w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3) *transition + + skew=w3/(w2**1.5) + skew2=skew*skew + + radw2=sqrt(w2) !sigmaw + + fluarw=costluar4*skew**0.333333333333333 + fluarw2=fluarw*fluarw + rluarw=(1.+fluarw2)**3.*skew2/((3.+fluarw2)**2.*fluarw2) !-> r + xluarw=rluarw**0.5 !----> r^1/2 + + 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,ithread) + + if (dcas.le.aluarw) then + dcas1=gasdev(idum,ithread) + wp=timedir*(dcas1*sigmawa+wa) + else + dcas1=gasdev(idum,ithread) + wp=timedir*(dcas1*sigmawb-wb) + end if + + return +end subroutine init_cbl_vel diff --git a/src/cbl_mod.f90 b/src/cbl_mod.f90 index a618437bcfc5c636382c82eb901458a945f43323..0594ede740dacdc72b3ccb4bce850983bfa35176 100644 --- a/src/cbl_mod.f90 +++ b/src/cbl_mod.f90 @@ -1,419 +1,21 @@ ! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt ! SPDX-License-Identifier: GPL-3.0-or-later module cbl_mod - + implicit none private :: cuberoot public :: cbl,reinit_particle,init_cbl_vel - -contains - -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 i o - - use par_mod, only:pi - use com_mod, only:ldirect - - implicit none - -!******************************************************************************* -! CBL skewed vertical profiles and formulation of LHH 1996 with profile of w^3 -! from LHB 2000 -! LHH formulation has been modified to account for variable density profiles -! and backward in time or forward in time simulations -! see Cassiani et al. BLM 2014 doi for explanations and references -!******************************************************************************* - - real :: usurad2,usurad2p,C0,costluar4,eps - parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=3,costluar4=0.66667,eps=0.000001) - - - integer :: flagrein - 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 ::z0,ol,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 !put to 1 for test constant density simulation - ddens=rhograd !put to 0 for test constant density simulation - - - timedir=ldirect !ldirect contains direction of time forward (1) or backward(-1) - ! assegnazione z - z=(zp/h) - - ! stability transition function see Cassiani et al(2015) BLM - 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 - - ! momento secondo - - w2=(sigmaw*sigmaw) - dw2=(2.*sigmaw*dsigmawdz) - - - !=================== dissipazione ======================================= - - alfa=2.*w2/(C0*tlw) - - !======================================================================== - - wold=timedir*wp - - !========================================================================= - !------------------------------ momento terzo ============================ - - 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)) !skew**(1./3.) - 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) !----> r^1/2 - - 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 - - if (abs(deltawa).gt.6.*sigmawa.and.abs(deltawb).gt.6.*sigmawb) flagrein=1 - - pa=(usurad2p*(1./sigmawa))*(exp(-(0.5*((deltawa/sigmawa)**2.)))) - pb=(usurad2p*(1./sigmawb))*(exp(-(0.5*((deltawb/sigmawb)**2.)))) - - ptot=dens*aluarw*pa+dens*bluarw*pb - - aperfa=deltawa*usurad2/sigmawa - aperfb=deltawb*usurad2/sigmawb - - 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) - bth=sqrt(C0*alfa) - !bth=sngl(sigmaw*sqrt(2.*tlw)) - - return -end subroutine cbl - -function cuberoot(x) result(y) - - implicit none - - real, intent(in) :: x - real :: y - real, parameter :: third=0.333333333 - - y=sign((abs(x))**third,x) -end function cuberoot - -subroutine reinit_particle(zp,ust,wst,h,sigmaw,wp,nrand,ol) -! i i i i i io io i -!****************************************************************************** -! CBL skewed vertical profiles and formulation of LHH 1996 with profile of w^3 -! from lHB 2000 -! LHH formulation has been modified to account for variable density profiles -! and backward in time or forward in time simulations -! This routine re-initialize particle velocity if a numerical instability -! in the cbl scheme generated a NaN value -! The particle velocity is extracted from the updraft and downdraft -! distribution as required -! The re-initialization si not perfect -! See e.g. Cassiani et al(2015) BLM -!****************************************************************************** - use par_mod, only:pi - use com_mod, only:ldirect,rannumb - - 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 - real :: z, & - skew, & - skew2, & - radw2, & - fluarw,fluarw2, & - rluarw, & - xluarw, & - aluarw, & - bluarw, & - sigmawa, & - sigmawb, & - ath, & - bth, & - wb,wa - real timedir - real ol,transition - -!--------------------------------------------------------------------------- -!timedir direction of time forward (1) or backward(-1) - nrand=nrand+1 - dcas1=rannumb(nrand) - timedir=ldirect - z=zp/h - transition=1. - - if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5 - - w2=sigmaw*sigmaw - w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3)*transition - skew=w3/(w2**1.5) - skew2=skew*skew - radw2=sqrt(w2) !sigmaw - - 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 - - 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 - - return -end subroutine reinit_particle - -subroutine init_cbl_vel(idum,zp,ust,wst,h,sigmaw,wp,ol,ithread) - ! i/o i i i i i o i - - use par_mod, only:pi - use com_mod, only:ldirect - use random_mod, only: gasdev, ran3 - - implicit none - !=============================================================================== - ! 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 - ! see Cassiani et al. BLM 2014 doi for explanations and references - !=============================================================================== - - integer,intent(in) :: ithread - real :: usurad2,usurad2p,C0,costluar4,eps - parameter (usurad2=0.7071067812,usurad2p=0.3989422804,C0=2,costluar4=0.66667,eps=0.000001) - - - 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 - integer :: idum - - !--------------------------------------------------------------------------- - timedir=ldirect !direction of time forward (1) or backward(-1) - z=zp/h - - - transition=1. - if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5 !see also in cbl.f90 - - w2=sigmaw*sigmaw - w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3) *transition - - skew=w3/(w2**1.5) - skew2=skew*skew - - radw2=sqrt(w2) !sigmaw - - fluarw=costluar4*skew**0.333333333333333 - fluarw2=fluarw*fluarw - rluarw=(1.+fluarw2)**3.*skew2/((3.+fluarw2)**2.*fluarw2) !-> r - xluarw=rluarw**0.5 !----> r^1/2 - - 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 +contains - wa=(fluarw*sigmawa) - wb=(fluarw*sigmawb) +#include "cbl_cbl.f90" - dcas=ran3(idum,ithread) +#include "cbl_cuberoot.f90" - if (dcas.le.aluarw) then - dcas1=gasdev(idum,ithread) - wp=timedir*(dcas1*sigmawa+wa) - else - dcas1=gasdev(idum,ithread) - wp=timedir*(dcas1*sigmawb-wb) - end if +#include "cbl_reinit_particle.f90" - return -end subroutine init_cbl_vel +#include "cbl_init_cbl_vel.f90" end module cbl_mod diff --git a/src/cbl_reinit_particle.f90 b/src/cbl_reinit_particle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9d8228242143d7b1fca7defd299fe8af95d1ec31 --- /dev/null +++ b/src/cbl_reinit_particle.f90 @@ -0,0 +1,99 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine reinit_particle(zp,ust,wst,h,sigmaw,wp,nrand,ol) +! i i i i i io io i + +!****************************************************************************** +! CBL skewed vertical profiles and formulation of LHH 1996 with profile of w^3 +! from lHB 2000 +! LHH formulation has been modified to account for variable density profiles +! and backward in time or forward in time simulations +! This routine re-initialize particle velocity if a numerical instability +! in the cbl scheme generated a NaN value +! The particle velocity is extracted from the updraft and downdraft +! distribution as required +! The re-initialization si not perfect +! See e.g. Cassiani et al(2015) BLM +!****************************************************************************** + use par_mod, only:pi + use com_mod, only:ldirect,rannumb + + 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 + real :: z, & + skew, & + skew2, & + radw2, & + fluarw,fluarw2, & + rluarw, & + xluarw, & + aluarw, & + bluarw, & + sigmawa, & + sigmawb, & + ath, & + bth, & + wb,wa + real timedir + real ol,transition + +!--------------------------------------------------------------------------- +!timedir direction of time forward (1) or backward(-1) + nrand=nrand+1 + dcas1=rannumb(nrand) + timedir=ldirect + z=zp/h + transition=1. + + if (-h/ol.lt.15) transition=((sin((((-h/ol)+10.)/10.)*pi)))/2.+0.5 + + w2=sigmaw*sigmaw + w3=(((1.2*z*((1.-z)**(3./2.)))+eps)*wst**3)*transition + skew=w3/(w2**1.5) + skew2=skew*skew + radw2=sqrt(w2) !sigmaw + + 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 + + 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 + + return +end subroutine reinit_particle diff --git a/src/cla_get_3d_u_dims.f90 b/src/cla_get_3d_u_dims.f90 new file mode 100644 index 0000000000000000000000000000000000000000..43b9a03ecb62ff9a63cc279d8c47508359db1a81 --- /dev/null +++ b/src/cla_get_3d_u_dims.f90 @@ -0,0 +1,128 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + SUBROUTINE get_3d_u_dims(filepath, gribfile_type, xlon, ylat, zlev) + + ! Looks at the 3d u fields in the GRIBFILE to get x and y dims, as well as number of levels + USE grib_api + + IMPLICIT NONE + + CHARACTER(LEN=*), INTENT(IN) :: filepath ! full path to GRIB file + INTEGER, INTENT(IN) :: gribfile_type + INTEGER, INTENT(OUT) :: xlon, ylat, zlev + + INTEGER :: ifile, iret, igrib, grib_centre + LOGICAL :: end_of_file + + ! These will be assigned according to type of grib file, then used to filter + ! for the 3d messages + ! Name of the key being sought + CHARACTER(LEN=64) :: keyname_leveltype, keyname_shortname, keyname_level, & + keyname_xlon, keyname_ylat + + ! The key value being filtered for + CHARACTER(LEN=64) :: keyvalue_leveltype, keyvalue_shortname + + ! Actual values read in from the grib file + CHARACTER(LEN=64) :: value_leveltype, value_shortname + INTEGER :: value_level + + INTEGER :: num_levels + + ! Get the field names to read, based on the type of grib file + + !!! Note that ALL of these have the same key names, except that + !!! leveltype is 'hybrid' in ECMWF and 'isobaricInhPa' in NCEP. + !!! This could probably be consolidated, but because these are + !!! files that go through some preprocessing, and aren't + !!! necessarily standard (at least for ECMWF), I'm going to be + !!! safe and leave it as is for now, so it would be easier to + !!! modify for one type, if necessary. + IF (gribfile_type == GRIBFILE_TYPE_ECMWF_GRIB1) THEN + keyname_leveltype = 'typeOfLevel' + keyname_shortname = 'shortName' + keyname_level = 'level' + keyvalue_leveltype = 'hybrid' + keyvalue_shortname = 'u' + keyname_xlon = 'Ni' + keyname_ylat = 'Nj' + ELSE IF (gribfile_type == GRIBFILE_TYPE_ECMWF_GRIB1_2) THEN + keyname_leveltype = 'typeOfLevel' + keyname_shortname = 'shortName' + keyname_level = 'level' + keyvalue_leveltype = 'hybrid' + keyvalue_shortname = 'u' + keyname_xlon = 'Ni' + keyname_ylat = 'Nj' + ELSE IF (gribfile_type == GRIBFILE_TYPE_ECMWF_GRIB2) THEN + keyname_leveltype = 'typeOfLevel' + keyname_shortname = 'shortName' + keyname_level = 'level' + keyvalue_leveltype = 'hybrid' + keyvalue_shortname = 'u' + keyname_xlon = 'Ni' + keyname_ylat = 'Nj' + ELSE IF (gribfile_type == GRIBFILE_TYPE_NCEP_GRIB1) THEN + keyname_leveltype = 'typeOfLevel' + keyname_shortname = 'shortName' + keyname_level = 'level' + keyvalue_leveltype = 'isobaricInhPa' + keyvalue_shortname = 'u' + keyname_xlon = 'Ni' + keyname_ylat = 'Nj' + ELSE IF (gribfile_type == GRIBFILE_TYPE_NCEP_GRIB2) THEN + keyname_leveltype = 'typeOfLevel' + keyname_shortname = 'shortName' + keyname_level = 'level' + keyvalue_leveltype = 'isobaricInhPa' + keyvalue_shortname = 'u' + keyname_xlon = 'Ni' + keyname_ylat = 'Nj' + ELSE + PRINT *, 'class_gribfile:get_3d_u_dims(): Unsupported gribfile type: ', gribfile_type + STOP + ENDIF + + CALL grib_open_file(ifile, filepath, 'r', iret) + IF (iret == 0) THEN + + ! Iterate through all messages to count 3d u messages (levels) and get x,y dimensions + end_of_file = .FALSE. + num_levels = 0 + DO WHILE (.NOT. end_of_file) + CALL grib_new_from_file(ifile, igrib, iret) + IF (iret .eq. GRIB_END_OF_FILE) THEN + end_of_file = .TRUE. + ELSE + + ! Get relevant keys and filter for the 3d U wind + CALL grib_get(igrib, keyname_shortname, value_shortname) + CALL grib_get(igrib, keyname_leveltype, value_leveltype) + CALL grib_get(igrib, keyname_level, value_level) + IF ( TRIM(value_leveltype) == TRIM(keyvalue_leveltype) .AND. & + TRIM(value_shortname) == TRIM(keyvalue_shortname) ) THEN + + ! If this is first 3d U wind message, get dimensions + IF (num_levels == 0) THEN + CONTINUE + CALL grib_get(igrib, keyname_xlon, xlon) + CALL grib_get(igrib, keyname_ylat, ylat) + ENDIF + !PRINT *, TRIM(value_shortname), ' ', TRIM(value_leveltype), ' ', value_level + num_levels = num_levels + 1 + END IF + END IF + END DO + + + ELSE + PRINT *, "ERROR: class_gribfile::get_3d_u_dims(): problem opening GRIB file: ", filepath + STOP + END IF + + CALL grib_close_file(ifile) + + zlev = num_levels + + END SUBROUTINE get_3d_u_dims diff --git a/src/cla_get_centre_and_type.f90 b/src/cla_get_centre_and_type.f90 new file mode 100644 index 0000000000000000000000000000000000000000..64cb95d9c92044d5d8fc72fb1cc1c1f346971a5e --- /dev/null +++ b/src/cla_get_centre_and_type.f90 @@ -0,0 +1,84 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + SUBROUTINE get_centre_and_type(filepath, grib_centre, gribfile_type) + ! Given specified grib file, passes back centre and gribfile + ! type to the calling program. Numeric codes are defined as integer parameters + ! in this module + + ! To get this information, we have to iterate through the entire file in order to + ! determine if it is hybrid or not + ! + + USE grib_api + IMPLICIT NONE + CHARACTER(LEN=*), INTENT(IN) :: filepath ! full path to GRIB file + INTEGER, INTENT(OUT) :: grib_centre, gribfile_type + + INTEGER :: fileptr, iret, igrib, centre, grib_edition + LOGICAL :: end_of_file + LOGICAL :: grib1_detected, grib2_detected + + + grib1_detected = .FALSE. + grib2_detected = .FALSE. + + CALL grib_open_file(fileptr, filepath, 'r', iret) + IF (iret /= 0) THEN + PRINT *, 'class_gributils:get_centre_and_type()...' + PRINT *, ' unable to open filepath: ', filepath + STOP + END IF + + + ! Use first record to detect centre and and grib version of first messages. We will + ! then assume that all following messages have same centre, but not necessarily same + ! GRIB version + CALL grib_new_from_file(fileptr, igrib, iret) + CALL grib_get(igrib, 'centre', grib_centre) + CALL grib_get(igrib, 'edition', grib_edition) + + IF (grib_edition == 1) grib1_detected = .TRUE. + IF (grib_edition == 2) grib2_detected = .TRUE. + + ! Now, iterate through the rest of records to determine if this is a mixed edition file + end_of_file = .FALSE. + DO WHILE (.NOT. end_of_file) + CALL grib_new_from_file(fileptr, igrib, iret) + IF (iret .eq. GRIB_END_OF_FILE) THEN + end_of_file = .TRUE. + ELSE + + ! Get edition from file + CALL grib_get(igrib, 'edition', grib_edition) + IF (grib_edition .eq. 1) grib1_detected = .TRUE. + IF (grib_edition .eq. 2) grib2_detected = .TRUE. + END IF + END DO + + CALL grib_close_file(fileptr) + + ! Determine the gribfile type depending on centre and edition(s) + IF (grib_centre == CENTRE_ECMWF) THEN + IF (grib1_detected .AND. grib2_detected) THEN + gribfile_type = GRIBFILE_TYPE_ECMWF_GRIB1_2 + ELSE IF (grib1_detected .AND. .NOT. grib2_detected) THEN + gribfile_type = GRIBFILE_TYPE_ECMWF_GRIB1 + ELSE IF (.NOT. grib1_detected .AND. grib2_detected) THEN + gribfile_type = GRIBFILE_TYPE_ECMWF_GRIB2 + ELSE + gribfile_type = GRIBFILE_TYPE_UNKNOWN + ENDIF + ELSE IF (grib_centre == CENTRE_NCEP) THEN + IF (grib1_detected .AND. .NOT. grib2_detected) THEN + gribfile_type = GRIBFILE_TYPE_NCEP_GRIB1 + ELSE IF (.NOT. grib1_detected .AND. grib2_detected) THEN + gribfile_type = GRIBFILE_TYPE_NCEP_GRIB2 + ELSE + gribfile_type = GRIBFILE_TYPE_UNKNOWN + ENDIF + ELSE + gribfile_type = GRIBFILE_TYPE_UNKNOWN + ENDIF + + END SUBROUTINE get_centre_and_type diff --git a/src/cla_gribfile_centre.f90 b/src/cla_gribfile_centre.f90 new file mode 100644 index 0000000000000000000000000000000000000000..34a7b979d40066aaf8f80d928b77b3f6ec1ad2a1 --- /dev/null +++ b/src/cla_gribfile_centre.f90 @@ -0,0 +1,45 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + INTEGER FUNCTION gribfile_centre(filepath) + + ! Returns an integer constant denoting the grib centre (currently either ECMWF, NCEP or UNKNOWN) + ! for the specified filepath. Returns one of the GRIBFILE_CENTRE_ constants defined at top of this + ! module. + + + USE grib_api + + IMPLICIT NONE + + CHARACTER(LEN=*), INTENT(IN) :: filepath ! full path to GRIB file + + + + INTEGER :: ifile, iret, igrib, grib_centre + + CALL grib_open_file(ifile, filepath, 'r', iret) + IF (iret == 0) THEN + ! Use first record to detect centre, which is assumed constant + ! amongst all messages + CALL grib_new_from_file(ifile, igrib, iret) + CALL grib_get(igrib, 'centre', grib_centre) + CALL grib_close_file(ifile) + ELSE + PRINT *, "WARNING: problem opening GRIB file: ", filepath + grib_centre = -999 + END IF + + + + + + IF (grib_centre == CENTRE_NCEP) THEN + gribfile_centre = GRIBFILE_CENTRE_NCEP + ELSE IF (grib_centre == CENTRE_ECMWF) THEN + gribfile_centre = GRIBFILE_CENTRE_ECMWF + ELSE + gribfile_centre = GRIBFILE_CENTRE_UNKNOWN + END IF + + END FUNCTION gribfile_centre diff --git a/src/cla_gribfile_num_xlon.f90 b/src/cla_gribfile_num_xlon.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ca93aed96110cf80c824c86db5c17873883fefc3 --- /dev/null +++ b/src/cla_gribfile_num_xlon.f90 @@ -0,0 +1,14 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + INTEGER FUNCTION gribfile_num_xlon(gribfile_obj) + + ! Returns x (lon) dimension of met data + TYPE(gribfile_object), INTENT(IN) :: gribfile_obj + + IF (.NOT. gribfile_obj%is_instantiated) THEN + PRINT *, 'ERROR: class_gribfile: gribfile_obj not instantiated' + ENDIF + gribfile_num_xlon = gribfile_obj%num_xlon + + END FUNCTION gribfile_num_xlon diff --git a/src/cla_gribfile_num_ylat.f90 b/src/cla_gribfile_num_ylat.f90 new file mode 100644 index 0000000000000000000000000000000000000000..21f702952d38cddcc3c35d3e977db562c10e6b6a --- /dev/null +++ b/src/cla_gribfile_num_ylat.f90 @@ -0,0 +1,14 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + INTEGER FUNCTION gribfile_num_ylat(gribfile_obj) + + ! Returns y (lat) dimension of met data + TYPE(gribfile_object), INTENT(IN) :: gribfile_obj + + IF (.NOT. gribfile_obj%is_instantiated) THEN + PRINT *, 'ERROR: class_gribfile: gribfile_obj not instantiated' + ENDIF + gribfile_num_ylat = gribfile_obj%num_ylat + + END FUNCTION gribfile_num_ylat diff --git a/src/cla_gribfile_num_zlevel.f90 b/src/cla_gribfile_num_zlevel.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0b4d3392dfb371953eb697071f3ffb7300dd88f1 --- /dev/null +++ b/src/cla_gribfile_num_zlevel.f90 @@ -0,0 +1,14 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + INTEGER FUNCTION gribfile_num_zlevel(gribfile_obj) + + ! Returns z (level) dimension of met data + TYPE(gribfile_object), INTENT(IN) :: gribfile_obj + + IF (.NOT. gribfile_obj%is_instantiated) THEN + PRINT *, 'ERROR: class_gribfile: gribfile_obj not instantiated' + ENDIF + gribfile_num_zlevel = gribfile_obj%num_zlevel + + END FUNCTION gribfile_num_zlevel diff --git a/src/cla_gribfile_printobj.f90 b/src/cla_gribfile_printobj.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b6f229ff666041fcb9d699f496e94bc6783ab75f --- /dev/null +++ b/src/cla_gribfile_printobj.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + SUBROUTINE gribfile_printobj(gribfile_obj) + + ! Pretty prints the attributes of the gribfile pseudo-object + TYPE(gribfile_object), INTENT(IN) :: gribfile_obj + + PRINT *, 'is_instantiated: ', gribfile_obj%is_instantiated + PRINT *, 'filepath: ', TRIM(gribfile_obj%file_path) + PRINT *, 'grib_centre: ', gribfile_obj%grib_centre + PRINT *, 'gribfile_type: ', gribfile_obj%gribfile_type + PRINT *, 'num_xlon: ', gribfile_obj%num_xlon + PRINT *, 'num_ylat: ', gribfile_obj%num_ylat + PRINT *, 'num_zlevel: ', gribfile_obj%num_zlevel + + END SUBROUTINE gribfile_printobj diff --git a/src/cla_gribfile_testhello.f90 b/src/cla_gribfile_testhello.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4a7d536cd1c4ca1160b293985d72fa516edb02cc --- /dev/null +++ b/src/cla_gribfile_testhello.f90 @@ -0,0 +1,6 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + SUBROUTINE gribfile_testhello() + PRINT *, 'Hello gribfile' + END SUBROUTINE gribfile_testhello diff --git a/src/class_gribfile_mod.f90 b/src/class_gribfile_mod.f90 index 928b95bd2039fd6bc670195a4e81a55ac9cf3a75..be7b1a6b04b54c561b222a720318e1f625f84b5a 100644 --- a/src/class_gribfile_mod.f90 +++ b/src/class_gribfile_mod.f90 @@ -34,7 +34,7 @@ MODULE class_gribfile_mod GRIBFILE_CENTRE_ECMWF, & GRIBFILE_CENTRE_UNKNOWN - ! These are codes for designating the type of GRIB file + ! These are codes for designating the type of GRIB file ! being looked at INTEGER, PARAMETER :: GRIBFILE_TYPE_ECMWF_GRIB1 = 1, & GRIBFILE_TYPE_ECMWF_GRIB2 = 2, & @@ -65,9 +65,7 @@ MODULE class_gribfile_mod CONTAINS - SUBROUTINE gribfile_testhello() - PRINT *, 'Hello gribfile' - END SUBROUTINE gribfile_testhello +#include "cla_gribfile_testhello.f90" @@ -108,312 +106,24 @@ CONTAINS END FUNCTION gribfile_object_create - SUBROUTINE gribfile_printobj(gribfile_obj) +#include "cla_gribfile_printobj.f90" - ! Pretty prints the attributes of the gribfile pseudo-object - TYPE(gribfile_object), INTENT(IN) :: gribfile_obj - - PRINT *, 'is_instantiated: ', gribfile_obj%is_instantiated - PRINT *, 'filepath: ', TRIM(gribfile_obj%file_path) - PRINT *, 'grib_centre: ', gribfile_obj%grib_centre - PRINT *, 'gribfile_type: ', gribfile_obj%gribfile_type - PRINT *, 'num_xlon: ', gribfile_obj%num_xlon - PRINT *, 'num_ylat: ', gribfile_obj%num_ylat - PRINT *, 'num_zlevel: ', gribfile_obj%num_zlevel - - END SUBROUTINE gribfile_printobj - - INTEGER FUNCTION gribfile_centre(filepath) - - ! Returns an integer constant denoting the grib centre (currently either ECMWF, NCEP or UNKNOWN) - ! for the specified filepath. Returns one of the GRIBFILE_CENTRE_ constants defined at top of this - ! module. - - - USE grib_api - - IMPLICIT NONE - - CHARACTER(LEN=*), INTENT(IN) :: filepath ! full path to GRIB file - - - - INTEGER :: ifile, iret, igrib, grib_centre - - CALL grib_open_file(ifile, filepath, 'r', iret) - IF (iret == 0) THEN - ! Use first record to detect centre, which is assumed constant - ! amongst all messages - CALL grib_new_from_file(ifile, igrib, iret) - CALL grib_get(igrib, 'centre', grib_centre) - CALL grib_close_file(ifile) - ELSE - PRINT *, "WARNING: problem opening GRIB file: ", filepath - grib_centre = -999 - END IF - - - - - - IF (grib_centre == CENTRE_NCEP) THEN - gribfile_centre = GRIBFILE_CENTRE_NCEP - ELSE IF (grib_centre == CENTRE_ECMWF) THEN - gribfile_centre = GRIBFILE_CENTRE_ECMWF - ELSE - gribfile_centre = GRIBFILE_CENTRE_UNKNOWN - END IF - - END FUNCTION gribfile_centre +#include "cla_gribfile_centre.f90" ! This is currently a PRIVATE subroutine - SUBROUTINE get_centre_and_type(filepath, grib_centre, gribfile_type) - ! Given specified grib file, passes back centre and gribfile - ! type to the calling program. Numeric codes are defined as integer parameters - ! in this module +#include "cla_get_centre_and_type.f90" - ! To get this information, we have to iterate through the entire file in order to - ! determine if it is hybrid or not - ! - USE grib_api - IMPLICIT NONE - CHARACTER(LEN=*), INTENT(IN) :: filepath ! full path to GRIB file - INTEGER, INTENT(OUT) :: grib_centre, gribfile_type - - INTEGER :: fileptr, iret, igrib, centre, grib_edition - LOGICAL :: end_of_file - LOGICAL :: grib1_detected, grib2_detected - - - grib1_detected = .FALSE. - grib2_detected = .FALSE. - - CALL grib_open_file(fileptr, filepath, 'r', iret) - IF (iret /= 0) THEN - PRINT *, 'class_gributils:get_centre_and_type()...' - PRINT *, ' unable to open filepath: ', filepath - STOP - END IF - - - ! Use first record to detect centre and and grib version of first messages. We will - ! then assume that all following messages have same centre, but not necessarily same - ! GRIB version - CALL grib_new_from_file(fileptr, igrib, iret) - CALL grib_get(igrib, 'centre', grib_centre) - CALL grib_get(igrib, 'edition', grib_edition) - - IF (grib_edition == 1) grib1_detected = .TRUE. - IF (grib_edition == 2) grib2_detected = .TRUE. - - ! Now, iterate through the rest of records to determine if this is a mixed edition file - end_of_file = .FALSE. - DO WHILE (.NOT. end_of_file) - CALL grib_new_from_file(fileptr, igrib, iret) - IF (iret .eq. GRIB_END_OF_FILE) THEN - end_of_file = .TRUE. - ELSE - - ! Get edition from file - CALL grib_get(igrib, 'edition', grib_edition) - IF (grib_edition .eq. 1) grib1_detected = .TRUE. - IF (grib_edition .eq. 2) grib2_detected = .TRUE. - END IF - END DO - - CALL grib_close_file(fileptr) - - ! Determine the gribfile type depending on centre and edition(s) - IF (grib_centre == CENTRE_ECMWF) THEN - IF (grib1_detected .AND. grib2_detected) THEN - gribfile_type = GRIBFILE_TYPE_ECMWF_GRIB1_2 - ELSE IF (grib1_detected .AND. .NOT. grib2_detected) THEN - gribfile_type = GRIBFILE_TYPE_ECMWF_GRIB1 - ELSE IF (.NOT. grib1_detected .AND. grib2_detected) THEN - gribfile_type = GRIBFILE_TYPE_ECMWF_GRIB2 - ELSE - gribfile_type = GRIBFILE_TYPE_UNKNOWN - ENDIF - ELSE IF (grib_centre == CENTRE_NCEP) THEN - IF (grib1_detected .AND. .NOT. grib2_detected) THEN - gribfile_type = GRIBFILE_TYPE_NCEP_GRIB1 - ELSE IF (.NOT. grib1_detected .AND. grib2_detected) THEN - gribfile_type = GRIBFILE_TYPE_NCEP_GRIB2 - ELSE - gribfile_type = GRIBFILE_TYPE_UNKNOWN - ENDIF - ELSE - gribfile_type = GRIBFILE_TYPE_UNKNOWN - ENDIF - - END SUBROUTINE get_centre_and_type - - - SUBROUTINE get_3d_u_dims(filepath, gribfile_type, xlon, ylat, zlev) - - ! Looks at the 3d u fields in the GRIBFILE to get x and y dims, as well as number of levels - USE grib_api - - IMPLICIT NONE - - CHARACTER(LEN=*), INTENT(IN) :: filepath ! full path to GRIB file - INTEGER, INTENT(IN) :: gribfile_type - INTEGER, INTENT(OUT) :: xlon, ylat, zlev - - INTEGER :: ifile, iret, igrib, grib_centre - LOGICAL :: end_of_file - - ! These will be assigned according to type of grib file, then used to filter - ! for the 3d messages - ! Name of the key being sought - CHARACTER(LEN=64) :: keyname_leveltype, keyname_shortname, keyname_level, & - keyname_xlon, keyname_ylat - - ! The key value being filtered for - CHARACTER(LEN=64) :: keyvalue_leveltype, keyvalue_shortname - - ! Actual values read in from the grib file - CHARACTER(LEN=64) :: value_leveltype, value_shortname - INTEGER :: value_level - - INTEGER :: num_levels - - ! Get the field names to read, based on the type of grib file - - !!! Note that ALL of these have the same key names, except that - !!! leveltype is 'hybrid' in ECMWF and 'isobaricInhPa' in NCEP. - !!! This could probably be consolidated, but because these are - !!! files that go through some preprocessing, and aren't - !!! necessarily standard (at least for ECMWF), I'm going to be - !!! safe and leave it as is for now, so it would be easier to - !!! modify for one type, if necessary. - IF (gribfile_type == GRIBFILE_TYPE_ECMWF_GRIB1) THEN - keyname_leveltype = 'typeOfLevel' - keyname_shortname = 'shortName' - keyname_level = 'level' - keyvalue_leveltype = 'hybrid' - keyvalue_shortname = 'u' - keyname_xlon = 'Ni' - keyname_ylat = 'Nj' - ELSE IF (gribfile_type == GRIBFILE_TYPE_ECMWF_GRIB1_2) THEN - keyname_leveltype = 'typeOfLevel' - keyname_shortname = 'shortName' - keyname_level = 'level' - keyvalue_leveltype = 'hybrid' - keyvalue_shortname = 'u' - keyname_xlon = 'Ni' - keyname_ylat = 'Nj' - ELSE IF (gribfile_type == GRIBFILE_TYPE_ECMWF_GRIB2) THEN - keyname_leveltype = 'typeOfLevel' - keyname_shortname = 'shortName' - keyname_level = 'level' - keyvalue_leveltype = 'hybrid' - keyvalue_shortname = 'u' - keyname_xlon = 'Ni' - keyname_ylat = 'Nj' - ELSE IF (gribfile_type == GRIBFILE_TYPE_NCEP_GRIB1) THEN - keyname_leveltype = 'typeOfLevel' - keyname_shortname = 'shortName' - keyname_level = 'level' - keyvalue_leveltype = 'isobaricInhPa' - keyvalue_shortname = 'u' - keyname_xlon = 'Ni' - keyname_ylat = 'Nj' - ELSE IF (gribfile_type == GRIBFILE_TYPE_NCEP_GRIB2) THEN - keyname_leveltype = 'typeOfLevel' - keyname_shortname = 'shortName' - keyname_level = 'level' - keyvalue_leveltype = 'isobaricInhPa' - keyvalue_shortname = 'u' - keyname_xlon = 'Ni' - keyname_ylat = 'Nj' - ELSE - PRINT *, 'class_gribfile:get_3d_u_dims(): Unsupported gribfile type: ', gribfile_type - STOP - ENDIF - - CALL grib_open_file(ifile, filepath, 'r', iret) - IF (iret == 0) THEN - - ! Iterate through all messages to count 3d u messages (levels) and get x,y dimensions - end_of_file = .FALSE. - num_levels = 0 - DO WHILE (.NOT. end_of_file) - CALL grib_new_from_file(ifile, igrib, iret) - IF (iret .eq. GRIB_END_OF_FILE) THEN - end_of_file = .TRUE. - ELSE - - ! Get relevant keys and filter for the 3d U wind - CALL grib_get(igrib, keyname_shortname, value_shortname) - CALL grib_get(igrib, keyname_leveltype, value_leveltype) - CALL grib_get(igrib, keyname_level, value_level) - IF ( TRIM(value_leveltype) == TRIM(keyvalue_leveltype) .AND. & - TRIM(value_shortname) == TRIM(keyvalue_shortname) ) THEN - - ! If this is first 3d U wind message, get dimensions - IF (num_levels == 0) THEN - CONTINUE - CALL grib_get(igrib, keyname_xlon, xlon) - CALL grib_get(igrib, keyname_ylat, ylat) - ENDIF - !PRINT *, TRIM(value_shortname), ' ', TRIM(value_leveltype), ' ', value_level - num_levels = num_levels + 1 - END IF - END IF - END DO - - - ELSE - PRINT *, "ERROR: class_gribfile::get_3d_u_dims(): problem opening GRIB file: ", filepath - STOP - END IF - - CALL grib_close_file(ifile) - - zlev = num_levels - - END SUBROUTINE get_3d_u_dims +#include "cla_get_3d_u_dims.f90" !!! Getter methods - INTEGER FUNCTION gribfile_num_xlon(gribfile_obj) - - ! Returns x (lon) dimension of met data - TYPE(gribfile_object), INTENT(IN) :: gribfile_obj - - IF (.NOT. gribfile_obj%is_instantiated) THEN - PRINT *, 'ERROR: class_gribfile: gribfile_obj not instantiated' - ENDIF - gribfile_num_xlon = gribfile_obj%num_xlon - - END FUNCTION gribfile_num_xlon - - INTEGER FUNCTION gribfile_num_ylat(gribfile_obj) - - ! Returns y (lat) dimension of met data - TYPE(gribfile_object), INTENT(IN) :: gribfile_obj - - IF (.NOT. gribfile_obj%is_instantiated) THEN - PRINT *, 'ERROR: class_gribfile: gribfile_obj not instantiated' - ENDIF - gribfile_num_ylat = gribfile_obj%num_ylat - - END FUNCTION gribfile_num_ylat - - INTEGER FUNCTION gribfile_num_zlevel(gribfile_obj) - - ! Returns z (level) dimension of met data - TYPE(gribfile_object), INTENT(IN) :: gribfile_obj +#include "cla_gribfile_num_xlon.f90" - IF (.NOT. gribfile_obj%is_instantiated) THEN - PRINT *, 'ERROR: class_gribfile: gribfile_obj not instantiated' - ENDIF - gribfile_num_zlevel = gribfile_obj%num_zlevel +#include "cla_gribfile_num_ylat.f90" - END FUNCTION gribfile_num_zlevel +#include "cla_gribfile_num_zlevel.f90" END MODULE class_gribfile_mod diff --git a/src/cma_cc2gll.f90 b/src/cma_cc2gll.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6bb57133cf377c3c7ba67d0206a37ae268f792b4 --- /dev/null +++ b/src/cma_cc2gll.f90 @@ -0,0 +1,32 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_ccrvll.f90 b/src/cma_ccrvll.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2511f626a0bea26bd489a20ffe0b11fcde3aa35e --- /dev/null +++ b/src/cma_ccrvll.f90 @@ -0,0 +1,25 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_ccrvxy.f90 b/src/cma_ccrvxy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3857c73d4cb5b5c5507e325ead57ca3a2998a2ac --- /dev/null +++ b/src/cma_ccrvxy.f90 @@ -0,0 +1,36 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cg2cll.f90 b/src/cma_cg2cll.f90 new file mode 100644 index 0000000000000000000000000000000000000000..db645625e41d7a6b453029b62e3c6d49cbdd35cf --- /dev/null +++ b/src/cma_cg2cll.f90 @@ -0,0 +1,31 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cg2cxy.f90 b/src/cma_cg2cxy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..674b7837814c3ebbc0fbe6b6197c6542dd37aca0 --- /dev/null +++ b/src/cma_cg2cxy.f90 @@ -0,0 +1,52 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cgszll.f90 b/src/cma_cgszll.f90 new file mode 100644 index 0000000000000000000000000000000000000000..19f12674fd15fb9e23fce1f52e0da9904f19a9ad --- /dev/null +++ b/src/cma_cgszll.f90 @@ -0,0 +1,52 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cgszxy.f90 b/src/cma_cgszxy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1e385764f9df52271022d1abac55e34bfcc5c36d --- /dev/null +++ b/src/cma_cgszxy.f90 @@ -0,0 +1,57 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cll2xy.f90 b/src/cma_cll2xy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2f92b19b2c3fa40836f6aed847fe65f93aa0d5ac --- /dev/null +++ b/src/cma_cll2xy.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cnllxy.f90 b/src/cma_cnllxy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..601b62493b405a52c44aac8051908f1e02ea2fe0 --- /dev/null +++ b/src/cma_cnllxy.f90 @@ -0,0 +1,59 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cnxyll.f90 b/src/cma_cnxyll.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a9909897a1ab6b4a8462161da9311fb35df6259f --- /dev/null +++ b/src/cma_cnxyll.f90 @@ -0,0 +1,62 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 = sngl(strcmp(2) + dgprad * along) + xlat = xlat * dgprad + return +end subroutine cnxyll diff --git a/src/cma_cpolll.f90 b/src/cma_cpolll.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9e2d2be9676ed70ab5e224fd3933665e00dab158 --- /dev/null +++ b/src/cma_cpolll.f90 @@ -0,0 +1,25 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cpolxy.f90 b/src/cma_cpolxy.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3c78af136144067beec0e93ce317022f6e62df2a --- /dev/null +++ b/src/cma_cpolxy.f90 @@ -0,0 +1,46 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cspanf.f90 b/src/cma_cspanf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1f5b6aed25a89b32dd84293aca3712d6a4026ea2 --- /dev/null +++ b/src/cma_cspanf.f90 @@ -0,0 +1,34 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_cxy2ll.f90 b/src/cma_cxy2ll.f90 new file mode 100644 index 0000000000000000000000000000000000000000..503e40e4a3d48331f01bc2bb610ec8e7ea43662b --- /dev/null +++ b/src/cma_cxy2ll.f90 @@ -0,0 +1,21 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_eqvlat.f90 b/src/cma_eqvlat.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a0ef12f4200c0e9fabaca9f00c9735b5f7405cdf --- /dev/null +++ b/src/cma_eqvlat.f90 @@ -0,0 +1,34 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_stcm1p.f90 b/src/cma_stcm1p.f90 new file mode 100644 index 0000000000000000000000000000000000000000..827c09a17f11a21dd90fdf78a0fed47a51922594 --- /dev/null +++ b/src/cma_stcm1p.f90 @@ -0,0 +1,28 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_stcm2p.f90 b/src/cma_stcm2p.f90 new file mode 100644 index 0000000000000000000000000000000000000000..aff2789ab5d927a2c5ab5e150fd0832678ab0f79 --- /dev/null +++ b/src/cma_stcm2p.f90 @@ -0,0 +1,34 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cma_stlmbr.f90 b/src/cma_stlmbr.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0cda4b90a4ec734a41b0182bdcd024540933df66 --- /dev/null +++ b/src/cma_stlmbr.f90 @@ -0,0 +1,34 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 diff --git a/src/cmapf_mod.f90 b/src/cmapf_mod.f90 index b57e8059207f6e1317894039fb515c57c01ba487..9bb0316566201072e9b04f6a0acfc419302c3334 100644 --- a/src/cmapf_mod.f90 +++ b/src/cmapf_mod.f90 @@ -21,616 +21,39 @@ module cmapf_mod contains -subroutine cc2gll (strcmp, xlat,xlong, ue,vn, ug,vg) - !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL +#include "cma_cc2gll.f90" - 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 +#include "cma_ccrvll.f90" - 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 = sngl(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 +#include "cma_ccrvxy.f90" - 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 +#include "cma_cg2cll.f90" - use par_mod, only: dp +#include "cma_cg2cxy.f90" - implicit none +#include "cma_cgszll.f90" - 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.) +#include "cma_cgszxy.f90" - implicit none +#include "cma_cll2xy.f90" - real :: first,last, value, begin, end, val +#include "cma_cnllxy.f90" - 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 +#include "cma_cnxyll.f90" -subroutine cxy2ll (strcmp, x,y, xlat,xlong) - !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL +#include "cma_cpolll.f90" - use par_mod, only: dp +#include "cma_cpolxy.f90" - implicit none - - real(kind=dp) :: xi0,eta0,xi,eta - real :: strcmp(9), x, y, xlat, xlong +#include "cma_cspanf.f90" - 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 +#include "cma_cxy2ll.f90" -real function eqvlat (xlat1,xlat2) - !* Written on 3/31/94 by Dr. Albion Taylor NOAA / OAR / ARL +#include "cma_eqvlat.f90" - implicit none +#include "cma_stcm1p.f90" - 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 +#include "cma_stcm2p.f90" !* General conformal map routines for meteorological modelers !* written on 3/31/94 by @@ -781,36 +204,6 @@ end subroutine stcm2p !* 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 +#include "cma_stlmbr.f90" end module cmapf_mod diff --git a/src/com_mod.f90 b/src/com_mod.f90 index 29c51cddfb6742a64a1494f872030dada862334d..0021a80a98edff390d0d58bc4c8638e973e0fe22 100644 --- a/src/com_mod.f90 +++ b/src/com_mod.f90 @@ -40,7 +40,7 @@ module com_mod integer :: length(numpath+2*maxnests) character(len=256) :: pathfile, flexversion, flexversion_major, arg1, arg2 character(len=256) :: ohfields_path - + ! path path names needed for trajectory model ! length length of path names needed for trajectory model ! pathfile file where pathnames are stored @@ -165,7 +165,7 @@ module com_mod logical :: lsettling=.true. logical,dimension(maxnests) :: readclouds_nest, sumclouds_nest - + !NIK 16.02.2015 integer(selected_int_kind(16)), dimension(maxspec) :: tot_blc_count=0, & @@ -265,7 +265,7 @@ module com_mod ! Variables associated with the ECMWF meteorological input data ("wind fields") !****************************************************************************** - integer :: memtime(numwfmem),memind(3),lwindinterv ! eso: or memind(numwfmem) + integer :: memtime(numwfmem),memind(3),lwindinterv ! eso: or memind(numwfmem) ! memtime [s] validation times of wind fields in memory ! memind pointer to wind field, in order to avoid shuffling @@ -419,7 +419,7 @@ module com_mod ! xtra1,ytra1,ztra1 spatial positions of the particles ! xmass1 [kg] particle masses ! xscav_frac1 fraction of particle masse which has been scavenged at receptor - + !******************************************************* @@ -453,10 +453,10 @@ module com_mod real :: rannumb(maxrand+2) ! rannumb field of normally distributed random numbers - + !******************************************************************** - ! variables to control stability of CBL scheme under variation - ! of statistics in time and space + ! variables to control stability of CBL scheme under variation + ! of statistics in time and space !******************************************************************** integer :: sum_nan_count(3600),maxtl=1200 integer,allocatable,dimension(:) :: nan_count @@ -465,12 +465,12 @@ module com_mod !******************************************************************** ! variables to test well-mixed state of CBL scheme not to be included in final release !******************************************************************** - real :: well_mixed_vector(50),h_well,well_mixed_norm,avg_air_dens(50),avg_ol,avg_wst,avg_h + real :: well_mixed_vector(50),h_well,well_mixed_norm,avg_air_dens(50),avg_ol,avg_wst,avg_h ! modified by mc to test well-mixed for cbl !******************** ! Verbosity, testing flags, namelist I/O - !******************** + !******************** logical :: debug_mode=.false. integer :: verbosity=0 integer :: info_flag=0 @@ -484,13 +484,13 @@ module com_mod !***************************************************************** integer :: mpi_mode=0 ! .gt. 0 if running MPI version logical :: lroot=.true. ! true if serial version, or if MPI .and. root process - + logical, parameter :: interpolhmix=.false. ! true if the hmix shall be interpolated logical, parameter :: turboff=.false. ! true if the turbulence shall be switched off integer :: numthreads,numthreads_grid ! number of available threads in parallel sections !integer :: nclassunc2, nrecclunc, ngriclunc - + !********************************************************* !LB 04.05.2021, simple timing of IO and total running time !********************************************************* @@ -499,28 +499,6 @@ module com_mod contains - subroutine mpi_alloc_part(nmpart) - !******************************************************************************* - ! Dynamic allocation of arrays - ! - ! For FLEXPART version 9.2 and earlier these arrays were statically declared - ! with size maxpart. This function is introduced so that the MPI version - ! can declare these arrays with smaller size ("maxpart per process"), while - ! the serial version allocate at run-time with size maxpart - ! - !******************************************************************************* - implicit none - - integer, intent(in) :: nmpart ! maximum number of particles (per process) - - if (ipout.eq.3) then - allocate(npart_av(nmpart),part_av_cartx(nmpart),part_av_carty(nmpart),& - & part_av_cartz(nmpart),part_av_z(nmpart),part_av_topo(nmpart)) - allocate(part_av_pv(nmpart),part_av_qv(nmpart),part_av_tt(nmpart),& - & part_av_rho(nmpart),part_av_tro(nmpart),part_av_hmix(nmpart)) - allocate(part_av_uu(nmpart),part_av_vv(nmpart),part_av_energy(nmpart)) - end if - - end subroutine mpi_alloc_part +#include "com_mpi_alloc_part.f90" end module com_mod diff --git a/src/com_mpi_alloc_part.f90 b/src/com_mpi_alloc_part.f90 new file mode 100644 index 0000000000000000000000000000000000000000..174ffa72bf021a6a60faf63a66063b12eefcc9ae --- /dev/null +++ b/src/com_mpi_alloc_part.f90 @@ -0,0 +1,26 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine mpi_alloc_part(nmpart) + !******************************************************************************* + ! Dynamic allocation of arrays + ! + ! For FLEXPART version 9.2 and earlier these arrays were statically declared + ! with size maxpart. This function is introduced so that the MPI version + ! can declare these arrays with smaller size ("maxpart per process"), while + ! the serial version allocate at run-time with size maxpart + ! + !******************************************************************************* + implicit none + + integer, intent(in) :: nmpart ! maximum number of particles (per process) + + if (ipout.eq.3) then + allocate(npart_av(nmpart),part_av_cartx(nmpart),part_av_carty(nmpart),& + & part_av_cartz(nmpart),part_av_z(nmpart),part_av_topo(nmpart)) + allocate(part_av_pv(nmpart),part_av_qv(nmpart),part_av_tt(nmpart),& + & part_av_rho(nmpart),part_av_tro(nmpart),part_av_hmix(nmpart)) + allocate(part_av_uu(nmpart),part_av_vv(nmpart),part_av_energy(nmpart)) + end if + + end subroutine mpi_alloc_part diff --git a/src/con_CONVECT.f90 b/src/con_CONVECT.f90 new file mode 100644 index 0000000000000000000000000000000000000000..501d4005720d74200875c7def1e5eacb2e3afa2c --- /dev/null +++ b/src/con_CONVECT.f90 @@ -0,0 +1,1023 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + 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 + + 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 TOLD(NA) + + 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) + ! + ! ----------------------------------------------------------------------- + ! + ! *** 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 *** + ! + + FT(:NL+1)=0.0 + FQ(:NL+1)=0.0 + FDOWN(:NL+1)=0.0 + SUB(:NL+1)=0.0 + FUP(:NL+1)=0.0 + M(:NL+1)=0.0 + MP(:NL+1)=0.0 + FMASS(:NL+1,:NL+1)=0.0 + MENT(:NL+1,:NL+1)=0.0 + ! 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 + ! LB 04.05.2021, below is not mentioned anywhere, so I commented it + ! TH(:NL+1)=TCONV(:NL+1)*(1000.0/PCONV_HPA(:NL+1))** & + ! (RD*(1.-QCONV(:NL+1))+QCONV(:NL+1)*RV)/ (CPD*(1.-QCONV(:NL+1))+QCONV(:NL+1)*CPV) + 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 + ! LB 04.05.2021, replace above with array operations (maxloc not working) + ! NK=MINORIG+maxloc(HM(MINORIG:IHMIN))-1 + + ! + ! *** 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) + TVP(NK:ICB)=TVP(NK:ICB)-TP(NK:ICB)*QCONV(NK) + ! + ! *** 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) *** + ! + EP(1:NK)=0.0 + SIGP(1:NL)=SIGS + + 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 + ! LB 04.05.2021, replace above with array operations + ! (this makes it less readable, and not any faster) + ! PROBLEM 1 is within the statement below + ! EPMAX=0.999 + ! where ((TP(NK+1:NL)-273.15).ge.0.0) + ! EP(NK+1:NL)=EPMAX*(1.0-max(ELCRIT, 0.0)/MAX(CLW(NK+1:NL),1.0E-8)) + ! elsewhere + ! EP(NK+1:NL)=EPMAX*(1.0-max(ELCRIT*(1.0-TCA/TLCRIT), 0.0)/MAX(CLW(NK+1:NL),1.0E-8)) + ! end where + ! where (EP(NK+1:NL).lt.0.0) + ! EP(NK+1:NL)=0.0 + ! elsewhere (EP(NK+1:NL).gt.EPMAX) + ! EP(NK+1:NL)=EPMAX + ! end where + + ! + ! *** CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL *** + ! *** VIRTUAL TEMPERATURE *** + ! ! + TVP(ICB+1:NL)=TVP(ICB+1:NL)-TP(ICB+1:NL)*QCONV(NK) + TVP(NL+1)=TVP(NL)-(GZ(NL+1)-GZ(NL))/CPD + ! + ! *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS *** + + HP(:NL+1)=H(:NL+1) + NENT(:NL+1)=0 + WATER(:NL+1)=0.0 + EVAP(:NL+1)=0.0 + WT(:NL+1)=OMTSNOW + LVCP(:NL+1)=LV(:NL+1)/CPN(:NL+1) + ELIJ(:NL+1,:NL+1)=0.0 + SIJ(:NL+1,:NL+1)=0.0 + DO I=1,NL+1 + QENT(I,:NL+1)=QCONV(:NL+1) + END DO + QP(1)=QCONV(1) + QP(2:NL+1)=QCONV(:NL) + + ! + ! *** 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 *** + ! + HP(ICB:INB)=H(NK)+(LV(ICB:INB)+(CPD-CPV)*TCONV(ICB:INB))*EP(ICB:INB)*CLW(ICB:INB) + ! + ! *** CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), *** + ! *** AT EACH MODEL LEVEL *** + ! + + ! + ! *** 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 + + DTPBL=sum((TVP(NK:ICB-1)-TV(NK:ICB-1))*(PHCONV_HPA(NK:ICB-1)-PHCONV_HPA(NK+1:ICB)))/ & + (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 + M(ICB+1:INB1)=ABS(TV(ICB+1:INB1)-TVP(ICB+1:INB1))+ & + ENTP*0.02*(PHCONV_HPA(ICB+1:INB1)-PHCONV_HPA(ICB+2:INB1+1)) + M(INB1:INB)=ABS(TV(INB1)-TVP(INB1))+ & + ENTP*0.02*(PHCONV_HPA(INB1)-PHCONV_HPA(INB1+1)) + M(ICB+1:INB)=CBMF*M(ICB+1:INB)/sum(M(ICB+1:INB)) + + ! + ! *** 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 + ! LB 04.05.2021, Attempt to array the loop above: PROBLEM 2 is here + ! DO J=ICB,INB + ! BF2=1.+LV(J)*LV(J)*QSCONV(J)/(RV*TCONV(J)*TCONV(J)*CPD) + ! CWAT=CLW(J)*(1.-EP(J)) + ! DO I=ICB+1,INB + ! QTI=QCONV(NK)-EP(I)*CLW(I) + ! 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(I.EQ.J)THEN + ! SIJ(I,I)=1.0 + ! ELSE IF(ABS(DENOM).LT.0.01)THEN + ! SIJ(I,J)=ANUM/0.01 + ! ELSE + ! SIJ(I,J)=ANUM/DENOM + ! END IF + ! ALTEM=(SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J))/BF2 + ! IF((SIJ(I,J).LT.0.0.OR.SIJ(I,J).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 + ! END DO + ! ! + ! ! *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS *** + ! ! *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES *** + ! ! + ! do I=ICB+1,INB + ! 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 *** + ! + ! LB 04.05.2021, depending on how often NENT.ne.0, reversing the loop could + ! speed it up... + 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).ge.0.0001) then + ! + ! *** 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 (.not. I.eq.1) then + 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 + endif + ! + ! *** FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT *** + ! + if (.not. I.eq.INB) then + 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) + endif + END DO + ! + ! *** CALCULATE SURFACE PRECIPITATION IN MM/DAY *** + ! + PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G) + ! + endif ! Downdraft calculation + ! + ! *** 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 + AM = sum(M(2:INB)) + 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 + + FQ(1)=FQ(1)+G*DPINV*sum(MENT(2:INB,1)*(QENT(2:INB,1)-QCONV(1))) + ! + ! *** 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 + AMP1 = sum(M(I+1:INB+1)) + END IF + AMP1 = AMP1 + sum(MENT(1:I,I+1:INB+1)) + ! save saturated upward mass flux + FUP(I)=AMP1 + IF((2.*G*DPINV*AMP1).GE.DELTI)IFLAG=4 + + AD = sum(MENT(I:INB,1:I-1)) + ! 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 + + FQ(I)=FQ(I)+G*DPINV*sum(MENT(I:INB,I)*(QENT(I:INB,I)-QCONV(I))) + 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 + + ENTS = sum((CPN(1:INB)*FT(1:INB)+LV(1:INB)*FQ(1:INB))* & + (PHCONV_HPA(1:INB)-PHCONV_HPA(2:INB+1))) + + ENTS=ENTS/(PHCONV_HPA(1)-PHCONV_HPA(INB+1)) + + FT(1:INB)=FT(1:INB) - ENTS/CPN(1:INB) + + ! ************************************************ + ! **** 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 + + FMASS(NK, :INB+1) = FMASS(NK,:INB+1)+M(:INB+1) + FMASS(:INB+1,:INB+1) = FMASS(:INB+1,:INB+1)+MENT(:INB+1,:INB+1) + SUB(1) = 0. + SUB(2:INB+1) = FUP(1:INB) - FDOWN(2:INB+1) + NCONVTOP=1 + do i=1,INB+1 + do j=1,INB+1 + if (FMASS(j,i).gt.EPSILON) NCONVTOP=MAX(NCONVTOP,i,j) + end do + end do + NCONVTOP=NCONVTOP+1 + RETURN + ! +END SUBROUTINE CONVECT diff --git a/src/con_TLIFT.f90 b/src/con_TLIFT.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d98acb285bd7f56e916c27f5e9b0a3d96a804971 --- /dev/null +++ b/src/con_TLIFT.f90 @@ -0,0 +1,94 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +SUBROUTINE TLIFT(GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK) + ! + !-cv + use par_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 *** + ! + CLW(1:ICB-1) = 0.0 + TPK(NK:ICB-1)=TCONV(NK)-(GZ(NK:ICB-1)-GZ(NK))*CPINV + TVP(NK:ICB-1)=TPK(NK:ICB-1)*(1.+QCONV(NK)*EPSI) + 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/con_alloc_convect.f90 b/src/con_alloc_convect.f90 new file mode 100644 index 0000000000000000000000000000000000000000..63d82d5ba5a261de4a7fc5c8c3a33d29e2ae5712 --- /dev/null +++ b/src/con_alloc_convect.f90 @@ -0,0 +1,25 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine alloc_convect + implicit none + if (.not.lconvection.eq.1) return + ! ! nconvlevmax=nuvzmax-1 + ! ! na=nconvlevmax+1 + ! allocate(pconv(nconvlevmax),phconv(na),dpr(nconvlevmax), & + ! pconv_hpa(nconvlevmax),phconv_hpa(na),ft(nconvlevmax), & + ! fq(nconvlevmax),fmass(nconvlevmax,nconvlevmax), & + ! sub(nconvlevmax),fmassfrac(nconvlevmax,nconvlevmax), & + ! cbaseflux(0:nxmax-1,0:nymax-1), & + ! cbasefluxn(0:nxmaxn-1,0:nymaxn-1,maxnests), & + ! tconv(na),qconv(na),qsconv(na)) + + ! allocate(uvzlev(nuvzmax),wsub(nuvzmax)) + + ! allocate(FUP(NA),FDOWN(NA),NENT(NA), & + ! M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA), & + ! SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA), & + ! QP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA), & + ! SIGP(NA),TP(NA),CPN(NA), & + ! LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA),HM(NA)) +end subroutine alloc_convect diff --git a/src/con_calcmatrix.f90 b/src/con_calcmatrix.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9cb1550646a1353a1ac98d34182188e430ef4611 --- /dev/null +++ b/src/con_calcmatrix.f90 @@ -0,0 +1,158 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 * + ! * + !***************************************************************************** + ! Changes: * + ! changed by C. Forster, November 2003 - February 2004 * + ! array fmassfrac(nconvlevmax,nconvlevmax) represents * + ! the convective redistribution matrix for the particles * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! - Merged calcmatrix and calcmatrix_gfs into one routine using if-then * + ! for meteo-type dependent code * + !***************************************************************************** + ! * + ! lconv indicates whether there is convection in this cell, or not * + ! delt time step for convection [s] * + ! cbmf cloud base mass flux * + ! metdata_format format of metdata (ecmwf/gfs) * + ! * + !***************************************************************************** + + use par_mod + use com_mod + use class_gribfile_mod + use qvsat_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 + 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 + ! dpr(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 + ! if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + ! pconv(k) = (akz(kuvz) + bkz(kuvz)*psconv) + ! phconv(kuvz) = (akm(kuvz) + bkm(kuvz)*psconv) + ! else + ! phconv(kuvz) = 0.5*(pconv(kuvz)+pconv(k)) + ! endif + ! 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. + ! end do + ! end do + ! LB 04.05.2021, replace above with array operations + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + pconv(1:nuvz-1) = (akz(2:nuvz) + bkz(2:nuvz)*psconv) + phconv(2:nuvz) = (akm(2:nuvz) + bkm(2:nuvz)*psconv) + else + phconv(2:nuvz) = 0.5*(pconv(2:nuvz)+pconv(1:nuvz-1)) + endif + dpr(1:nuvz-1) = phconv(1:nuvz-1) - phconv(2:nuvz) + do k = 1,nuvz-1 + qsconv(k) = f_qvsat( pconv(k), tconv(k) ) + end do + fmassfrac(1:nuvz-1,1:nconvlev)=0. + ! LB end + + !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 !old + ! do k=1,nconvlev+1 !bugfix + ! pconv_hpa(k)=pconv(k)/100. + ! phconv_hpa(k)=phconv(k)/100. + ! end do + ! phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100. + ! LB 04.05.2021, replace above with array operations + pconv_hpa(1:nconvlev+1)=pconv(1:nconvlev+1)/100. + phconv_hpa(1:nconvlev+1)=phconv(1:nconvlev+1)/100. + ! LB end + + 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 + return + 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 + return + 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 + ! LB 04.05.2021, replace above with array operations (not the problem) + ! fmassfrac(1:nconvtop,1:nconvtop) = delt*fmass(1:nconvtop,1:nconvtop) + ! do k=1, nconvtop + ! fmassfrac(k, k) = fmassfrac(k, k) + dpr(k)/ga - sum(fmassfrac(k, 1:nconvtop)) + ! end do + ! LB end +end subroutine calcmatrix diff --git a/src/con_convmix.f90 b/src/con_convmix.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b9f2c3ffdd320aad6c4e414ad8f0361b4acdfa57 --- /dev/null +++ b/src/con_convmix.f90 @@ -0,0 +1,375 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 + ! CHANGES by C. Forster, November 2005, NCEP GFS version + ! in the ECMWF version convection is calculated on the + ! original eta-levels + ! in the GFS version convection is calculated on the + ! FLEXPART levels + ! + ! Unified ECMWF and GFS builds + ! Marian Harustak, 12.5.2017 + ! - Merged convmix and convmix_gfs into one routine using if-then + ! for meteo-type dependent code + !************************************************************** + use omp_lib + use flux_mod + use par_mod + use com_mod + use class_gribfile_mod + use particle_mod + + implicit none + + integer :: igr,igrold, ipart, itime, ix, j, inest + integer :: ipconv,thread,ithread + integer :: jy, kpart, ktop, ngrid,kz + integer,allocatable :: igrid(:), ipoint(:), 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,inage + + ! OMP changes + integer :: cnt,kk + integer,allocatable,dimension(:) :: frst + double precision :: tmarray(2) + + integer :: totpart,alivepart + real:: eps + eps=nxmax/3.e5 + ! Calculate auxiliary variables for time interpolation + !***************************************************** + + dt1=real(itime-memtime(1)) + dt2=real(memtime(2)-itime) + dtt=1./(dt1+dt2) + mind1=memind(1) + mind2=memind(2) + delt=real(abs(lsynctime)) + + lconv = .false. + + ! if no particles are present return after initialization + !******************************************************** + call get_alivepart_num(alivepart) + if (alivepart.le.0 ) return + + call get_totalpart_num(totpart) + allocate( igrid(totpart) ) + allocate( ipoint(totpart) ) + allocate( igridn(totpart,maxnests) ) + + ! 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 + !************************************************************************ +!$OMP PARALLEL PRIVATE(ipart, j, x, y, ngrid, xtn, ytn, ix, jy) +!$OMP DO + do ipart=1,numpart + igrid(ipart)=-1 + do j=numbnests,1,-1 + igridn(ipart,j)=-1 + end do + ipoint(ipart)=ipart + ! do not consider particles that are not (yet) part of simulation + if (.not. part(ipart)%alive) cycle + x = part(ipart)%xlon + y = part(ipart)%ylat + + ! Determine which nesting level to be used + !********************************************************** + + ngrid=0 + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + do j=numbnests,1,-1 + ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) + if ( x.gt.xln(j)+dxn(j) .and. x.lt.xrn(j)-dxn(j) .and. & + y.gt.yln(j)+dyn(j) .and. y.lt.yrn(j)-dyn(j) ) then + ngrid=j + exit + endif + end do + else + 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 + exit + endif + end do + endif + ! 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 + igridn(ipart,ngrid) = 1 + ix*nyn(ngrid) + jy + else if(ngrid.eq.0) then + ! mother grid + ix=nint(x) + jy=nint(y) + !igrid(ipart) = 1 + jy*nx + ix + igrid(ipart) = 1 + ix*ny + jy + endif + end do +!$OMP END DO +!$OMP END PARALLEL + + ! sumall = 0. + ! sumconv = 0. + + !***************************************************************************** + ! 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. + !***************************************************************************** + + ! sort particles according to horizontal position and calculate index vector IPOINT + + call sort2(numpart,igrid,ipoint) + + ! Now visit all grid columns where particles are present + ! by going through the sorted particles + + !LB changes following the CTM version + allocate(frst(nx*(ny+1)+1)) + frst(1) = 1 + cnt = 2 + igrold = igrid(1) + ! Looping over all particles and counting how many in each igrid reside. + ! This is saved in frst. The number of consecutive particles in igrid is saved in frst(i) + do kpart=1,numpart + if (igrold.ne.igrid(kpart)) then + frst(cnt) = kpart + igrold=igrid(kpart) + cnt=cnt+1 + endif + end do + frst(cnt) = numpart+1 + +!$OMP PARALLEL PRIVATE(kk,jy,ix,tmarray,j,kz,ktop,lconv,kpart,ipart,& +!$OMP ztold,nage,ipconv,itage,thread) + +#if (defined _OPENMP) + thread = OMP_GET_THREAD_NUM() ! Starts at 0 +#else + thread = 0 +#endif + +!$OMP DO SCHEDULE(static) + do kk=1,cnt-1 + ! Only consider grids that have particles inside + if (igrid(frst(kk)).eq.-1) cycle + + ! Find horizontal location of grid column + ix = (igrid(frst(kk))-1)/ny + jy = igrid(frst(kk)) - ix*ny - 1 + ! jy = (igrid(frst(kk))-1)/nx + ! ix = igrid(frst(kk)) - jy*nx - 1 + + ! Interpolate all meteorological data needed for the convection scheme + psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt + tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt + td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt + + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + do kz=1,nuvz-1 !bugfix + tconv(kz)=(tth(ix,jy,kz+1,mind1)*dt2+ & + tth(ix,jy,kz+1,mind2)*dt1)*dtt + qconv(kz)=(qvh(ix,jy,kz+1,mind1)*dt2+ & + qvh(ix,jy,kz+1,mind2)*dt1)*dtt + end do + else + do kz=1,nuvz-1 !bugfix + pconv(kz)=(pplev(ix,jy,kz,mind1)*dt2+ & + pplev(ix,jy,kz,mind2)*dt1)*dtt + tconv(kz)=(tt(ix,jy,kz,mind1)*dt2+ & + tt(ix,jy,kz,mind2)*dt1)*dtt + qconv(kz)=(qv(ix,jy,kz,mind1)*dt2+ & + qv(ix,jy,kz,mind2)*dt1)*dtt + end do + end if + + ! Calculate translocation matrix + call calcmatrix(lconv,delt,cbaseflux(ix,jy)) + + ! treat particle only if column has convection + if (lconv .eqv. .true.) then + ktop = 0 + ! assign new vertical position to particle + do kpart=frst(kk), frst(kk+1)-1 + ipart = ipoint(kpart) + ztold=real(part(ipart)%z) + call redist(itime,ipart,ktop,ipconv) + ! if (ipconv.le.0) sumconv = sumconv+1 + + ! Calculate the gross fluxes across layer interfaces + !*************************************************** + + if (iflux.eq.1) then + itage=abs(itime-part(ipart)%tstart) + nage=1 + do inage=1,nageclass + nage=inage + if ((itage.lt.lage(nage)).or.(.not.part(ipart)%alive)) exit + end do + + if (nage.le.nageclass) & + call calcfluxes(itime,nage,ipart,real(part(ipart)%xlon), & + real(part(ipart)%ylat),ztold,thread+1) + endif + enddo + + endif !(lconv .eqv. .true) + end do +!$OMP END DO +!$OMP END PARALLEL + + deallocate(frst) + + ! OpenMP Reduction for dynamically allocated arrays. This is done manually since this + ! is not yet supported in most OpenMP versions + !************************************************************************************ + if (iflux.eq.1) then + do ithread=1,numthreads + flux(:,:,:,:,:,:,:)=flux(:,:,:,:,:,:,:)+flux_omp(:,:,:,:,:,:,:,ithread) + end do + endif + + !***************************************************************************** + ! 2. Nested domains + !***************************************************************************** + + ! sort particles according to horizontal position and calculate index vector IPOINT + do inest=1,numbnests + do ipart=1,numpart + ipoint(ipart)=ipart + igrid(ipart) = igridn(ipart,inest) + enddo + call sort2(numpart,igrid,ipoint) + + ! Now visit all grid columns where particles are present + ! by going through the sorted particles +!$OMP PARALLEL PRIVATE (igrold,kpart,ipart,igr,jy,ix,kz,lconv, & +!$OMP ktop,ztold,nage,ipconv,itage) + igrold = -1 +!$OMP DO + do kpart=1,numpart + igr = igrid(kpart) + if (igr .eq. -1) cycle + 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 + psconv=(psn(ix,jy,1,mind1,inest)*dt2+ & + psn(ix,jy,1,mind2,inest)*dt1)*dtt + tt2conv=(tt2n(ix,jy,1,mind1,inest)*dt2+ & + tt2n(ix,jy,1,mind2,inest)*dt1)*dtt + td2conv=(td2n(ix,jy,1,mind1,inest)*dt2+ & + td2n(ix,jy,1,mind2,inest)*dt1)*dtt +!!$ do kz=1,nconvlev+1 !old + do kz=1,nuvz-1 !bugfix + tconv(kz)=(tthn(ix,jy,kz+1,mind1,inest)*dt2+ & + tthn(ix,jy,kz+1,mind2,inest)*dt1)*dtt + qconv(kz)=(qvhn(ix,jy,kz+1,mind1,inest)*dt2+ & + qvhn(ix,jy,kz+1,mind2,inest)*dt1)*dtt + end do + + ! calculate translocation matrix + !******************************* + call calcmatrix(lconv,delt,cbasefluxn(ix,jy,inest)) + igrold = igr + ktop = 0 + endif + + ! treat particle only if column has convection + if (lconv .eqv. .true.) then + ! assign new vertical position to particle + ztold=part(ipart)%z + call redist(itime,ipart,ktop,ipconv) + ! if (ipconv.le.0) sumconv = sumconv+1 + + ! Calculate the gross fluxes across layer interfaces + !*************************************************** + + if (iflux.eq.1) then + itage=abs(itime-part(ipart)%tstart) + nage=1 + do inage=1,nageclass + nage=inage + if ((itage.lt.lage(nage)).or.(.not.part(ipart)%alive)) exit + end do + + if (nage.le.nageclass) & + call calcfluxes(itime,nage,ipart,real(part(ipart)%xlon), & + real(part(ipart)%ylat),ztold,1) + endif + + endif !(lconv .eqv. .true.) + + end do +!$OMP END DO +!$OMP END PARALLEL + end do + ! OpenMP Reduction for dynamically allocated arrays. This is done manually since this + ! is not yet supported in most OpenMP versions + !************************************************************************************ + if (iflux.eq.1) then + do ithread=1,numthreads + flux(:,:,:,:,:,:,:)=flux(:,:,:,:,:,:,:)+flux_omp(:,:,:,:,:,:,:,ithread) + end do + endif + !-------------------------------------------------------------------------- + ! 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(*,*)'############################################' + + deallocate( igrid ) + deallocate( ipoint ) + deallocate( igridn ) + + return +end subroutine convmix diff --git a/src/con_dealloc_convect.f90 b/src/con_dealloc_convect.f90 new file mode 100644 index 0000000000000000000000000000000000000000..01b31085a2f803666e9327d80e31e6dd13203620 --- /dev/null +++ b/src/con_dealloc_convect.f90 @@ -0,0 +1,13 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine dealloc_convect + implicit none + if (.not.lconvection.eq.1) return + ! deallocate(pconv,phconv,dpr,pconv_hpa,phconv_hpa,ft,fq,sub, & + ! tconv,qconv,qsconv,fmass,fmassfrac,cbaseflux,cbasefluxn) + ! deallocate(uvzlev,wsub) + ! deallocate(fup,fdown,ment,M,MP,QENT,ELIJ,SIJ,TVP,TV, & + ! WATER,QP,EP,TH,WT,EVAP,CLW,SIGP,TP,CPN,LV,LVCP, & + ! H,HP,GZ,HM) +end subroutine dealloc_convect diff --git a/src/con_redist.f90 b/src/con_redist.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a93d477bbe6c719de990f9c2a38360f6ff8c3e71 --- /dev/null +++ b/src/con_redist.f90 @@ -0,0 +1,308 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine redist(itime,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 random_mod + use omp_lib + use interpol_mod + use coord_ec_mod + use particle_mod + use qvsat_mod + + implicit none + + real,parameter :: const=r_air/ga + integer :: ipart, ktop,ipconv,itime + integer :: k, kz, levnew, levold,ithread + + real :: totlevmass, wsubpart + real :: temp_levold,temp_levold1 + real :: sub_levold,sub_levold1 + real :: pint, pold, rn, tv, tvold, dlevfrac + real :: ztold,ffraction + real :: tv1, tv2, dlogp, dz, dz1, dz2 + +#ifdef _OPENMP + ithread = OMP_GET_THREAD_NUM() ! Starts at 0 +#else + ithread=0 +#endif + + ! ipart ... number of particle to be treated + + ipconv=1 + + ! ! determine vertical grid position of particle in the eta system + ! !**************************************************************** + select case (wind_coord_type) + + case ('ETA') + ztold = real(part(abs(ipart))%zeta) + ! find old particle grid position + levold = nconvtop + do kz = 2, nconvtop + if (wheight(kz) .le. ztold ) then + levold = kz-1 + exit + endif + end do + + case ('METER') + + ! 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)/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)) + 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)) + 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 + + ztold = real(part(abs(ipart))%z) + ! find old particle grid position + levold = nconvtop + do kz = 2, nconvtop + if (uvzlev(kz) .ge. ztold ) then + levold = kz-1 + exit + endif + end do + case default + write(*,*) 'The wind_coord_type is not defined in redist.f90' + stop + + end select + + ! If the particle is above the potentially convective domain, it will be skipped + if (levold.ne.nconvtop) then + + ! now redistribute particles + !**************************** + + ! Choose a random number and find corresponding level of destination + ! Random numbers to be evenly distributed in [0,1] + + rn = ran3(iseed2(ithread),ithread) + + ! initialize levnew + + levnew = levold + + ffraction = 0. + totlevmass=dpr(levold)/ga + loop1: 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 + exit loop1 + endif + end do loop1 + + ! now assign new position to particle + select case (wind_coord_type) + + case ('ETA') + if ((levnew.le.nconvtop).and.(levnew.ne.levold)) then + dlogp = (1.-dlevfrac) * (wheight(levnew+1)-wheight(levnew)) + call set_zeta(ipart,wheight(levnew)+dlogp) + if (part(abs(ipart))%zeta.ge.1.) call set_zeta(ipart,1.-(part(abs(ipart))%zeta-1.)) + if (part(abs(ipart))%zeta.eq.1.) call update_zeta(ipart,-1.e-4) + if (ipconv.gt.0) ipconv=-1 + endif + + case ('METER') + if ((levnew.le.nconvtop).and.(levnew.ne.levold)) then + 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 + call set_z(ipart,(uvzlev(levnew)*dz2+uvzlev(levnew+1)*dz1)/dz) + if (part(abs(ipart))%z.lt.0.) call set_z(ipart,-1.*part(abs(ipart))%z) + if (ipconv.gt.0) ipconv=-1 + endif + + case default + write(*,*) 'The chosen wind_coord_type is not defined in redist.f90' + stop + + end select + + ! 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 + + ! 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)) + ! Bug fix: Added lsynctime to make units correct + sub_levold = sub(levold)/(1.-ga*sub(levold)*lsynctime/dpr(levold)) + 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)) + ! Bug fix: Added lsynctime to make units correct + sub_levold1 = sub(levold+1)/(1.-ga*sub(levold+1)*lsynctime/dpr(levold+1)) + wsub(levold+1)=-1.*sub_levold1*r_air*temp_levold1/ & + (phconv(levold+1)) + + ! interpolate wsub to the vertical particle position + select case (wind_coord_type) + case ('ETA') + ztold = real(part(abs(ipart))%zeta) + dz1 = ztold - wheight(levold) + dz2 = wheight(levold+1) - ztold + dz = dz1 + dz2 + + ! Convert z(eta) to z(m) in order to add subsidence + call update_zeta_to_z(itime, ipart) + ! call zeta_to_z(itime,part(abs(ipart))%xlon,part(abs(ipart))%ylat, & + ! part(abs(ipart))%zeta,part(abs(ipart))%z) + + wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz + + call update_z(ipart,wsubpart*real(lsynctime)) + + if (part(abs(ipart))%z.lt.0.) call set_z(ipart,-1.*part(abs(ipart))%z) + + ! Convert new z(m) back to z(eta) + call update_z_to_zeta(itime, ipart) + + case ('METER') + ztold = real(part(abs(ipart))%z) + dz1 = ztold - uvzlev(levold) + dz2 = uvzlev(levold+1) - ztold + dz = dz1 + dz2 + + wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz + + call update_z(ipart,wsubpart*real(lsynctime)) + + if (part(abs(ipart))%z.lt.0.) call set_z(ipart,-1.*part(abs(ipart))%z) + + case default + write(*,*) 'The wind_coord_type is not defined in redist.f90' + stop + end select + endif !(levnew.le.nconvtop.and.levnew.eq.levold) + endif + ! Maximum altitude .5 meter below uppermost model level + !******************************************************* + + select case (wind_coord_type) + case ('ETA') + if (part(abs(ipart))%zeta .lt. uvheight(nz)) call set_zeta(ipart,uvheight(nz)+1.e-4) + if (part(abs(ipart))%zeta.ge.1.) call set_zeta(ipart,1.-(part(abs(ipart))%zeta-1.)) + if (part(abs(ipart))%zeta.eq.1.) call update_zeta(ipart,-1.e-4) + case ('METER') + if (part(abs(ipart))%z .gt. height(nz)-0.5) call set_z(ipart,height(nz)-0.5) + case default + write(*,*) 'The wind_coord_type is not defined in redist.f90' + stop + end select + +end subroutine redist diff --git a/src/con_set_conv_top.f90 b/src/con_set_conv_top.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7c0bc69eb9922439d1220353ed137aadea89b3ce --- /dev/null +++ b/src/con_set_conv_top.f90 @@ -0,0 +1,23 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine set_conv_top() +! 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) +!***************************************************************************** + + integer :: i + real :: pint + + do i=1,nuvz-2 + pint=akz(i)+bkz(i)*101325. + if (pint.lt.5000.) exit + end do + nconvlev=i + if (nconvlev.gt.nconvlevmax-1) then + nconvlev=nconvlevmax-1 + write(*,*) 'INFORMATION: Convection only calculated up to ', & + akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa' + endif + +end subroutine set_conv_top diff --git a/src/con_sort2.f90 b/src/con_sort2.f90 new file mode 100644 index 0000000000000000000000000000000000000000..28e4c40a02d136f2e0052f7a8494c9542c2f573e --- /dev/null +++ b/src/con_sort2.f90 @@ -0,0 +1,110 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine sort2(n,arr,brr) + ! From numerical recipes + ! Change by A. Stohl: Use of integer instead of real values + implicit none + + integer, intent(in) :: n + integer, intent(inout) :: 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 + do + if(ir-l.lt.m)then + do j=l+1,ir + a=arr(j) + b=brr(j) + i=j-1 + do while(i.gt.0) + if (arr(i).le.a) exit + arr(i+1)=arr(i) + brr(i+1)=brr(i) + i=i-1 + end do + 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) + do + do + i=i+1 + if(arr(i).ge.a) exit + end do + do + j=j-1 + if(arr(j).le.a) exit + end do + if(j.lt.i) exit + temp=arr(i) + arr(i)=arr(j) + arr(j)=temp + temp=brr(i) + brr(i)=brr(j) + brr(j)=temp + end do + 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 + end do +! (C) Copr. 1986-92 Numerical Recipes Software us. +end subroutine sort2 diff --git a/src/conv_mod.f90 b/src/conv_mod.f90 index b295c2ebc9a2a2e78865b5de72935e3a911211f4..0c623b3ac9f5b67541d4ac1acf32b27b64a2a02e 100644 --- a/src/conv_mod.f90 +++ b/src/conv_mod.f90 @@ -29,7 +29,7 @@ module conv_mod !these parameters are defined in par_mod now! ! I do not know how to allocate each array for each thread, not automaticaly done... real :: &!,allocatable,dimension(:) :: & - pconv(nconvlevmax), & ! + pconv(nconvlevmax), & ! phconv(na), & ! dpr(nconvlevmax), & ! pconv_hpa(nconvlevmax), & ! @@ -39,11 +39,11 @@ module conv_mod sub(nconvlevmax), & ! subsidence tconv(na), & ! qconv(na), & ! - qsconv(na) + qsconv(na) real :: &!,allocatable,dimension(:,:) :: & ! fmass(nconvlevmax,nconvlevmax), & ! fmassfrac(nconvlevmax,nconvlevmax), & ! - cbaseflux(0:nxmax-1,0:nymax-1) + cbaseflux(0:nxmax-1,0:nymax-1) real :: &!,allocatable,dimension(:,:,:) :: & cbasefluxn(0:nxmaxn-1,0:nymaxn-1,maxnests) ! integer,dimension(na) :: & @@ -58,7 +58,7 @@ module conv_mod real,dimension(na) :: & uvzlev(nuvzmax),wsub(nuvzmax) real :: psconv,tt2conv,td2conv - + integer :: nconvlev,nconvtop save :: uvzlev @@ -74,895 +74,17 @@ module conv_mod contains -subroutine alloc_convect - implicit none - if (.not.lconvection.eq.1) return - ! ! nconvlevmax=nuvzmax-1 - ! ! na=nconvlevmax+1 - ! allocate(pconv(nconvlevmax),phconv(na),dpr(nconvlevmax), & - ! pconv_hpa(nconvlevmax),phconv_hpa(na),ft(nconvlevmax), & - ! fq(nconvlevmax),fmass(nconvlevmax,nconvlevmax), & - ! sub(nconvlevmax),fmassfrac(nconvlevmax,nconvlevmax), & - ! cbaseflux(0:nxmax-1,0:nymax-1), & - ! cbasefluxn(0:nxmaxn-1,0:nymaxn-1,maxnests), & - ! tconv(na),qconv(na),qsconv(na)) - - ! allocate(uvzlev(nuvzmax),wsub(nuvzmax)) - - ! allocate(FUP(NA),FDOWN(NA),NENT(NA), & - ! M(NA),MP(NA),MENT(NA,NA),QENT(NA,NA),ELIJ(NA,NA), & - ! SIJ(NA,NA),TVP(NA),TV(NA),WATER(NA), & - ! QP(NA),EP(NA),TH(NA),WT(NA),EVAP(NA),CLW(NA), & - ! SIGP(NA),TP(NA),CPN(NA), & - ! LV(NA),LVCP(NA),H(NA),HP(NA),GZ(NA),HM(NA)) -end subroutine alloc_convect - -subroutine dealloc_convect - implicit none - if (.not.lconvection.eq.1) return - ! deallocate(pconv,phconv,dpr,pconv_hpa,phconv_hpa,ft,fq,sub, & - ! tconv,qconv,qsconv,fmass,fmassfrac,cbaseflux,cbasefluxn) - ! deallocate(uvzlev,wsub) - ! deallocate(fup,fdown,ment,M,MP,QENT,ELIJ,SIJ,TVP,TV, & - ! WATER,QP,EP,TH,WT,EVAP,CLW,SIGP,TP,CPN,LV,LVCP, & - ! H,HP,GZ,HM) -end subroutine dealloc_convect - -subroutine set_conv_top() -! 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) -!***************************************************************************** - - integer :: i - real :: pint - - do i=1,nuvz-2 - pint=akz(i)+bkz(i)*101325. - if (pint.lt.5000.) exit - end do - nconvlev=i - if (nconvlev.gt.nconvlevmax-1) then - nconvlev=nconvlevmax-1 - write(*,*) 'INFORMATION: Convection only calculated up to ', & - akz(nconvlev)+bkz(nconvlev)*1013.25,' hPa' - endif - -end subroutine set_conv_top - -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 - ! CHANGES by C. Forster, November 2005, NCEP GFS version - ! in the ECMWF version convection is calculated on the - ! original eta-levels - ! in the GFS version convection is calculated on the - ! FLEXPART levels - ! - ! Unified ECMWF and GFS builds - ! Marian Harustak, 12.5.2017 - ! - Merged convmix and convmix_gfs into one routine using if-then - ! for meteo-type dependent code - !************************************************************** - use omp_lib - use flux_mod - use par_mod - use com_mod - use class_gribfile_mod - use particle_mod - - implicit none - - integer :: igr,igrold, ipart, itime, ix, j, inest - integer :: ipconv,thread,ithread - integer :: jy, kpart, ktop, ngrid,kz - integer,allocatable :: igrid(:), ipoint(:), 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,inage - - ! OMP changes - integer :: cnt,kk - integer,allocatable,dimension(:) :: frst - double precision :: tmarray(2) - - integer :: totpart,alivepart - real:: eps - eps=nxmax/3.e5 - ! Calculate auxiliary variables for time interpolation - !***************************************************** - - dt1=real(itime-memtime(1)) - dt2=real(memtime(2)-itime) - dtt=1./(dt1+dt2) - mind1=memind(1) - mind2=memind(2) - delt=real(abs(lsynctime)) - - lconv = .false. - - ! if no particles are present return after initialization - !******************************************************** - call get_alivepart_num(alivepart) - if (alivepart.le.0 ) return - - call get_totalpart_num(totpart) - allocate( igrid(totpart) ) - allocate( ipoint(totpart) ) - allocate( igridn(totpart,maxnests) ) - - ! 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 - !************************************************************************ -!$OMP PARALLEL PRIVATE(ipart, j, x, y, ngrid, xtn, ytn, ix, jy) -!$OMP DO - do ipart=1,numpart - igrid(ipart)=-1 - do j=numbnests,1,-1 - igridn(ipart,j)=-1 - end do - ipoint(ipart)=ipart - ! do not consider particles that are not (yet) part of simulation - if (.not. part(ipart)%alive) cycle - x = part(ipart)%xlon - y = part(ipart)%ylat - - ! Determine which nesting level to be used - !********************************************************** - - ngrid=0 - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - do j=numbnests,1,-1 - ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) - if ( x.gt.xln(j)+dxn(j) .and. x.lt.xrn(j)-dxn(j) .and. & - y.gt.yln(j)+dyn(j) .and. y.lt.yrn(j)-dyn(j) ) then - ngrid=j - exit - endif - end do - else - 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 - exit - endif - end do - endif - ! 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 - igridn(ipart,ngrid) = 1 + ix*nyn(ngrid) + jy - else if(ngrid.eq.0) then - ! mother grid - ix=nint(x) - jy=nint(y) - !igrid(ipart) = 1 + jy*nx + ix - igrid(ipart) = 1 + ix*ny + jy - endif - end do -!$OMP END DO -!$OMP END PARALLEL - - ! sumall = 0. - ! sumconv = 0. - - !***************************************************************************** - ! 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. - !***************************************************************************** - - ! sort particles according to horizontal position and calculate index vector IPOINT - - call sort2(numpart,igrid,ipoint) - - ! Now visit all grid columns where particles are present - ! by going through the sorted particles - - !LB changes following the CTM version - allocate(frst(nx*(ny+1)+1)) - frst(1) = 1 - cnt = 2 - igrold = igrid(1) - ! Looping over all particles and counting how many in each igrid reside. - ! This is saved in frst. The number of consecutive particles in igrid is saved in frst(i) - do kpart=1,numpart - if (igrold.ne.igrid(kpart)) then - frst(cnt) = kpart - igrold=igrid(kpart) - cnt=cnt+1 - endif - end do - frst(cnt) = numpart+1 - -!$OMP PARALLEL PRIVATE(kk,jy,ix,tmarray,j,kz,ktop,lconv,kpart,ipart,& -!$OMP ztold,nage,ipconv,itage,thread) - -#if (defined _OPENMP) - thread = OMP_GET_THREAD_NUM() ! Starts at 0 -#else - thread = 0 -#endif - -!$OMP DO SCHEDULE(static) - do kk=1,cnt-1 - ! Only consider grids that have particles inside - if (igrid(frst(kk)).eq.-1) cycle - - ! Find horizontal location of grid column - ix = (igrid(frst(kk))-1)/ny - jy = igrid(frst(kk)) - ix*ny - 1 - ! jy = (igrid(frst(kk))-1)/nx - ! ix = igrid(frst(kk)) - jy*nx - 1 - - ! Interpolate all meteorological data needed for the convection scheme - psconv=(ps(ix,jy,1,mind1)*dt2+ps(ix,jy,1,mind2)*dt1)*dtt - tt2conv=(tt2(ix,jy,1,mind1)*dt2+tt2(ix,jy,1,mind2)*dt1)*dtt - td2conv=(td2(ix,jy,1,mind1)*dt2+td2(ix,jy,1,mind2)*dt1)*dtt - - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - do kz=1,nuvz-1 !bugfix - tconv(kz)=(tth(ix,jy,kz+1,mind1)*dt2+ & - tth(ix,jy,kz+1,mind2)*dt1)*dtt - qconv(kz)=(qvh(ix,jy,kz+1,mind1)*dt2+ & - qvh(ix,jy,kz+1,mind2)*dt1)*dtt - end do - else - do kz=1,nuvz-1 !bugfix - pconv(kz)=(pplev(ix,jy,kz,mind1)*dt2+ & - pplev(ix,jy,kz,mind2)*dt1)*dtt - tconv(kz)=(tt(ix,jy,kz,mind1)*dt2+ & - tt(ix,jy,kz,mind2)*dt1)*dtt - qconv(kz)=(qv(ix,jy,kz,mind1)*dt2+ & - qv(ix,jy,kz,mind2)*dt1)*dtt - end do - end if - - ! Calculate translocation matrix - call calcmatrix(lconv,delt,cbaseflux(ix,jy)) - - ! treat particle only if column has convection - if (lconv .eqv. .true.) then - ktop = 0 - ! assign new vertical position to particle - do kpart=frst(kk), frst(kk+1)-1 - ipart = ipoint(kpart) - ztold=real(part(ipart)%z) - call redist(itime,ipart,ktop,ipconv) - ! if (ipconv.le.0) sumconv = sumconv+1 - - ! Calculate the gross fluxes across layer interfaces - !*************************************************** - - if (iflux.eq.1) then - itage=abs(itime-part(ipart)%tstart) - nage=1 - do inage=1,nageclass - nage=inage - if ((itage.lt.lage(nage)).or.(.not.part(ipart)%alive)) exit - end do +#include "con_alloc_convect.f90" - if (nage.le.nageclass) & - call calcfluxes(itime,nage,ipart,real(part(ipart)%xlon), & - real(part(ipart)%ylat),ztold,thread+1) - endif - enddo +#include "con_dealloc_convect.f90" - endif !(lconv .eqv. .true) - end do -!$OMP END DO -!$OMP END PARALLEL +#include "con_set_conv_top.f90" - deallocate(frst) - - ! OpenMP Reduction for dynamically allocated arrays. This is done manually since this - ! is not yet supported in most OpenMP versions - !************************************************************************************ - if (iflux.eq.1) then - do ithread=1,numthreads - flux(:,:,:,:,:,:,:)=flux(:,:,:,:,:,:,:)+flux_omp(:,:,:,:,:,:,:,ithread) - end do - endif - - !***************************************************************************** - ! 2. Nested domains - !***************************************************************************** - - ! sort particles according to horizontal position and calculate index vector IPOINT - do inest=1,numbnests - do ipart=1,numpart - ipoint(ipart)=ipart - igrid(ipart) = igridn(ipart,inest) - enddo - call sort2(numpart,igrid,ipoint) - - ! Now visit all grid columns where particles are present - ! by going through the sorted particles -!$OMP PARALLEL PRIVATE (igrold,kpart,ipart,igr,jy,ix,kz,lconv, & -!$OMP ktop,ztold,nage,ipconv,itage) - igrold = -1 -!$OMP DO - do kpart=1,numpart - igr = igrid(kpart) - if (igr .eq. -1) cycle - 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 - psconv=(psn(ix,jy,1,mind1,inest)*dt2+ & - psn(ix,jy,1,mind2,inest)*dt1)*dtt - tt2conv=(tt2n(ix,jy,1,mind1,inest)*dt2+ & - tt2n(ix,jy,1,mind2,inest)*dt1)*dtt - td2conv=(td2n(ix,jy,1,mind1,inest)*dt2+ & - td2n(ix,jy,1,mind2,inest)*dt1)*dtt -!!$ do kz=1,nconvlev+1 !old - do kz=1,nuvz-1 !bugfix - tconv(kz)=(tthn(ix,jy,kz+1,mind1,inest)*dt2+ & - tthn(ix,jy,kz+1,mind2,inest)*dt1)*dtt - qconv(kz)=(qvhn(ix,jy,kz+1,mind1,inest)*dt2+ & - qvhn(ix,jy,kz+1,mind2,inest)*dt1)*dtt - end do - - ! calculate translocation matrix - !******************************* - call calcmatrix(lconv,delt,cbasefluxn(ix,jy,inest)) - igrold = igr - ktop = 0 - endif - - ! treat particle only if column has convection - if (lconv .eqv. .true.) then - ! assign new vertical position to particle - ztold=part(ipart)%z - call redist(itime,ipart,ktop,ipconv) - ! if (ipconv.le.0) sumconv = sumconv+1 - - ! Calculate the gross fluxes across layer interfaces - !*************************************************** - - if (iflux.eq.1) then - itage=abs(itime-part(ipart)%tstart) - nage=1 - do inage=1,nageclass - nage=inage - if ((itage.lt.lage(nage)).or.(.not.part(ipart)%alive)) exit - end do - - if (nage.le.nageclass) & - call calcfluxes(itime,nage,ipart,real(part(ipart)%xlon), & - real(part(ipart)%ylat),ztold,1) - endif - - endif !(lconv .eqv. .true.) - - end do -!$OMP END DO -!$OMP END PARALLEL - end do - ! OpenMP Reduction for dynamically allocated arrays. This is done manually since this - ! is not yet supported in most OpenMP versions - !************************************************************************************ - if (iflux.eq.1) then - do ithread=1,numthreads - flux(:,:,:,:,:,:,:)=flux(:,:,:,:,:,:,:)+flux_omp(:,:,:,:,:,:,:,ithread) - end do - endif - !-------------------------------------------------------------------------- - ! 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(*,*)'############################################' - - deallocate( igrid ) - deallocate( ipoint ) - deallocate( igridn ) - - return -end subroutine convmix - -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 * - ! * - !***************************************************************************** - ! Changes: * - ! changed by C. Forster, November 2003 - February 2004 * - ! array fmassfrac(nconvlevmax,nconvlevmax) represents * - ! the convective redistribution matrix for the particles * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! - Merged calcmatrix and calcmatrix_gfs into one routine using if-then * - ! for meteo-type dependent code * - !***************************************************************************** - ! * - ! lconv indicates whether there is convection in this cell, or not * - ! delt time step for convection [s] * - ! cbmf cloud base mass flux * - ! metdata_format format of metdata (ecmwf/gfs) * - ! * - !***************************************************************************** - - use par_mod - use com_mod - use class_gribfile_mod - use qvsat_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 - 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 - ! dpr(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 - ! if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - ! pconv(k) = (akz(kuvz) + bkz(kuvz)*psconv) - ! phconv(kuvz) = (akm(kuvz) + bkm(kuvz)*psconv) - ! else - ! phconv(kuvz) = 0.5*(pconv(kuvz)+pconv(k)) - ! endif - ! 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. - ! end do - ! end do - ! LB 04.05.2021, replace above with array operations - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - pconv(1:nuvz-1) = (akz(2:nuvz) + bkz(2:nuvz)*psconv) - phconv(2:nuvz) = (akm(2:nuvz) + bkm(2:nuvz)*psconv) - else - phconv(2:nuvz) = 0.5*(pconv(2:nuvz)+pconv(1:nuvz-1)) - endif - dpr(1:nuvz-1) = phconv(1:nuvz-1) - phconv(2:nuvz) - do k = 1,nuvz-1 - qsconv(k) = f_qvsat( pconv(k), tconv(k) ) - end do - fmassfrac(1:nuvz-1,1:nconvlev)=0. - ! LB end - - !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 !old - ! do k=1,nconvlev+1 !bugfix - ! pconv_hpa(k)=pconv(k)/100. - ! phconv_hpa(k)=phconv(k)/100. - ! end do - ! phconv_hpa(nconvlev+1)=phconv(nconvlev+1)/100. - ! LB 04.05.2021, replace above with array operations - pconv_hpa(1:nconvlev+1)=pconv(1:nconvlev+1)/100. - phconv_hpa(1:nconvlev+1)=phconv(1:nconvlev+1)/100. - ! LB end - - 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 - return - 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 - return - 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 - ! LB 04.05.2021, replace above with array operations (not the problem) - ! fmassfrac(1:nconvtop,1:nconvtop) = delt*fmass(1:nconvtop,1:nconvtop) - ! do k=1, nconvtop - ! fmassfrac(k, k) = fmassfrac(k, k) + dpr(k)/ga - sum(fmassfrac(k, 1:nconvtop)) - ! end do - ! LB end -end subroutine calcmatrix - -subroutine redist(itime,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 random_mod - use omp_lib - use interpol_mod - use coord_ec_mod - use particle_mod - use qvsat_mod - - implicit none +#include "con_convmix.f90" - real,parameter :: const=r_air/ga - integer :: ipart, ktop,ipconv,itime - integer :: k, kz, levnew, levold,ithread +#include "con_calcmatrix.f90" - real :: totlevmass, wsubpart - real :: temp_levold,temp_levold1 - real :: sub_levold,sub_levold1 - real :: pint, pold, rn, tv, tvold, dlevfrac - real :: ztold,ffraction - real :: tv1, tv2, dlogp, dz, dz1, dz2 - -#ifdef _OPENMP - ithread = OMP_GET_THREAD_NUM() ! Starts at 0 -#else - ithread=0 -#endif - - ! ipart ... number of particle to be treated - - ipconv=1 - - ! ! determine vertical grid position of particle in the eta system - ! !**************************************************************** - select case (wind_coord_type) - - case ('ETA') - ztold = real(part(abs(ipart))%zeta) - ! find old particle grid position - levold = nconvtop - do kz = 2, nconvtop - if (wheight(kz) .le. ztold ) then - levold = kz-1 - exit - endif - end do - - case ('METER') - - ! 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)/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)) - 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)) - 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 - - ztold = real(part(abs(ipart))%z) - ! find old particle grid position - levold = nconvtop - do kz = 2, nconvtop - if (uvzlev(kz) .ge. ztold ) then - levold = kz-1 - exit - endif - end do - case default - write(*,*) 'The wind_coord_type is not defined in redist.f90' - stop - - end select - - ! If the particle is above the potentially convective domain, it will be skipped - if (levold.ne.nconvtop) then - - ! now redistribute particles - !**************************** - - ! Choose a random number and find corresponding level of destination - ! Random numbers to be evenly distributed in [0,1] - - rn = ran3(iseed2(ithread),ithread) - - ! initialize levnew - - levnew = levold - - ffraction = 0. - totlevmass=dpr(levold)/ga - loop1: 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 - exit loop1 - endif - end do loop1 - - ! now assign new position to particle - select case (wind_coord_type) - - case ('ETA') - if ((levnew.le.nconvtop).and.(levnew.ne.levold)) then - dlogp = (1.-dlevfrac) * (wheight(levnew+1)-wheight(levnew)) - call set_zeta(ipart,wheight(levnew)+dlogp) - if (part(abs(ipart))%zeta.ge.1.) call set_zeta(ipart,1.-(part(abs(ipart))%zeta-1.)) - if (part(abs(ipart))%zeta.eq.1.) call update_zeta(ipart,-1.e-4) - if (ipconv.gt.0) ipconv=-1 - endif - - case ('METER') - if ((levnew.le.nconvtop).and.(levnew.ne.levold)) then - 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 - call set_z(ipart,(uvzlev(levnew)*dz2+uvzlev(levnew+1)*dz1)/dz) - if (part(abs(ipart))%z.lt.0.) call set_z(ipart,-1.*part(abs(ipart))%z) - if (ipconv.gt.0) ipconv=-1 - endif - - case default - write(*,*) 'The chosen wind_coord_type is not defined in redist.f90' - stop - - end select - - ! 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 - - ! 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)) - ! Bug fix: Added lsynctime to make units correct - sub_levold = sub(levold)/(1.-ga*sub(levold)*lsynctime/dpr(levold)) - 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)) - ! Bug fix: Added lsynctime to make units correct - sub_levold1 = sub(levold+1)/(1.-ga*sub(levold+1)*lsynctime/dpr(levold+1)) - wsub(levold+1)=-1.*sub_levold1*r_air*temp_levold1/ & - (phconv(levold+1)) - - ! interpolate wsub to the vertical particle position - select case (wind_coord_type) - case ('ETA') - ztold = real(part(abs(ipart))%zeta) - dz1 = ztold - wheight(levold) - dz2 = wheight(levold+1) - ztold - dz = dz1 + dz2 - - ! Convert z(eta) to z(m) in order to add subsidence - call update_zeta_to_z(itime, ipart) - ! call zeta_to_z(itime,part(abs(ipart))%xlon,part(abs(ipart))%ylat, & - ! part(abs(ipart))%zeta,part(abs(ipart))%z) - - wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz - - call update_z(ipart,wsubpart*real(lsynctime)) - - if (part(abs(ipart))%z.lt.0.) call set_z(ipart,-1.*part(abs(ipart))%z) - - ! Convert new z(m) back to z(eta) - call update_z_to_zeta(itime, ipart) - - case ('METER') - ztold = real(part(abs(ipart))%z) - dz1 = ztold - uvzlev(levold) - dz2 = uvzlev(levold+1) - ztold - dz = dz1 + dz2 - - wsubpart = (dz2*wsub(levold)+dz1*wsub(levold+1))/dz - - call update_z(ipart,wsubpart*real(lsynctime)) - - if (part(abs(ipart))%z.lt.0.) call set_z(ipart,-1.*part(abs(ipart))%z) - - case default - write(*,*) 'The wind_coord_type is not defined in redist.f90' - stop - end select - endif !(levnew.le.nconvtop.and.levnew.eq.levold) - endif - ! Maximum altitude .5 meter below uppermost model level - !******************************************************* - - select case (wind_coord_type) - case ('ETA') - if (part(abs(ipart))%zeta .lt. uvheight(nz)) call set_zeta(ipart,uvheight(nz)+1.e-4) - if (part(abs(ipart))%zeta.ge.1.) call set_zeta(ipart,1.-(part(abs(ipart))%zeta-1.)) - if (part(abs(ipart))%zeta.eq.1.) call update_zeta(ipart,-1.e-4) - case ('METER') - if (part(abs(ipart))%z .gt. height(nz)-0.5) call set_z(ipart,height(nz)-0.5) - case default - write(*,*) 'The wind_coord_type is not defined in redist.f90' - stop - end select - -end subroutine redist +#include "con_redist.f90" !************************************************************************** !**** SUBROUTINE CONVECT ***** @@ -971,1227 +93,12 @@ end subroutine redist !**** 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 - - 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 TOLD(NA) - - 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) - ! - ! ----------------------------------------------------------------------- - ! - ! *** 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 *** - ! - - FT(:NL+1)=0.0 - FQ(:NL+1)=0.0 - FDOWN(:NL+1)=0.0 - SUB(:NL+1)=0.0 - FUP(:NL+1)=0.0 - M(:NL+1)=0.0 - MP(:NL+1)=0.0 - FMASS(:NL+1,:NL+1)=0.0 - MENT(:NL+1,:NL+1)=0.0 - ! 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 - ! LB 04.05.2021, below is not mentioned anywhere, so I commented it - ! TH(:NL+1)=TCONV(:NL+1)*(1000.0/PCONV_HPA(:NL+1))** & - ! (RD*(1.-QCONV(:NL+1))+QCONV(:NL+1)*RV)/ (CPD*(1.-QCONV(:NL+1))+QCONV(:NL+1)*CPV) - 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 - ! LB 04.05.2021, replace above with array operations (maxloc not working) - ! NK=MINORIG+maxloc(HM(MINORIG:IHMIN))-1 - - ! - ! *** 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) - TVP(NK:ICB)=TVP(NK:ICB)-TP(NK:ICB)*QCONV(NK) - ! - ! *** 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) *** - ! - EP(1:NK)=0.0 - SIGP(1:NL)=SIGS - - 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 - ! LB 04.05.2021, replace above with array operations - ! (this makes it less readable, and not any faster) - ! PROBLEM 1 is within the statement below - ! EPMAX=0.999 - ! where ((TP(NK+1:NL)-273.15).ge.0.0) - ! EP(NK+1:NL)=EPMAX*(1.0-max(ELCRIT, 0.0)/MAX(CLW(NK+1:NL),1.0E-8)) - ! elsewhere - ! EP(NK+1:NL)=EPMAX*(1.0-max(ELCRIT*(1.0-TCA/TLCRIT), 0.0)/MAX(CLW(NK+1:NL),1.0E-8)) - ! end where - ! where (EP(NK+1:NL).lt.0.0) - ! EP(NK+1:NL)=0.0 - ! elsewhere (EP(NK+1:NL).gt.EPMAX) - ! EP(NK+1:NL)=EPMAX - ! end where - - ! - ! *** CALCULATE VIRTUAL TEMPERATURE AND LIFTED PARCEL *** - ! *** VIRTUAL TEMPERATURE *** - ! ! - TVP(ICB+1:NL)=TVP(ICB+1:NL)-TP(ICB+1:NL)*QCONV(NK) - TVP(NL+1)=TVP(NL)-(GZ(NL+1)-GZ(NL))/CPD - ! - ! *** NOW INITIALIZE VARIOUS ARRAYS USED IN THE COMPUTATIONS *** - - HP(:NL+1)=H(:NL+1) - NENT(:NL+1)=0 - WATER(:NL+1)=0.0 - EVAP(:NL+1)=0.0 - WT(:NL+1)=OMTSNOW - LVCP(:NL+1)=LV(:NL+1)/CPN(:NL+1) - ELIJ(:NL+1,:NL+1)=0.0 - SIJ(:NL+1,:NL+1)=0.0 - DO I=1,NL+1 - QENT(I,:NL+1)=QCONV(:NL+1) - END DO - QP(1)=QCONV(1) - QP(2:NL+1)=QCONV(:NL) - - ! - ! *** 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 *** - ! - HP(ICB:INB)=H(NK)+(LV(ICB:INB)+(CPD-CPV)*TCONV(ICB:INB))*EP(ICB:INB)*CLW(ICB:INB) - ! - ! *** CALCULATE CLOUD BASE MASS FLUX AND RATES OF MIXING, M(I), *** - ! *** AT EACH MODEL LEVEL *** - ! - - ! - ! *** 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 - - DTPBL=sum((TVP(NK:ICB-1)-TV(NK:ICB-1))*(PHCONV_HPA(NK:ICB-1)-PHCONV_HPA(NK+1:ICB)))/ & - (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 - M(ICB+1:INB1)=ABS(TV(ICB+1:INB1)-TVP(ICB+1:INB1))+ & - ENTP*0.02*(PHCONV_HPA(ICB+1:INB1)-PHCONV_HPA(ICB+2:INB1+1)) - M(INB1:INB)=ABS(TV(INB1)-TVP(INB1))+ & - ENTP*0.02*(PHCONV_HPA(INB1)-PHCONV_HPA(INB1+1)) - M(ICB+1:INB)=CBMF*M(ICB+1:INB)/sum(M(ICB+1:INB)) - - ! - ! *** 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 - ! LB 04.05.2021, Attempt to array the loop above: PROBLEM 2 is here - ! DO J=ICB,INB - ! BF2=1.+LV(J)*LV(J)*QSCONV(J)/(RV*TCONV(J)*TCONV(J)*CPD) - ! CWAT=CLW(J)*(1.-EP(J)) - ! DO I=ICB+1,INB - ! QTI=QCONV(NK)-EP(I)*CLW(I) - ! 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(I.EQ.J)THEN - ! SIJ(I,I)=1.0 - ! ELSE IF(ABS(DENOM).LT.0.01)THEN - ! SIJ(I,J)=ANUM/0.01 - ! ELSE - ! SIJ(I,J)=ANUM/DENOM - ! END IF - ! ALTEM=(SIJ(I,J)*QCONV(I)+(1.-SIJ(I,J))*QTI-QSCONV(J))/BF2 - ! IF((SIJ(I,J).LT.0.0.OR.SIJ(I,J).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 - ! END DO - ! ! - ! ! *** IF NO AIR CAN ENTRAIN AT LEVEL I ASSUME THAT UPDRAFT DETRAINS *** - ! ! *** AT THAT LEVEL AND CALCULATE DETRAINED AIR FLUX AND PROPERTIES *** - ! ! - ! do I=ICB+1,INB - ! 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 *** - ! - ! LB 04.05.2021, depending on how often NENT.ne.0, reversing the loop could - ! speed it up... - 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).ge.0.0001) then - ! - ! *** 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 (.not. I.eq.1) then - 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 - endif - ! - ! *** FIND MIXING RATIO OF PRECIPITATING DOWNDRAFT *** - ! - if (.not. I.eq.INB) then - 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) - endif - END DO - ! - ! *** CALCULATE SURFACE PRECIPITATION IN MM/DAY *** - ! - PRECIP=PRECIP+WT(1)*SIGD*WATER(1)*3600.*24000./(ROWL*G) - ! - endif ! Downdraft calculation - ! - ! *** 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 - AM = sum(M(2:INB)) - 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 - - FQ(1)=FQ(1)+G*DPINV*sum(MENT(2:INB,1)*(QENT(2:INB,1)-QCONV(1))) - ! - ! *** 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 - AMP1 = sum(M(I+1:INB+1)) - END IF - AMP1 = AMP1 + sum(MENT(1:I,I+1:INB+1)) - ! save saturated upward mass flux - FUP(I)=AMP1 - IF((2.*G*DPINV*AMP1).GE.DELTI)IFLAG=4 - - AD = sum(MENT(I:INB,1:I-1)) - ! 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 - - FQ(I)=FQ(I)+G*DPINV*sum(MENT(I:INB,I)*(QENT(I:INB,I)-QCONV(I))) - 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 - - ENTS = sum((CPN(1:INB)*FT(1:INB)+LV(1:INB)*FQ(1:INB))* & - (PHCONV_HPA(1:INB)-PHCONV_HPA(2:INB+1))) - - ENTS=ENTS/(PHCONV_HPA(1)-PHCONV_HPA(INB+1)) - - FT(1:INB)=FT(1:INB) - ENTS/CPN(1:INB) - - ! ************************************************ - ! **** 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 - - FMASS(NK, :INB+1) = FMASS(NK,:INB+1)+M(:INB+1) - FMASS(:INB+1,:INB+1) = FMASS(:INB+1,:INB+1)+MENT(:INB+1,:INB+1) - SUB(1) = 0. - SUB(2:INB+1) = FUP(1:INB) - FDOWN(2:INB+1) - NCONVTOP=1 - do i=1,INB+1 - do j=1,INB+1 - if (FMASS(j,i).gt.EPSILON) NCONVTOP=MAX(NCONVTOP,i,j) - end do - end do - NCONVTOP=NCONVTOP+1 - RETURN - ! -END SUBROUTINE CONVECT +#include "con_CONVECT.f90" ! ! --------------------------------------------------------------------------- ! -SUBROUTINE TLIFT(GZ,ICB,NK,TVP,TPK,CLW,ND,NL,KK) - ! - !-cv - use par_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 *** - ! - CLW(1:ICB-1) = 0.0 - TPK(NK:ICB-1)=TCONV(NK)-(GZ(NK:ICB-1)-GZ(NK))*CPINV - TVP(NK:ICB-1)=TPK(NK:ICB-1)*(1.+QCONV(NK)*EPSI) - 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 - -subroutine sort2(n,arr,brr) - ! From numerical recipes - ! Change by A. Stohl: Use of integer instead of real values - implicit none +#include "con_TLIFT.f90" - integer, intent(in) :: n - integer, intent(inout) :: 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 - do - if(ir-l.lt.m)then - do j=l+1,ir - a=arr(j) - b=brr(j) - i=j-1 - do while(i.gt.0) - if (arr(i).le.a) exit - arr(i+1)=arr(i) - brr(i+1)=brr(i) - i=i-1 - end do - 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) - do - do - i=i+1 - if(arr(i).ge.a) exit - end do - do - j=j-1 - if(arr(j).le.a) exit - end do - if(j.lt.i) exit - temp=arr(i) - arr(i)=arr(j) - arr(j)=temp - temp=brr(i) - brr(i)=brr(j) - brr(j)=temp - end do - 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 - end do -! (C) Copr. 1986-92 Numerical Recipes Software us. -end subroutine sort2 +#include "con_sort2.f90" end module conv_mod diff --git a/src/coo_update_z_to_zeta.f90 b/src/coo_update_z_to_zeta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e5530111b8fdd39f5d06b95b45eaa0ab1ed8b907 --- /dev/null +++ b/src/coo_update_z_to_zeta.f90 @@ -0,0 +1,20 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine update_z_to_zeta(itime, ipart) + use particle_mod + implicit none + + integer, intent(in) :: & + itime, & ! time index + ipart ! particle index + + if (.not. wind_coord_type.eq.'ETA') return + if (.not. part(ipart)%alive) return + if (part(ipart)%meterupdate) return + + call z_to_zeta(itime,part(ipart)%xlon,part(ipart)%ylat, & + part(ipart)%z,part(ipart)%zeta) + part(ipart)%etaupdate = .true. + part(ipart)%meterupdate = .true. +end subroutine update_z_to_zeta diff --git a/src/coo_update_zeta_to_z.f90 b/src/coo_update_zeta_to_z.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4953e999fc7eff7bd31a6736e3f91b484cd8e075 --- /dev/null +++ b/src/coo_update_zeta_to_z.f90 @@ -0,0 +1,20 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine update_zeta_to_z(itime, ipart) + use particle_mod + implicit none + + integer, intent(in) :: & + itime, & ! time index + ipart ! particle index + + if (.not. wind_coord_type.eq.'ETA') return + if (.not. part(ipart)%alive) return + if (part(ipart)%etaupdate) return + + call zeta_to_z(itime,part(ipart)%xlon,part(ipart)%ylat, & + part(ipart)%zeta,part(ipart)%z) + part(ipart)%etaupdate = .true. + part(ipart)%meterupdate = .true. +end subroutine update_zeta_to_z diff --git a/src/coo_w_to_weta.f90 b/src/coo_w_to_weta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..73b71e21bccbc15ff4d30750ae162f41b57745e2 --- /dev/null +++ b/src/coo_w_to_weta.f90 @@ -0,0 +1,41 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine w_to_weta(itime,dt,xt,yt,z_old,zeta_old,w_in,weta_out) + !***************************************************************************** + ! Converting z from meter coordinates to eta using logarithmic vertical * + ! interpolation * + !***************************************************************************** + ! * + ! Variables: * + ! itime [s] current temporal position * + ! xt,yt,zold,zold spatial positions of trajectory (meters) * + ! zteta vertical position in eta coordinates (output) * + ! * + ! etauvheight defined in windfields: half model heights for ETA coordinates * + ! Constants: * + ! * + !***************************************************************************** + use interpol_mod + + implicit none + integer, intent(in) :: & + itime ! time index + integer :: & + i,m,k,n ! loop indices + real, intent(in) :: & + dt ! time step + real(kind=dp), intent(in) :: & + xt,yt,z_old,zeta_old ! particle position + real, intent(in) :: & + w_in ! w in meters/s + real, intent(inout) :: & + weta_out ! converted output w in meters to eta + real(kind=dp) :: & + znew + + call z_to_zeta(itime,xt,yt,z_old+real(w_in*dt,kind=dp),znew) + + weta_out=real(znew-zeta_old)/dt + +end subroutine w_to_weta diff --git a/src/coo_z_to_zeta.f90 b/src/coo_z_to_zeta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..abba465cd586159d1e899a54e060331893a52d62 --- /dev/null +++ b/src/coo_z_to_zeta.f90 @@ -0,0 +1,121 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine z_to_zeta(itime,xt,yt,zold,zteta) + !***************************************************************************** + ! Converting z from meter coordinates to eta using logarithmic vertical * + ! interpolation * + !***************************************************************************** + ! * + ! Variables: * + ! itime [s] current temporal position * + ! xt,yt,zold,zold spatial positions of trajectory (meters) * + ! zteta vertical position in eta coordinates (output) * + ! * + ! etauvheight defined in windfields: half model heights for ETA coordinates * + ! Constants: * + ! * + !***************************************************************************** + use interpol_mod + + implicit none + integer, intent(in) :: & + itime ! time index + integer :: & + i,m,k,n ! loop indices + real(kind=dp), intent(in) :: & + xt,yt ! particle position + real(kind=dp), intent(in) :: & + zold ! particle verticle position in eta coordinates + real(kind=dp), intent(inout) :: & + zteta ! converted output z in meters + real :: & + frac, & ! fraction between z levels + ztemp1,ztemp2, & ! z positions of the two encompassing levels + ttemp1(2), & ! storing virtual temperature + psint1(2),psint ! pressure of encompassing levels + real :: & + prx,pr1,pr2 ! pressure of encompassing levels + + if (.not. log_interpol) then + call z_to_zeta_lin(itime,xt,yt,zold,zteta) + return + endif + + call find_ngrid(xt,yt) + call find_grid_indices(real(xt),real(yt)) + call find_grid_distances(real(xt),real(yt)) + call find_time_vars(itime) + + ! Integration method as used in the original verttransform_ecmwf.f90 + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! First estimate the level it is at, to reduce computation time + n=nz-3 + if (ngrid.le.0) then + do i=2,nz-1 + if ((etauvheight(ix,jy,i,memind(1)).gt.real(zold)) .or. & + (etauvheight(ixp,jy,i,memind(1)).gt.real(zold)) .or. & + (etauvheight(ix,jyp,i,memind(1)).gt.real(zold)) .or. & + (etauvheight(ixp,jyp,i,memind(1)).gt.real(zold))) then + n=i-2 + exit + endif + end do + else + do i=2,nz-1 + if ((etauvheightn(ix,jy,i,memind(1),ngrid).gt.real(zold)) .or. & + (etauvheightn(ixp,jy,i,memind(1),ngrid).gt.real(zold)) .or. & + (etauvheightn(ix,jyp,i,memind(1),ngrid).gt.real(zold)) .or. & + (etauvheightn(ixp,jyp,i,memind(1),ngrid).gt.real(zold))) then + n=i-2 + exit + endif + end do + endif + n=max(n,2) + + ztemp1 = 0. + do i=n,nz-1 + k=i + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(etauvheight,ttemp1(m),i,memind(m),nzmax) + end do + else + do m=1,2 + call hor_interpol_nest(etauvheightn,ttemp1(m),i,memind(m),nzmax) + end do + endif + call temp_interpol(ttemp1(1),ttemp1(2),ztemp2) + + if (ztemp2.gt.real(zold)) then + !frac = (real(zold)-ztemp1)/(ztemp2-ztemp1) + exit + else if (i.eq.nz-1) then + frac = 1. + exit + endif + ztemp1=ztemp2 + end do + + if (k.lt.nz-1) then + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(ps,psint1(m),1,memind(m),1) + end do + else + do m=1,2 + call hor_interpol_nest(psn,psint1(m),1,memind(m),1) + end do + endif + call temp_interpol(psint1(1),psint1(2),psint) + pr1=akz(k-1) + bkz(k-1)*psint + pr2=akz(k) + bkz(k)*psint + + prx=pr1/exp(log(pr2/pr1)/(ztemp2-ztemp1)*ztemp1) * & + exp(log(pr2/pr1)/(ztemp2-ztemp1)*real(zold)) + frac=(prx-pr1)/(pr2 - pr1) + endif + + zteta=real(uvheight(k-1)*(1.-frac)+uvheight(k)*frac,kind=dp) +end subroutine z_to_zeta diff --git a/src/coo_z_to_zeta_lin.f90 b/src/coo_z_to_zeta_lin.f90 new file mode 100644 index 0000000000000000000000000000000000000000..855f1b7bcf534ff79abca7ed83caaa4b0e081170 --- /dev/null +++ b/src/coo_z_to_zeta_lin.f90 @@ -0,0 +1,97 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine z_to_zeta_lin(itime,xt,yt,zold,zteta) + !***************************************************************************** + ! Converting z from meter coordinates to eta using linear interpolation * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! itime [s] current temporal position * + ! xt,yt,zold,zold spatial positions of trajectory (meters) * + ! zteta vertical position in eta coordinates (output) * + ! * + ! etauvheight defined in windfields: half model heights for ETA coordinates * + ! Constants: * + ! * + !***************************************************************************** + use interpol_mod + + implicit none + integer, intent(in) :: & + itime ! time index + integer :: & + i,m,k,n ! loop indices + real(kind=dp), intent(in) :: & + xt,yt ! particle position + real(kind=dp), intent(in) :: & + zold ! particle verticle position in eta coordinates + real(kind=dp), intent(inout) :: & + zteta ! converted output z in meters + real :: & + frac, & ! fraction between z levels + ztemp1,ztemp2, & ! z positions of the two encompassing levels + ttemp1(2), & ! storing virtual temperature + psint1(2),psint ! pressure of encompassing levels + real :: & + prx,pr1,pr2 ! pressure of encompassing levels + + call find_ngrid(xt,yt) + call find_grid_indices(real(xt),real(yt)) + call find_grid_distances(real(xt),real(yt)) + call find_time_vars(itime) + + ! Integration method as used in the original verttransform_ecmwf.f90 + !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! First estimate the level it is at, to reduce computation time + n=nz-3 + if (ngrid.le.0) then + do i=2,nz-1 + if ((etauvheight(ix,jy,i,memind(1)).gt.real(zold)) .or. & + (etauvheight(ixp,jy,i,memind(1)).gt.real(zold)) .or. & + (etauvheight(ix,jyp,i,memind(1)).gt.real(zold)) .or. & + (etauvheight(ixp,jyp,i,memind(1)).gt.real(zold))) then + n=i-2 + exit + endif + end do + else + do i=2,nz-1 + if ((etauvheightn(ix,jy,i,memind(1),ngrid).gt.real(zold)) .or. & + (etauvheightn(ixp,jy,i,memind(1),ngrid).gt.real(zold)) .or. & + (etauvheightn(ix,jyp,i,memind(1),ngrid).gt.real(zold)) .or. & + (etauvheightn(ixp,jyp,i,memind(1),ngrid).gt.real(zold))) then + n=i-2 + exit + endif + end do + endif + n=max(n,2) + + ztemp1 = 0. + do i=n,nz-1 + k=i + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(etauvheight,ttemp1(m),i,memind(m),nzmax) + end do + else + do m=1,2 + call hor_interpol_nest(etauvheightn,ttemp1(m),i,memind(m),nzmax) + end do + endif + call temp_interpol(ttemp1(1),ttemp1(2),ztemp2) + + if (ztemp2.gt.real(zold)) then + frac = (real(zold)-ztemp1)/(ztemp2-ztemp1) + exit + else if (i.eq.nz-1) then + frac = 1. + exit + endif + ztemp1=ztemp2 + end do + + zteta=real(uvheight(k-1)*(1.-frac)+uvheight(k)*frac,kind=dp) +end subroutine z_to_zeta_lin diff --git a/src/coo_zeta_to_z.f90 b/src/coo_zeta_to_z.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3a619ca30e2be01b5d70c27bed754a92578a8278 --- /dev/null +++ b/src/coo_zeta_to_z.f90 @@ -0,0 +1,97 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine zeta_to_z(itime,xt,yt,zteta,ztout) + !***************************************************************************** + ! Converting z from eta coordinates to meters using logarithmic * + ! vertical interpolation * + !***************************************************************************** + ! * + ! Variables: * + ! itime [s] current temporal position * + ! xt,yt,zteta spatial position of trajectory * + ! ztout vertical postion in meter (output) * + ! * + ! * + !***************************************************************************** + use interpol_mod + + implicit none + integer, intent(in) :: & + itime ! time index + integer :: & + i,j,k,m,ii,indexh ! loop indices + real(kind=dp), intent(in) :: & + xt,yt ! particle position + real(kind=dp), intent(in) :: & + zteta ! particle verticle position in eta coordinates + real(kind=dp), intent(inout) :: & + ztout ! converted output z in meters + real(kind=dp) :: & + frac ! fraction between z levels + real :: & + ztemp1(2), & ! z positions of the two encompassing levels + ttemp1(2), & ! storing virtual temperature + psint1(2),psint,prx,pr1,pr2 ! pressure of encompassing levels + + if (.not. log_interpol) then + call zeta_to_z_lin(itime,xt,yt,zteta,ztout) + return + endif + + ! Convert eta z coordinate to meters + !*********************************** + call find_ngrid(xt,yt) + call find_grid_indices(real(xt),real(yt)) + call find_grid_distances(real(xt),real(yt)) + call find_time_vars(itime) + + k=nz-1 + frac=1. + do i=2,nz-1 + k=i + if (zteta.ge.real(uvheight(k),kind=dp)) then + frac=(zteta-real(uvheight(k-1),kind=dp))/(real(uvheight(k)-uvheight(k-1),kind=dp)) + exit + endif + end do + + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(ps,psint1(m),1,memind(m),1) + end do + else + do m=1,2 + call hor_interpol_nest(psn,psint1(m),1,memind(m),1) + end do + endif + + call temp_interpol(psint1(1),psint1(2),psint) + pr1=akz(k-1) + bkz(k-1)*psint + pr2=akz(k) + bkz(k)*psint + prx=pr1*(1.-frac) + pr2*frac + + if (ngrid.le.0) then + do ii=1,2 + do m=1,2 + call hor_interpol(etauvheight,ttemp1(m),k+ii-2,memind(m),nzmax) + end do + call temp_interpol(ttemp1(1),ttemp1(2),ztemp1(ii)) + end do + else + do ii=1,2 + do m=1,2 + call hor_interpol_nest(etauvheightn, & + ttemp1(m),k+ii-2,memind(m),nzmax) + end do + call temp_interpol(ttemp1(1),ttemp1(2),ztemp1(ii)) + end do + endif + + if ((pr2.eq.0).or.(pr1.eq.0)) then + ztout = real(ztemp1(1),kind=dp)*(1.-frac)+real(ztemp1(2),kind=dp)*frac + return + endif + + ztout = ztemp1(1) + (ztemp1(2)-ztemp1(1))/log(pr2/pr1)*log(prx/pr1) +end subroutine zeta_to_z diff --git a/src/coo_zeta_to_z_lin.f90 b/src/coo_zeta_to_z_lin.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2850c08f31e67e3c13812a98563302a56ba3d236 --- /dev/null +++ b/src/coo_zeta_to_z_lin.f90 @@ -0,0 +1,73 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine zeta_to_z_lin(itime,xt,yt,zteta,ztout) + + !***************************************************************************** + ! Converting z from eta coordinates to meters using linear interpolation * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! itime [s] current temporal position * + ! xt,yt,zteta spatial position of trajectory * + ! ztout vertical postion in meter (output) * + ! * + ! * + !***************************************************************************** + use interpol_mod + + implicit none + integer, intent(in) :: & + itime ! time index + integer :: & + i,j,k,m,ii,indexh ! loop indices + real(kind=dp), intent(in) :: & + xt,yt ! particle position + real(kind=dp), intent(in) :: & + zteta ! particle verticle position in eta coordinates + real(kind=dp), intent(inout) :: & + ztout ! converted output z in meters + real(kind=dp) :: & + frac ! fraction between z levels + real :: & + ztemp1(2), & ! z positions of the two encompassing levels + ttemp1(2), & ! storing virtual temperature + psint1(2),psint ! pressure of encompassing levels + + + ! Convert eta z coordinate to meters + !*********************************** + call find_ngrid(xt,yt) + call find_grid_indices(real(xt),real(yt)) + call find_grid_distances(real(xt),real(yt)) + call find_time_vars(itime) + + k=nz-1 + frac=1. + do i=2,nz-1 + k=i + if (zteta.ge.real(uvheight(k),kind=dp)) then + frac=(zteta-real(uvheight(k-1),kind=dp))/(real(uvheight(k)-uvheight(k-1),kind=dp)) + exit + endif + end do + + if (ngrid.le.0) then + do ii=1,2 + do m=1,2 + call hor_interpol(etauvheight,ttemp1(m),k+ii-2,memind(m),nzmax) + end do + call temp_interpol(ttemp1(1),ttemp1(2),ztemp1(ii)) + end do + else + do ii=1,2 + do m=1,2 + call hor_interpol_nest(etauvheightn,ttemp1(m),k+ii-2,memind(m),nzmax) + end do + call temp_interpol(ttemp1(1),ttemp1(2),ztemp1(ii)) + end do + endif + + ztout = real(ztemp1(1),kind=dp)*(1.-frac)+real(ztemp1(2),kind=dp)*frac +end subroutine zeta_to_z_lin diff --git a/src/coord_ec_mod.f90 b/src/coord_ec_mod.f90 index 5bdfc0035f1c6714ccf572b9289f7bd2c6b134d9..e2fd0398293b1965554be0b350e42123272c21da 100644 --- a/src/coord_ec_mod.f90 +++ b/src/coord_ec_mod.f90 @@ -17,459 +17,18 @@ module coord_ec_mod contains -subroutine update_zeta_to_z(itime, ipart) - use particle_mod - implicit none +#include "coo_update_zeta_to_z.f90" - integer, intent(in) :: & - itime, & ! time index - ipart ! particle index +#include "coo_update_z_to_zeta.f90" - if (.not. wind_coord_type.eq.'ETA') return - if (.not. part(ipart)%alive) return - if (part(ipart)%etaupdate) return +#include "coo_z_to_zeta.f90" - call zeta_to_z(itime,part(ipart)%xlon,part(ipart)%ylat, & - part(ipart)%zeta,part(ipart)%z) - part(ipart)%etaupdate = .true. - part(ipart)%meterupdate = .true. -end subroutine update_zeta_to_z +#include "coo_zeta_to_z.f90" -subroutine update_z_to_zeta(itime, ipart) - use particle_mod - implicit none +#include "coo_w_to_weta.f90" - integer, intent(in) :: & - itime, & ! time index - ipart ! particle index +#include "coo_z_to_zeta_lin.f90" - if (.not. wind_coord_type.eq.'ETA') return - if (.not. part(ipart)%alive) return - if (part(ipart)%meterupdate) return - - call z_to_zeta(itime,part(ipart)%xlon,part(ipart)%ylat, & - part(ipart)%z,part(ipart)%zeta) - part(ipart)%etaupdate = .true. - part(ipart)%meterupdate = .true. -end subroutine update_z_to_zeta - -subroutine z_to_zeta(itime,xt,yt,zold,zteta) - !***************************************************************************** - ! Converting z from meter coordinates to eta using logarithmic vertical * - ! interpolation * - !***************************************************************************** - ! * - ! Variables: * - ! itime [s] current temporal position * - ! xt,yt,zold,zold spatial positions of trajectory (meters) * - ! zteta vertical position in eta coordinates (output) * - ! * - ! etauvheight defined in windfields: half model heights for ETA coordinates * - ! Constants: * - ! * - !***************************************************************************** - use interpol_mod - - implicit none - integer, intent(in) :: & - itime ! time index - integer :: & - i,m,k,n ! loop indices - real(kind=dp), intent(in) :: & - xt,yt ! particle position - real(kind=dp), intent(in) :: & - zold ! particle verticle position in eta coordinates - real(kind=dp), intent(inout) :: & - zteta ! converted output z in meters - real :: & - frac, & ! fraction between z levels - ztemp1,ztemp2, & ! z positions of the two encompassing levels - ttemp1(2), & ! storing virtual temperature - psint1(2),psint ! pressure of encompassing levels - real :: & - prx,pr1,pr2 ! pressure of encompassing levels - - if (.not. log_interpol) then - call z_to_zeta_lin(itime,xt,yt,zold,zteta) - return - endif - - call find_ngrid(xt,yt) - call find_grid_indices(real(xt),real(yt)) - call find_grid_distances(real(xt),real(yt)) - call find_time_vars(itime) - - ! Integration method as used in the original verttransform_ecmwf.f90 - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! First estimate the level it is at, to reduce computation time - n=nz-3 - if (ngrid.le.0) then - do i=2,nz-1 - if ((etauvheight(ix,jy,i,memind(1)).gt.real(zold)) .or. & - (etauvheight(ixp,jy,i,memind(1)).gt.real(zold)) .or. & - (etauvheight(ix,jyp,i,memind(1)).gt.real(zold)) .or. & - (etauvheight(ixp,jyp,i,memind(1)).gt.real(zold))) then - n=i-2 - exit - endif - end do - else - do i=2,nz-1 - if ((etauvheightn(ix,jy,i,memind(1),ngrid).gt.real(zold)) .or. & - (etauvheightn(ixp,jy,i,memind(1),ngrid).gt.real(zold)) .or. & - (etauvheightn(ix,jyp,i,memind(1),ngrid).gt.real(zold)) .or. & - (etauvheightn(ixp,jyp,i,memind(1),ngrid).gt.real(zold))) then - n=i-2 - exit - endif - end do - endif - n=max(n,2) - - ztemp1 = 0. - do i=n,nz-1 - k=i - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(etauvheight,ttemp1(m),i,memind(m),nzmax) - end do - else - do m=1,2 - call hor_interpol_nest(etauvheightn,ttemp1(m),i,memind(m),nzmax) - end do - endif - call temp_interpol(ttemp1(1),ttemp1(2),ztemp2) - - if (ztemp2.gt.real(zold)) then - !frac = (real(zold)-ztemp1)/(ztemp2-ztemp1) - exit - else if (i.eq.nz-1) then - frac = 1. - exit - endif - ztemp1=ztemp2 - end do - - if (k.lt.nz-1) then - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(ps,psint1(m),1,memind(m),1) - end do - else - do m=1,2 - call hor_interpol_nest(psn,psint1(m),1,memind(m),1) - end do - endif - call temp_interpol(psint1(1),psint1(2),psint) - pr1=akz(k-1) + bkz(k-1)*psint - pr2=akz(k) + bkz(k)*psint - - prx=pr1/exp(log(pr2/pr1)/(ztemp2-ztemp1)*ztemp1) * & - exp(log(pr2/pr1)/(ztemp2-ztemp1)*real(zold)) - frac=(prx-pr1)/(pr2 - pr1) - endif - - zteta=real(uvheight(k-1)*(1.-frac)+uvheight(k)*frac,kind=dp) -end subroutine z_to_zeta - -subroutine zeta_to_z(itime,xt,yt,zteta,ztout) - !***************************************************************************** - ! Converting z from eta coordinates to meters using logarithmic * - ! vertical interpolation * - !***************************************************************************** - ! * - ! Variables: * - ! itime [s] current temporal position * - ! xt,yt,zteta spatial position of trajectory * - ! ztout vertical postion in meter (output) * - ! * - ! * - !***************************************************************************** - use interpol_mod - - implicit none - integer, intent(in) :: & - itime ! time index - integer :: & - i,j,k,m,ii,indexh ! loop indices - real(kind=dp), intent(in) :: & - xt,yt ! particle position - real(kind=dp), intent(in) :: & - zteta ! particle verticle position in eta coordinates - real(kind=dp), intent(inout) :: & - ztout ! converted output z in meters - real(kind=dp) :: & - frac ! fraction between z levels - real :: & - ztemp1(2), & ! z positions of the two encompassing levels - ttemp1(2), & ! storing virtual temperature - psint1(2),psint,prx,pr1,pr2 ! pressure of encompassing levels - - if (.not. log_interpol) then - call zeta_to_z_lin(itime,xt,yt,zteta,ztout) - return - endif - - ! Convert eta z coordinate to meters - !*********************************** - call find_ngrid(xt,yt) - call find_grid_indices(real(xt),real(yt)) - call find_grid_distances(real(xt),real(yt)) - call find_time_vars(itime) - - k=nz-1 - frac=1. - do i=2,nz-1 - k=i - if (zteta.ge.real(uvheight(k),kind=dp)) then - frac=(zteta-real(uvheight(k-1),kind=dp))/(real(uvheight(k)-uvheight(k-1),kind=dp)) - exit - endif - end do - - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(ps,psint1(m),1,memind(m),1) - end do - else - do m=1,2 - call hor_interpol_nest(psn,psint1(m),1,memind(m),1) - end do - endif - - call temp_interpol(psint1(1),psint1(2),psint) - pr1=akz(k-1) + bkz(k-1)*psint - pr2=akz(k) + bkz(k)*psint - prx=pr1*(1.-frac) + pr2*frac - - if (ngrid.le.0) then - do ii=1,2 - do m=1,2 - call hor_interpol(etauvheight,ttemp1(m),k+ii-2,memind(m),nzmax) - end do - call temp_interpol(ttemp1(1),ttemp1(2),ztemp1(ii)) - end do - else - do ii=1,2 - do m=1,2 - call hor_interpol_nest(etauvheightn, & - ttemp1(m),k+ii-2,memind(m),nzmax) - end do - call temp_interpol(ttemp1(1),ttemp1(2),ztemp1(ii)) - end do - endif - - if ((pr2.eq.0).or.(pr1.eq.0)) then - ztout = real(ztemp1(1),kind=dp)*(1.-frac)+real(ztemp1(2),kind=dp)*frac - return - endif - - ztout = ztemp1(1) + (ztemp1(2)-ztemp1(1))/log(pr2/pr1)*log(prx/pr1) -end subroutine zeta_to_z - -subroutine w_to_weta(itime,dt,xt,yt,z_old,zeta_old,w_in,weta_out) - !***************************************************************************** - ! Converting z from meter coordinates to eta using logarithmic vertical * - ! interpolation * - !***************************************************************************** - ! * - ! Variables: * - ! itime [s] current temporal position * - ! xt,yt,zold,zold spatial positions of trajectory (meters) * - ! zteta vertical position in eta coordinates (output) * - ! * - ! etauvheight defined in windfields: half model heights for ETA coordinates * - ! Constants: * - ! * - !***************************************************************************** - use interpol_mod - - implicit none - integer, intent(in) :: & - itime ! time index - integer :: & - i,m,k,n ! loop indices - real, intent(in) :: & - dt ! time step - real(kind=dp), intent(in) :: & - xt,yt,z_old,zeta_old ! particle position - real, intent(in) :: & - w_in ! w in meters/s - real, intent(inout) :: & - weta_out ! converted output w in meters to eta - real(kind=dp) :: & - znew - - call z_to_zeta(itime,xt,yt,z_old+real(w_in*dt,kind=dp),znew) - - weta_out=real(znew-zeta_old)/dt - -end subroutine w_to_weta - -subroutine z_to_zeta_lin(itime,xt,yt,zold,zteta) - !***************************************************************************** - ! Converting z from meter coordinates to eta using linear interpolation * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! itime [s] current temporal position * - ! xt,yt,zold,zold spatial positions of trajectory (meters) * - ! zteta vertical position in eta coordinates (output) * - ! * - ! etauvheight defined in windfields: half model heights for ETA coordinates * - ! Constants: * - ! * - !***************************************************************************** - use interpol_mod - - implicit none - integer, intent(in) :: & - itime ! time index - integer :: & - i,m,k,n ! loop indices - real(kind=dp), intent(in) :: & - xt,yt ! particle position - real(kind=dp), intent(in) :: & - zold ! particle verticle position in eta coordinates - real(kind=dp), intent(inout) :: & - zteta ! converted output z in meters - real :: & - frac, & ! fraction between z levels - ztemp1,ztemp2, & ! z positions of the two encompassing levels - ttemp1(2), & ! storing virtual temperature - psint1(2),psint ! pressure of encompassing levels - real :: & - prx,pr1,pr2 ! pressure of encompassing levels - - call find_ngrid(xt,yt) - call find_grid_indices(real(xt),real(yt)) - call find_grid_distances(real(xt),real(yt)) - call find_time_vars(itime) - - ! Integration method as used in the original verttransform_ecmwf.f90 - !+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ - ! First estimate the level it is at, to reduce computation time - n=nz-3 - if (ngrid.le.0) then - do i=2,nz-1 - if ((etauvheight(ix,jy,i,memind(1)).gt.real(zold)) .or. & - (etauvheight(ixp,jy,i,memind(1)).gt.real(zold)) .or. & - (etauvheight(ix,jyp,i,memind(1)).gt.real(zold)) .or. & - (etauvheight(ixp,jyp,i,memind(1)).gt.real(zold))) then - n=i-2 - exit - endif - end do - else - do i=2,nz-1 - if ((etauvheightn(ix,jy,i,memind(1),ngrid).gt.real(zold)) .or. & - (etauvheightn(ixp,jy,i,memind(1),ngrid).gt.real(zold)) .or. & - (etauvheightn(ix,jyp,i,memind(1),ngrid).gt.real(zold)) .or. & - (etauvheightn(ixp,jyp,i,memind(1),ngrid).gt.real(zold))) then - n=i-2 - exit - endif - end do - endif - n=max(n,2) - - ztemp1 = 0. - do i=n,nz-1 - k=i - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(etauvheight,ttemp1(m),i,memind(m),nzmax) - end do - else - do m=1,2 - call hor_interpol_nest(etauvheightn,ttemp1(m),i,memind(m),nzmax) - end do - endif - call temp_interpol(ttemp1(1),ttemp1(2),ztemp2) - - if (ztemp2.gt.real(zold)) then - frac = (real(zold)-ztemp1)/(ztemp2-ztemp1) - exit - else if (i.eq.nz-1) then - frac = 1. - exit - endif - ztemp1=ztemp2 - end do - - zteta=real(uvheight(k-1)*(1.-frac)+uvheight(k)*frac,kind=dp) -end subroutine z_to_zeta_lin - -subroutine zeta_to_z_lin(itime,xt,yt,zteta,ztout) - - !***************************************************************************** - ! Converting z from eta coordinates to meters using linear interpolation * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! itime [s] current temporal position * - ! xt,yt,zteta spatial position of trajectory * - ! ztout vertical postion in meter (output) * - ! * - ! * - !***************************************************************************** - use interpol_mod - - implicit none - integer, intent(in) :: & - itime ! time index - integer :: & - i,j,k,m,ii,indexh ! loop indices - real(kind=dp), intent(in) :: & - xt,yt ! particle position - real(kind=dp), intent(in) :: & - zteta ! particle verticle position in eta coordinates - real(kind=dp), intent(inout) :: & - ztout ! converted output z in meters - real(kind=dp) :: & - frac ! fraction between z levels - real :: & - ztemp1(2), & ! z positions of the two encompassing levels - ttemp1(2), & ! storing virtual temperature - psint1(2),psint ! pressure of encompassing levels - - - ! Convert eta z coordinate to meters - !*********************************** - call find_ngrid(xt,yt) - call find_grid_indices(real(xt),real(yt)) - call find_grid_distances(real(xt),real(yt)) - call find_time_vars(itime) - - k=nz-1 - frac=1. - do i=2,nz-1 - k=i - if (zteta.ge.real(uvheight(k),kind=dp)) then - frac=(zteta-real(uvheight(k-1),kind=dp))/(real(uvheight(k)-uvheight(k-1),kind=dp)) - exit - endif - end do - - if (ngrid.le.0) then - do ii=1,2 - do m=1,2 - call hor_interpol(etauvheight,ttemp1(m),k+ii-2,memind(m),nzmax) - end do - call temp_interpol(ttemp1(1),ttemp1(2),ztemp1(ii)) - end do - else - do ii=1,2 - do m=1,2 - call hor_interpol_nest(etauvheightn,ttemp1(m),k+ii-2,memind(m),nzmax) - end do - call temp_interpol(ttemp1(1),ttemp1(2),ztemp1(ii)) - end do - endif - - ztout = real(ztemp1(1),kind=dp)*(1.-frac)+real(ztemp1(2),kind=dp)*frac -end subroutine zeta_to_z_lin +#include "coo_zeta_to_z_lin.f90" end module coord_ec_mod diff --git a/src/dat_caldate.f90 b/src/dat_caldate.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2bbf3761b30b94d7dbcc8287b843b1cc15c972fa --- /dev/null +++ b/src/dat_caldate.f90 @@ -0,0 +1,75 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine caldate(juliandate,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 * + ! juliandate Julian Date * + ! julday help variable * + ! mi Minute * + ! mm Month * + ! ss Seconds * + ! yyyy Year * + ! yyyymmdd Year, Month, Day * + ! * + ! Constants: * + ! igreg help constant * + ! * + !***************************************************************************** + + implicit none + + integer :: yyyymmdd,yyyy,mm,dd,hhmiss,hh,mi,ss + integer :: julday,ja,jb,jc,jd,je,jalpha + real(kind=dp) :: juliandate + integer,parameter :: igreg=2299161 + + julday=int(juliandate) + if ((juliandate-julday)*86400._dp .ge. 86399.5_dp) then + juliandate = juliandate + juliandate-julday-86399.5_dp/86400._dp + julday=int(juliandate) + endif + 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*(juliandate-real(julday,kind=dp))) + mi=int(1440._dp*(juliandate-real(julday,kind=dp))-60._dp*real(hh,kind=dp)) + ss=nint(86400._dp*(juliandate-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/date_mod.f90 b/src/date_mod.f90 index eadf4951051cab498b07c44241d9d0f7fa98f50b..015eb31a52a4c223b5d7ff39a02b6c02be85d1f5 100644 --- a/src/date_mod.f90 +++ b/src/date_mod.f90 @@ -10,83 +10,12 @@ module date_mod use par_mod, only: dp - - implicit none - -contains - -subroutine caldate(juliandate,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 * - ! juliandate Julian Date * - ! julday help variable * - ! mi Minute * - ! mm Month * - ! ss Seconds * - ! yyyy Year * - ! yyyymmdd Year, Month, Day * - ! * - ! Constants: * - ! igreg help constant * - ! * - !***************************************************************************** implicit none - integer :: yyyymmdd,yyyy,mm,dd,hhmiss,hh,mi,ss - integer :: julday,ja,jb,jc,jd,je,jalpha - real(kind=dp) :: juliandate - integer,parameter :: igreg=2299161 - - julday=int(juliandate) - if ((juliandate-julday)*86400._dp .ge. 86399.5_dp) then - juliandate = juliandate + juliandate-julday-86399.5_dp/86400._dp - julday=int(juliandate) - endif - 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*(juliandate-real(julday,kind=dp))) - mi=int(1440._dp*(juliandate-real(julday,kind=dp))-60._dp*real(hh,kind=dp)) - ss=nint(86400._dp*(juliandate-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 +contains -end subroutine caldate +#include "dat_caldate.f90" real(kind=dp) function juldate(yyyymmdd,hhmiss) diff --git a/src/dry_alloc_drydepo.f90 b/src/dry_alloc_drydepo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..714e41dca7aecfc646fbe90addbf944c4d22149f --- /dev/null +++ b/src/dry_alloc_drydepo.f90 @@ -0,0 +1,14 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine alloc_drydepo + + implicit none + + if (.not. drydep) return + write(*,*) 'allocate drydepo fields' + allocate(xlanduse(0:nxmax-1,0:nymax-1,numclass), & + xlandusen(0:nxmaxn-1,0:nymaxn-1,numclass,maxnests), & + vdep(0:nxmax-1,0:nymax-1,maxspec,numwfmem)) + +end subroutine alloc_drydepo diff --git a/src/dry_assignland.f90 b/src/dry_assignland.f90 new file mode 100644 index 0000000000000000000000000000000000000000..699587f1e995bdc973485fa0758f8bbd1bd9cefd --- /dev/null +++ b/src/dry_assignland.f90 @@ -0,0 +1,218 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine assignland + + !***************************************************************************** + ! * + ! This routine assigns fractions of the 13 landuse classes to each ECMWF * + ! grid point. * + ! The landuse inventory of * + ! * + ! 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 * + ! * + ! if there are no data in the inventory * + ! 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 * + ! 29 December 2006 new landuse inventory, S. Eckhardt * + !***************************************************************************** + ! * + ! Variables: * + ! xlanduse fractions of numclass landuses for each model grid point * + ! landinvent landuse inventory (0.3 deg resolution) * + ! * + !***************************************************************************** + + implicit none + + integer :: ix,jy,k,l,li,nrefine,iix,jjy + integer,parameter :: lumaxx=1200,lumaxy=600 + integer,parameter :: xlon0lu=-180,ylat0lu=-90 + real,parameter :: dxlu=0.3 + real :: xlon,ylat,sumperc,p,xi,yj + real :: xlandusep(lumaxx,lumaxy,numclass) + ! character*2 ck + + if (.not.DRYDEP) return + + 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 + + ! do 13 k=1,11 + ! write (ck,'(i2.2)') k + ! open(4,file='xlandusetest'//ck,form='formatted') + ! do 11 ix=1,lumaxx + !11 write (4,*) (xlandusep(ix,jy,k),jy=1,lumaxy) + !11 write (4,*) (landinvent(ix,jy,k),jy=1,lumaxy) + !13 close(4) + + ! write (*,*) xlon0,ylat0,xlon0n(1),ylat0n(1),nxmin1,nymin1 + ! write (*,*) dx, dy, dxout, dyout, ylat0, xlon0 + nrefine=10 + do ix=0,nxmin1 + do jy=0,nymin1 + do k=1,numclass + sumperc=0. + xlanduse(ix,jy,k)=0. + end do + do iix=1, nrefine + xlon=(ix+(iix-1)/real(nrefine))*dx+xlon0 ! longitude, should be between -180 and 179 + if (xlon.ge.(xlon0lu+lumaxx*dxlu)) then + xlon=xlon-lumaxx*dxlu + endif + do jjy=1, nrefine + ylat=(jy+(jjy-1)/real(nrefine))*dy+ylat0 ! and lat. of each gridpoint + 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 + + !*********************************** + ! for test: write out xlanduse + + ! 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' + + !**************************************** + ! Same as above, but for the nested grids + !**************************************** + + !************** TEST ******************** + ! dyn(1)=dyn(1)/40 + ! dxn(1)=dxn(1)/40 + ! xlon0n(1)=1 + ! ylat0n(1)=50 + !************** TEST ******************** + + do l=1,numbnests + do ix=0,nxn(l)-1 + do jy=0,nyn(l)-1 + do k=1,numclass + sumperc=0. + xlandusen(ix,jy,k,l)=0. + end do + do iix=1, nrefine + xlon=(ix+(iix-1)/real(nrefine))*dxn(l)+xlon0n(l) + do jjy=1, nrefine + ylat=(jy+(jjy-1)/real(nrefine))*dyn(l)+ylat0n(l) + 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 + + !*********************************** + ! for test: write out xlanduse + + ! do 66 k=1,11 + ! write (ck,'(i2.2)') k + ! open(4,file='nlandusetest'//ck,form='formatted') + ! do 65 ix=0,nxn(1)-1 + !65 write (4,*) (xlandusen(ix,jy,k,1),jy=0,nyn(1)-1) + !66 close(4) + + ! write (*,*) 'landuse nested written' +end subroutine assignland diff --git a/src/dry_dealloc_drydepo.f90 b/src/dry_dealloc_drydepo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f934fa45ebc353e317682ace92b1c0c2c6469235 --- /dev/null +++ b/src/dry_dealloc_drydepo.f90 @@ -0,0 +1,9 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine dealloc_drydepo + + if (.not. drydep) return + deallocate(xlanduse,xlandusen,vdep) + +end subroutine dealloc_drydepo diff --git a/src/dry_drydepo_massloss.f90 b/src/dry_drydepo_massloss.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5c91f42339374cb5ff57cfd015f95ee2b00eddf6 --- /dev/null +++ b/src/dry_drydepo_massloss.f90 @@ -0,0 +1,33 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine drydepo_massloss(ipart,ks,ldeltat,drydepopart) + use particle_mod + + implicit none + + integer,intent(in) :: & + ipart, & ! particle index + ks, & ! species index + ldeltat ! radioactive decay time + real(dep_prec),intent(out) :: & + drydepopart ! drydeposit for particle ipart + real decfact ! radioactive decay factor + + if (decay(ks).gt.0.) then ! radioactive decay + decfact=exp(-real(abs(lsynctime))*decay(ks)) + else + decfact=1. + endif + drydepopart=part(ipart)%mass(ks)*part(ipart)%prob(ks)*decfact + + part(ipart)%drydepo(ks)=part(ipart)%drydepo(ks)+ & + part(ipart)%mass(ks)*part(ipart)%prob(ks)*decfact + + part(ipart)%mass(ks)=part(ipart)%mass(ks)*(1.-part(ipart)%prob(ks))*decfact + + if (decay(ks).gt.0.) then ! correct for decay (see wetdepo) + drydepopart=drydepopart*exp(real(abs(ldeltat))*decay(ks)) + endif + +end subroutine drydepo_massloss diff --git a/src/dry_drydepo_probability.f90 b/src/dry_drydepo_probability.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c56eb5dc0c3031faca01c4789787bf3fb0e061e0 --- /dev/null +++ b/src/dry_drydepo_probability.f90 @@ -0,0 +1,40 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine drydepo_probability(prob,dt,zts,vdepo) + use par_mod + use com_mod + use interpol_mod + + implicit none + + real,intent(inout) :: prob(maxspec) + real,intent(inout) :: vdepo(maxspec) ! deposition velocities for all species + real,intent(in) :: dt,zts ! real(ldt), real(zt) + integer :: ns,m ! loop variable over species + real :: vdeptemp(2) + + if ((DRYDEP).and.(zts.lt.2.*href)) then + do ns=1,nspec + if (DRYDEPSPEC(ns)) then + if (depoindicator(ns)) then + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(vdep,vdeptemp(m),ns,memind(m),maxspec) + end do + else + do m=1,2 + call hor_interpol_nest(vdepn,vdeptemp(m),ns,memind(m),maxspec) + end do + endif + call temp_interpol(vdeptemp(1),vdeptemp(2),vdepo(ns)) + 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(ns)=1.+(prob(ns)-1.)*exp(-vdepo(ns)*abs(dt)/(2.*href)) + !if (pp.eq.535) write(*,*) 'advance1', ks,dtt,p1,vdep(ix,jy,ks,1) + endif + end do + endif +end subroutine drydepo_probability diff --git a/src/dry_drydepokernel.f90 b/src/dry_drydepokernel.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cbcd572fd014589f62a38789c94542a4e8849d8c --- /dev/null +++ b/src/dry_drydepokernel.f90 @@ -0,0 +1,138 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine drydepokernel(nunc,deposit,x,y,nage,kp,thread) + ! 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 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! nunc uncertainty class of the respective particle * + ! nage age class of the respective particle * + ! deposit amount (kg) to be deposited * + ! * + !***************************************************************************** + ! Changes: + ! eso 10/2016: Added option to disregard kernel + ! + !***************************************************************************** + + implicit none + + integer,intent(in) :: thread + real(dep_prec), dimension(maxspec) :: deposit + real :: x,y,ddx,ddy,xl,yl,wx,wy,w + integer :: ix,jy,ixp,jyp,ks,nunc,nage,kp + + + xl=(x*dx+xoutshift)/dxout + yl=(y*dy+youtshift)/dyout + ix=int(xl) + jy=int(yl) + 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 + + ! If no kernel is used, direct attribution to grid cell + !****************************************************** + + if (.not.lusekerneloutput) then + 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 +#ifdef _OPENMP + gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks) +#else + drygridunc(ix,jy,ks,kp,nunc,nage)= & + drygridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks) +#endif + end if + end if + end do + else ! use kernel + + + ! 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 +#ifdef _OPENMP + gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + drygridunc(ix,jy,ks,kp,nunc,nage)= & + drygridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w +#endif + 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) +#ifdef _OPENMP + gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + drygridunc(ixp,jyp,ks,kp,nunc,nage)= & + drygridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. & + (jy.le.numygrid-1)) then + w=(1.-wx)*wy +#ifdef _OPENMP + gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + drygridunc(ixp,jy,ks,kp,nunc,nage)= & + drygridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. & + (jyp.le.numygrid-1)) then + w=wx*(1.-wy) +#ifdef _OPENMP + gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + drygridunc(ix,jyp,ks,kp,nunc,nage)= & + drygridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + endif ! deposit>0 + end do + end if +end subroutine drydepokernel diff --git a/src/dry_drydepokernel_nest.f90 b/src/dry_drydepokernel_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b52e02e64b99024f0b05dab111191b530e409a40 --- /dev/null +++ b/src/dry_drydepokernel_nest.f90 @@ -0,0 +1,118 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine drydepokernel_nest(nunc,deposit,x,y,nage,kp,thread) + ! 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 * + ! * + !***************************************************************************** + + implicit none + + integer,intent(in) :: thread + real(dep_prec), dimension(maxspec) :: deposit + real :: x,y,ddx,ddy,xl,yl,wx,wy,w + integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage + + + + xl=(x*dx+xoutshiftn)/dxoutn + yl=(y*dy+youtshiftn)/dyoutn + ix=int(xl) + jy=int(yl) + 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 +#ifdef _OPENMP + griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & + griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + drygriduncn(ix,jy,ks,kp,nunc,nage)= & + drygriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w +#endif + 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) +#ifdef _OPENMP + griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= & + griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + drygriduncn(ixp,jyp,ks,kp,nunc,nage)= & + drygriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. & + (jy.le.numygridn-1)) then + w=(1.-wx)*wy +#ifdef _OPENMP + griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= & + griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + drygriduncn(ixp,jy,ks,kp,nunc,nage)= & + drygriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. & + (jyp.le.numygridn-1)) then + w=wx*(1.-wy) +#ifdef _OPENMP + griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= & + griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + drygriduncn(ix,jyp,ks,kp,nunc,nage)= & + drygriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + endif + + end do +end subroutine drydepokernel_nest diff --git a/src/dry_get_vdep_prob.f90 b/src/dry_get_vdep_prob.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8b2bf7bd2c6eb97e9c2cddfbeef5f0c0fbe6ffe1 --- /dev/null +++ b/src/dry_get_vdep_prob.f90 @@ -0,0 +1,98 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine get_vdep_prob(itime,xt,yt,zt,prob) + ! i i i i o + !***************************************************************************** + ! * + ! Calculation of the probability for dry deposition * + ! * + ! Particle positions are read in - prob returned * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! 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 * + ! 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 * + ! prob probability of absorption due to dry deposition * + ! vdepo Deposition velocities for all species * + ! xt,yt,zt Particle position * + ! * + !***************************************************************************** + + use point_mod + use par_mod + use com_mod + use interpol_mod + + implicit none + + real :: xt,yt,zt + integer :: itime,i,j,k,memindnext + integer :: ks,m!nix,njy, + real :: prob(maxspec),vdepo(maxspec),vdeptemp(2) + real :: eps + + eps=nxmax/3.e5 + + if (DRYDEP) then ! reset probability for deposition + do ks=1,nspec + depoindicator(ks)=.true. + prob(ks)=0. + end do + endif + + + ! Determine whether lat/long grid or polarstereographic projection + ! is to be used + ! Furthermore, determine which nesting level to be used + !***************************************************************** + call find_ngrid(xt,yt) + + !*************************** + ! Interpolate necessary data + !*************************** + + if (abs(itime-memtime(1)).lt.abs(itime-memtime(2))) then + memindnext=1 + else + memindnext=2 + endif + + ! Determine nested grid coordinates + !********************************** + call find_grid_indices(xt,yt) + + ! Determine probability of deposition + !************************************ + + if ((DRYDEP).and.(real(zt).lt.2.*href)) then + do ks=1,nspec + if (DRYDEPSPEC(ks)) then + if (depoindicator(ks)) then + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(vdep,vdeptemp(m),ks,memind(m),maxspec) + end do + else + do m=1,2 + call hor_interpol_nest(vdepn,vdeptemp(m),ks,memind(m),maxspec) + end do + endif + call temp_interpol(vdeptemp(1),vdeptemp(2),vdepo(ks)) + 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)=vdepo(ks) + ! prob(ks)=vdepo(ks)/2./href + ! instead of prob - return vdepo -> result kg/m2/s + endif + end do + endif +end subroutine get_vdep_prob diff --git a/src/dry_getrb.f90 b/src/dry_getrb.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2fbbd6f3961481497dec14e857a723d213358cea --- /dev/null +++ b/src/dry_getrb.f90 @@ -0,0 +1,40 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 * + ! * + !***************************************************************************** + + 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/dry_getrc.f90 b/src/dry_getrc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2a4d42413b0926ad9cb5a0a755f843e668d387c5 --- /dev/null +++ b/src/dry_getrc.f90 @@ -0,0 +1,100 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 * + ! * + !***************************************************************************** + + 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/dry_getvdep.f90 b/src/dry_getvdep.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3b1a764f186b191a779d0d3a451dc2e22b30f488 --- /dev/null +++ b/src/dry_getvdep.f90 @@ -0,0 +1,185 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine getvdep(n,ix,jy,ust,temp,pa,L,gr,rh,rr,snow,vdepo) + ! i 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 date_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 :: 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 + + ! 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 + !**************************** + + ! Why is this different from the viscosity funtion??? + + 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)) + 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, & + rhoa,vdepo) + + !if (debug_mode) then + ! print*,'getvdep:188: vdepo=', vdepo + !stop + !endif + + ! 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/dry_getvdep_nest.f90 b/src/dry_getvdep_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..484a0a6e45930e5aa63b6af693daad37c69a11f8 --- /dev/null +++ b/src/dry_getvdep_nest.f90 @@ -0,0 +1,182 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine getvdep_nest(n,ix,jy,ust,temp,pa, & + L,gr,rh,rr,snow,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 date_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 :: 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 + + ! 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, & + rhoa,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_nest diff --git a/src/dry_part0.f90 b/src/dry_part0.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d1be653e64be14a144b37259885ae369ad783b02 --- /dev/null +++ b/src/dry_part0.f90 @@ -0,0 +1,125 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine part0(dquer,dsigma,density,ni,fract,schmi,cun,vsh) + ! i 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 * + ! * + !***************************************************************************** + + implicit none + + real,parameter :: tr=293.15 + + integer :: i,ni + real :: dquer,dsigma,density,xdummy,d01,d02,delta,x01,x02 + real :: dmean,alpha,cun,dc,schmidt,kn,erf,fract_norm + real,dimension(ni),intent(inout) :: fract,schmi,vsh + 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 + !********************************************************* + ! Normalisation. Why was it not normalised? + !****************************************** + x01=alog(dsigma**3)/xdummy + x02=alog(dsigma**(-3))/xdummy + fract_norm=0.5*(erf(x01)-erf(x02)) + + 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 + !print*,'part0:: d02=' , d02 , 'd01=', d01 + + ! Area under Gauss-function is calculated and gives mass fraction of interval + !**************************************************************************** + + fract(i)=0.5*(erf(x01)-erf(x02))/fract_norm + !print*,'part0:: fract(',i,')', fract(i) + !print*,'part0:: fract', fract(i), x01, x02, erf(x01), erf(x02) + + ! Geometric mean diameter of interval in [m] + !******************************************* + + dmean=1.E-6*exp(0.5*alog(d01*d02)) + !print*,'part0:: dmean=', dmean + + ! 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) + + !print*,'part0:: vsh(',i,')', vsh(i) + + end do + + !stop 'part0' +end subroutine part0 diff --git a/src/dry_partdep.f90 b/src/dry_partdep.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f68d8a0405b113935a68c26fce890c3e100b29a3 --- /dev/null +++ b/src/dry_partdep.f90 @@ -0,0 +1,183 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine partdep(nc,density,fract,schmi,vset,ra,ustar,nyl,rhoa,vdep) + ! i i 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 * + ! * + !***************************************************************************** + + implicit none + + real, intent(in) :: & + nyl, & ! kinematic viscosity + rhoa, & ! air density + ustar, & ! friction velocity + ra, & ! aerodynamical resistance + vset(maxspec,maxndia), & ! gravitational settling velocity of each interval + density(maxspec), & ! density of the particle + fract(maxspec,maxndia) ! mass fraction of each diameter interval + real, intent(inout) :: & + vdep(maxspec) + real :: schmi(maxspec,maxndia) + real :: stokes,vdepj,rdp,alpha + real :: & ! Variables related to shape + dfdr, alpha1, alpha2, beta1, beta2, ks, kn, c_d, & + settling, settling_old, reynolds, ks1, ks2, kn1, kn2 + + real,parameter :: eps=1.e-5 + integer :: ic,j,nc,i + + + do ic=1,nc ! loop over all species + if (density(ic).gt.0.) then + do j=1,ndia(ic) ! loop over all diameter intervals + if (ustar.gt.eps) then + if (shape(ic).eq.0) then + + ! Stokes number for each diameter interval + !***************************************** + ! Use this stokes number for different shapes + 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 ! Daria Tatsii: Drag coefficient scheme by Bagheri & Bonadonna 2016 + ! Settling velocities of other shapes + dfdr=density(ic)/rhoa + + reynolds=dquer(ic)/1.e6*vset(ic,j)/nyl + settling_old=-1.0*vset(ic,j) + + ! Orientation of particles + !************************* + if (orient(ic).eq.0) then + ! Horizontal orientation + alpha2=0.77 ! B&B: eq. 32 + beta2=0.63 + ks=0.5*((Fs(ic)**0.05)+(Fs(ic)**(-0.36))) ! B&B Figure 12 k_(s,max) + kn=10.**(alpha2*(-log10(Fn(ic)))**beta2) + else if (orient(ic).eq.1) then + ! Random orientation + alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0) + beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0) + ks=(Fs(ic)**(1./3.) + Fs(ic)**(-1./3))/2. + kn=10.**(alpha1*(-log10(Fn(ic)))**beta1) + else + ! The average of random and horizontal orientation + alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0) + beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0) + alpha2=0.77 ! B&B: eq. 32 + beta2=0.63 + ks1=(Fs(ic)**(1./3.) + Fs(ic)**(-1./3))/2. + kn1=10.**(alpha1*(-log10(Fn(ic)))**beta1) + ks2=0.5*((Fs(ic)**0.05)+(Fs(ic)**(-0.36))) ! B&B Figure 12 k_(s,max) + kn2=10.**(alpha2*(-log10(Fn(ic)))**beta2) + ks=(ks1+ks2)/2. + kn=(kn1+kn2)/2. + endif + + do i=1,20 + c_d=(24.*ks/reynolds)*(1.+0.125*((reynolds*kn/ks)**(2./3.)))+ & + (0.46*kn/(1.+5330./(reynolds*kn/ks))) + + ! Settling velocity of a particle is defined by the Newton's impact law: + settling=-1.* & + sqrt(4.*ga*dquer(ic)/1.e6*density(ic)*cunningham(ic)/ & + (3.*c_d*rhoa)) + + if (abs((settling-settling_old)/settling).lt.0.01) exit + + reynolds=dquer(ic)/1.e6*abs(settling)/nyl + settling_old=settling + end do + ! We assume aerodynamic resistance ra and quasi-laminar sub-layer resistance rdp + ! Stokes number for each diameter interval + !***************************************** + ! Use this stokes number for different shapes + stokes=abs(settling)/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=abs(settling)+1./(ra+rdp+ra*rdp*abs(settling)) + + endif + + 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/dry_raerod.f90 b/src/dry_raerod.f90 new file mode 100644 index 0000000000000000000000000000000000000000..407abe2684cac0bc8e08111425bb5c05acd087db --- /dev/null +++ b/src/dry_raerod.f90 @@ -0,0 +1,44 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real 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 turbulence_mod, only: psih + + implicit none + + real :: l,ust,z0 + + raerod=(alog(href/z0)-psih(href,l)+psih(z0,l))/(karman*ust) + +end function raerod diff --git a/src/drydepo_mod.f90 b/src/drydepo_mod.f90 index 231348cfce9f134540664f32f20255692d56b19e..f473a70901a1dc40fef8f9ec03891268874f5146 100644 --- a/src/drydepo_mod.f90 +++ b/src/drydepo_mod.f90 @@ -14,10 +14,10 @@ module drydepo_mod use unc_mod use windfields_mod use erf_mod - + implicit none - real,allocatable,dimension(:,:,:) :: xlanduse + real,allocatable,dimension(:,:,:) :: xlanduse ! area fractions in percent [0-1] real,allocatable,dimension(:,:,:,:) :: xlandusen ! nested area fractions in percent [0-1] @@ -25,1501 +25,34 @@ module drydepo_mod contains -subroutine alloc_drydepo - - implicit none - - if (.not. drydep) return - write(*,*) 'allocate drydepo fields' - allocate(xlanduse(0:nxmax-1,0:nymax-1,numclass), & - xlandusen(0:nxmaxn-1,0:nymaxn-1,numclass,maxnests), & - vdep(0:nxmax-1,0:nymax-1,maxspec,numwfmem)) - -end subroutine alloc_drydepo - -subroutine dealloc_drydepo - - if (.not. drydep) return - deallocate(xlanduse,xlandusen,vdep) - -end subroutine dealloc_drydepo - -subroutine assignland - - !***************************************************************************** - ! * - ! This routine assigns fractions of the 13 landuse classes to each ECMWF * - ! grid point. * - ! The landuse inventory of * - ! * - ! 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 * - ! * - ! if there are no data in the inventory * - ! 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 * - ! 29 December 2006 new landuse inventory, S. Eckhardt * - !***************************************************************************** - ! * - ! Variables: * - ! xlanduse fractions of numclass landuses for each model grid point * - ! landinvent landuse inventory (0.3 deg resolution) * - ! * - !***************************************************************************** - - implicit none - - integer :: ix,jy,k,l,li,nrefine,iix,jjy - integer,parameter :: lumaxx=1200,lumaxy=600 - integer,parameter :: xlon0lu=-180,ylat0lu=-90 - real,parameter :: dxlu=0.3 - real :: xlon,ylat,sumperc,p,xi,yj - real :: xlandusep(lumaxx,lumaxy,numclass) - ! character*2 ck - - if (.not.DRYDEP) return - - 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 - - ! do 13 k=1,11 - ! write (ck,'(i2.2)') k - ! open(4,file='xlandusetest'//ck,form='formatted') - ! do 11 ix=1,lumaxx - !11 write (4,*) (xlandusep(ix,jy,k),jy=1,lumaxy) - !11 write (4,*) (landinvent(ix,jy,k),jy=1,lumaxy) - !13 close(4) - - ! write (*,*) xlon0,ylat0,xlon0n(1),ylat0n(1),nxmin1,nymin1 - ! write (*,*) dx, dy, dxout, dyout, ylat0, xlon0 - nrefine=10 - do ix=0,nxmin1 - do jy=0,nymin1 - do k=1,numclass - sumperc=0. - xlanduse(ix,jy,k)=0. - end do - do iix=1, nrefine - xlon=(ix+(iix-1)/real(nrefine))*dx+xlon0 ! longitude, should be between -180 and 179 - if (xlon.ge.(xlon0lu+lumaxx*dxlu)) then - xlon=xlon-lumaxx*dxlu - endif - do jjy=1, nrefine - ylat=(jy+(jjy-1)/real(nrefine))*dy+ylat0 ! and lat. of each gridpoint - 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 - - !*********************************** - ! for test: write out xlanduse - - ! 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' - - !**************************************** - ! Same as above, but for the nested grids - !**************************************** - - !************** TEST ******************** - ! dyn(1)=dyn(1)/40 - ! dxn(1)=dxn(1)/40 - ! xlon0n(1)=1 - ! ylat0n(1)=50 - !************** TEST ******************** - - do l=1,numbnests - do ix=0,nxn(l)-1 - do jy=0,nyn(l)-1 - do k=1,numclass - sumperc=0. - xlandusen(ix,jy,k,l)=0. - end do - do iix=1, nrefine - xlon=(ix+(iix-1)/real(nrefine))*dxn(l)+xlon0n(l) - do jjy=1, nrefine - ylat=(jy+(jjy-1)/real(nrefine))*dyn(l)+ylat0n(l) - 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 - - !*********************************** - ! for test: write out xlanduse - - ! do 66 k=1,11 - ! write (ck,'(i2.2)') k - ! open(4,file='nlandusetest'//ck,form='formatted') - ! do 65 ix=0,nxn(1)-1 - !65 write (4,*) (xlandusen(ix,jy,k,1),jy=0,nyn(1)-1) - !66 close(4) - - ! write (*,*) 'landuse nested written' -end subroutine assignland - -real 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 turbulence_mod, only: psih - - implicit none - - real :: l,ust,z0 - - raerod=(alog(href/z0)-psih(href,l)+psih(z0,l))/(karman*ust) - -end function raerod - -subroutine drydepo_massloss(ipart,ks,ldeltat,drydepopart) - use particle_mod - - implicit none - - integer,intent(in) :: & - ipart, & ! particle index - ks, & ! species index - ldeltat ! radioactive decay time - real(dep_prec),intent(out) :: & - drydepopart ! drydeposit for particle ipart - real decfact ! radioactive decay factor - - if (decay(ks).gt.0.) then ! radioactive decay - decfact=exp(-real(abs(lsynctime))*decay(ks)) - else - decfact=1. - endif - drydepopart=part(ipart)%mass(ks)*part(ipart)%prob(ks)*decfact - - part(ipart)%drydepo(ks)=part(ipart)%drydepo(ks)+ & - part(ipart)%mass(ks)*part(ipart)%prob(ks)*decfact - - part(ipart)%mass(ks)=part(ipart)%mass(ks)*(1.-part(ipart)%prob(ks))*decfact - - if (decay(ks).gt.0.) then ! correct for decay (see wetdepo) - drydepopart=drydepopart*exp(real(abs(ldeltat))*decay(ks)) - endif - -end subroutine drydepo_massloss - -subroutine drydepokernel(nunc,deposit,x,y,nage,kp,thread) - ! 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 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! nunc uncertainty class of the respective particle * - ! nage age class of the respective particle * - ! deposit amount (kg) to be deposited * - ! * - !***************************************************************************** - ! Changes: - ! eso 10/2016: Added option to disregard kernel - ! - !***************************************************************************** - - implicit none - - integer,intent(in) :: thread - real(dep_prec), dimension(maxspec) :: deposit - real :: x,y,ddx,ddy,xl,yl,wx,wy,w - integer :: ix,jy,ixp,jyp,ks,nunc,nage,kp - - - xl=(x*dx+xoutshift)/dxout - yl=(y*dy+youtshift)/dyout - ix=int(xl) - jy=int(yl) - 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 - - ! If no kernel is used, direct attribution to grid cell - !****************************************************** - - if (.not.lusekerneloutput) then - 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 -#ifdef _OPENMP - gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks) -#else - drygridunc(ix,jy,ks,kp,nunc,nage)= & - drygridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks) -#endif - end if - end if - end do - else ! use kernel - - - ! 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 -#ifdef _OPENMP - gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - drygridunc(ix,jy,ks,kp,nunc,nage)= & - drygridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w -#endif - 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) -#ifdef _OPENMP - gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - drygridunc(ixp,jyp,ks,kp,nunc,nage)= & - drygridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. & - (jy.le.numygrid-1)) then - w=(1.-wx)*wy -#ifdef _OPENMP - gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - drygridunc(ixp,jy,ks,kp,nunc,nage)= & - drygridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. & - (jyp.le.numygrid-1)) then - w=wx*(1.-wy) -#ifdef _OPENMP - gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - drygridunc(ix,jyp,ks,kp,nunc,nage)= & - drygridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - endif ! deposit>0 - end do - end if -end subroutine drydepokernel - -subroutine drydepokernel_nest(nunc,deposit,x,y,nage,kp,thread) - ! 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 * - ! * - !***************************************************************************** - - implicit none - - integer,intent(in) :: thread - real(dep_prec), dimension(maxspec) :: deposit - real :: x,y,ddx,ddy,xl,yl,wx,wy,w - integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage - - - - xl=(x*dx+xoutshiftn)/dxoutn - yl=(y*dy+youtshiftn)/dyoutn - ix=int(xl) - jy=int(yl) - 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 -#ifdef _OPENMP - griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & - griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - drygriduncn(ix,jy,ks,kp,nunc,nage)= & - drygriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w -#endif - 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) -#ifdef _OPENMP - griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= & - griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - drygriduncn(ixp,jyp,ks,kp,nunc,nage)= & - drygriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. & - (jy.le.numygridn-1)) then - w=(1.-wx)*wy -#ifdef _OPENMP - griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= & - griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - drygriduncn(ixp,jy,ks,kp,nunc,nage)= & - drygriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. & - (jyp.le.numygridn-1)) then - w=wx*(1.-wy) -#ifdef _OPENMP - griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= & - griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - drygriduncn(ix,jyp,ks,kp,nunc,nage)= & - drygriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - endif - - end do -end subroutine drydepokernel_nest - -subroutine part0(dquer,dsigma,density,ni,fract,schmi,cun,vsh) - ! i 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 * - ! * - !***************************************************************************** - - implicit none - - real,parameter :: tr=293.15 - - integer :: i,ni - real :: dquer,dsigma,density,xdummy,d01,d02,delta,x01,x02 - real :: dmean,alpha,cun,dc,schmidt,kn,erf,fract_norm - real,dimension(ni),intent(inout) :: fract,schmi,vsh - 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 - !********************************************************* - ! Normalisation. Why was it not normalised? - !****************************************** - x01=alog(dsigma**3)/xdummy - x02=alog(dsigma**(-3))/xdummy - fract_norm=0.5*(erf(x01)-erf(x02)) - - 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 - !print*,'part0:: d02=' , d02 , 'd01=', d01 - - ! Area under Gauss-function is calculated and gives mass fraction of interval - !**************************************************************************** - - fract(i)=0.5*(erf(x01)-erf(x02))/fract_norm - !print*,'part0:: fract(',i,')', fract(i) - !print*,'part0:: fract', fract(i), x01, x02, erf(x01), erf(x02) - - ! Geometric mean diameter of interval in [m] - !******************************************* - - dmean=1.E-6*exp(0.5*alog(d01*d02)) - !print*,'part0:: dmean=', dmean - - ! 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) - - !print*,'part0:: vsh(',i,')', vsh(i) - - end do - - !stop 'part0' -end subroutine part0 - -subroutine get_vdep_prob(itime,xt,yt,zt,prob) - ! i i i i o - !***************************************************************************** - ! * - ! Calculation of the probability for dry deposition * - ! * - ! Particle positions are read in - prob returned * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! 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 * - ! 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 * - ! prob probability of absorption due to dry deposition * - ! vdepo Deposition velocities for all species * - ! xt,yt,zt Particle position * - ! * - !***************************************************************************** - - use point_mod - use par_mod - use com_mod - use interpol_mod - - implicit none - - real :: xt,yt,zt - integer :: itime,i,j,k,memindnext - integer :: ks,m!nix,njy, - real :: prob(maxspec),vdepo(maxspec),vdeptemp(2) - real :: eps - - eps=nxmax/3.e5 - - if (DRYDEP) then ! reset probability for deposition - do ks=1,nspec - depoindicator(ks)=.true. - prob(ks)=0. - end do - endif - - - ! Determine whether lat/long grid or polarstereographic projection - ! is to be used - ! Furthermore, determine which nesting level to be used - !***************************************************************** - call find_ngrid(xt,yt) - - !*************************** - ! Interpolate necessary data - !*************************** - - if (abs(itime-memtime(1)).lt.abs(itime-memtime(2))) then - memindnext=1 - else - memindnext=2 - endif - - ! Determine nested grid coordinates - !********************************** - call find_grid_indices(xt,yt) - - ! Determine probability of deposition - !************************************ - - if ((DRYDEP).and.(real(zt).lt.2.*href)) then - do ks=1,nspec - if (DRYDEPSPEC(ks)) then - if (depoindicator(ks)) then - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(vdep,vdeptemp(m),ks,memind(m),maxspec) - end do - else - do m=1,2 - call hor_interpol_nest(vdepn,vdeptemp(m),ks,memind(m),maxspec) - end do - endif - call temp_interpol(vdeptemp(1),vdeptemp(2),vdepo(ks)) - 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)=vdepo(ks) - ! prob(ks)=vdepo(ks)/2./href - ! instead of prob - return vdepo -> result kg/m2/s - endif - end do - endif -end subroutine get_vdep_prob - -subroutine drydepo_probability(prob,dt,zts,vdepo) - use par_mod - use com_mod - use interpol_mod - - implicit none - - real,intent(inout) :: prob(maxspec) - real,intent(inout) :: vdepo(maxspec) ! deposition velocities for all species - real,intent(in) :: dt,zts ! real(ldt), real(zt) - integer :: ns,m ! loop variable over species - real :: vdeptemp(2) - - if ((DRYDEP).and.(zts.lt.2.*href)) then - do ns=1,nspec - if (DRYDEPSPEC(ns)) then - if (depoindicator(ns)) then - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(vdep,vdeptemp(m),ns,memind(m),maxspec) - end do - else - do m=1,2 - call hor_interpol_nest(vdepn,vdeptemp(m),ns,memind(m),maxspec) - end do - endif - call temp_interpol(vdeptemp(1),vdeptemp(2),vdepo(ns)) - 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(ns)=1.+(prob(ns)-1.)*exp(-vdepo(ns)*abs(dt)/(2.*href)) - !if (pp.eq.535) write(*,*) 'advance1', ks,dtt,p1,vdep(ix,jy,ks,1) - endif - end do - endif -end subroutine drydepo_probability - -subroutine getvdep(n,ix,jy,ust,temp,pa,L,gr,rh,rr,snow,vdepo) - ! i 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 date_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 :: 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 - - ! 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 - !**************************** - - ! Why is this different from the viscosity funtion??? - - 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)) - 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, & - rhoa,vdepo) - - !if (debug_mode) then - ! print*,'getvdep:188: vdepo=', vdepo - !stop - !endif - - ! 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 - -subroutine getvdep_nest(n,ix,jy,ust,temp,pa, & - L,gr,rh,rr,snow,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 date_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 :: 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 - - ! 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, & - rhoa,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_nest - -subroutine partdep(nc,density,fract,schmi,vset,ra,ustar,nyl,rhoa,vdep) - ! i i 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 * - ! * - !***************************************************************************** - - implicit none - - real, intent(in) :: & - nyl, & ! kinematic viscosity - rhoa, & ! air density - ustar, & ! friction velocity - ra, & ! aerodynamical resistance - vset(maxspec,maxndia), & ! gravitational settling velocity of each interval - density(maxspec), & ! density of the particle - fract(maxspec,maxndia) ! mass fraction of each diameter interval - real, intent(inout) :: & - vdep(maxspec) - real :: schmi(maxspec,maxndia) - real :: stokes,vdepj,rdp,alpha - real :: & ! Variables related to shape - dfdr, alpha1, alpha2, beta1, beta2, ks, kn, c_d, & - settling, settling_old, reynolds, ks1, ks2, kn1, kn2 - - real,parameter :: eps=1.e-5 - integer :: ic,j,nc,i - - - do ic=1,nc ! loop over all species - if (density(ic).gt.0.) then - do j=1,ndia(ic) ! loop over all diameter intervals - if (ustar.gt.eps) then - if (shape(ic).eq.0) then - - ! Stokes number for each diameter interval - !***************************************** - ! Use this stokes number for different shapes - 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 ! Daria Tatsii: Drag coefficient scheme by Bagheri & Bonadonna 2016 - ! Settling velocities of other shapes - dfdr=density(ic)/rhoa - - reynolds=dquer(ic)/1.e6*vset(ic,j)/nyl - settling_old=-1.0*vset(ic,j) - - ! Orientation of particles - !************************* - if (orient(ic).eq.0) then - ! Horizontal orientation - alpha2=0.77 ! B&B: eq. 32 - beta2=0.63 - ks=0.5*((Fs(ic)**0.05)+(Fs(ic)**(-0.36))) ! B&B Figure 12 k_(s,max) - kn=10.**(alpha2*(-log10(Fn(ic)))**beta2) - else if (orient(ic).eq.1) then - ! Random orientation - alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0) - beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0) - ks=(Fs(ic)**(1./3.) + Fs(ic)**(-1./3))/2. - kn=10.**(alpha1*(-log10(Fn(ic)))**beta1) - else - ! The average of random and horizontal orientation - alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0) - beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0) - alpha2=0.77 ! B&B: eq. 32 - beta2=0.63 - ks1=(Fs(ic)**(1./3.) + Fs(ic)**(-1./3))/2. - kn1=10.**(alpha1*(-log10(Fn(ic)))**beta1) - ks2=0.5*((Fs(ic)**0.05)+(Fs(ic)**(-0.36))) ! B&B Figure 12 k_(s,max) - kn2=10.**(alpha2*(-log10(Fn(ic)))**beta2) - ks=(ks1+ks2)/2. - kn=(kn1+kn2)/2. - endif - - do i=1,20 - c_d=(24.*ks/reynolds)*(1.+0.125*((reynolds*kn/ks)**(2./3.)))+ & - (0.46*kn/(1.+5330./(reynolds*kn/ks))) - - ! Settling velocity of a particle is defined by the Newton's impact law: - settling=-1.* & - sqrt(4.*ga*dquer(ic)/1.e6*density(ic)*cunningham(ic)/ & - (3.*c_d*rhoa)) - - if (abs((settling-settling_old)/settling).lt.0.01) exit - - reynolds=dquer(ic)/1.e6*abs(settling)/nyl - settling_old=settling - end do - ! We assume aerodynamic resistance ra and quasi-laminar sub-layer resistance rdp - ! Stokes number for each diameter interval - !***************************************** - ! Use this stokes number for different shapes - stokes=abs(settling)/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=abs(settling)+1./(ra+rdp+ra*rdp*abs(settling)) - - endif - - 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 - -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 * - ! * - !***************************************************************************** - - 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 - -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 * - ! * - !***************************************************************************** - - 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 - +#include "dry_alloc_drydepo.f90" - ! Correct stomatal resistance for effect of dew and rain - !******************************************************* +#include "dry_dealloc_drydepo.f90" - if ((rh.gt.0.9).or.(rr.gt.0.)) rs=rs*3. +#include "dry_assignland.f90" - ! Compute the lower canopy resistance - !************************************ +#include "dry_raerod.f90" - rdc=100.*(1.+1000./(gr+10.)) +#include "dry_drydepo_massloss.f90" +#include "dry_drydepokernel.f90" - corr=1000.*exp(-1.*t-4.) - do ic=1,nc - if (reldiff(ic).gt.0.) then +#include "dry_drydepokernel_nest.f90" - ! Compute combined stomatal and mesophyll resistance - !*************************************************** +#include "dry_part0.f90" - rsm=rs*reldiff(ic)+rm(ic) +#include "dry_get_vdep_prob.f90" - ! Correct leaf cuticular, lower canopy and ground resistance - !*********************************************************** +#include "dry_drydepo_probability.f90" - rluc=rlu(ic,i,j)+corr - rclc=rcl(ic,i,j)+corr - rgsc=rgs(ic,i,j)+corr +#include "dry_getvdep.f90" - ! Correct leaf cuticular resistance for effect of dew and rain - !************************************************************* +#include "dry_getvdep_nest.f90" - 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 +#include "dry_partdep.f90" - ! Combine resistances to give total resistance - !********************************************* +#include "dry_getrb.f90" - 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 +#include "dry_getrc.f90" end module drydepo_mod diff --git a/src/erf_erf.f90 b/src/erf_erf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..040ac64a7d0ffcc7dfb98bd1ebcef7d4dd9af478 --- /dev/null +++ b/src/erf_erf.f90 @@ -0,0 +1,16 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +function erf(x) + + implicit none + + real :: x, erf + !real, external :: gammp + + if(x.lt.0.)then + erf=-gammp(.5,x**2) + else + erf=gammp(.5,x**2) + endif +end function erf diff --git a/src/erf_erfc.f90 b/src/erf_erfc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6da3862fe59692f363fc5b1fe173e153aa2dbbf5 --- /dev/null +++ b/src/erf_erfc.f90 @@ -0,0 +1,16 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +function erfc(x) + + implicit none + + real :: x, erfc + !real, external :: gammp, gammq + + if(x.lt.0.)then + erfc=1.+gammp(.5,x**2) + else + erfc=gammq(.5,x**2) + endif +end function erfc diff --git a/src/erf_erfcc.f90 b/src/erf_erfcc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f486f77e129ffb72b9a61dba208a7e854b005e9c --- /dev/null +++ b/src/erf_erfcc.f90 @@ -0,0 +1,16 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +function erfcc(x) + + implicit none + + real :: x, z, t, erfcc + + 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 +end function erfcc diff --git a/src/erf_flexpart.f90 b/src/erf_flexpart.f90 new file mode 100644 index 0000000000000000000000000000000000000000..75a2520b418d8de6436f6279380994c016aca394 --- /dev/null +++ b/src/erf_flexpart.f90 @@ -0,0 +1,147 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +program flexpart + + !***************************************************************************** + ! * + ! This is the Lagrangian Particle Dispersion Model FLEXPART. * + ! 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 * + ! * + !***************************************************************************** + ! Changes: * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! (moved to read_options_and_initialise_flexpart by LB) * + ! - Added detection of metdata format using gributils routines * + ! - Distinguished calls to ecmwf/gfs gridcheck versions based on * + ! detected metdata format * + ! - Passed metdata format down to timemanager * + ! L. Bakels 2022 * + ! - OpenMP parallelisation * + ! - Added input options * + ! - Restructuring into subroutines (below) * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! Constants: * + ! * + !***************************************************************************** + use omp_lib, only: OMP_GET_MAX_THREADS + use par_mod + use com_mod + use timemanager_mod + use output_mod + + implicit none + + real :: s_timemanager + character(len=256) :: & + inline_options ! pathfile, flexversion, arg2 + + ! Keeping track of the total running time of FLEXPART, printed out at the end. + !***************************************************************************** + CALL SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_total = (count_clock - count_clock0)/real(count_rate) + + + ! FLEXPART version string + flexversion_major = '10' ! Major version number, also used for species file names + flexversion='Version '//trim(flexversion_major)//'.4 (2019-11-12)' + verbosity=0 + + ! Read the pathnames where input/output files are stored + !******************************************************* + + inline_options='none' + select case (iargc()) + case (2) + call getarg(1,arg1) + pathfile=arg1 + call getarg(2,arg2) + inline_options=arg2 + case (1) + call getarg(1,arg1) + pathfile=arg1 + if (arg1(1:1).eq.'-') then + write(pathfile,'(a11)') './pathnames' + inline_options=arg1 + endif + case (0) + write(pathfile,'(a11)') './pathnames' + end select + + ! Print the GPL License statement + !******************************************************* + print*,'Welcome to FLEXPART ', trim(flexversion) + print*,'FLEXPART is free software released under the GNU General Public License.' + write(*,*) 'FLEXPART is running with ', trim(wind_coord_type), 'coordinates.' + ! Reading the number of threads available and print them for user + !**************************************************************** +#ifdef _OPENMP + numthreads = OMP_GET_MAX_THREADS() + numthreads_grid = min(numthreads,max_numthreads_grid) + !numthreads = min(40,numthreads) +#else + numthreads = 1 + numthreads_grid = 1 +#endif + + if (numthreads.gt.1) then + write(*,*) + write(*,*) "*********** WARNING **********************************" + write(*,*) "* FLEXPART running in parallel mode *" + write(*,*) "* Number of uncertainty classes in *" + write(*,901) " * set to number of threads: ", & + numthreads_grid, " *" + write(*,901) " * All other computations are done with ",& + numthreads, " threads. *" + write(*,*) "*******************************************************" + write(*,*) +901 format (a,i5,a) + endif + + ! Reading user specified options, allocating fields and checking bounds + !********************************************************************** + call read_options_and_initialise_flexpart + + ! Inform whether output kernel is used or not + !********************************************* + if (lroot) then + if (.not.lusekerneloutput) then + write(*,*) "Concentrations are calculated without using kernel" + else + write(*,*) "Concentrations are calculated using kernel" + end if + end if + + if (turboff) write(*,*) 'Turbulence switched off' + + ! Calculate particle trajectories + !******************************** + CALL SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_timemanager = (count_clock - count_clock0)/real(count_rate) + + call timemanager + + CALL SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_timemanager = (count_clock - count_clock0)/real(count_rate) - s_timemanager + + CALL SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_total = (count_clock - count_clock0)/real(count_rate) - s_total + + write(*,*) 'Read wind fields: ', s_readwind, ' seconds' + write(*,*) 'Timemanager: ', s_timemanager, ' seconds,', 'first timestep: ',s_firstt, 'seconds' + write(*,*) 'Write particle files: ', s_writepart, ' seconds' + write(*,*) 'Total running time: ', s_total, ' seconds' + write(*,*) 'tps,io,tot: ', (s_timemanager-s_firstt)/4.,(s_readwind+s_writepart)/5.,s_total + write(*,*) 'CONGRATULATIONS: YOU HAVE SUCCESSFULLY COMPLETED A FLE& + &XPART MODEL RUN!' + +end program flexpart diff --git a/src/erf_gammln.f90 b/src/erf_gammln.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5b0f2eac70d76115eb6859a8502ed98e15a2041a --- /dev/null +++ b/src/erf_gammln.f90 @@ -0,0 +1,27 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +function gammln(xx) + + use par_mod, only: dp + + implicit none + + integer :: j + real :: x,tmp,ser,xx,gammln + real :: cof(6) = (/ & + 76.18009173_dp, -86.50532033_dp, 24.01409822_dp, & + -1.231739516_dp, .120858003e-2_dp, -.536382e-5_dp /) + real :: stp = 2.50662827465_dp + real :: half = 0.5_dp, one = 1.0_dp, fpf = 5.5_dp + + x=xx-one + tmp=x+fpf + tmp=(x+half)*log(tmp)-tmp + ser=one + do j=1,6 + x=x+one + ser=ser+cof(j)/x + end do + gammln=tmp+log(stp*ser) +end function gammln diff --git a/src/erf_gammp.f90 b/src/erf_gammp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cec23d3ab866ad9b3103c8a27049150c00a1f480 --- /dev/null +++ b/src/erf_gammp.f90 @@ -0,0 +1,21 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +function gammp(a,x) + + implicit none + + real :: a, x, gln, gamser, gammp, gammcf + + if(x .lt. 0. .or. a .le. 0.) then + print*, 'gammp' + stop + end if + 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 +end function gammp diff --git a/src/erf_gammq.f90 b/src/erf_gammq.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ff260d0e6ccf8656ea2c4c14595c1c8b75d631e7 --- /dev/null +++ b/src/erf_gammq.f90 @@ -0,0 +1,21 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +function gammq(a,x) + + implicit none + + real :: a, x, gln, gamser, gammq, gammcf + + if(x.lt.0..or.a.le.0.) then + print*, 'gammq' + stop + end if + 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 +end function gammq diff --git a/src/erf_gcf.f90 b/src/erf_gcf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..387301fa69d4a737b3af4ff688bf93674fb70148 --- /dev/null +++ b/src/erf_gcf.f90 @@ -0,0 +1,40 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine gcf(gammcf,a,x,gln) + + implicit none + + integer :: n + real :: gammcf, a, x, gln, gold, a0, a1, b0, b1, fac, an, anf, ana, g + !real, external :: gammln + + integer,parameter :: itmax=100 + real,parameter :: eps=3.e-7 + + gln=gammln(a) + gold=0. + a0=1. + a1=x + b0=0. + b1=1. + fac=1. + do n=1,itmax + an=real(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 + end do + print*, 'gcf: a too large, itmax too small' + stop +1 gammcf=exp(-x+a*alog(x)-gln)*g +end subroutine gcf diff --git a/src/erf_gser.f90 b/src/erf_gser.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a95ba09c4797d72469dc84d53c359f83117164e2 --- /dev/null +++ b/src/erf_gser.f90 @@ -0,0 +1,36 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine gser(gamser,a,x,gln) + + implicit none + + integer :: n + real :: gamser, a, x, gln, ap, summ, del + !real, external :: gammln + + integer,parameter :: itmax=100 + real,parameter :: eps=3.e-7 + + gln=gammln(a) + if(x.le.0.)then + if(x.lt.0.) then + print*, 'gser' + stop + end if + gamser=0. + return + endif + ap=a + summ=1./a + del=summ + do n=1,itmax + ap=ap+1. + del=del*x/ap + summ=summ+del + if(abs(del).lt.abs(summ)*eps)go to 1 + end do + print*, 'gser: a too large, itmax too small' + stop +1 gamser=summ*exp(-x+a*log(x)-gln) +end subroutine gser diff --git a/src/erf_initialise_particle.f90 b/src/erf_initialise_particle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4ff3cb7549f29a658e19eabb460ce73c336c04d3 --- /dev/null +++ b/src/erf_initialise_particle.f90 @@ -0,0 +1,69 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine initialise_particle + + !***************************************************************************** + ! * + ! This subroutine handles the different forms of starting FLEXPART * + ! depending on IPIN (set in COMMAND) * + ! * + ! IPIN=0: this routine is not called and particles are read from the * + ! RELEASE option file * + ! IPIN=1: restarting from a restart.bin file, written by a previous run * + ! IPIN=2: restarting from a partoutput_xxx.nc file written by a previous * + ! run, depending on what PARTOPTIONS the user has chosen, this * + ! option might not be possible to use * + ! IPIN=3: starting a run from a user defined initial particle conditions, * + ! more on how to create such a file can be found in the manual * + ! IPIN=4: restarting a run, while also reading in the initial particle * + ! conditions * + ! * + ! Author: L. Bakels 2022 * + ! * + !***************************************************************************** + + use point_mod + use com_mod + use initialise_mod +#ifdef USE_NCF + use netcdf_output_mod !PS +#endif + use readoptions_mod + + implicit none + + integer :: i + + ! Read the coordinates of the release locations + !********************************************** + if (ipin.le.2) call readreleases ! CHECK ETA + + itime_init=0 + if ((ipin.eq.1).or.(ipin.eq.4)) then ! Restarting from restart.bin file + call readrestart + else if (ipin.eq.2) then ! Restarting from netcdf partoutput file +#ifdef USE_NCF + call readpartpositions +#else + stop 'Compile with netCDF if you want to use the ipin=2 option.' +#endif + else if (ipin.eq.3) then ! User defined particle properties + ! Reading initial conditions from netcdf file +#ifdef USE_NCF + call read_init_cond_nc +#else + stop 'Compile with netCDF if you want to use the ipin=3 option.' +#endif + else + ! 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 + end do + numpart=0 + numparticlecount=0 + endif + +end subroutine initialise_particle diff --git a/src/erf_mod.f90 b/src/erf_mod.f90 index 9fc13a4452a0120984c80e3a438ffc5b3c9f42b4..32ff3d03697c9b1d8bfd4439ba2a06bb0069822c 100644 --- a/src/erf_mod.f90 +++ b/src/erf_mod.f90 @@ -26,181 +26,20 @@ contains ! 6.2:GCF/6.1:GAMMLN> !6.2 FUNCTION ERFCC -function gammln(xx) +#include "erf_gammln.f90" - use par_mod, only: dp +#include "erf_gammp.f90" - implicit none - - integer :: j - real :: x,tmp,ser,xx,gammln - real :: cof(6) = (/ & - 76.18009173_dp, -86.50532033_dp, 24.01409822_dp, & - -1.231739516_dp, .120858003e-2_dp, -.536382e-5_dp /) - real :: stp = 2.50662827465_dp - real :: half = 0.5_dp, one = 1.0_dp, fpf = 5.5_dp - - x=xx-one - tmp=x+fpf - tmp=(x+half)*log(tmp)-tmp - ser=one - do j=1,6 - x=x+one - ser=ser+cof(j)/x - end do - gammln=tmp+log(stp*ser) -end function gammln - -function gammp(a,x) - - implicit none - - real :: a, x, gln, gamser, gammp, gammcf - - if(x .lt. 0. .or. a .le. 0.) then - print*, 'gammp' - stop - end if - 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 -end function gammp - -function gammq(a,x) - - implicit none - - real :: a, x, gln, gamser, gammq, gammcf - - if(x.lt.0..or.a.le.0.) then - print*, 'gammq' - stop - end if - 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 -end function gammq - -subroutine gser(gamser,a,x,gln) - - implicit none - - integer :: n - real :: gamser, a, x, gln, ap, summ, del - !real, external :: gammln - - integer,parameter :: itmax=100 - real,parameter :: eps=3.e-7 +#include "erf_gammq.f90" - gln=gammln(a) - if(x.le.0.)then - if(x.lt.0.) then - print*, 'gser' - stop - end if - gamser=0. - return - endif - ap=a - summ=1./a - del=summ - do n=1,itmax - ap=ap+1. - del=del*x/ap - summ=summ+del - if(abs(del).lt.abs(summ)*eps)go to 1 - end do - print*, 'gser: a too large, itmax too small' - stop -1 gamser=summ*exp(-x+a*log(x)-gln) -end subroutine gser +#include "erf_gser.f90" -subroutine gcf(gammcf,a,x,gln) +#include "erf_gcf.f90" - implicit none - - integer :: n - real :: gammcf, a, x, gln, gold, a0, a1, b0, b1, fac, an, anf, ana, g - !real, external :: gammln - - integer,parameter :: itmax=100 - real,parameter :: eps=3.e-7 - - gln=gammln(a) - gold=0. - a0=1. - a1=x - b0=0. - b1=1. - fac=1. - do n=1,itmax - an=real(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 - end do - print*, 'gcf: a too large, itmax too small' - stop -1 gammcf=exp(-x+a*alog(x)-gln)*g -end subroutine gcf - -function erf(x) - - implicit none - - real :: x, erf - !real, external :: gammp - - if(x.lt.0.)then - erf=-gammp(.5,x**2) - else - erf=gammp(.5,x**2) - endif -end function erf - -function erfc(x) - - implicit none - - real :: x, erfc - !real, external :: gammp, gammq - - if(x.lt.0.)then - erfc=1.+gammp(.5,x**2) - else - erfc=gammq(.5,x**2) - endif -end function erfc - -function erfcc(x) - - implicit none +#include "erf_erf.f90" - real :: x, z, t, erfcc +#include "erf_erfc.f90" - 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 -end function erfcc +#include "erf_erfcc.f90" end module erf_mod diff --git a/src/erf_read_options_and_initialise_flexpart.f90 b/src/erf_read_options_and_initialise_flexpart.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ef864238145124108b1da0d258a3b77ee1800c9c --- /dev/null +++ b/src/erf_read_options_and_initialise_flexpart.f90 @@ -0,0 +1,191 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine read_options_and_initialise_flexpart + + !***************************************************************************** + ! * + ! Moved from main flexpart program: * + ! Reading all option files, initialisation of random numbers, and * + ! allocating memory for windfields, grids, etc. * + ! * + ! L. Bakels 2022 * + ! * + !***************************************************************************** + + use point_mod + use random_mod + use par_mod + use com_mod + use conv_mod + use class_gribfile_mod + use readoptions_mod + use windfields_mod + use plume_mod + use initialise_mod + use drydepo_mod + use getfields_mod + use interpol_mod, only: alloc_interpol + use prepoutgrid_mod + use binary_output_mod + + implicit none + + integer :: & + i, & ! loop variable for number of points + inest ! loop variable for nested gridcells + integer :: & + j, & ! loop variable for random numbers + idummy=-320 ! dummy value used by the random routine + + call alloc_random(numthreads) + + ! Generate a large number of random numbers + !****************************************** + do j=1,maxrand-1,2 + call gasdev1(idummy,rannumb(j),rannumb(j+1)) + end do + call gasdev1(idummy,rannumb(maxrand),rannumb(maxrand-1)) + + ! Read pathnames from file in working director that specify I/O directories + !************************************************************************** + call readpaths + + ! Read the user specifications for the current model run + !******************************************************* + call readcommand + + ! Read the age classes to be used + !******************************** + call readageclasses + + + ! Allocate memory for windfields + !******************************* + call alloc_windf + if (numbnests.ge.1) then + ! If nested wind fields are used, allocate arrays + !************************************************ + call alloc_windf_nest + endif + + ! Read, which wind fields are available within the modelling period + !****************************************************************** + call readavailable + + if (ipout.ne.0) call readpartoptions + + ! Detect metdata format + !********************** + call detectformat + + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + print *,'ECMWF metdata detected' + if (nxshift.eq.-9999) nxshift=359 + elseif (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then + print *,'NCEP metdata detected' + if (nxshift.eq.-9999) nxshift=0 + else + print *,'Unknown metdata format' + stop + endif + write(*,*) 'NXSHIFT is set to', nxshift + + ! Read the model grid specifications, + ! both for the mother domain and eventual nests + !********************************************** + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + call gridcheck_ecmwf + else + call gridcheck_gfs + endif + + ! Set the upper level for where the convection will be working + !************************************************************* + call set_conv_top + + if (numbnests.ge.1) then + ! If nested wind fields are used, allocate arrays + !************************************************ + call gridcheck_nest + endif + + ! Read the output grid specifications if requested by user + !********************************************************* + if (iout.ne.0) then + call readoutgrid + + if (nested_output.eq.1) then + call readoutgrid_nest + endif + endif + + ! Read the receptor points for which extra concentrations are to be calculated + !***************************************************************************** + call readreceptors + + ! Read the physico-chemical species property table + !************************************************* + !SEC: now only needed SPECIES are read in readreleases.f + !call readspecies + + ! Read the landuse inventory + !*************************** + call readlanduse ! CHECK ETA + + ! For continuation of previous run or from user defined initial + ! conditions, read in particle positions + !************************************************************************* + call initialise_particle + + ! Convert the release point coordinates from geografical to grid coordinates + !*************************************************************************** + call coordtrafo(nxmin1,nymin1) ! CHECK ETA + + ! Read and compute surface resistances to dry deposition of gases + !**************************************************************** + call readdepo ! CHECK ETA + + ! Allocate dry deposition fields if necessary + !********************************************* + call alloc_drydepo + call alloc_convect + call alloc_getfields + call alloc_interpol + + ! Assign fractional cover of landuse classes to each ECMWF grid point + !******************************************************************** + call assignland ! CHECK ETA + + ! Calculate volume, surface area, etc., of all output grid cells + ! Allocate fluxes and OHfield if necessary + !*************************************************************** + if (iout.ne.0) then + call outgrid_init ! CHECK ETA + if (nested_output.eq.1) call outgrid_init_nest ! CHECK ETA + endif + + ! Read the OH field + !****************** + if (OHREA) then + call readOHfield ! CHECK ETA + endif + +#ifndef USE_NCF + call openreceptors +#endif + if ((iout.eq.4).or.(iout.eq.5)) call openouttraj ! CHECK ETA + + + ! Initialize cloud-base mass fluxes for the convection scheme + !************************************************************ + + cbaseflux(0:nxmin1,0:nymin1)=0. + do inest=1,numbnests + cbasefluxn(0:nxn(inest)-1,0:nyn(inest)-1,inest)=0. + end do + + ! Allocating nan_count for CBL option + !************************************ + allocate(nan_count(numthreads)) +end subroutine read_options_and_initialise_flexpart diff --git a/src/flu_calcfluxes.f90 b/src/flu_calcfluxes.f90 new file mode 100644 index 0000000000000000000000000000000000000000..80be45eba1ccad613febb5525bd897f49e4aa801 --- /dev/null +++ b/src/flu_calcfluxes.f90 @@ -0,0 +1,216 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine calcfluxes(itime,nage,jpart,xold,yold,zold,thread) + ! 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 * + ! * + ! Changes * + ! 2021 L. Bakels: OpenMP parallelisation * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! nage Age class of the particle considered * + ! jpart Index of the particle considered * + ! xold,yold,zold "Memorized" old positions of the particle * + ! * + !***************************************************************************** + + use particle_mod + use coord_ec_mod + + implicit none + integer, intent(in) :: thread ! for OMP, number of thread + integer :: itime,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=part(jpart)%npoint + else + kp=1 + endif + call update_zeta_to_z(itime,jpart) + xmean=(xold+part(jpart)%xlon)/2. + ymean=(yold+part(jpart)%ylat)/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.part(jpart)%z) exit + end do + 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) exit + end do + k1=min(numzgrid,kz) + do kz=1,numzgrid ! determine height of cell + if (outheighthalf(kz).gt.part(jpart)%z) exit + end do + k2=min(numzgrid,kz) + + do k=1,nspec + do kz=k1,k2-1 +#ifdef _OPENMP + flux_omp(5,ixave,jyave,kz,k,kp,nage,thread)= & + flux_omp(5,ixave,jyave,kz,k,kp,nage,thread)+ & + part(jpart)%mass(k) +#else + flux(5,ixave,jyave,kz,k,kp,nage)= & + flux(5,ixave,jyave,kz,k,kp,nage)+ & + part(jpart)%mass(k) +#endif + end do + do kz=k2,k1-1 +#ifdef _OPENMP + flux_omp(6,ixave,jyave,kz,k,kp,nage,thread)= & + flux_omp(6,ixave,jyave,kz,k,kp,nage,thread)+ & + part(jpart)%mass(k) +#else + flux(6,ixave,jyave,kz,k,kp,nage)= & + flux(6,ixave,jyave,kz,k,kp,nage)+ & + part(jpart)%mass(k) +#endif + 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-part(jpart)%xlon).lt.real(nx)/2.) then + ix1=int((xold*dx+xoutshift)/dxout+0.5) + ix2=int((part(jpart)%xlon*dx+xoutshift)/dxout+0.5) + do k=1,nspec + do ix=ix1,ix2-1 + if ((ix.ge.0).and.(ix.le.numxgrid-1)) then +#ifdef _OPENMP + flux_omp(1,ix,jyave,kzave,k,kp,nage,thread)= & + flux_omp(1,ix,jyave,kzave,k,kp,nage,thread) & + +part(jpart)%mass(k) +#else + flux(1,ix,jyave,kzave,k,kp,nage)= & + flux(1,ix,jyave,kzave,k,kp,nage) & + +part(jpart)%mass(k) +#endif + endif + end do + do ix=ix2,ix1-1 + if ((ix.ge.0).and.(ix.le.numxgrid-1)) then +#ifdef _OPENMP + flux_omp(2,ix,jyave,kzave,k,kp,nage,thread)= & + flux_omp(2,ix,jyave,kzave,k,kp,nage,thread) & + +part(jpart)%mass(k) +#else + flux(2,ix,jyave,kzave,k,kp,nage)= & + flux(2,ix,jyave,kzave,k,kp,nage) & + +part(jpart)%mass(k) +#endif + 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.part(jpart)%xlon) then ! west-east flux + do k=1,nspec +#ifdef _OPENMP + flux_omp(1,ixs,jyave,kzave,k,kp,nage,thread)= & + flux_omp(1,ixs,jyave,kzave,k,kp,nage,thread) & + +part(jpart)%mass(k) +#else + flux(1,ixs,jyave,kzave,k,kp,nage)= & + flux(1,ixs,jyave,kzave,k,kp,nage) & + +part(jpart)%mass(k) +#endif + end do + else ! east-west flux + do k=1,nspec +#ifdef _OPENMP + flux_omp(2,ixs,jyave,kzave,k,kp,nage,thread)= & + flux_omp(2,ixs,jyave,kzave,k,kp,nage,thread) & + +part(jpart)%mass(k) +#else + flux(2,ixs,jyave,kzave,k,kp,nage)= & + flux(2,ixs,jyave,kzave,k,kp,nage) & + +part(jpart)%mass(k) +#endif + 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((part(jpart)%ylat*dy+youtshift)/dyout+0.5) + + do k=1,nspec + do jy=jy1,jy2-1 + if ((jy.ge.0).and.(jy.le.numygrid-1)) then +#ifdef _OPENMP + flux_omp(3,ixave,jy,kzave,k,kp,nage,thread)= & + flux_omp(3,ixave,jy,kzave,k,kp,nage,thread) & + +part(jpart)%mass(k) +#else + flux(3,ixave,jy,kzave,k,kp,nage)= & + flux(3,ixave,jy,kzave,k,kp,nage) & + +part(jpart)%mass(k) +#endif + endif + end do + do jy=jy2,jy1-1 + if ((jy.ge.0).and.(jy.le.numygrid-1)) then +#ifdef _OPENMP + flux_omp(4,ixave,jy,kzave,k,kp,nage,thread)= & + flux_omp(4,ixave,jy,kzave,k,kp,nage,thread) & + +part(jpart)%mass(k) +#else + flux(4,ixave,jy,kzave,k,kp,nage)= & + flux(4,ixave,jy,kzave,k,kp,nage) & + +part(jpart)%mass(k) +#endif + endif + end do + end do + endif +end subroutine calcfluxes diff --git a/src/flu_fluxoutput.f90 b/src/flu_fluxoutput.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8bdcb0e8a006f1c0a0f1e827627527ec5c31dc60 --- /dev/null +++ b/src/flu_fluxoutput.f90 @@ -0,0 +1,303 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 date_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(2)(1:length(2))//'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) + + write(*,*) 'Flux:', itime, flux(:,1,1,1,1,1,1) + ! 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. +#ifdef _OPENMP + flux_omp(i,ix,jy,kz,k,kp,nage,:)=0. +#endif + end do + end do + end do + end do + end do + end do + end do +end subroutine fluxoutput diff --git a/src/flux_mod.f90 b/src/flux_mod.f90 index 10e52511388fe778300c9bdac181d35144105cbc..699a3c1be449d7e4f2da0dc1baa772be6f70adb1 100644 --- a/src/flux_mod.f90 +++ b/src/flux_mod.f90 @@ -14,7 +14,7 @@ module flux_mod implicit none !Moved to prepoutgrid_mod, because of dependencies - ! real,allocatable, dimension (:,:,:,:,:,:,:) :: flux + ! real,allocatable, dimension (:,:,:,:,:,:,:) :: flux !1 fluxw west - east !2 fluxe east - west @@ -27,519 +27,8 @@ module flux_mod contains -subroutine calcfluxes(itime,nage,jpart,xold,yold,zold,thread) - ! 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 * - ! * - ! Changes * - ! 2021 L. Bakels: OpenMP parallelisation * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! nage Age class of the particle considered * - ! jpart Index of the particle considered * - ! xold,yold,zold "Memorized" old positions of the particle * - ! * - !***************************************************************************** - - use particle_mod - use coord_ec_mod +#include "flu_calcfluxes.f90" - implicit none - integer, intent(in) :: thread ! for OMP, number of thread - integer :: itime,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=part(jpart)%npoint - else - kp=1 - endif - call update_zeta_to_z(itime,jpart) - xmean=(xold+part(jpart)%xlon)/2. - ymean=(yold+part(jpart)%ylat)/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.part(jpart)%z) exit - end do - 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) exit - end do - k1=min(numzgrid,kz) - do kz=1,numzgrid ! determine height of cell - if (outheighthalf(kz).gt.part(jpart)%z) exit - end do - k2=min(numzgrid,kz) - - do k=1,nspec - do kz=k1,k2-1 -#ifdef _OPENMP - flux_omp(5,ixave,jyave,kz,k,kp,nage,thread)= & - flux_omp(5,ixave,jyave,kz,k,kp,nage,thread)+ & - part(jpart)%mass(k) -#else - flux(5,ixave,jyave,kz,k,kp,nage)= & - flux(5,ixave,jyave,kz,k,kp,nage)+ & - part(jpart)%mass(k) -#endif - end do - do kz=k2,k1-1 -#ifdef _OPENMP - flux_omp(6,ixave,jyave,kz,k,kp,nage,thread)= & - flux_omp(6,ixave,jyave,kz,k,kp,nage,thread)+ & - part(jpart)%mass(k) -#else - flux(6,ixave,jyave,kz,k,kp,nage)= & - flux(6,ixave,jyave,kz,k,kp,nage)+ & - part(jpart)%mass(k) -#endif - 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-part(jpart)%xlon).lt.real(nx)/2.) then - ix1=int((xold*dx+xoutshift)/dxout+0.5) - ix2=int((part(jpart)%xlon*dx+xoutshift)/dxout+0.5) - do k=1,nspec - do ix=ix1,ix2-1 - if ((ix.ge.0).and.(ix.le.numxgrid-1)) then -#ifdef _OPENMP - flux_omp(1,ix,jyave,kzave,k,kp,nage,thread)= & - flux_omp(1,ix,jyave,kzave,k,kp,nage,thread) & - +part(jpart)%mass(k) -#else - flux(1,ix,jyave,kzave,k,kp,nage)= & - flux(1,ix,jyave,kzave,k,kp,nage) & - +part(jpart)%mass(k) -#endif - endif - end do - do ix=ix2,ix1-1 - if ((ix.ge.0).and.(ix.le.numxgrid-1)) then -#ifdef _OPENMP - flux_omp(2,ix,jyave,kzave,k,kp,nage,thread)= & - flux_omp(2,ix,jyave,kzave,k,kp,nage,thread) & - +part(jpart)%mass(k) -#else - flux(2,ix,jyave,kzave,k,kp,nage)= & - flux(2,ix,jyave,kzave,k,kp,nage) & - +part(jpart)%mass(k) -#endif - 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.part(jpart)%xlon) then ! west-east flux - do k=1,nspec -#ifdef _OPENMP - flux_omp(1,ixs,jyave,kzave,k,kp,nage,thread)= & - flux_omp(1,ixs,jyave,kzave,k,kp,nage,thread) & - +part(jpart)%mass(k) -#else - flux(1,ixs,jyave,kzave,k,kp,nage)= & - flux(1,ixs,jyave,kzave,k,kp,nage) & - +part(jpart)%mass(k) -#endif - end do - else ! east-west flux - do k=1,nspec -#ifdef _OPENMP - flux_omp(2,ixs,jyave,kzave,k,kp,nage,thread)= & - flux_omp(2,ixs,jyave,kzave,k,kp,nage,thread) & - +part(jpart)%mass(k) -#else - flux(2,ixs,jyave,kzave,k,kp,nage)= & - flux(2,ixs,jyave,kzave,k,kp,nage) & - +part(jpart)%mass(k) -#endif - 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((part(jpart)%ylat*dy+youtshift)/dyout+0.5) - - do k=1,nspec - do jy=jy1,jy2-1 - if ((jy.ge.0).and.(jy.le.numygrid-1)) then -#ifdef _OPENMP - flux_omp(3,ixave,jy,kzave,k,kp,nage,thread)= & - flux_omp(3,ixave,jy,kzave,k,kp,nage,thread) & - +part(jpart)%mass(k) -#else - flux(3,ixave,jy,kzave,k,kp,nage)= & - flux(3,ixave,jy,kzave,k,kp,nage) & - +part(jpart)%mass(k) -#endif - endif - end do - do jy=jy2,jy1-1 - if ((jy.ge.0).and.(jy.le.numygrid-1)) then -#ifdef _OPENMP - flux_omp(4,ixave,jy,kzave,k,kp,nage,thread)= & - flux_omp(4,ixave,jy,kzave,k,kp,nage,thread) & - +part(jpart)%mass(k) -#else - flux(4,ixave,jy,kzave,k,kp,nage)= & - flux(4,ixave,jy,kzave,k,kp,nage) & - +part(jpart)%mass(k) -#endif - endif - end do - end do - endif -end subroutine calcfluxes - -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 date_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(2)(1:length(2))//'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) - - write(*,*) 'Flux:', itime, flux(:,1,1,1,1,1,1) - ! 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. -#ifdef _OPENMP - flux_omp(i,ix,jy,kz,k,kp,nage,:)=0. -#endif - end do - end do - end do - end do - end do - end do - end do -end subroutine fluxoutput +#include "flu_fluxoutput.f90" end module flux_mod diff --git a/src/get_alloc_getfields.f90 b/src/get_alloc_getfields.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c5d08776f0092d7f6c58156b3ff9cab86832c188 --- /dev/null +++ b/src/get_alloc_getfields.f90 @@ -0,0 +1,18 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine alloc_getfields + implicit none + allocate(uuh(0:nxmax-1,0:nymax-1,nuvzmax), & + vvh(0:nxmax-1,0:nymax-1,nuvzmax), & + pvh(0:nxmax-1,0:nymax-1,nuvzmax), & + wwh(0:nxmax-1,0:nymax-1,nwzmax), & + uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests), & + vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests), & + pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests), & + wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests), & + pwater(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + + allocate(ppml(0:nxmax-1,0:nymax-1,nuvzmax),ppmk(0:nxmax-1,0:nymax-1,nuvzmax)) + allocate(ttlev(nuvzmax),qvlev(nuvzmax),ulev(nuvzmax),vlev(nuvzmax),zlev(nuvzmax)) +end subroutine alloc_getfields diff --git a/src/get_calcpar.f90 b/src/get_calcpar.f90 new file mode 100644 index 0000000000000000000000000000000000000000..273549b542a0e19d66330f97454839f230eeb730 --- /dev/null +++ b/src/get_calcpar.f90 @@ -0,0 +1,277 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine calcpar(n) + ! 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. * + ! * + ! Author: A. Stohl * + ! * + ! 21 May 1995 * + ! * + ! ------------------------------------------------------------------ * + ! Petra Seibert, Feb 2000: * + ! convection scheme: * + ! new variables in call to richardson * + ! * + ! CHANGE 17/11/2005 Caroline Forster NCEP GFS version * + ! * + ! Changes, Bernd C. Krueger, Feb. 2001: * + ! Variables tth and qvh (on eta coordinates) in common block * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! - Merged calcpar and calcpar_gfs into one routine using if-then * + ! for meteo-type dependent code * + !***************************************************************************** + + !***************************************************************************** + ! * + ! Variables: * + ! n temporal index for meteorological fields (1 to 3) * + ! metdata_format format of metdata (ecmwf/gfs) * + ! * + ! Constants: * + ! * + ! * + ! Functions: * + ! scalev computation of ustar * + ! obukhov computatio of Obukhov length * + ! * + !***************************************************************************** + + use class_gribfile_mod + use drydepo_mod, global_ol => ol + use qvsat_mod + + implicit none + + integer :: n,ix,jy,i,kz,lz,kzmin,llev,loop_start,ierr + real :: ol,hmixplus + real :: rh,subsceff,ylat + real :: altmin,tvold,pold,zold,pint,tv,hmixdummy,akzdummy + real :: vd(maxspec) + real :: z0_tmp(numclass) ! temporary variable for z0 (shared between OMP threads) + real,parameter :: const=r_air/ga + + !write(*,*) 'in calcpar writting snowheight' + !*********************************** + ! for test: write out snow depths + + ! open(4,file='slandusetest',form='formatted') + ! do 5 ix=0,nxmin1 + !5 write (4,*) (sd(ix,jy,1,n),jy=0,nymin1) + ! close(4) + + + ! Loop over entire grid + !********************** + + ! openmp change + z0_tmp = z0 + !$OMP PARALLEL PRIVATE(jy,ix,ulev,vlev,ttlev,qvlev,llev,ylat,ol,i,hmixplus, & + !$OMP subsceff,vd,kz,lz,zlev,rh,kzmin,pold,zold,tvold,pint,tv,loop_start,ierr, & + !$OMP altmin) + z0 = z0_tmp + + !$OMP DO + do jy=0,nymin1 + + ! Set minimum height for tropopause + !********************************** + + ylat=ylat0+real(jy)*dy + 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 + + do ix=0,nxmin1 + + ! 1) Calculation of friction velocity + !************************************ + + ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), & + td2(ix,jy,1,n),sfcstress(ix,jy,1,n)) + if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8 + + ! 2) Calculation of inverse Obukhov length scale + !*********************************************** + + if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then + ! NCEP version: find first level above ground + llev = 0 + do i=1,nuvz + if (ps(ix,jy,1,n).lt.akz(i)) llev=i + end do + llev = llev+1 + if (llev.gt.nuvz) llev = nuvz-1 + ! NCEP version + + ! calculate inverse Obukhov length scale with tth(llev) + ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), & + tth(ix,jy,llev,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n), & + akm,bkm,akz(llev)) + else + llev=0 + 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,akzdummy) + end if + + 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) + ttlev(i)=tth(ix,jy,i,n) + qvlev(i)=qvh(ix,jy,i,n) + end do + + if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then + ! NCEP version hmix has been read in in readwind.f, is therefore not calculated here + 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),hmixdummy,wstar(ix,jy,1,n),hmixplus,ierr) + else + 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,ierr) + end if + + if (ierr.lt.0) then + write(*,9500) 'failure', ix, jy + stop + endif +9500 format( 'calcpar - richardson ', a, ' - ix,jy=', 2i5 ) + + if(lsubgrid.eq.1) then + subsceff=min(excessoro(ix,jy),hmixplus) + else + subsceff=0.0 + endif + ! + ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY + ! + hmix(ix,jy,1,n)=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 + ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on + ! windspeed + z0(7)=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),ps(ix,jy,1,n))/ew(tt2(ix,jy,1,n),ps(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), & + sd(ix,jy,1,n),vd) + + do i=1,nspec + vdep(ix,jy,i,n)=vd(i) + end do + + endif + + !****************************************************** + ! Calculate height of thermal tropopause (Hoinka, 1997) + !****************************************************** + + ! 1) Calculate altitudes of model levels + !*************************************** + + tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n),ps(ix,jy,1,n))/ & + ps(ix,jy,1,n)) + pold=ps(ix,jy,1,n) + zold=0. + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + loop_start=2 + else + loop_start=llev + end if + do kz=loop_start,nuvz + pint=akz(kz)+bkz(kz)*ps(ix,jy,1,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) + 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 + !************************************************************************ + + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + !LB, The CTM version has 2 (as bugfix), so I changed it 2 from 1 to try out + loop_start=2 + else + loop_start=llev + end if + + do kz=loop_start,nuvz + if (zlev(kz).ge.altmin) then + kzmin=kz + exit + endif + end do + + ! 3) Search for first stable layer above minimum height that fulfills the + ! thermal tropopause criterion + !************************************************************************ + + outer: do kz=kzmin,nuvz + inner: 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) + exit outer + endif + exit inner + endif + end do inner + end do outer + + end do + end do + !$OMP END DO + !$OMP END PARALLEL + ! openmp change end + + ! Calculation of potential vorticity on 3-d grid + !*********************************************** + + call calcpv(n) +end subroutine calcpar diff --git a/src/get_calcpar_nest.f90 b/src/get_calcpar_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d2efd7cf573c023d3208f4994c6b643591ad4dfa --- /dev/null +++ b/src/get_calcpar_nest.f90 @@ -0,0 +1,234 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine calcpar_nest(n) + ! 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. * + ! * + ! 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 * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + !***************************************************************************** + ! * + ! Variables: * + ! n temporal index for meteorological fields (1 to 3) * + ! metdata_format format of metdata (ecmwf/gfs) * + ! * + ! Constants: * + ! * + ! * + ! Functions: * + ! scalev computation of ustar * + ! obukhov computatio of Obukhov length * + ! * + !***************************************************************************** + + use drydepo_mod, global_ol => ol + use qvsat_mod + + implicit none + + integer :: n,ix,jy,i,l,kz,lz,kzmin,ierr + real :: ol,hmixplus,dummyakzllev + real :: rh,subsceff,ylat + real :: altmin,tvold,pold,zold,pint,tv + real :: vd(maxspec) + real :: z0_tmp(numclass) ! temporary variable for z0 (shared between OMP threads) + real,parameter :: const=r_air/ga + + + ! Loop over all nests + !******************** + + do l=1,numbnests + + ! Loop over entire grid + !********************** + z0_tmp = z0 +!$OMP PARALLEL DEFAULT(SHARED) & +!$OMP PRIVATE(i,ix,jy,kz,lz,kzmin,tvold,pold,zold,zlev,tv,pint, & +!$OMP rh,ierr,subsceff,ulev,vlev,ttlev,qvlev,ol,altmin,ylat,hmixplus, & +!$OMP dummyakzllev,vd ) + z0 = z0_tmp + +!$OMP DO + do jy=0,nyn(l)-1 + + ! Set minimum height for tropopause + !********************************** + + ylat=ylat0n(l)+real(jy)*dyn(l) + 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 + + do ix=0,nxn(l)-1 + + ! 1) Calculation of friction velocity + !************************************ + + 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),sfcstressn(ix,jy,1,n,l)) + if (ustarn(ix,jy,1,n,l).le.1.e-8) ustarn(ix,jy,1,n,l)=1.e-8 + + ! 2) Calculation of inverse Obukhov length scale + !*********************************************** + + 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,dummyakzllev) + 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) + ttlev(i)=tthn(ix,jy,i,n,l) + qvlev(i)=qvhn(ix,jy,i,n,l) + end do + + 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,ierr) + if (ierr.lt.0) then + write(*,9500) 'failure', ix, jy, l + stop + endif +9500 format( 'calcparn - richardson ', a, ' - ix,jy=', 2i5 ) + + if(lsubgrid.eq.1) then + subsceff=min(excessoron(ix,jy,l),hmixplus) + else + subsceff=0.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 + z0(7)=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),psn(ix,jy,1,n,l))/ew(tt2n(ix,jy,1,n,l),psn(ix,jy,1,n,l)) + + call getvdep_nest(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),sdn(ix,jy,1,n,l),vd,l) + + do i=1,nspec + vdepn(ix,jy,i,n,l)=vd(i) + end do + + 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))/ & + psn(ix,jy,1,n,l)) + pold=psn(ix,jy,1,n,l) + zold=0. + 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 + exit + endif + end do + + ! 3) Search for first stable layer above minimum height that fulfills the + ! thermal tropopause criterion + !************************************************************************ + + kzloop : do kz=kzmin,nuvz + lzloop : 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) + exit kzloop + endif + exit lzloop + endif + end do lzloop + end do kzloop + + end do + end do + +!$OMP END DO +!$OMP END PARALLEL + + ! Calculation of potential vorticity on 3-d grid + !*********************************************** + + call calcpv_nest(l,n) + + end do +end subroutine calcpar_nest diff --git a/src/get_calcpv.f90 b/src/get_calcpv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c7e347f65edd336166a325ac74bad094ff301f43 --- /dev/null +++ b/src/get_calcpv.f90 @@ -0,0 +1,305 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine calcpv(n) + ! i i i o + !***************************************************************************** + ! * + ! Calculation of potential vorticity on 3-d grid. * + ! * + ! Author: P. James * + ! 3 February 2000 * + ! * + ! Adaptation to FLEXPART, A. Stohl, 1 May 2000 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! n temporal index for meteorological fields (1 to 2) * + ! * + ! Constants: * + ! * + !***************************************************************************** + + 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 + real :: pvavr + real :: thup,thdn + real,parameter :: eps=1.e-5, p0=101325 + + ! Set number of levels to check for adjacent theta + nlck=nuvz/3 + ! + ! Loop over entire grid + !********************** + do kl=1,nuvz + do jy=0,nymin1 + do ix=0,nxmin1 + ppml(ix,jy,kl)=akz(kl)+bkz(kl)*ps(ix,jy,1,n) + enddo + enddo + enddo + +! ppmk(:,:,1:nuvz)=(100000./ppml(:,:,1:nuvz))**kappa + ppmk(0:nxmin1,0:nymin1,1:nuvz)=(100000./ppml(0:nxmin1,0:nymin1,1:nuvz))**kappa +!$OMP PARALLEL PRIVATE(jy,ix,kl,phi,f,tanphi,cosphi,jyvp,jyvm,jumpy,juy, & +!$OMP ixvp,ixvm,jumpx,ivrp,ivrm,jux,theta,klvrp,klvrm,klpt,thetap,thetam,dthetadp, & +!$OMP ii,i,ivr,kdn,kch,kup,thdn,thup,dt1,dt2,dt,vx,k,dvdx, & +!$OMP jj,j,uy,dudy) +!$OMP DO + do jy=0,nymin1 + if (sglobal.and.jy.eq.0) cycle + if (nglobal.and.jy.eq.nymin1) cycle + 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 + ! 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 + ! + ! Loop over the vertical + !*********************** + + do kl=1,nuvz + theta=tth(ix,jy,kl,n)*ppmk(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=tth(ix,jy,klvrp,n)*ppmk(ix,jy,klvrp) + thetam=tth(ix,jy,klvrm,n)*ppmk(ix,jy,klvrm) + dthetadp=(thetap-thetam)/(ppml(ix,jy,klvrp)-ppml(ix,jy,klvrm)) + + ! Compute vertical position at pot. temperature surface on subgrid + ! and the wind at that position + !***************************************************************** + ! a) in x direction + ii=0 + x_loop: 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 + x_lev_loop: do while (kch.lt.nlck) + ! Upward branch + kup=kup+1 + if (kup.lt.nuvz) then + kch=kch+1 + k=kup + thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k) + thup=tth(ivr,jy,k+1,n)*ppmk(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 + cycle x_loop + endif + endif + ! Downward branch + kdn=kdn-1 + if (kdn.ge.1) then + kch=kch+1 + k=kdn + thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k) + thup=tth(ivr,jy,k+1,n)*ppmk(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 + cycle x_loop + endif + endif + end do x_lev_loop + ! This section used when no values were found + ! Must use vv at current level and long. jux becomes smaller by 1 + vx(ii)=vvh(ix,jy,kl) + jux=jux-1 + ! Otherwise OK + end do x_loop + if (jux.gt.0) then + dvdx=(vx(2)-vx(1))/real(jux)/(dx*pi/180.) + else + dvdx=vvh(ivrp,jy,kl)-vvh(ivrm,jy,kl) + dvdx=dvdx/real(jumpx)/(dx*pi/180.) + ! 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 + y_loop: 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 + y_lev_loop: do while (kch.lt.nlck) + ! Upward branch + kup=kup+1 + if (kup.lt.nuvz) then + kch=kch+1 + k=kup + thdn=tth(ix,j,k,n)*ppmk(ix,j,k) + thup=tth(ix,j,k+1,n)*ppmk(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 + cycle y_loop + endif + endif + ! Downward branch + kdn=kdn-1 + if (kdn.ge.1) then + kch=kch+1 + k=kdn + thdn=tth(ix,j,k,n)*ppmk(ix,j,k) + thup=tth(ix,j,k+1,n)*ppmk(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 + cycle y_loop + endif + endif + end do y_lev_loop + ! This section used when no values were found + ! Must use uu at current level and lat. juy becomes smaller by 1 + uy(jj)=uuh(ix,jy,kl) + juy=juy-1 + ! Otherwise OK + end do y_loop + if (juy.gt.0) then + dudy=(uy(2)-uy(1))/real(juy)/(dy*pi/180.) + else + dudy=uuh(ix,jyvp,kl)-uuh(ix,jyvm,kl) + dudy=dudy/real(jumpy)/(dy*pi/180.) + end if + ! + pvh(ix,jy,kl)=dthetadp*(f+(dvdx/cosphi-dudy & + +uuh(ix,jy,kl)*tanphi)/r_earth)*(-1.e6)*9.81 + ! + ! Resest jux and juy + jux=jumpx + juy=jumpy + end do + end do + end do +!$OMP END DO +!$OMP END PARALLEL + ! + ! 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/get_calcpv_nest.f90 b/src/get_calcpv_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..74c1a1f1040e50f4756293a6dca31bde147ed6af --- /dev/null +++ b/src/get_calcpv_nest.f90 @@ -0,0 +1,244 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine calcpv_nest(l,n) + ! i i i i o + !***************************************************************************** + ! * + ! Calculation of potential vorticity on 3-d nested grid * + ! * + ! Author: P. James * + ! 22 February 2000 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! n temporal index for meteorological fields (1 to 2) * + ! l index of current nest * + ! * + ! Constants: * + ! * + !***************************************************************************** + + 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 + real :: thup,thdn + real,parameter :: eps=1.e-5,p0=101325 + + ! Set number of levels to check for adjacent theta + nlck=nuvz/3 + ! + ! Loop over entire grid + !********************** + do kl=1,nuvz + do jy=0,nyn(l)-1 + do ix=0,nxn(l)-1 + ppml(ix,jy,kl)=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l) + enddo + enddo + enddo + ! ppmk=(100000./ppml)**kappa + ppmk(0:nxn(l)-1,0:nyn(l)-1,1:nuvz)=(100000./ppml(0:nxn(l)-1,0:nyn(l)-1,1:nuvz))**kappa + + do jy=0,nyn(l)-1 + 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 + ! 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 + ! + ! Loop over the vertical + !*********************** + + do kl=1,nuvz + theta=tthn(ix,jy,kl,n,l)*ppmk(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=tthn(ix,jy,klvrp,n,l)*ppmk(ix,jy,klvrp) + thetam=tthn(ix,jy,klvrm,n,l)*ppmk(ix,jy,klvrm) + dthetadp=(thetap-thetam)/(ppml(ix,jy,klvrp)-ppml(ix,jy,klvrm)) + + ! Compute vertical position at pot. temperature surface on subgrid + ! and the wind at that position + !***************************************************************** + ! a) in x direction + ii=0 + x_loop: 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 + x_lev_loop: do while (kch.lt.nlck) + ! Upward branch + kup=kup+1 + if (kup.lt.nuvz) then + kch=kch+1 + k=kup + thdn=tthn(ivr,jy,k,n,l)*ppmk(ivr,jy,k) + thup=tthn(ivr,jy,k+1,n,l)*ppmk(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)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt + cycle x_loop + endif + endif + ! Downward branch + kdn=kdn-1 + if (kdn.ge.1) then + kch=kch+1 + k=kdn + thdn=tthn(ivr,jy,k,n,l)*ppmk(ivr,jy,k) + thup=tthn(ivr,jy,k+1,n,l)*ppmk(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)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt + cycle x_loop + endif + endif + end do x_lev_loop + ! This section used when no values were found + ! 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 + end do x_loop + if (jux.gt.0) then + dvdx=(vx(2)-vx(1))/real(jux)/(dxn(l)*pi/180.) + else + dvdx=vvhn(ivrp,jy,kl,l)-vvhn(ivrm,jy,kl,l) + dvdx=dvdx/real(jumpx)/(dxn(l)*pi/180.) + ! 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 + y_loop: 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 + y_lev_loop: do while (kch.lt.nlck) + ! Upward branch + kup=kup+1 + if (kup.lt.nuvz) then + kch=kch+1 + k=kup + thdn=tthn(ix,j,k,n,l)*ppmk(ix,j,k) + thup=tthn(ix,j,k+1,n,l)*ppmk(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)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt + cycle y_loop + endif + endif + ! Downward branch + kdn=kdn-1 + if (kdn.ge.1) then + kch=kch+1 + k=kdn + thdn=tthn(ix,j,k,n,l)*ppmk(ix,j,k) + thup=tthn(ix,j,k+1,n,l)*ppmk(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)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt + cycle y_loop + endif + endif + end do y_lev_loop + ! This section used when no values were found + ! 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 + end do y_loop + if (juy.gt.0) then + dudy=(uy(2)-uy(1))/real(juy)/(dyn(l)*pi/180.) + else + dudy=uuhn(ix,jyvp,kl,l)-uuhn(ix,jyvm,kl,l) + dudy=dudy/real(jumpy)/(dyn(l)*pi/180.) + end if + + pvhn(ix,jy,kl,l)=dthetadp*(f+(dvdx/cosphi-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_nest diff --git a/src/get_dealloc_getfields.f90 b/src/get_dealloc_getfields.f90 new file mode 100644 index 0000000000000000000000000000000000000000..aedc822e2f6bad4d74c4e99512bd50ae921bcb6f --- /dev/null +++ b/src/get_dealloc_getfields.f90 @@ -0,0 +1,11 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine dealloc_getfields + + implicit none + deallocate(uuh,vvh,pvh,wwh,uuhn,vvhn,pvhn,wwhn,pwater) + deallocate(ppml,ppmk) + deallocate(ttlev,qvlev,ulev,vlev,zlev) + +end subroutine dealloc_getfields diff --git a/src/get_getfields.f90 b/src/get_getfields.f90 new file mode 100644 index 0000000000000000000000000000000000000000..840b72c0b592aa55cc82ec5f381cef31201db9e8 --- /dev/null +++ b/src/get_getfields.f90 @@ -0,0 +1,207 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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. * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! - Added passing of metdata_format as it was needed by called routines * + !***************************************************************************** + ! * + ! 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 calcu- * + ! lation * + ! 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] * + ! metdata_format format of metdata (ecmwf/gfs) * + ! * + ! Constants: * + ! idiffmax maximum allowable time difference between 2 wind * + ! fields * + ! * + !***************************************************************************** + + use class_gribfile_mod + use wetdepo_mod + + implicit none + + integer :: indj,itime,nstop,memaux + integer :: kz, ix + character(len=100) :: rowfmt + + integer :: indmin = 1 + + ! 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 + + 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 + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_temp = (count_clock - count_clock0)/real(count_rate) + call readwind_ecmwf(indj+1,memind(2),uuh,vvh,wwh) + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp) + else + call readwind_gfs(indj+1,memind(2),uuh,vvh,wwh) + end if + call readwind_nest(indj+1,memind(2),uuhn,vvhn,wwhn) + call calcpar(memind(2)) + call calcpar_nest(memind(2)) + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + call verttransform_ecmwf(memind(2),uuh,vvh,wwh,pvh) + else + call verttransform_gfs(memind(2),uuh,vvh,wwh,pvh) + end if + call verttransform_nest(memind(2),uuhn,vvhn,wwhn,pvhn) + memtime(2)=wftime(indj+1) + nstop = 1 + exit + endif + end do + indmin=indj + + if ((WETBKDEP).and.(ipin.ne.3).and.(ipin.ne.4)) then + call writeprecip(itime,memind(1)) + endif + + 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 (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_temp = (count_clock - count_clock0)/real(count_rate) + call readwind_ecmwf(indj,memind(1),uuh,vvh,wwh) + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp) + else + call readwind_gfs(indj,memind(1),uuh,vvh,wwh) + end if + call readwind_nest(indj,memind(1),uuhn,vvhn,wwhn) + call calcpar(memind(1)) + call calcpar_nest(memind(1)) + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + call verttransform_ecmwf(memind(1),uuh,vvh,wwh,pvh) + else + call verttransform_gfs(memind(1),uuh,vvh,wwh,pvh) + end if + call verttransform_nest(memind(1),uuhn,vvhn,wwhn,pvhn) + memtime(1)=wftime(indj) + memind(2)=2 + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_temp = (count_clock - count_clock0)/real(count_rate) + call readwind_ecmwf(indj+1,memind(2),uuh,vvh,wwh) + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp) + else + call readwind_gfs(indj+1,memind(2),uuh,vvh,wwh) + end if + call readwind_nest(indj+1,memind(2),uuhn,vvhn,wwhn) + call calcpar(memind(2)) + call calcpar_nest(memind(2)) + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + call verttransform_ecmwf(memind(2),uuh,vvh,wwh,pvh) + else + call verttransform_gfs(memind(2),uuh,vvh,wwh,pvh) + end if + call verttransform_nest(memind(2),uuhn,vvhn,wwhn,pvhn) + memtime(2)=wftime(indj+1) + nstop = 1 + exit + endif + end do + indmin=indj + + if ((WETBKDEP).and.(ipin.ne.3).and.(ipin.ne.4)) then + call writeprecip(itime,memind(1)) + endif + + end if + + ! RLT calculate dry air density + if (DRYDEP) then + pwater=qv*prs/((r_air/r_water)*(1.-qv)+qv) + rho_dry=(prs-pwater)/(r_air*tt) + endif +#ifndef USE_NCF + pwater=qv*prs/((r_air/r_water)*(1.-qv)+qv) + rho_dry=(prs-pwater)/(r_air*tt) +#endif + + lwindinterv=abs(memtime(2)-memtime(1)) + + if (lwindinterv.gt.idiffmax) nstop=3 +end subroutine getfields diff --git a/src/get_obukhov.f90 b/src/get_obukhov.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a7ff35a944ec82651d8d82aae0d792fcfa866a19 --- /dev/null +++ b/src/get_obukhov.f90 @@ -0,0 +1,70 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,akm,bkm,plev) + + !******************************************************************** + ! * + ! Author: G. WOTAWA * + ! Date: 1994-06-27 * + ! * + ! This program calculates Obukhov scale height from surface * + ! meteorological data and sensible heat flux. * + ! * + !******************************************************************** + ! * + ! Update: A. Stohl, 2000-09-25, avoid division by zero by * + ! setting ustar to minimum value * + ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! - Merged obukhov and obukhov_gfs into one routine using * + ! if-then for meteo-type dependent code * + ! * + !******************************************************************** + ! * + ! 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 * + ! plev * + ! metdata_format format of metdata (ecmwf/gfs) * + ! * + !******************************************************************** + + use class_gribfile_mod + use qvsat_mod + + implicit none + + real,dimension(:) :: akm,bkm + real :: ps,tsurf,tdsurf,tlev,ustar,hf,e,tv,rhoa,plev + real :: ak1,bk1,theta,thetastar + + + e=ew(tdsurf,ps) ! vapor pressure + tv=tsurf*(1.+0.378*e/ps) ! virtual temperature + rhoa=ps/(r_air*tv) ! air density + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + ak1=(akm(1)+akm(2))/2. + bk1=(bkm(1)+bkm(2))/2. + plev=ak1+bk1*ps ! Pressure level 1 + end if + 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/get_richardson.f90 b/src/get_richardson.f90 new file mode 100644 index 0000000000000000000000000000000000000000..17712268f8cdee21d7f54439fe97cd5bdf078717 --- /dev/null +++ b/src/get_richardson.f90 @@ -0,0 +1,253 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 + !**************************************************************************** + ! * + ! 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. * + ! * + ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! - Merged richardson and richardson_gfs into one routine using * + ! if-then for meteo-type dependent code * + ! * + !**************************************************************************** + ! * + ! Variables: * + ! h mixing height [m] * + ! hf sensible heat flux * + ! psurf surface pressure at point (xt,yt) [Pa] * + ! tv virtual temperature * + ! wst convective velocity scale * + ! metdata_format format of metdata (ecmwf/gfs) * + ! * + ! Constants: * + ! ric critical Richardson number * + ! * + !**************************************************************************** + + use class_gribfile_mod + use qvsat_mod + + implicit none + + integer,intent(out) :: & + ierr ! Returns error when no richardson number can be found + real, intent(out) :: & + h, & ! mixing height [m] + wst, & ! convective velocity scale + hmixplus ! + integer,intent(in) :: & + nuvz ! Upper vertical level + real,intent(in) :: & + psurf, & ! surface pressure at point (xt,yt) [Pa] + ust, & ! Scale velocity + hf, & ! Surface sensible heat flux + tt2,td2 ! Temperature + real,intent(in),dimension(:) :: & + ttlev, & + qvlev, & + ulev, & + vlev, & + akz,bkz + integer :: & + i,k,iter,llev,loop_start ! Loop variables + real :: & + tv,tvold, & ! Virtual temperature + zref,z,zold,zl,zl1,zl2, & ! Heights + pint,pold, & ! Pressures + theta,thetaold,thetaref,thetal, & ! Potential temperature + theta1,theta2,thetam, & + ri, & ! Richardson number per level + ril, & ! Richardson number sub level + excess, & ! + ul,vl, & ! Velocities sub level + wspeed, & ! Wind speed at z=hmix + bvfsq, & ! Brunt-Vaisala frequency + bvf, & ! square root of bvfsq + rh,rhold,rhl + real,parameter :: const=r_air/ga, ric=0.25, b=100., bs=8.5 + integer,parameter :: itmax=3 + + excess=0.0 + + if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then + ! NCEP version: find first model level above ground + !************************************************** + + llev = 0 + do i=1,nuvz + if (psurf.lt.akz(i)) llev=i + end do + llev = llev+1 + ! sec llev should not be 1! + if (llev.eq.1) llev = 2 + if (llev.gt.nuvz) llev = nuvz-1 + ! NCEP version + end if + + + ! Compute virtual temperature and virtual potential temperature at + ! reference level (2 m) + !***************************************************************** + + do iter=1,itmax,1 + + pold=psurf + tvold=tt2*(1.+0.378*ew(td2,psurf)/psurf) + zold=2.0 + zref=zold + rhold=ew(td2,psurf)/ew(tt2,psurf) + + thetaref=tvold*(100000./pold)**(r_air/cpa)+excess + thetaold=thetaref + + + ! Integrate z up to one level above zt + !************************************* + if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then + loop_start=2 + else + loop_start=llev + end if + do k=loop_start,nuvz + pint=akz(k)+bkz(k)*psurf ! 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) ) + + + ! Calculate 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) exit + + tvold=tv + pold=pint + rhold=rh + thetaold=theta + zold=z + end do + ! Check opied from FLEXPART-WRF, 2022 LB + if (k.ge.nuvz) then + write(*,*) 'richardson not working -- k = nuvz' + ierr = -10 + goto 7000 + endif + !k=min(k,nuvz) ! ESO: make sure k <= nuvz (ticket #139) !MD change to work without goto + + ! Determine Richardson number between the critical levels + !******************************************************** + + zl1=zold + theta1=thetaold + do i=1,20 + zl=zold+real(i)/20.*(z-zold) + ul=ulev(k-1)+real(i)/20.*(ulev(k)-ulev(k-1)) + vl=vlev(k-1)+real(i)/20.*(vlev(k)-vlev(k-1)) + thetal=thetaold+real(i)/20.*(theta-thetaold) + rhl=rhold+real(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) exit + if (i.eq.20) then + write(*,*) 'WARNING: NO RICHARDSON NUMBER GREATER THAN 0.25 FOUND', k,ril,ri + exit + endif + zl1=zl + theta1=thetal + !if (i.eq.20) stop 'RICHARDSON: NO RICHARDSON NUMBER GREATER THAN 0.25 FOUND' + end do + + h=zl + 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 + endif + + + ! Calculate convective velocity scale + !************************************ + + if (hf.lt.0.) then + wst=(-h*ga/thetaref*hf/cpa)**0.333 + excess=-bs*hf/cpa/wst + else + wst=0. + exit + endif + end do + + 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/get_scalev.f90 b/src/get_scalev.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8db46359e36996140dafa0e2016f27ac39218ab0 --- /dev/null +++ b/src/get_scalev.f90 @@ -0,0 +1,37 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 qvsat_mod + + implicit none + + real :: ps,t,td,e,tv,rhoa,stress + + e=ew(td,ps) ! 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/getfields_mod.f90 b/src/getfields_mod.f90 index d0b3e71cbba03b00bb9be9db52f38aad8290bce3..662452fdc69fa93caa94045ca0e0b1020b9fed64 100644 --- a/src/getfields_mod.f90 +++ b/src/getfields_mod.f90 @@ -14,7 +14,7 @@ !***************************************************************************** module getfields_mod - + use par_mod use com_mod use windfields_mod @@ -23,8 +23,8 @@ module getfields_mod implicit none real,allocatable,dimension(:,:,:) :: & - uuh, & ! wind components in x-direction [m/s] - vvh, & ! wind components in y-direction [m/s] + uuh, & ! wind components in x-direction [m/s] + vvh, & ! wind components in y-direction [m/s] pvh, & ! potential vorticity wwh ! wind components in y-direction [m/s] real,allocatable,dimension(:,:,:,:) :: & ! Same for nexted grids @@ -32,7 +32,7 @@ module getfields_mod vvhn, & ! pvhn, & ! wwhn, & ! - pwater ! RLT added partial pressure water vapor + pwater ! RLT added partial pressure water vapor real,allocatable,dimension(:,:,:) :: & ! For calcpv ppml, & ! ppmk ! @@ -48,1640 +48,24 @@ module getfields_mod public :: getfields contains -subroutine alloc_getfields - implicit none - allocate(uuh(0:nxmax-1,0:nymax-1,nuvzmax), & - vvh(0:nxmax-1,0:nymax-1,nuvzmax), & - pvh(0:nxmax-1,0:nymax-1,nuvzmax), & - wwh(0:nxmax-1,0:nymax-1,nwzmax), & - uuhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests), & - vvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests), & - pvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests), & - wwhn(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests), & - pwater(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - - allocate(ppml(0:nxmax-1,0:nymax-1,nuvzmax),ppmk(0:nxmax-1,0:nymax-1,nuvzmax)) - allocate(ttlev(nuvzmax),qvlev(nuvzmax),ulev(nuvzmax),vlev(nuvzmax),zlev(nuvzmax)) -end subroutine alloc_getfields - -subroutine dealloc_getfields - - implicit none - deallocate(uuh,vvh,pvh,wwh,uuhn,vvhn,pvhn,wwhn,pwater) - deallocate(ppml,ppmk) - deallocate(ttlev,qvlev,ulev,vlev,zlev) - -end subroutine dealloc_getfields - -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. * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! - Added passing of metdata_format as it was needed by called routines * - !***************************************************************************** - ! * - ! 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 calcu- * - ! lation * - ! 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] * - ! metdata_format format of metdata (ecmwf/gfs) * - ! * - ! Constants: * - ! idiffmax maximum allowable time difference between 2 wind * - ! fields * - ! * - !***************************************************************************** - - use class_gribfile_mod - use wetdepo_mod - - implicit none - - integer :: indj,itime,nstop,memaux - integer :: kz, ix - character(len=100) :: rowfmt - - integer :: indmin = 1 - - ! 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 - - 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 - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_temp = (count_clock - count_clock0)/real(count_rate) - call readwind_ecmwf(indj+1,memind(2),uuh,vvh,wwh) - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp) - else - call readwind_gfs(indj+1,memind(2),uuh,vvh,wwh) - end if - call readwind_nest(indj+1,memind(2),uuhn,vvhn,wwhn) - call calcpar(memind(2)) - call calcpar_nest(memind(2)) - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - call verttransform_ecmwf(memind(2),uuh,vvh,wwh,pvh) - else - call verttransform_gfs(memind(2),uuh,vvh,wwh,pvh) - end if - call verttransform_nest(memind(2),uuhn,vvhn,wwhn,pvhn) - memtime(2)=wftime(indj+1) - nstop = 1 - exit - endif - end do - indmin=indj - - if ((WETBKDEP).and.(ipin.ne.3).and.(ipin.ne.4)) then - call writeprecip(itime,memind(1)) - endif - - 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 (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_temp = (count_clock - count_clock0)/real(count_rate) - call readwind_ecmwf(indj,memind(1),uuh,vvh,wwh) - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp) - else - call readwind_gfs(indj,memind(1),uuh,vvh,wwh) - end if - call readwind_nest(indj,memind(1),uuhn,vvhn,wwhn) - call calcpar(memind(1)) - call calcpar_nest(memind(1)) - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - call verttransform_ecmwf(memind(1),uuh,vvh,wwh,pvh) - else - call verttransform_gfs(memind(1),uuh,vvh,wwh,pvh) - end if - call verttransform_nest(memind(1),uuhn,vvhn,wwhn,pvhn) - memtime(1)=wftime(indj) - memind(2)=2 - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_temp = (count_clock - count_clock0)/real(count_rate) - call readwind_ecmwf(indj+1,memind(2),uuh,vvh,wwh) - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_readwind = s_readwind + ((count_clock - count_clock0)/real(count_rate)-s_temp) - else - call readwind_gfs(indj+1,memind(2),uuh,vvh,wwh) - end if - call readwind_nest(indj+1,memind(2),uuhn,vvhn,wwhn) - call calcpar(memind(2)) - call calcpar_nest(memind(2)) - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - call verttransform_ecmwf(memind(2),uuh,vvh,wwh,pvh) - else - call verttransform_gfs(memind(2),uuh,vvh,wwh,pvh) - end if - call verttransform_nest(memind(2),uuhn,vvhn,wwhn,pvhn) - memtime(2)=wftime(indj+1) - nstop = 1 - exit - endif - end do - indmin=indj - - if ((WETBKDEP).and.(ipin.ne.3).and.(ipin.ne.4)) then - call writeprecip(itime,memind(1)) - endif - - end if - - ! RLT calculate dry air density - if (DRYDEP) then - pwater=qv*prs/((r_air/r_water)*(1.-qv)+qv) - rho_dry=(prs-pwater)/(r_air*tt) - endif -#ifndef USE_NCF - pwater=qv*prs/((r_air/r_water)*(1.-qv)+qv) - rho_dry=(prs-pwater)/(r_air*tt) -#endif - - lwindinterv=abs(memtime(2)-memtime(1)) - - if (lwindinterv.gt.idiffmax) nstop=3 -end subroutine getfields - -subroutine calcpv(n) - ! i i i o - !***************************************************************************** - ! * - ! Calculation of potential vorticity on 3-d grid. * - ! * - ! Author: P. James * - ! 3 February 2000 * - ! * - ! Adaptation to FLEXPART, A. Stohl, 1 May 2000 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! n temporal index for meteorological fields (1 to 2) * - ! * - ! Constants: * - ! * - !***************************************************************************** - - 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 - real :: pvavr - real :: thup,thdn - real,parameter :: eps=1.e-5, p0=101325 - - ! Set number of levels to check for adjacent theta - nlck=nuvz/3 - ! - ! Loop over entire grid - !********************** - do kl=1,nuvz - do jy=0,nymin1 - do ix=0,nxmin1 - ppml(ix,jy,kl)=akz(kl)+bkz(kl)*ps(ix,jy,1,n) - enddo - enddo - enddo - -! ppmk(:,:,1:nuvz)=(100000./ppml(:,:,1:nuvz))**kappa - ppmk(0:nxmin1,0:nymin1,1:nuvz)=(100000./ppml(0:nxmin1,0:nymin1,1:nuvz))**kappa -!$OMP PARALLEL PRIVATE(jy,ix,kl,phi,f,tanphi,cosphi,jyvp,jyvm,jumpy,juy, & -!$OMP ixvp,ixvm,jumpx,ivrp,ivrm,jux,theta,klvrp,klvrm,klpt,thetap,thetam,dthetadp, & -!$OMP ii,i,ivr,kdn,kch,kup,thdn,thup,dt1,dt2,dt,vx,k,dvdx, & -!$OMP jj,j,uy,dudy) -!$OMP DO - do jy=0,nymin1 - if (sglobal.and.jy.eq.0) cycle - if (nglobal.and.jy.eq.nymin1) cycle - 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 - ! 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 - ! - ! Loop over the vertical - !*********************** - - do kl=1,nuvz - theta=tth(ix,jy,kl,n)*ppmk(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=tth(ix,jy,klvrp,n)*ppmk(ix,jy,klvrp) - thetam=tth(ix,jy,klvrm,n)*ppmk(ix,jy,klvrm) - dthetadp=(thetap-thetam)/(ppml(ix,jy,klvrp)-ppml(ix,jy,klvrm)) - - ! Compute vertical position at pot. temperature surface on subgrid - ! and the wind at that position - !***************************************************************** - ! a) in x direction - ii=0 - x_loop: 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 - x_lev_loop: do while (kch.lt.nlck) - ! Upward branch - kup=kup+1 - if (kup.lt.nuvz) then - kch=kch+1 - k=kup - thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k) - thup=tth(ivr,jy,k+1,n)*ppmk(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 - cycle x_loop - endif - endif - ! Downward branch - kdn=kdn-1 - if (kdn.ge.1) then - kch=kch+1 - k=kdn - thdn=tth(ivr,jy,k,n)*ppmk(ivr,jy,k) - thup=tth(ivr,jy,k+1,n)*ppmk(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 - cycle x_loop - endif - endif - end do x_lev_loop - ! This section used when no values were found - ! Must use vv at current level and long. jux becomes smaller by 1 - vx(ii)=vvh(ix,jy,kl) - jux=jux-1 - ! Otherwise OK - end do x_loop - if (jux.gt.0) then - dvdx=(vx(2)-vx(1))/real(jux)/(dx*pi/180.) - else - dvdx=vvh(ivrp,jy,kl)-vvh(ivrm,jy,kl) - dvdx=dvdx/real(jumpx)/(dx*pi/180.) - ! 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 - y_loop: 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 - y_lev_loop: do while (kch.lt.nlck) - ! Upward branch - kup=kup+1 - if (kup.lt.nuvz) then - kch=kch+1 - k=kup - thdn=tth(ix,j,k,n)*ppmk(ix,j,k) - thup=tth(ix,j,k+1,n)*ppmk(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 - cycle y_loop - endif - endif - ! Downward branch - kdn=kdn-1 - if (kdn.ge.1) then - kch=kch+1 - k=kdn - thdn=tth(ix,j,k,n)*ppmk(ix,j,k) - thup=tth(ix,j,k+1,n)*ppmk(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 - cycle y_loop - endif - endif - end do y_lev_loop - ! This section used when no values were found - ! Must use uu at current level and lat. juy becomes smaller by 1 - uy(jj)=uuh(ix,jy,kl) - juy=juy-1 - ! Otherwise OK - end do y_loop - if (juy.gt.0) then - dudy=(uy(2)-uy(1))/real(juy)/(dy*pi/180.) - else - dudy=uuh(ix,jyvp,kl)-uuh(ix,jyvm,kl) - dudy=dudy/real(jumpy)/(dy*pi/180.) - end if - ! - pvh(ix,jy,kl)=dthetadp*(f+(dvdx/cosphi-dudy & - +uuh(ix,jy,kl)*tanphi)/r_earth)*(-1.e6)*9.81 - ! - ! Resest jux and juy - jux=jumpx - juy=jumpy - end do - end do - end do -!$OMP END DO -!$OMP END PARALLEL - ! - ! 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 - -subroutine calcpv_nest(l,n) - ! i i i i o - !***************************************************************************** - ! * - ! Calculation of potential vorticity on 3-d nested grid * - ! * - ! Author: P. James * - ! 22 February 2000 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! n temporal index for meteorological fields (1 to 2) * - ! l index of current nest * - ! * - ! Constants: * - ! * - !***************************************************************************** - - 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 - real :: thup,thdn - real,parameter :: eps=1.e-5,p0=101325 - - ! Set number of levels to check for adjacent theta - nlck=nuvz/3 - ! - ! Loop over entire grid - !********************** - do kl=1,nuvz - do jy=0,nyn(l)-1 - do ix=0,nxn(l)-1 - ppml(ix,jy,kl)=akz(kl)+bkz(kl)*psn(ix,jy,1,n,l) - enddo - enddo - enddo - ! ppmk=(100000./ppml)**kappa - ppmk(0:nxn(l)-1,0:nyn(l)-1,1:nuvz)=(100000./ppml(0:nxn(l)-1,0:nyn(l)-1,1:nuvz))**kappa - - do jy=0,nyn(l)-1 - 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 - ! 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 - ! - ! Loop over the vertical - !*********************** - - do kl=1,nuvz - theta=tthn(ix,jy,kl,n,l)*ppmk(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=tthn(ix,jy,klvrp,n,l)*ppmk(ix,jy,klvrp) - thetam=tthn(ix,jy,klvrm,n,l)*ppmk(ix,jy,klvrm) - dthetadp=(thetap-thetam)/(ppml(ix,jy,klvrp)-ppml(ix,jy,klvrm)) - - ! Compute vertical position at pot. temperature surface on subgrid - ! and the wind at that position - !***************************************************************** - ! a) in x direction - ii=0 - x_loop: 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 - x_lev_loop: do while (kch.lt.nlck) - ! Upward branch - kup=kup+1 - if (kup.lt.nuvz) then - kch=kch+1 - k=kup - thdn=tthn(ivr,jy,k,n,l)*ppmk(ivr,jy,k) - thup=tthn(ivr,jy,k+1,n,l)*ppmk(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)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt - cycle x_loop - endif - endif - ! Downward branch - kdn=kdn-1 - if (kdn.ge.1) then - kch=kch+1 - k=kdn - thdn=tthn(ivr,jy,k,n,l)*ppmk(ivr,jy,k) - thup=tthn(ivr,jy,k+1,n,l)*ppmk(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)=(vvhn(ivr,jy,k,l)*dt2+vvhn(ivr,jy,k+1,l)*dt1)/dt - cycle x_loop - endif - endif - end do x_lev_loop - ! This section used when no values were found - ! 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 - end do x_loop - if (jux.gt.0) then - dvdx=(vx(2)-vx(1))/real(jux)/(dxn(l)*pi/180.) - else - dvdx=vvhn(ivrp,jy,kl,l)-vvhn(ivrm,jy,kl,l) - dvdx=dvdx/real(jumpx)/(dxn(l)*pi/180.) - ! 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 - y_loop: 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 - y_lev_loop: do while (kch.lt.nlck) - ! Upward branch - kup=kup+1 - if (kup.lt.nuvz) then - kch=kch+1 - k=kup - thdn=tthn(ix,j,k,n,l)*ppmk(ix,j,k) - thup=tthn(ix,j,k+1,n,l)*ppmk(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)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt - cycle y_loop - endif - endif - ! Downward branch - kdn=kdn-1 - if (kdn.ge.1) then - kch=kch+1 - k=kdn - thdn=tthn(ix,j,k,n,l)*ppmk(ix,j,k) - thup=tthn(ix,j,k+1,n,l)*ppmk(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)=(uuhn(ix,j,k,l)*dt2+uuhn(ix,j,k+1,l)*dt1)/dt - cycle y_loop - endif - endif - end do y_lev_loop - ! This section used when no values were found - ! 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 - end do y_loop - if (juy.gt.0) then - dudy=(uy(2)-uy(1))/real(juy)/(dyn(l)*pi/180.) - else - dudy=uuhn(ix,jyvp,kl,l)-uuhn(ix,jyvm,kl,l) - dudy=dudy/real(jumpy)/(dyn(l)*pi/180.) - end if - - pvhn(ix,jy,kl,l)=dthetadp*(f+(dvdx/cosphi-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_nest - -subroutine calcpar(n) - ! 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. * - ! * - ! Author: A. Stohl * - ! * - ! 21 May 1995 * - ! * - ! ------------------------------------------------------------------ * - ! Petra Seibert, Feb 2000: * - ! convection scheme: * - ! new variables in call to richardson * - ! * - ! CHANGE 17/11/2005 Caroline Forster NCEP GFS version * - ! * - ! Changes, Bernd C. Krueger, Feb. 2001: * - ! Variables tth and qvh (on eta coordinates) in common block * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! - Merged calcpar and calcpar_gfs into one routine using if-then * - ! for meteo-type dependent code * - !***************************************************************************** - - !***************************************************************************** - ! * - ! Variables: * - ! n temporal index for meteorological fields (1 to 3) * - ! metdata_format format of metdata (ecmwf/gfs) * - ! * - ! Constants: * - ! * - ! * - ! Functions: * - ! scalev computation of ustar * - ! obukhov computatio of Obukhov length * - ! * - !***************************************************************************** - - use class_gribfile_mod - use drydepo_mod, global_ol => ol - use qvsat_mod - - implicit none - - integer :: n,ix,jy,i,kz,lz,kzmin,llev,loop_start,ierr - real :: ol,hmixplus - real :: rh,subsceff,ylat - real :: altmin,tvold,pold,zold,pint,tv,hmixdummy,akzdummy - real :: vd(maxspec) - real :: z0_tmp(numclass) ! temporary variable for z0 (shared between OMP threads) - real,parameter :: const=r_air/ga - - !write(*,*) 'in calcpar writting snowheight' - !*********************************** - ! for test: write out snow depths - - ! open(4,file='slandusetest',form='formatted') - ! do 5 ix=0,nxmin1 - !5 write (4,*) (sd(ix,jy,1,n),jy=0,nymin1) - ! close(4) - - - ! Loop over entire grid - !********************** - - ! openmp change - z0_tmp = z0 - !$OMP PARALLEL PRIVATE(jy,ix,ulev,vlev,ttlev,qvlev,llev,ylat,ol,i,hmixplus, & - !$OMP subsceff,vd,kz,lz,zlev,rh,kzmin,pold,zold,tvold,pint,tv,loop_start,ierr, & - !$OMP altmin) - z0 = z0_tmp - - !$OMP DO - do jy=0,nymin1 - - ! Set minimum height for tropopause - !********************************** - - ylat=ylat0+real(jy)*dy - 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 - - do ix=0,nxmin1 - - ! 1) Calculation of friction velocity - !************************************ +#include "get_alloc_getfields.f90" - ustar(ix,jy,1,n)=scalev(ps(ix,jy,1,n),tt2(ix,jy,1,n), & - td2(ix,jy,1,n),sfcstress(ix,jy,1,n)) - if (ustar(ix,jy,1,n).le.1.e-8) ustar(ix,jy,1,n)=1.e-8 +#include "get_dealloc_getfields.f90" - ! 2) Calculation of inverse Obukhov length scale - !*********************************************** +#include "get_getfields.f90" - if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then - ! NCEP version: find first level above ground - llev = 0 - do i=1,nuvz - if (ps(ix,jy,1,n).lt.akz(i)) llev=i - end do - llev = llev+1 - if (llev.gt.nuvz) llev = nuvz-1 - ! NCEP version +#include "get_calcpv.f90" - ! calculate inverse Obukhov length scale with tth(llev) - ol=obukhov(ps(ix,jy,1,n),tt2(ix,jy,1,n),td2(ix,jy,1,n), & - tth(ix,jy,llev,n),ustar(ix,jy,1,n),sshf(ix,jy,1,n), & - akm,bkm,akz(llev)) - else - llev=0 - 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,akzdummy) - end if +#include "get_calcpv_nest.f90" - if (ol.ne.0.) then - oli(ix,jy,1,n)=1./ol - else - oli(ix,jy,1,n)=99999. - endif +#include "get_calcpar.f90" +#include "get_calcpar_nest.f90" - ! 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) - ttlev(i)=tth(ix,jy,i,n) - qvlev(i)=qvh(ix,jy,i,n) - end do - - if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then - ! NCEP version hmix has been read in in readwind.f, is therefore not calculated here - 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),hmixdummy,wstar(ix,jy,1,n),hmixplus,ierr) - else - 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,ierr) - end if - - if (ierr.lt.0) then - write(*,9500) 'failure', ix, jy - stop - endif -9500 format( 'calcpar - richardson ', a, ' - ix,jy=', 2i5 ) - - if(lsubgrid.eq.1) then - subsceff=min(excessoro(ix,jy),hmixplus) - else - subsceff=0.0 - endif - ! - ! CALCULATE HMIX EXCESS ACCORDING TO SUBGRIDSCALE VARIABILITY AND STABILITY - ! - hmix(ix,jy,1,n)=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 - ! Sabine Eckhardt, Dec 06: use new index for z0 for water depending on - ! windspeed - z0(7)=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),ps(ix,jy,1,n))/ew(tt2(ix,jy,1,n),ps(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), & - sd(ix,jy,1,n),vd) - - do i=1,nspec - vdep(ix,jy,i,n)=vd(i) - end do - - endif - - !****************************************************** - ! Calculate height of thermal tropopause (Hoinka, 1997) - !****************************************************** - - ! 1) Calculate altitudes of model levels - !*************************************** - - tvold=tt2(ix,jy,1,n)*(1.+0.378*ew(td2(ix,jy,1,n),ps(ix,jy,1,n))/ & - ps(ix,jy,1,n)) - pold=ps(ix,jy,1,n) - zold=0. - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - loop_start=2 - else - loop_start=llev - end if - do kz=loop_start,nuvz - pint=akz(kz)+bkz(kz)*ps(ix,jy,1,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) - 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 - !************************************************************************ - - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - !LB, The CTM version has 2 (as bugfix), so I changed it 2 from 1 to try out - loop_start=2 - else - loop_start=llev - end if - - do kz=loop_start,nuvz - if (zlev(kz).ge.altmin) then - kzmin=kz - exit - endif - end do - - ! 3) Search for first stable layer above minimum height that fulfills the - ! thermal tropopause criterion - !************************************************************************ - - outer: do kz=kzmin,nuvz - inner: 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) - exit outer - endif - exit inner - endif - end do inner - end do outer - - end do - end do - !$OMP END DO - !$OMP END PARALLEL - ! openmp change end - - ! Calculation of potential vorticity on 3-d grid - !*********************************************** - - call calcpv(n) -end subroutine calcpar - -subroutine calcpar_nest(n) - ! 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. * - ! * - ! 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 * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - !***************************************************************************** - ! * - ! Variables: * - ! n temporal index for meteorological fields (1 to 3) * - ! metdata_format format of metdata (ecmwf/gfs) * - ! * - ! Constants: * - ! * - ! * - ! Functions: * - ! scalev computation of ustar * - ! obukhov computatio of Obukhov length * - ! * - !***************************************************************************** - - use drydepo_mod, global_ol => ol - use qvsat_mod - - implicit none - - integer :: n,ix,jy,i,l,kz,lz,kzmin,ierr - real :: ol,hmixplus,dummyakzllev - real :: rh,subsceff,ylat - real :: altmin,tvold,pold,zold,pint,tv - real :: vd(maxspec) - real :: z0_tmp(numclass) ! temporary variable for z0 (shared between OMP threads) - real,parameter :: const=r_air/ga - - - ! Loop over all nests - !******************** - - do l=1,numbnests - - ! Loop over entire grid - !********************** - z0_tmp = z0 -!$OMP PARALLEL DEFAULT(SHARED) & -!$OMP PRIVATE(i,ix,jy,kz,lz,kzmin,tvold,pold,zold,zlev,tv,pint, & -!$OMP rh,ierr,subsceff,ulev,vlev,ttlev,qvlev,ol,altmin,ylat,hmixplus, & -!$OMP dummyakzllev,vd ) - z0 = z0_tmp - -!$OMP DO - do jy=0,nyn(l)-1 - - ! Set minimum height for tropopause - !********************************** - - ylat=ylat0n(l)+real(jy)*dyn(l) - 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 - - do ix=0,nxn(l)-1 - - ! 1) Calculation of friction velocity - !************************************ - - 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),sfcstressn(ix,jy,1,n,l)) - if (ustarn(ix,jy,1,n,l).le.1.e-8) ustarn(ix,jy,1,n,l)=1.e-8 - - ! 2) Calculation of inverse Obukhov length scale - !*********************************************** - - 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,dummyakzllev) - 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) - ttlev(i)=tthn(ix,jy,i,n,l) - qvlev(i)=qvhn(ix,jy,i,n,l) - end do - - 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,ierr) - if (ierr.lt.0) then - write(*,9500) 'failure', ix, jy, l - stop - endif -9500 format( 'calcparn - richardson ', a, ' - ix,jy=', 2i5 ) - - if(lsubgrid.eq.1) then - subsceff=min(excessoron(ix,jy,l),hmixplus) - else - subsceff=0.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 - z0(7)=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),psn(ix,jy,1,n,l))/ew(tt2n(ix,jy,1,n,l),psn(ix,jy,1,n,l)) - - call getvdep_nest(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),sdn(ix,jy,1,n,l),vd,l) - - do i=1,nspec - vdepn(ix,jy,i,n,l)=vd(i) - end do - - 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))/ & - psn(ix,jy,1,n,l)) - pold=psn(ix,jy,1,n,l) - zold=0. - 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 - exit - endif - end do - - ! 3) Search for first stable layer above minimum height that fulfills the - ! thermal tropopause criterion - !************************************************************************ - - kzloop : do kz=kzmin,nuvz - lzloop : 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) - exit kzloop - endif - exit lzloop - endif - end do lzloop - end do kzloop - - end do - end do - -!$OMP END DO -!$OMP END PARALLEL - - ! Calculation of potential vorticity on 3-d grid - !*********************************************** - - call calcpv_nest(l,n) - - end do -end subroutine calcpar_nest - -real function obukhov(ps,tsurf,tdsurf,tlev,ustar,hf,akm,bkm,plev) - - !******************************************************************** - ! * - ! Author: G. WOTAWA * - ! Date: 1994-06-27 * - ! * - ! This program calculates Obukhov scale height from surface * - ! meteorological data and sensible heat flux. * - ! * - !******************************************************************** - ! * - ! Update: A. Stohl, 2000-09-25, avoid division by zero by * - ! setting ustar to minimum value * - ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! - Merged obukhov and obukhov_gfs into one routine using * - ! if-then for meteo-type dependent code * - ! * - !******************************************************************** - ! * - ! 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 * - ! plev * - ! metdata_format format of metdata (ecmwf/gfs) * - ! * - !******************************************************************** - - use class_gribfile_mod - use qvsat_mod - - implicit none - - real,dimension(:) :: akm,bkm - real :: ps,tsurf,tdsurf,tlev,ustar,hf,e,tv,rhoa,plev - real :: ak1,bk1,theta,thetastar - - - e=ew(tdsurf,ps) ! vapor pressure - tv=tsurf*(1.+0.378*e/ps) ! virtual temperature - rhoa=ps/(r_air*tv) ! air density - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - ak1=(akm(1)+akm(2))/2. - bk1=(bkm(1)+bkm(2))/2. - plev=ak1+bk1*ps ! Pressure level 1 - end if - 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 - -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 - !**************************************************************************** - ! * - ! 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. * - ! * - ! CHANGE: 17/11/2005 Caroline Forster NCEP GFS version * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! - Merged richardson and richardson_gfs into one routine using * - ! if-then for meteo-type dependent code * - ! * - !**************************************************************************** - ! * - ! Variables: * - ! h mixing height [m] * - ! hf sensible heat flux * - ! psurf surface pressure at point (xt,yt) [Pa] * - ! tv virtual temperature * - ! wst convective velocity scale * - ! metdata_format format of metdata (ecmwf/gfs) * - ! * - ! Constants: * - ! ric critical Richardson number * - ! * - !**************************************************************************** - - use class_gribfile_mod - use qvsat_mod - - implicit none - - integer,intent(out) :: & - ierr ! Returns error when no richardson number can be found - real, intent(out) :: & - h, & ! mixing height [m] - wst, & ! convective velocity scale - hmixplus ! - integer,intent(in) :: & - nuvz ! Upper vertical level - real,intent(in) :: & - psurf, & ! surface pressure at point (xt,yt) [Pa] - ust, & ! Scale velocity - hf, & ! Surface sensible heat flux - tt2,td2 ! Temperature - real,intent(in),dimension(:) :: & - ttlev, & - qvlev, & - ulev, & - vlev, & - akz,bkz - integer :: & - i,k,iter,llev,loop_start ! Loop variables - real :: & - tv,tvold, & ! Virtual temperature - zref,z,zold,zl,zl1,zl2, & ! Heights - pint,pold, & ! Pressures - theta,thetaold,thetaref,thetal, & ! Potential temperature - theta1,theta2,thetam, & - ri, & ! Richardson number per level - ril, & ! Richardson number sub level - excess, & ! - ul,vl, & ! Velocities sub level - wspeed, & ! Wind speed at z=hmix - bvfsq, & ! Brunt-Vaisala frequency - bvf, & ! square root of bvfsq - rh,rhold,rhl - real,parameter :: const=r_air/ga, ric=0.25, b=100., bs=8.5 - integer,parameter :: itmax=3 - - excess=0.0 - - if (metdata_format.eq.GRIBFILE_CENTRE_NCEP) then - ! NCEP version: find first model level above ground - !************************************************** - - llev = 0 - do i=1,nuvz - if (psurf.lt.akz(i)) llev=i - end do - llev = llev+1 - ! sec llev should not be 1! - if (llev.eq.1) llev = 2 - if (llev.gt.nuvz) llev = nuvz-1 - ! NCEP version - end if - - - ! Compute virtual temperature and virtual potential temperature at - ! reference level (2 m) - !***************************************************************** - - do iter=1,itmax,1 - - pold=psurf - tvold=tt2*(1.+0.378*ew(td2,psurf)/psurf) - zold=2.0 - zref=zold - rhold=ew(td2,psurf)/ew(tt2,psurf) - - thetaref=tvold*(100000./pold)**(r_air/cpa)+excess - thetaold=thetaref - - - ! Integrate z up to one level above zt - !************************************* - if (metdata_format.eq.GRIBFILE_CENTRE_ECMWF) then - loop_start=2 - else - loop_start=llev - end if - do k=loop_start,nuvz - pint=akz(k)+bkz(k)*psurf ! 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) ) - - - ! Calculate 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) exit - - tvold=tv - pold=pint - rhold=rh - thetaold=theta - zold=z - end do - ! Check opied from FLEXPART-WRF, 2022 LB - if (k.ge.nuvz) then - write(*,*) 'richardson not working -- k = nuvz' - ierr = -10 - goto 7000 - endif - !k=min(k,nuvz) ! ESO: make sure k <= nuvz (ticket #139) !MD change to work without goto - - ! Determine Richardson number between the critical levels - !******************************************************** - - zl1=zold - theta1=thetaold - do i=1,20 - zl=zold+real(i)/20.*(z-zold) - ul=ulev(k-1)+real(i)/20.*(ulev(k)-ulev(k-1)) - vl=vlev(k-1)+real(i)/20.*(vlev(k)-vlev(k-1)) - thetal=thetaold+real(i)/20.*(theta-thetaold) - rhl=rhold+real(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) exit - if (i.eq.20) then - write(*,*) 'WARNING: NO RICHARDSON NUMBER GREATER THAN 0.25 FOUND', k,ril,ri - exit - endif - zl1=zl - theta1=thetal - !if (i.eq.20) stop 'RICHARDSON: NO RICHARDSON NUMBER GREATER THAN 0.25 FOUND' - end do - - h=zl - 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 - endif - - - ! Calculate convective velocity scale - !************************************ - - if (hf.lt.0.) then - wst=(-h*ga/thetaref*hf/cpa)**0.333 - excess=-bs*hf/cpa/wst - else - wst=0. - exit - endif - end do - - 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 - -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 qvsat_mod - - implicit none +#include "get_obukhov.f90" - real :: ps,t,td,e,tv,rhoa,stress +#include "get_richardson.f90" - e=ew(td,ps) ! 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 +#include "get_scalev.f90" end module getfields_mod diff --git a/src/ini_alloc_domainfill.f90 b/src/ini_alloc_domainfill.f90 new file mode 100644 index 0000000000000000000000000000000000000000..355565a2db5c66181bc8ab1af8b6be96c491e06c --- /dev/null +++ b/src/ini_alloc_domainfill.f90 @@ -0,0 +1,9 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine alloc_domainfill + + allocate(numcolumn_we(2,0:nymax-1),numcolumn_sn(2,0:nxmax-1)) + allocate(zcolumn_we(2,0:nymax-1,maxcolumn),zcolumn_sn(2,0:nxmax-1,maxcolumn),& + acc_mass_we(2,0:nymax-1,maxcolumn),acc_mass_sn(2,0:nxmax-1,maxcolumn)) +end subroutine alloc_domainfill diff --git a/src/ini_boundcond_domainfill.f90 b/src/ini_boundcond_domainfill.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4b4207e1b1866f471f9129e56b39323b3d2b8b61 --- /dev/null +++ b/src/ini_boundcond_domainfill.f90 @@ -0,0 +1,530 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine boundcond_domainfill(itime,loutend) + ! i i + !***************************************************************************** + ! * + ! 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 * + ! * + ! Changes * + ! 2022, L. Bakels: OpenMP parallelisation * + ! * + !***************************************************************************** + ! * + ! 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 +#ifdef _OPENMP + use omp_lib +#endif + implicit none + + real :: dz,dz1,dz2,dt1,dt2,dtt,ylat,xm,cosfact,accmasst + integer :: itime,in,indz,indzp,i,loutend,numparticlecount_tmp + integer :: j,k,ix,jy,m,indzh,indexh,minpart,ipart,mmass,ithread + integer :: numactiveparticles + + real :: windl(2),rhol(2) + 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 + + ! Determine auxiliary variables for time interpolation + !***************************************************** + + dt1=real(itime-memtime(1)) + dt2=real(memtime(2)-itime) + dtt=1./(dt1+dt2) + + numactiveparticles=0 + numparticlecount_tmp=numparticlecount + accmasst=0. + ! Terminate trajectories that have left the domain, if domain-filling + ! trajectory calculation domain is not global + !******************************************************************** + + do i=1,numpart + if (.not. part(i)%alive) cycle + + if ((part(i)%ylat.gt.real(ny_sn(2))).or. & + (part(i)%ylat.lt.real(ny_sn(1)))) call terminate_particle(i,itime) + if (((.not.xglobal).or.(nx_we(2).ne.(nx-2))).and. & + ((part(i)%xlon.lt.real(nx_we(1))).or. & + (part(i)%xlon.gt.real(nx_we(2))))) call terminate_particle(i,itime) + if (part(i)%alive) numactiveparticles = numactiveparticles+1 + end do + + !*************************************** + ! Western and eastern boundary condition + !*************************************** + + ! Loop from south to north + !************************* +!$OMP PARALLEL PRIVATE(i,jy,k,j,deltaz,boundarea,indz,indzp,indexh,windl,rhol, & +!$OMP windhl,rhohl,windx,rhox,fluxofmass,mmass,ixm,jym,ixp,jyp,ddx,ddy,rddx, & +!$OMP rddy,p1,p2,p3,p4,indzm,mm,indzh,pvpart,ylat,ix,cosfact,ipart) & +!$OMP REDUCTION(+:numactiveparticles,numparticlecount_tmp,accmasst) + +#ifdef _OPENMP + ithread = OMP_GET_THREAD_NUM() +#else + ithread = 0 +#endif + +!$OMP DO + do jy=ny_sn(1),ny_sn(2) + + ! Loop over western (index 1) and eastern (index 2) boundary + !*********************************************************** + + do k=1,2 + + ! 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 + ! 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 + 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 + + + ! Interpolate the wind velocity and density to the release location + !****************************************************************** + + ! Determine the model level below the release position + !***************************************************** + indz=nz-1 + indzp=nz + do i=2,nz + if (height(i).gt.zcolumn_we(k,jy,j)) then + indz=i-1 + indzp=i + exit + endif + end do + + ! 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) + 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_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 + call get_newpart_index(ipart) + call spawn_particle(itime, ipart) + + ! Assign particle positions + !************************** + + call set_xlon(ipart,real(nx_we(k),kind=dp)) + if (jy.eq.ny_sn(1)) then + call set_ylat(ipart,real(real(jy)+0.5*ran1(idummy,ithread),kind=dp)) + else if (jy.eq.ny_sn(2)) then + call set_ylat(ipart,real(real(jy)-0.5*ran1(idummy,ithread),kind=dp)) + else + call set_ylat(ipart,real(real(jy)+(ran1(idummy,ithread)-.5),kind=dp)) + endif + if (j.eq.1) then + call set_z(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 + call set_z(ipart,(2.*zcolumn_we(k,jy,j)+ & + zcolumn_we(k,jy,j-1)+height(nz))/4.) + else + call set_z(ipart,zcolumn_we(k,jy,j-1)+ran1(idummy,ithread)* & + (zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))) + endif + + call update_z_to_zeta(itime, ipart) + + ! Interpolate PV to the particle position + !**************************************** + ixm=int(part(ipart)%xlon) + jym=int(part(ipart)%ylat) + ixp=ixm+1 + jyp=jym+1 + ddx=part(ipart)%xlon-real(ixm) + ddy=part(ipart)%ylat-real(jym) + rddx=1.-ddx + rddy=1.-ddy + p1=rddx*rddy + p2=ddx*rddy + p3=rddx*ddy + p4=ddx*ddy + indzm=nz-1 + indzp=nz + do i=2,nz + if (real(height(i),kind=dp).gt.part(ipart)%z) then + indzm=i-1 + indzp=i + exit + endif + end do + dz1=real(part(ipart)%z)-height(indzm) + dz2=height(indzp)-real(part(ipart)%z) + 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 + ylat=ylat0+part(ipart)%ylat*dy + if (ylat.lt.0.) pvpart=-1.*pvpart + + + ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere + !***************************************************************************** + + if (((part(ipart)%z.gt.3000.).and. & + (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then + part(ipart)%nclass=min(int(ran1(idummy,ithread)* & + real(nclassunc))+1,nclassunc) + numactiveparticles=numactiveparticles+1 + numparticlecount_tmp=numparticlecount_tmp+1 + part(ipart)%npoint=numparticlecount_tmp + part(ipart)%idt=mintime + part(ipart)%tstart=itime + part(ipart)%mass(1)=xmassperparticle + if (mdomainfill.eq.2) part(ipart)%mass(1)= & + part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9 + part(ipart)%mass_init(1)=part(ipart)%mass(1) + else + stop 'boundcond_domainfill error: look into original to understand what should happen here' + endif + end do ! particles + end do ! release locations in column + end do ! western and eastern boundary + end do ! south to north +!$OMP END DO + + !***************************************** + ! Southern and northern boundary condition + !***************************************** + + ! Loop from west to east + !*********************** +!$OMP DO + do ix=nx_we(1),nx_we(2) + + ! Loop over southern (index 1) and northern (index 2) boundary + !************************************************************* + + do k=1,2 + ylat=ylat0+real(ny_sn(k))*dy + cosfact=cos(ylat*pi180) + + ! 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 + 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 + + + ! Interpolate the wind velocity and density to the release location + !****************************************************************** + + ! Determine the model level below the release position + !***************************************************** + indz=nz-1 + indzp=nz + do i=2,nz + if (height(i).gt.zcolumn_sn(k,ix,j)) then + indz=i-1 + indzp=i + exit + endif + end do + + ! 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 + call get_newpart_index(ipart) + call spawn_particle(itime, ipart) + + ! Assign particle positions + !************************** + call set_ylat(ipart,real(ny_sn(k),kind=dp)) + if (ix.eq.nx_we(1)) then + call set_xlon(ipart,real(real(ix)+0.5*ran1(idummy,ithread),kind=dp)) + else if (ix.eq.nx_we(2)) then + call set_xlon(ipart,real(real(ix)-0.5*ran1(idummy,ithread),kind=dp)) + else + call set_xlon(ipart,real(real(ix)+(ran1(idummy,ithread)-.5),kind=dp)) + endif + if (j.eq.1) then + call set_z(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 + call set_z(ipart,(2.*zcolumn_sn(k,ix,j)+ & + zcolumn_sn(k,ix,j-1)+height(nz))/4.) + else + call set_z(ipart,zcolumn_sn(k,ix,j-1)+ran1(idummy,ithread)* & + (zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))) + endif + + call update_z_to_zeta(itime, ipart) + + ! Interpolate PV to the particle position + !**************************************** + ixm=int(part(ipart)%xlon) + jym=int(part(ipart)%ylat) + ixp=ixm+1 + jyp=jym+1 + ddx=part(ipart)%xlon-real(ixm) + ddy=part(ipart)%ylat-real(jym) + rddx=1.-ddx + rddy=1.-ddy + p1=rddx*rddy + p2=ddx*rddy + p3=rddx*ddy + p4=ddx*ddy + indzm=nz-1 + indzp=nz + do i=2,nz + if (real(height(i),kind=dp).gt.part(ipart)%z) then + indzm=i-1 + indzp=i + exit + endif + end do + dz1=real(part(ipart)%z)-height(indzm) + dz2=height(indzp)-real(part(ipart)%z) + 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 (((part(ipart)%z.gt.3000.).and. & + (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then + part(ipart)%nclass=min(int(ran1(idummy,ithread)* & + real(nclassunc))+1,nclassunc) + numactiveparticles=numactiveparticles+1 + numparticlecount_tmp=numparticlecount_tmp+1 + part(ipart)%npoint=numparticlecount_tmp + part(ipart)%idt=mintime + part(ipart)%mass(1)=xmassperparticle + if (mdomainfill.eq.2) part(ipart)%mass(1)= & + part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9 + part(ipart)%mass_init(1)=part(ipart)%mass(1) + else + stop 'boundcond_domainfill error: look into original to understand what should happen here' + endif + end do ! particles + end do ! releases per column + end do ! east west + end do ! north south +!$OMP END DO +!$OMP END PARALLEL + numparticlecount = numparticlecount_tmp + ! 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/ini_dealloc_domainfill.f90 b/src/ini_dealloc_domainfill.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f0c2511514b66cc3b35a406b3f2a2d2c9512a690 --- /dev/null +++ b/src/ini_dealloc_domainfill.f90 @@ -0,0 +1,10 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine dealloc_domainfill + + if (mdomainfill.lt.1) return + deallocate(numcolumn_we,numcolumn_sn,zcolumn_sn,zcolumn_we,acc_mass_sn, & + acc_mass_we) + +end subroutine dealloc_domainfill diff --git a/src/ini_init_domainfill.f90 b/src/ini_init_domainfill.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ca4f4201eaad132f8253d3bba2c198fc378f0c58 --- /dev/null +++ b/src/ini_init_domainfill.f90 @@ -0,0 +1,470 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine init_domainfill + ! + !***************************************************************************** + ! * + ! 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 * + ! * + ! Changes * + ! 2022, L. Bakels: OpenMP parallelisation * + ! * + !***************************************************************************** + ! * + ! 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 particle_mod + + implicit none + + integer :: j,kz,lix,ljy,ncolumn,numparttot + real :: pp(nzmax),ylat,ylatp,ylatm,hzone + real :: cosfactm,cosfactp,deltacol,dz1,dz2,dz,pnew,pnew_temp,fractus + real,parameter :: pih=pi/180. + real :: colmasstotal,zposition + + integer :: ixm,ixp,jym,jyp,indzm,indzh,indzp,i,jj,ii + integer :: alive_tmp,allocated_tmp,spawned_tmp,terminated_tmp + real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2) + integer :: idummy = -11 + + real :: frac,psint,zzlev,zzlev2,ttemp,height_tmp + + logical :: deall + + real,allocatable,dimension(:) :: gridarea ! + real,allocatable,dimension(:,:) :: colmass ! + + ! Determine the release region (only full grid cells), over which particles + ! shall be initialized + ! Use 2 fields for west/east and south/north boundary + !************************************************************************** + call alloc_domainfill + + 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 + write(*,*) 'Global domain: ', gdomainfill + + ! Exit here if resuming a run from particle dump + !*********************************************** + if (gdomainfill.and.ipin.ne.0) return + + ! Allocate grid and column mass + !******************************* + allocate(gridarea(0:nymax-1),colmass(0:nxmax-1,0:nymax-1)) + + ! 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 + !************************************************************ + ! First for the south pole + + if (sglobal) then + 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 + 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 + + + + ! Allocate memory for storing the particles + !****************************************** + call alloc_particles(npart(1)) + + ! Initialise total particle number + numparttot=0 + ! Initialise max column number + numcolumn=0 + + ! Initialise the sum over the total mass of the atmosphere + colmasstotal=0. + +!$OMP PARALLEL PRIVATE(ljy,ylat,ylatp,ylatm,hzone,cosfactp,cosfactm,pp,lix) & +!$OMP REDUCTION(+:colmasstotal) +!$OMP DO + do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes + ylat=ylat0+real(ljy)*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 + gridarea(ljy)=2.*pi*r_earth*hzone*dx/360. + end do +!$OMP END DO +!$OMP BARRIER + + ! Calculate total mass of each grid column and of the whole atmosphere + !********************************************************************* +!$OMP DO + do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes + do lix=nx_we(1),nx_we(2) ! loop about longitudes + pp(1)=prs(lix,ljy,1,1) !rho(lix,ljy,1,1)*r_air*tt(lix,ljy,1,1) + pp(nz)=prs(lix,ljy,nz,1) !rho(lix,ljy,nz,1)*r_air*tt(lix,ljy,nz,1) + colmass(lix,ljy)=(pp(1)-pp(nz))/ga*gridarea(ljy) + colmasstotal=colmasstotal+colmass(lix,ljy) + end do + end do +!$OMP END DO +!$OMP END PARALLEL + + write(*,*) 'Atm. mass: ',colmasstotal + + if (ipin.eq.0) numpart=0 + + ! Determine the particle positions + !********************************* + do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes + ylat=ylat0+real(ljy)*dy + do lix=nx_we(1),nx_we(2) ! loop about longitudes + ncolumn=nint(0.999*real(npart(1))*colmass(lix,ljy)/colmasstotal) + if (ncolumn.eq.0) cycle + 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)=prs(lix,ljy,kz,1)!rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1) + end do + + deltacol=(pp(1)-pp(nz))/real(ncolumn) + pnew=pp(1)+deltacol/2. + jj=0 + + do j=1,ncolumn ! looping over the number of particles within the column + + ! For columns with many particles (i.e. around the equator), distribute + ! the particles equally (1 on a random position within the deltacol range), + ! for columns with few particles (i.e. around the poles), + ! distribute the particles randomly + !*********************************************************************** + + if ((ncolumn.gt.20).and.(ncolumn-j.gt.20)) then + pnew_temp=pnew-ran1(idummy,0)*deltacol + pnew=pnew-deltacol + else if ((ncolumn.gt.20).and.(ncolumn-j.le.20)) then + ! When only few particles are left, distribute them randomly above pnew + pnew_temp=pnew-ran1(idummy,0)*(pnew-pp(nz)) + else + pnew_temp=pp(1)-ran1(idummy,0)*(pp(1)-pp(nz)) + endif + + do kz=1,nz-1 + if ((pp(kz).ge.pnew_temp).and.(pp(kz+1).lt.pnew_temp)) then + dz1=log(pnew_temp)-log(pp(kz)) + dz=1./log(pp(kz+1)/pp(kz)) + + ! Assign particle position + !************************* + ! Do the following steps only if particles are not read in + ! from previous model run + + if (ipin.eq.0) then + ! First spawn the particle into existence + !**************************************** + jj=jj+1 + !THIS WILL CAUSE PROBLEMS WITH OMP! because of dynamical allocatio + call spawn_particle(0,numpart+jj) + if (allocated_tmp.lt.numpart+jj) allocated_tmp=numpart+jj + call set_xlon(numpart+jj, & + real( real(lix)-0.5+ran1(idummy,0), kind=dp ) ) + if (lix.eq.0) call set_xlon(numpart+jj, & + real( ran1(idummy,0), kind=dp ) ) + if (lix.eq.nxmin1) call set_xlon(numpart+jj, & + real( real(nxmin1)-ran1(idummy,0), kind=dp ) ) + call set_ylat(numpart+jj, & + real( real(ljy)-0.5+ran1(idummy,0), kind=dp ) ) + ! logarithmic distribution of particles along pressure levels: + ! hx=h1+(h2-h1)/log(p2/p1)*log(px/p1) + height_tmp=height(kz)+(height(kz+1)-height(kz))*dz*dz1 + call set_z(numpart+jj,height_tmp) + if (real(part(numpart+jj)%z).gt.height(nz)-0.5) & + call set_z(numpart+jj, height(nz)-0.5) + + call update_z_to_zeta(0, numpart+jj) + + ! Interpolate PV to the particle position + !**************************************** + ixm=int(part(numpart+jj)%xlon) + jym=int(part(numpart+jj)%ylat) + ixp=ixm+1 + jyp=jym+1 + ddx=part(numpart+jj)%xlon-real(ixm) + ddy=part(numpart+jj)%ylat-real(jym) + rddx=1.-ddx + rddy=1.-ddy + p1=rddx*rddy + p2=ddx*rddy + p3=rddx*ddy + p4=ddx*ddy + + !*************************************************************************** + indzm=nz-1 + indzp=nz + do i=2,nz + if (real(height(i),kind=dp).gt.part(numpart+jj)%z) then + indzm=i-1 + indzp=i + exit + endif + end do + dz1=real(part(numpart+jj)%z)-height(indzm) + dz2=height(indzp)-real(part(numpart+jj)%z) + dz=1./(dz1+dz2) + do ii=1,2 + indzh=indzm+ii-1 + y1(ii)=p1*pv(ixm,jym,indzh,1) & + + p2*pv(ixp,jym,indzh,1) & + + p3*pv(ixm,jyp,indzh,1) & + + p4*pv(ixp,jyp,indzh,1) + end do + 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 (( part(numpart+jj)%z .gt. 3000. .and. pvpart .gt. pvcrit ) & + .or. mdomainfill .eq. 1) then + + ! Assign certain properties to the particle + !****************************************** + part(numpart+jj)%nclass=min( & + int(ran1(idummy,0)*real(nclassunc))+1, nclassunc ) + numparticlecount=numparticlecount+1 + part(numpart+jj)%npoint=numparticlecount + part(numpart+jj)%idt=mintime + part(numpart+jj)%mass(1)=colmass(lix,ljy)/real(ncolumn) + if (mdomainfill.eq.2) part(numpart+jj)%mass(1)= & + part(numpart+jj)%mass(1)*pvpart*48./29.*ozonescale/10.**9 + part(numpart+jj)%mass_init(1)=part(numpart+jj)%mass(1) + else + call terminate_particle(numpart+jj, 0) + jj=jj-1 + endif + endif + endif + end do + end do + numparttot=numparttot+ncolumn + if (ipin.eq.0) numpart=numpart+jj + end do + end do + + + alive_tmp=count%alive + spawned_tmp=count%spawned + allocated_tmp=count%allocated + terminated_tmp=count%terminated + +!$OMP PARALLEL PRIVATE(j) REDUCTION(+:alive_tmp,spawned_tmp,allocated_tmp,terminated_tmp) + + ! Make sure that all particles are within domain + !*********************************************** +!$OMP DO + do j=1,numpart + if ((part(j)%xlon.lt.0.).or.(part(j)%xlon.ge.real(nxmin1,kind=dp)).or. & + (part(j)%ylat.lt.0.).or.(part(j)%ylat.ge.real(nymin1,kind=dp))) then + call terminate_particle(j,0) + alive_tmp=alive_tmp-1 + terminated_tmp=terminated_tmp+1 + endif + end do +!$OMP END DO +!$OMP END PARALLEL + + count%alive=alive_tmp + count%spawned=spawned_tmp + count%allocated=allocated_tmp + count%terminated=terminated_tmp + ! Check whether numpart is really smaller than maxpart + !***************************************************** + + ! ! ESO :TODO: this warning need to be moved further up, else out-of-bounds error earlier + ! 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) + + + ! 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 ljy=ny_sn(1),ny_sn(2) ! loop about latitudes + do lix=nx_we(1),nx_we(2) ! loop about longitudes + ncolumn=nint(0.999/fractus*real(npart(1))*colmass(lix,ljy) & + /colmasstotal) + if (ncolumn.gt.maxcolumn) stop 'maxcolumn too small' + if (ncolumn.eq.0) cycle + + + ! 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 (lix.eq.nx_we(1)) numcolumn_we(1,ljy)=ncolumn + if (lix.eq.nx_we(2)) numcolumn_we(2,ljy)=ncolumn + if (ljy.eq.ny_sn(1)) numcolumn_sn(1,lix)=ncolumn + if (ljy.eq.ny_sn(2)) numcolumn_sn(2,lix)=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)=prs(lix,ljy,kz,1) !rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1) + end do + + ! 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 (lix.eq.nx_we(1)) zcolumn_we(1,ljy,j)=zposition + if (lix.eq.nx_we(2)) zcolumn_we(2,ljy,j)=zposition + if (ljy.eq.ny_sn(1)) zcolumn_sn(1,lix,j)=zposition + if (ljy.eq.ny_sn(2)) zcolumn_sn(2,lix,j)=zposition + + ! Initialize mass that has accumulated at boundary to zero + !********************************************************* + + acc_mass_we(1,ljy,j)=0. + acc_mass_we(2,ljy,j)=0. + acc_mass_sn(1,ljy,j)=0. + acc_mass_sn(2,ljy,j)=0. + endif + end do + end do + end do + end do + + ! If there were more particles allocated than used, + ! Deallocate unused memory and update numpart + !************************************************** + deall=.false. + do i=numpart, 1, -1 + if (.not. part(i)%alive) then + deall=.true. + numpart = numpart - 1 + else + exit + endif + end do + + if (deall) call dealloc_particle(numpart) !Deallocates everything above numpart (F2008) + + + ! 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).and.(.not.gdomainfill)) then + open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', & + form='unformatted') + read(unitboundcond) numcolumn_we,numcolumn_sn, & + zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn + close(unitboundcond) + endif + + deallocate(gridarea,colmass) +end subroutine init_domainfill diff --git a/src/ini_init_particle.f90 b/src/ini_init_particle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..503728bf5abeaaa596efc02f60d15683bdddeff6 --- /dev/null +++ b/src/ini_init_particle.f90 @@ -0,0 +1,236 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine init_particle(itime,ipart) + ! 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 * + ! usig,vsig,wsig uncertainties of wind velocities due to interpolation * + ! 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 * + ! * + !***************************************************************************** + + use turbulence_mod + use random_mod, only: ran3 + use omp_lib + use interpol_mod + use cbl_mod + + implicit none + + integer,intent(in) :: & + itime, & + ipart + integer :: i,j,k,m,indexh + integer :: nrand + real :: dz,dz1,dz2,wp + real :: ttemp,dummy1,dummy2 + real :: xt,yt,zt,zteta + integer :: thread + +#ifdef _OPENMP + thread = OMP_GET_THREAD_NUM() +#else + thread = 0 +#endif + + part(ipart)%icbt=1 ! initialize particle to no "reflection" + + nrand=int(ran3(iseed1(thread),thread)*real(maxrand-1))+1 + + xt = real(part(ipart)%xlon) + yt = real(part(ipart)%ylat) + zt = real(part(ipart)%z) + zteta = real(part(ipart)%zeta) + + !****************************** + ! 2. Interpolate necessary data + !****************************** + + ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) + !*************************************************************** + call find_ngrid(xt,yt) + ! Compute maximum mixing height around particle position + !******************************************************* + call find_grid_indices(xt,yt) + + 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))) + + 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_pbl(itime,xt,yt,zt,zteta) + + ! 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 + !**************************************************************** + call interpol_pbl_short(zt,dummy1,dummy2) + + ! Compute the turbulent disturbances + + ! Determine the sigmas and the timescales + !**************************************** + + if (turbswitch) then + call hanna(zt) + else + call hanna1(zt) + endif + + + ! Determine the new diffusivity velocities + !***************************************** + + if (nrand+2.gt.maxrand) nrand=1 + part(ipart)%turbvel%u=rannumb(nrand)*sigu + part(ipart)%turbvel%v=rannumb(nrand+1)*sigv + part(ipart)%turbvel%w=rannumb(nrand+2) + if (.not.turbswitch) then ! modified by mc + part(ipart)%turbvel%w=part(ipart)%turbvel%w*sigw + else if (cblflag.eq.1) then ! modified by mc + if(-h/ol.gt.5) then + !if (ol.lt.0.) then + !if (ol.gt.0.) then !by mc : only for test correct is lt.0 + call init_cbl_vel( & + iseed1(thread),zt,ust,wst,h,sigw,part(ipart)%turbvel%w,ol,thread) + else + part(ipart)%turbvel%w=part(ipart)%turbvel%w*sigw + end if + end if + + + ! Determine time step for next integration + !***************************************** + + if (turbswitch) then + part(ipart)%idt = int( & + min( tlw, & + h / max( 2.*abs(part(ipart)%turbvel%w*sigw), 1.e-5 ), & + 0.5/abs(dsigwdz), & + 600.)& + *ctl ) + else + part(ipart)%idt = int( & + min( tlw, & + h / max( 2.*abs(part(ipart)%turbvel%w), 1.e-5), & + 600. ) & + *ctl) + endif + part(ipart)%idt=max(part(ipart)%idt,mintime) + + ! call interpol_average() + ! usig=(usigprof(indzp)+usigprof(indz))/2. + ! vsig=(vsigprof(indzp)+vsigprof(indz))/2. + ! wsig=(wsigprof(indzp)+wsigprof(indz))/2. + + ! wsigeta=(wsigprofeta(indzpeta)+wsigprofeta(indzeta))/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,xt,yt,zt,zteta,10) + + + ! Compute everything for above the PBL + + ! Assume constant turbulent perturbations + !**************************************** + + part(ipart)%idt=abs(lsynctime) + + if (nrand+1.gt.maxrand) nrand=1 + part(ipart)%turbvel%u=rannumb(nrand)*0.3 + part(ipart)%turbvel%v=rannumb(nrand+1)*0.3 + nrand=nrand+2 + part(ipart)%turbvel%w=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 (lmesoscale_turb) then + call interpol_mesoscale(itime,xt,yt,zt,zteta) + if (nrand+2.gt.maxrand) nrand=1 + part(ipart)%mesovel%u=rannumb(nrand)*usig + part(ipart)%mesovel%v=rannumb(nrand+1)*vsig + select case (wind_coord_type) + case ('ETA') + part(ipart)%mesovel%w=rannumb(nrand+2)*wsigeta + case ('METER') + part(ipart)%mesovel%w=rannumb(nrand+2)*wsig + case default + part(ipart)%mesovel%w=rannumb(nrand+2)*wsig + end select + endif +end subroutine init_particle diff --git a/src/ini_read_heightlevels.f90 b/src/ini_read_heightlevels.f90 new file mode 100644 index 0000000000000000000000000000000000000000..05ec34cd97e65d879e55b1ddd33b8d96f8e954f6 --- /dev/null +++ b/src/ini_read_heightlevels.f90 @@ -0,0 +1,32 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine read_heightlevels(height_tmp,nmixz_tmp) + implicit none + + real,intent(out) :: height_tmp(nzmax) + integer,intent(out) :: nmixz_tmp + integer :: kz,ios + character(len=256) :: heightlevels_filename + + heightlevels_filename = path(2)(1:length(2))//'heightlevels.bin' + + write(*,*) 'Reading heightlevels from file:', trim(heightlevels_filename) + + open(unitheightlevels,file=trim(heightlevels_filename),form='unformatted',err=9988) + + read(unitheightlevels,iostat=ios) nmixz_tmp + + do kz=1,nz + read(unitheightlevels) height_tmp(kz) + end do + close(unitheightlevels) + + return + +9988 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(2)(1:length(2))//'heightlevels.bin'//' #### ' + write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### ' + write(*,*) ' #### NAME DOES NOT EXISTS, REMOVE call read_heightlevels #### ' + write(*,*) ' #### FROM VERTTRANSFORM_MOD. #### ' +end subroutine read_heightlevels diff --git a/src/ini_readpartpositions.f90 b/src/ini_readpartpositions.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cbee1c876719bb286a77702c1cc618d90121d8d2 --- /dev/null +++ b/src/ini_readpartpositions.f90 @@ -0,0 +1,162 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 * + ! * + ! Changes * + ! 2022, L. Bakels: NetCDF option for reading particle information * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + !***************************************************************************** + +! use netcdf_output_mod + + implicit none + + integer :: ibdatein,ibtimein,nspecin,itimein,numpointin,i,j,lix,ios + integer :: id1,id2,it1,it2 + real :: xlonin,ylatin,topo,hmixi,pvi,qvi,rhoi,tri,tti + character :: specin*7 + real(kind=dp) :: julin,julpartin + + integer :: idummy = -8 + + numparticlecount=0 + + ! Open header file of dumped particle data + !***************************************** + if (lnetcdfout.eq.1) then +#ifdef USE_NCF + call read_partpos_ncf(ibtime,ibdate) + call get_totalpart_num(numpart) + numparticlecount=numpart + return +#endif + endif + + open(unitpartin,file=path(2)(1:length(2))//'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)) then + write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### ' + write(*,*) ' #### THE NUMBER OF SPECIES TO BE READ IN DOES #### ' + write(*,*) ' #### NOT AGREE WITH CURRENT SETTINGS! #### ' + stop + end if + + do i=1,nspecin + read(unitpartin) + read(unitpartin) + read(unitpartin) j,specin + if ((ldirect.eq.1).and.(species(i)(1:7).ne.specin)) then + write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### ' + write(*,*) ' #### SPECIES NAMES TO BE READ IN DO NOT #### ' + write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### ' + stop + end if + end do + + read(unitpartin) numpointin + if (numpointin.ne.numpoint) then + write(*,*) ' #### FLEXPART MODEL WARNING IN READPARTPOSITIONS#### ' + write(*,*) ' #### NUMBER OF RELEASE LOCATIONS DOES NOT #### ' + write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### ' + end if + do i=1,numpointin + read(unitpartin) + read(unitpartin) + read(unitpartin) + read(unitpartin) + do j=1,nspec + read(unitpartin) + read(unitpartin) + read(unitpartin) + end do + end do + read(unitpartin) + read(unitpartin) + + do lix=0,numxgrid-1 + read(unitpartin) + end do + + + ! Open data file of dumped particle data + !*************************************** + + close(unitpartin) + open(unitpartin,file=path(2)(1:length(2))//'partposit_end', & + form='unformatted',err=998) + + + do + read(unitpartin,iostat=ios) itimein + if (ios.lt.0) exit + i=0 + do + i=i+1 + read(unitpartin) part(i)%npoint,xlonin,ylatin,part(i)%z,part(i)%tstart, & + topo,pvi,qvi,rhoi,hmixi,tri,tti,(part(i)%mass(j),j=1,nspec) + ! For switching coordinates: this happens in timemanager.f90 after the first fields are read + if (xlonin.eq.-9999.9) exit + call set_xlon(i,real((xlonin-xlon0)/dx,kind=dp)) + call set_ylat(i,real((ylatin-ylat0)/dy,kind=dp)) + numparticlecount=max(numparticlecount,part(i)%npoint) + end do + end do + + numpart=i-1 + + close(unitpartin) + + julin=juldate(ibdatein,ibtimein)+real(itimein,kind=dp)/86400._dp + if (abs(julin-bdate).gt.1.e-5) then + write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### ' + write(*,*) ' #### ENDING TIME OF PREVIOUS MODEL RUN DOES #### ' + write(*,*) ' #### NOT AGREE WITH STARTING TIME OF THIS RUN.#### ' + call caldate(julin,id1,it1) + call caldate(bdate,id2,it2) + write(*,*) 'julin: ',julin,id1,it1 + write(*,*) 'bdate: ',bdate,id2,it2 + stop + end if + do i=1,numpart + julpartin=juldate(ibdatein,ibtimein)+ & + real(part(i)%tstart,kind=dp)/86400._dp + part(i)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, & + nclassunc) + part(i)%idt=mintime + part(i)%tstart=nint((julpartin-bdate)*86400.) + end do + + return + +998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(2)(1:length(2))//'partposit'//' #### ' + 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/ini_readrestart.f90 b/src/ini_readrestart.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d79dc6db238cf6a4f6b813cfd6b0a527b6299add --- /dev/null +++ b/src/ini_readrestart.f90 @@ -0,0 +1,132 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readrestart + + !***************************************************************************** + ! * + ! This routine opens the particle dump file and reads all the particle * + ! positions and gridded information from a previous run to initialize * + ! the current run. * + ! * + ! Author: L. Bakels 2022 * + ! * + !***************************************************************************** + +! use netcdf_output_mod + use unc_mod + + implicit none + + integer :: i,j,ios + integer :: id1,id2,it1,it2 + integer :: ks,kp,kz,nage,jy,ix,l + real(kind=dp) :: julin,julpartin + integer :: idummy = -8 + + numparticlecount=0 + + + open(unitpartin,file=path(2)(1:length(2))//'restart.bin', & + form='unformatted',err=9989) + + write(*,*) 'Reading Restart file:', path(2)(1:length(2))//'restart.bin' + + read(unitpartin,iostat=ios) itime_init + read(unitpartin) numpart + read(unitpartin) loutnext_init + read(unitpartin) outnum_init + call spawn_particles(itime_init, numpart) + do i=1,numpart + read(unitpartin) part(i)%xlon,part(i)%ylat,part(i)%z,part(i)%zeta, & + part(i)%npoint,part(i)%nclass,part(i)%idt,part(i)%tend, & + part(i)%tstart,part(i)%alive,part(i)%turbvel%u, & + part(i)%turbvel%v,part(i)%turbvel%w,part(i)%mesovel%u, & + part(i)%mesovel%v,part(i)%mesovel%w,(part(i)%mass(j),j=1,nspec), & + (part(i)%mass_init(j),j=1,nspec),(part(i)%wetdepo(j),j=1,nspec), & + (part(i)%drydepo(j),j=1,nspec) + part(i)%etaupdate=.true. + part(i)%meterupdate=.true. + if (.not. part(i)%alive) then + if (part(i)%tstart.le.itime_init) then + call terminate_particle(i,part(i)%tend) + else ! Particle is not spawned yet (original run with ipin=3) + count%alive = count%alive - 1 + count%spawned = count%spawned -1 + endif + endif + end do + if (iout.gt.0) then +#ifdef USE_NCF + read(unitpartin) tpointer +#endif + 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 + do kz=1,numzgrid + read(unitpartin) gridunc(ix,jy,kz,ks,kp,l,nage) + end do + if ((wetdep).and.(ldirect.gt.0)) then + read(unitpartin) wetgridunc(ix,jy,ks,kp,l,nage) + endif + if ((drydep).and.(ldirect.gt.0)) then + read(unitpartin) drygridunc(ix,jy,ks,kp,l,nage) + endif + 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 + do kz=1,numzgrid + read(unitpartin) griduncn(ix,jy,kz,ks,kp,l,nage) + end do + if ((wetdep).and.(ldirect.gt.0)) then + read(unitpartin) wetgriduncn(ix,jy,ks,kp,l,nage) + endif + if ((drydep).and.(ldirect.gt.0)) then + read(unitpartin) drygriduncn(ix,jy,ks,kp,l,nage) + endif + end do + end do + end do + endif + end do + end do + if ((drybkdep).or.(wetbkdep)) then + do i=1,numpart + read(unitpartin) xscav_frac1(i,ks) + end do + endif + end do + endif + close(unitpartin) + + numpart=count%spawned + + julin=juldate(ibdate,ibtime)+real(itime_init,kind=dp)/86400._dp + if (abs(julin-bdate).le.1.e-5) then + write(*,*) ' #### FLEXPART ERROR: PLEASE KEEP IBDATE #### ' + write(*,*) ' #### AND IBTIME INTACT FROM THE INITIAL RUN!#### ' + stop + endif + call caldate(julin,id1,it1) + call caldate(bdate,id2,it2) + write(*,*) ' #### Restarting Flexpart from restart.bin. #### ' + write(*,*) ' #### Original run started on #### ' + write(*,*) 'bdate: ',bdate,id2,it2 + write(*,*) ' #### Restarting run starts on #### ' + write(*,*) 'julin: ',julin,id1,it1 + + return + +9989 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(2)(1:length(2))//'restart.bin'//' #### ' + write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### ' + write(*,*) ' #### NAME DOES NOT EXISTS, RENAME THE APPROPRIATE #### ' + write(*,*) ' #### RESTART FILE TO restart.bin. #### ' +end subroutine readrestart diff --git a/src/ini_releaseparticle.f90 b/src/ini_releaseparticle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ac249b2859d30144211644342a0a0f1749eb801f --- /dev/null +++ b/src/ini_releaseparticle.f90 @@ -0,0 +1,416 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine releaseparticle(itime) + ! o + !***************************************************************************** + ! * + ! This subroutine releases particles from the release locations. * + ! * + ! 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 * + ! * + !***************************************************************************** + ! * + ! 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 point_mod + use xmass_mod +! use netcdf_output_mod + use output_mod + + implicit none + + !real xaux,yaux,zaux,ran1,rfraction,xmasssave(maxpoint) + real :: xaux,yaux,zaux,rfraction + real :: topo,rhoaux(2),r,t,rhoout + real :: dz1,dz2,dz,xlonav,timecorrect(maxspec),press,pressold + real :: presspart,average_timecorrect + integer :: itime,numrel,i,j,k,n,ipart,minpart,ii + integer :: kz,istart,iend,totpart + integer :: nweeks,ndayofweek,nhour,jjjjmmdd,ihmmss,mm + real(kind=dp) :: julmonday,jul,jullocal,juldiff + real,parameter :: eps2=1.e-6 + + integer :: ngrid,ix,jy,ixp,jyp,indz,indzp + real :: ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn + + integer :: idummy = -7 + !save idummy,xmasssave + !data idummy/-7/,xmasssave/maxpoint*0./ + + real :: frac,psint,zzlev,zzlev2,ttemp + + real :: eps + eps=nxmax/3.e5 + + + ! 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 saving time + + + ! For every release point, check whether we are in the release time interval + !*************************************************************************** + ! First allocate all particles that are going to be in the simulation + + if (itime.eq.0) then + totpart=0 + do i=1,numpoint + totpart = totpart+npart(i) + end do + call alloc_particles(totpart) + else if (itime.eq.itime_init) then !From restart point only allocate particles that are yet to be born + totpart=0 + do i=1,numpoint + totpart = totpart+npart(i) + end do + if (totpart.gt.count%allocated) call alloc_particles(totpart-count%allocated) + end if + + call get_totalpart_num(istart) + 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 + !********************************* + + xlonav=xlon0+(xpoint2(i)+xpoint1(i))/2.*dx ! longitude needed to determine local time + 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(abs(xpoint2(i)-xpoint1(i)).lt.1.E-4.and.abs(ypoint2(i)-ypoint1(i)).lt.1.E-4) then + ! 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) + end do + 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 + call get_newpart_index(ipart) + call spawn_particle(itime, ipart) + + ! Particle coordinates are determined by using a random position within the release volume + !***************************************************************************** + + ! Determine horizontal particle position + !*************************************** + call set_xlon(ipart,real(xpoint1(i)+ran1(idummy,0)*xaux,kind=dp)) + if (xglobal) then + if (part(ipart)%xlon.gt.real(nxmin1,kind=dp)) & + call set_xlon(ipart,-real(nxmin1,kind=dp)) + if (part(ipart)%xlon.lt.0.) & + call set_xlon(ipart,real(nxmin1,kind=dp)) + endif + call set_ylat(ipart,real(ypoint1(i)+ran1(idummy,0)*yaux,kind=dp)) + + ! 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 + ! for the scavenging calculation the mass needs to be multiplied with rho of the particle layer and + ! divided by the sum of rho of all particles. + !***************************************************************************** + do k=1,nspec + part(ipart)%mass(k)=xmass(i,k)/real(npart(i)) & + *timecorrect(k)/average_timecorrect + part(ipart)%mass_init(k)=part(ipart)%mass(k) + if (DRYBKDEP.or.WETBKDEP) then ! if there is no scavenging in wetdepo it will be set to 0 + ! if ( henry(k).gt.0 .or. & + ! crain_aero(k).gt.0. .or. csnow_aero(k).gt.0. .or. & + ! ccn_aero(k).gt.0. .or. in_aero(k).gt.0. ) then + xscav_frac1(ipart,k)=-1. + endif + ! Assign certain properties to particle + !************************************** + end do + part(ipart)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, & + nclassunc) + numparticlecount=numparticlecount+1 + if (mquasilag.eq.0) then + part(ipart)%npoint=i + else + part(ipart)%npoint=numparticlecount + endif + part(ipart)%idt=mintime ! first time step + + ! Determine vertical particle position + !************************************* + call set_z(ipart,zpoint1(i)+ran1(idummy,0)*zaux) + ! Interpolation of topography and density + !**************************************** + + ! Determine the nest we are in + !***************************** + ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) + ngrid=0 + do k=numbnests,1,-1 + if ((real(part(ipart)%xlon).gt.xln(k)+dxn(k)).and. & + (real(part(ipart)%xlon).lt.xrn(k)-dxn(k)).and. & + (real(part(ipart)%xlon).gt.yln(k)+dyn(k)).and. & + (real(part(ipart)%xlon).lt.yrn(k)-dyn(k))) then + ngrid=k + exit + endif + end do + + ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation + !***************************************************************************** + + if (ngrid.gt.0) then + xtn=(real(part(ipart)%xlon)-xln(ngrid))*xresoln(ngrid) + ytn=(real(part(ipart)%ylat)-yln(ngrid))*yresoln(ngrid) + ! ix=int(xtn) + ! jy=int(ytn) + ix=max(min(nint(xtn),nxn(ngrid)-1),0) + jy=max(min(nint(ytn),nyn(ngrid)-1),0) + ddy=ytn-real(jy) + ddx=xtn-real(ix) + else + ix=int(part(ipart)%xlon) + jy=int(part(ipart)%ylat) + ddy=part(ipart)%ylat-real(jy) + ddx=part(ipart)%xlon-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=part(ipart)%z + 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 + call set_z(ipart,height(1)/2.) + else + dz1=pressold-presspart + dz2=presspart-press + call set_z(ipart,(height(kz-1)*dz2+height(kz)*dz1) & + /(dz1+dz2)) + endif + exit + endif + pressold=press + end do + endif + + + ! If release positions are given in meters above sea level, subtract the + ! topography from the starting height + !*********************************************************************** + + if (kindz(i).eq.2) call update_z(ipart,-topo) + if (part(ipart)%z.lt.eps2) call set_z(ipart,eps2) ! Minimum starting height is eps2 + if (part(ipart)%z.gt.height(nz)-0.5) & + call set_z(ipart,height(nz)-0.5) ! Maximum starting height is uppermost level - 0.5 meters + + if (wind_coord_type.eq.'ETA') then + call z_to_zeta(itime,part(ipart)%xlon,part(ipart)%ylat,part(ipart)%z,part(ipart)%zeta) + part(ipart)%etaupdate = .true. ! The z(meter) coordinate is up to date + end if + + ! 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 + ! 0= no receptors + !Af 1="mass" + !Af 2="mass mixing ratio" + ! 3 = wet deposition in outputfield + ! 4 = dry deposition in outputfield + + !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).or.(ind_rel .eq. 3).or.(ind_rel .eq. 4)) then + + ! Interpolate the air density + !**************************** + + do ii=2,nz + if (height(ii).gt.part(ipart)%z) then + indz=ii-1 + indzp=ii + exit + endif + end do + + dz1=part(ipart)%z-height(indz) + dz2=height(indzp)-part(ipart)%z + 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) + end do + 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) + end do + endif + rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz + rho_rel(i)=rhoout + + + ! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density + !******************************************************************** + + do k=1,nspec + part(ipart)%mass(k)=part(ipart)%mass(k)*rhoout + part(ipart)%mass_init(k)=part(ipart)%mass(k) + end do + endif + + call get_totalpart_num(numpart) + + end do ! numrel + endif ! releasepoint + end do ! numpoint + + call get_totalpart_num(iend) + + ! NetCDF only: write initial positions of new particles +#ifdef USE_NCF + if ((iend-istart.gt.0).and.(ipout.ge.1)) then + call wrt_part_initialpos(itime,istart,iend) + call output_particle(itime,.true.) + endif +#endif + 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 releaseparticle diff --git a/src/initialise_mod.f90 b/src/initialise_mod.f90 index e9fe50988cfd1d0a12d27848d8016529154af596..94e92943de210170eb2b47027a2d0a9dca3dbcc7 100644 --- a/src/initialise_mod.f90 +++ b/src/initialise_mod.f90 @@ -19,7 +19,7 @@ module initialise_mod use coord_ec_mod #ifdef USE_NCF use netcdf_output_mod !PS -#endif +#endif implicit none !********************************************************** @@ -32,7 +32,7 @@ module initialise_mod numcolumn ! Max number of particles to be released within a single column integer,allocatable,dimension(:,:) :: & numcolumn_we, & ! Number of particles to be released within one col ! at the western and eastern boundary surfaces - numcolumn_sn ! Same as numcolumn_we, but for southern and northern + numcolumn_sn ! Same as numcolumn_we, but for southern and northern ! domain boundary. real,allocatable,dimension(:,:,:) :: & zcolumn_we, & ! Altitudes where particles are to be released @@ -46,1983 +46,22 @@ module initialise_mod contains -subroutine alloc_domainfill - - allocate(numcolumn_we(2,0:nymax-1),numcolumn_sn(2,0:nxmax-1)) - allocate(zcolumn_we(2,0:nymax-1,maxcolumn),zcolumn_sn(2,0:nxmax-1,maxcolumn),& - acc_mass_we(2,0:nymax-1,maxcolumn),acc_mass_sn(2,0:nxmax-1,maxcolumn)) -end subroutine alloc_domainfill - -subroutine dealloc_domainfill - - if (mdomainfill.lt.1) return - deallocate(numcolumn_we,numcolumn_sn,zcolumn_sn,zcolumn_we,acc_mass_sn, & - acc_mass_we) - -end subroutine dealloc_domainfill - -subroutine releaseparticle(itime) - ! o - !***************************************************************************** - ! * - ! This subroutine releases particles from the release locations. * - ! * - ! 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 * - ! * - !***************************************************************************** - ! * - ! 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 point_mod - use xmass_mod -! use netcdf_output_mod - use output_mod - - implicit none - - !real xaux,yaux,zaux,ran1,rfraction,xmasssave(maxpoint) - real :: xaux,yaux,zaux,rfraction - real :: topo,rhoaux(2),r,t,rhoout - real :: dz1,dz2,dz,xlonav,timecorrect(maxspec),press,pressold - real :: presspart,average_timecorrect - integer :: itime,numrel,i,j,k,n,ipart,minpart,ii - integer :: kz,istart,iend,totpart - integer :: nweeks,ndayofweek,nhour,jjjjmmdd,ihmmss,mm - real(kind=dp) :: julmonday,jul,jullocal,juldiff - real,parameter :: eps2=1.e-6 - - integer :: ngrid,ix,jy,ixp,jyp,indz,indzp - real :: ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn - - integer :: idummy = -7 - !save idummy,xmasssave - !data idummy/-7/,xmasssave/maxpoint*0./ - - real :: frac,psint,zzlev,zzlev2,ttemp - - real :: eps - eps=nxmax/3.e5 - - - ! 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 saving time - - - ! For every release point, check whether we are in the release time interval - !*************************************************************************** - ! First allocate all particles that are going to be in the simulation - - if (itime.eq.0) then - totpart=0 - do i=1,numpoint - totpart = totpart+npart(i) - end do - call alloc_particles(totpart) - else if (itime.eq.itime_init) then !From restart point only allocate particles that are yet to be born - totpart=0 - do i=1,numpoint - totpart = totpart+npart(i) - end do - if (totpart.gt.count%allocated) call alloc_particles(totpart-count%allocated) - end if - - call get_totalpart_num(istart) - 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 - !********************************* - - xlonav=xlon0+(xpoint2(i)+xpoint1(i))/2.*dx ! longitude needed to determine local time - 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(abs(xpoint2(i)-xpoint1(i)).lt.1.E-4.and.abs(ypoint2(i)-ypoint1(i)).lt.1.E-4) then - ! 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) - end do - 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 - call get_newpart_index(ipart) - call spawn_particle(itime, ipart) - - ! Particle coordinates are determined by using a random position within the release volume - !***************************************************************************** - - ! Determine horizontal particle position - !*************************************** - call set_xlon(ipart,real(xpoint1(i)+ran1(idummy,0)*xaux,kind=dp)) - if (xglobal) then - if (part(ipart)%xlon.gt.real(nxmin1,kind=dp)) & - call set_xlon(ipart,-real(nxmin1,kind=dp)) - if (part(ipart)%xlon.lt.0.) & - call set_xlon(ipart,real(nxmin1,kind=dp)) - endif - call set_ylat(ipart,real(ypoint1(i)+ran1(idummy,0)*yaux,kind=dp)) - - ! 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 - ! for the scavenging calculation the mass needs to be multiplied with rho of the particle layer and - ! divided by the sum of rho of all particles. - !***************************************************************************** - do k=1,nspec - part(ipart)%mass(k)=xmass(i,k)/real(npart(i)) & - *timecorrect(k)/average_timecorrect - part(ipart)%mass_init(k)=part(ipart)%mass(k) - if (DRYBKDEP.or.WETBKDEP) then ! if there is no scavenging in wetdepo it will be set to 0 - ! if ( henry(k).gt.0 .or. & - ! crain_aero(k).gt.0. .or. csnow_aero(k).gt.0. .or. & - ! ccn_aero(k).gt.0. .or. in_aero(k).gt.0. ) then - xscav_frac1(ipart,k)=-1. - endif - ! Assign certain properties to particle - !************************************** - end do - part(ipart)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, & - nclassunc) - numparticlecount=numparticlecount+1 - if (mquasilag.eq.0) then - part(ipart)%npoint=i - else - part(ipart)%npoint=numparticlecount - endif - part(ipart)%idt=mintime ! first time step - - ! Determine vertical particle position - !************************************* - call set_z(ipart,zpoint1(i)+ran1(idummy,0)*zaux) - ! Interpolation of topography and density - !**************************************** - - ! Determine the nest we are in - !***************************** - ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) - ngrid=0 - do k=numbnests,1,-1 - if ((real(part(ipart)%xlon).gt.xln(k)+dxn(k)).and. & - (real(part(ipart)%xlon).lt.xrn(k)-dxn(k)).and. & - (real(part(ipart)%xlon).gt.yln(k)+dyn(k)).and. & - (real(part(ipart)%xlon).lt.yrn(k)-dyn(k))) then - ngrid=k - exit - endif - end do - - ! Determine (nested) grid coordinates and auxiliary parameters used for interpolation - !***************************************************************************** - - if (ngrid.gt.0) then - xtn=(real(part(ipart)%xlon)-xln(ngrid))*xresoln(ngrid) - ytn=(real(part(ipart)%ylat)-yln(ngrid))*yresoln(ngrid) - ! ix=int(xtn) - ! jy=int(ytn) - ix=max(min(nint(xtn),nxn(ngrid)-1),0) - jy=max(min(nint(ytn),nyn(ngrid)-1),0) - ddy=ytn-real(jy) - ddx=xtn-real(ix) - else - ix=int(part(ipart)%xlon) - jy=int(part(ipart)%ylat) - ddy=part(ipart)%ylat-real(jy) - ddx=part(ipart)%xlon-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=part(ipart)%z - 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 - call set_z(ipart,height(1)/2.) - else - dz1=pressold-presspart - dz2=presspart-press - call set_z(ipart,(height(kz-1)*dz2+height(kz)*dz1) & - /(dz1+dz2)) - endif - exit - endif - pressold=press - end do - endif - - - ! If release positions are given in meters above sea level, subtract the - ! topography from the starting height - !*********************************************************************** - - if (kindz(i).eq.2) call update_z(ipart,-topo) - if (part(ipart)%z.lt.eps2) call set_z(ipart,eps2) ! Minimum starting height is eps2 - if (part(ipart)%z.gt.height(nz)-0.5) & - call set_z(ipart,height(nz)-0.5) ! Maximum starting height is uppermost level - 0.5 meters - - if (wind_coord_type.eq.'ETA') then - call z_to_zeta(itime,part(ipart)%xlon,part(ipart)%ylat,part(ipart)%z,part(ipart)%zeta) - part(ipart)%etaupdate = .true. ! The z(meter) coordinate is up to date - end if - - ! 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 - ! 0= no receptors - !Af 1="mass" - !Af 2="mass mixing ratio" - ! 3 = wet deposition in outputfield - ! 4 = dry deposition in outputfield - - !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).or.(ind_rel .eq. 3).or.(ind_rel .eq. 4)) then - - ! Interpolate the air density - !**************************** - - do ii=2,nz - if (height(ii).gt.part(ipart)%z) then - indz=ii-1 - indzp=ii - exit - endif - end do - - dz1=part(ipart)%z-height(indz) - dz2=height(indzp)-part(ipart)%z - 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) - end do - 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) - end do - endif - rhoout=(dz2*rhoaux(1)+dz1*rhoaux(2))*dz - rho_rel(i)=rhoout - - - ! Multiply "mass" (i.e., mass mixing ratio in forward runs) with density - !******************************************************************** - - do k=1,nspec - part(ipart)%mass(k)=part(ipart)%mass(k)*rhoout - part(ipart)%mass_init(k)=part(ipart)%mass(k) - end do - endif - - call get_totalpart_num(numpart) - - end do ! numrel - endif ! releasepoint - end do ! numpoint - - call get_totalpart_num(iend) - - ! NetCDF only: write initial positions of new particles -#ifdef USE_NCF - if ((iend-istart.gt.0).and.(ipout.ge.1)) then - call wrt_part_initialpos(itime,istart,iend) - call output_particle(itime,.true.) - endif -#endif - 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 releaseparticle - -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 * - ! * - ! Changes * - ! 2022, L. Bakels: NetCDF option for reading particle information * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - !***************************************************************************** - -! use netcdf_output_mod - - implicit none - - integer :: ibdatein,ibtimein,nspecin,itimein,numpointin,i,j,lix,ios - integer :: id1,id2,it1,it2 - real :: xlonin,ylatin,topo,hmixi,pvi,qvi,rhoi,tri,tti - character :: specin*7 - real(kind=dp) :: julin,julpartin - - integer :: idummy = -8 - - numparticlecount=0 - - ! Open header file of dumped particle data - !***************************************** - if (lnetcdfout.eq.1) then -#ifdef USE_NCF - call read_partpos_ncf(ibtime,ibdate) - call get_totalpart_num(numpart) - numparticlecount=numpart - return -#endif - endif - - open(unitpartin,file=path(2)(1:length(2))//'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)) then - write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### ' - write(*,*) ' #### THE NUMBER OF SPECIES TO BE READ IN DOES #### ' - write(*,*) ' #### NOT AGREE WITH CURRENT SETTINGS! #### ' - stop - end if - - do i=1,nspecin - read(unitpartin) - read(unitpartin) - read(unitpartin) j,specin - if ((ldirect.eq.1).and.(species(i)(1:7).ne.specin)) then - write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### ' - write(*,*) ' #### SPECIES NAMES TO BE READ IN DO NOT #### ' - write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### ' - stop - end if - end do - - read(unitpartin) numpointin - if (numpointin.ne.numpoint) then - write(*,*) ' #### FLEXPART MODEL WARNING IN READPARTPOSITIONS#### ' - write(*,*) ' #### NUMBER OF RELEASE LOCATIONS DOES NOT #### ' - write(*,*) ' #### AGREE WITH CURRENT SETTINGS! #### ' - end if - do i=1,numpointin - read(unitpartin) - read(unitpartin) - read(unitpartin) - read(unitpartin) - do j=1,nspec - read(unitpartin) - read(unitpartin) - read(unitpartin) - end do - end do - read(unitpartin) - read(unitpartin) - - do lix=0,numxgrid-1 - read(unitpartin) - end do - - - ! Open data file of dumped particle data - !*************************************** - - close(unitpartin) - open(unitpartin,file=path(2)(1:length(2))//'partposit_end', & - form='unformatted',err=998) - - - do - read(unitpartin,iostat=ios) itimein - if (ios.lt.0) exit - i=0 - do - i=i+1 - read(unitpartin) part(i)%npoint,xlonin,ylatin,part(i)%z,part(i)%tstart, & - topo,pvi,qvi,rhoi,hmixi,tri,tti,(part(i)%mass(j),j=1,nspec) - ! For switching coordinates: this happens in timemanager.f90 after the first fields are read - if (xlonin.eq.-9999.9) exit - call set_xlon(i,real((xlonin-xlon0)/dx,kind=dp)) - call set_ylat(i,real((ylatin-ylat0)/dy,kind=dp)) - numparticlecount=max(numparticlecount,part(i)%npoint) - end do - end do - - numpart=i-1 - - close(unitpartin) - - julin=juldate(ibdatein,ibtimein)+real(itimein,kind=dp)/86400._dp - if (abs(julin-bdate).gt.1.e-5) then - write(*,*) ' #### FLEXPART MODEL ERROR IN READPARTPOSITIONS#### ' - write(*,*) ' #### ENDING TIME OF PREVIOUS MODEL RUN DOES #### ' - write(*,*) ' #### NOT AGREE WITH STARTING TIME OF THIS RUN.#### ' - call caldate(julin,id1,it1) - call caldate(bdate,id2,it2) - write(*,*) 'julin: ',julin,id1,it1 - write(*,*) 'bdate: ',bdate,id2,it2 - stop - end if - do i=1,numpart - julpartin=juldate(ibdatein,ibtimein)+ & - real(part(i)%tstart,kind=dp)/86400._dp - part(i)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, & - nclassunc) - part(i)%idt=mintime - part(i)%tstart=nint((julpartin-bdate)*86400.) - end do - - return - -998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' - write(*,*) ' #### '//path(2)(1:length(2))//'partposit'//' #### ' - 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 - -subroutine readrestart - - !***************************************************************************** - ! * - ! This routine opens the particle dump file and reads all the particle * - ! positions and gridded information from a previous run to initialize * - ! the current run. * - ! * - ! Author: L. Bakels 2022 * - ! * - !***************************************************************************** - -! use netcdf_output_mod - use unc_mod - - implicit none - - integer :: i,j,ios - integer :: id1,id2,it1,it2 - integer :: ks,kp,kz,nage,jy,ix,l - real(kind=dp) :: julin,julpartin - integer :: idummy = -8 - - numparticlecount=0 - - - open(unitpartin,file=path(2)(1:length(2))//'restart.bin', & - form='unformatted',err=9989) - - write(*,*) 'Reading Restart file:', path(2)(1:length(2))//'restart.bin' - - read(unitpartin,iostat=ios) itime_init - read(unitpartin) numpart - read(unitpartin) loutnext_init - read(unitpartin) outnum_init - call spawn_particles(itime_init, numpart) - do i=1,numpart - read(unitpartin) part(i)%xlon,part(i)%ylat,part(i)%z,part(i)%zeta, & - part(i)%npoint,part(i)%nclass,part(i)%idt,part(i)%tend, & - part(i)%tstart,part(i)%alive,part(i)%turbvel%u, & - part(i)%turbvel%v,part(i)%turbvel%w,part(i)%mesovel%u, & - part(i)%mesovel%v,part(i)%mesovel%w,(part(i)%mass(j),j=1,nspec), & - (part(i)%mass_init(j),j=1,nspec),(part(i)%wetdepo(j),j=1,nspec), & - (part(i)%drydepo(j),j=1,nspec) - part(i)%etaupdate=.true. - part(i)%meterupdate=.true. - if (.not. part(i)%alive) then - if (part(i)%tstart.le.itime_init) then - call terminate_particle(i,part(i)%tend) - else ! Particle is not spawned yet (original run with ipin=3) - count%alive = count%alive - 1 - count%spawned = count%spawned -1 - endif - endif - end do - if (iout.gt.0) then -#ifdef USE_NCF - read(unitpartin) tpointer -#endif - 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 - do kz=1,numzgrid - read(unitpartin) gridunc(ix,jy,kz,ks,kp,l,nage) - end do - if ((wetdep).and.(ldirect.gt.0)) then - read(unitpartin) wetgridunc(ix,jy,ks,kp,l,nage) - endif - if ((drydep).and.(ldirect.gt.0)) then - read(unitpartin) drygridunc(ix,jy,ks,kp,l,nage) - endif - 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 - do kz=1,numzgrid - read(unitpartin) griduncn(ix,jy,kz,ks,kp,l,nage) - end do - if ((wetdep).and.(ldirect.gt.0)) then - read(unitpartin) wetgriduncn(ix,jy,ks,kp,l,nage) - endif - if ((drydep).and.(ldirect.gt.0)) then - read(unitpartin) drygriduncn(ix,jy,ks,kp,l,nage) - endif - end do - end do - end do - endif - end do - end do - if ((drybkdep).or.(wetbkdep)) then - do i=1,numpart - read(unitpartin) xscav_frac1(i,ks) - end do - endif - end do - endif - close(unitpartin) - - numpart=count%spawned - - julin=juldate(ibdate,ibtime)+real(itime_init,kind=dp)/86400._dp - if (abs(julin-bdate).le.1.e-5) then - write(*,*) ' #### FLEXPART ERROR: PLEASE KEEP IBDATE #### ' - write(*,*) ' #### AND IBTIME INTACT FROM THE INITIAL RUN!#### ' - stop - endif - call caldate(julin,id1,it1) - call caldate(bdate,id2,it2) - write(*,*) ' #### Restarting Flexpart from restart.bin. #### ' - write(*,*) ' #### Original run started on #### ' - write(*,*) 'bdate: ',bdate,id2,it2 - write(*,*) ' #### Restarting run starts on #### ' - write(*,*) 'julin: ',julin,id1,it1 - - return - -9989 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' - write(*,*) ' #### '//path(2)(1:length(2))//'restart.bin'//' #### ' - write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### ' - write(*,*) ' #### NAME DOES NOT EXISTS, RENAME THE APPROPRIATE #### ' - write(*,*) ' #### RESTART FILE TO restart.bin. #### ' -end subroutine readrestart - -subroutine read_heightlevels(height_tmp,nmixz_tmp) - implicit none - - real,intent(out) :: height_tmp(nzmax) - integer,intent(out) :: nmixz_tmp - integer :: kz,ios - character(len=256) :: heightlevels_filename - - heightlevels_filename = path(2)(1:length(2))//'heightlevels.bin' - - write(*,*) 'Reading heightlevels from file:', trim(heightlevels_filename) - - open(unitheightlevels,file=trim(heightlevels_filename),form='unformatted',err=9988) - - read(unitheightlevels,iostat=ios) nmixz_tmp - - do kz=1,nz - read(unitheightlevels) height_tmp(kz) - end do - close(unitheightlevels) - - return - -9988 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' - write(*,*) ' #### '//path(2)(1:length(2))//'heightlevels.bin'//' #### ' - write(*,*) ' #### CANNOT BE OPENED. IF A FILE WITH THIS #### ' - write(*,*) ' #### NAME DOES NOT EXISTS, REMOVE call read_heightlevels #### ' - write(*,*) ' #### FROM VERTTRANSFORM_MOD. #### ' -end subroutine read_heightlevels - -subroutine init_particle(itime,ipart) - ! 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 * - ! usig,vsig,wsig uncertainties of wind velocities due to interpolation * - ! 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 * - ! * - !***************************************************************************** - - use turbulence_mod - use random_mod, only: ran3 - use omp_lib - use interpol_mod - use cbl_mod - - implicit none - - integer,intent(in) :: & - itime, & - ipart - integer :: i,j,k,m,indexh - integer :: nrand - real :: dz,dz1,dz2,wp - real :: ttemp,dummy1,dummy2 - real :: xt,yt,zt,zteta - integer :: thread - -#ifdef _OPENMP - thread = OMP_GET_THREAD_NUM() -#else - thread = 0 -#endif - - part(ipart)%icbt=1 ! initialize particle to no "reflection" - - nrand=int(ran3(iseed1(thread),thread)*real(maxrand-1))+1 - - xt = real(part(ipart)%xlon) - yt = real(part(ipart)%ylat) - zt = real(part(ipart)%z) - zteta = real(part(ipart)%zeta) - - !****************************** - ! 2. Interpolate necessary data - !****************************** - - ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) - !*************************************************************** - call find_ngrid(xt,yt) - ! Compute maximum mixing height around particle position - !******************************************************* - call find_grid_indices(xt,yt) - - 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))) - - 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_pbl(itime,xt,yt,zt,zteta) - - ! 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 - !**************************************************************** - call interpol_pbl_short(zt,dummy1,dummy2) - - ! Compute the turbulent disturbances - - ! Determine the sigmas and the timescales - !**************************************** - - if (turbswitch) then - call hanna(zt) - else - call hanna1(zt) - endif - - - ! Determine the new diffusivity velocities - !***************************************** - - if (nrand+2.gt.maxrand) nrand=1 - part(ipart)%turbvel%u=rannumb(nrand)*sigu - part(ipart)%turbvel%v=rannumb(nrand+1)*sigv - part(ipart)%turbvel%w=rannumb(nrand+2) - if (.not.turbswitch) then ! modified by mc - part(ipart)%turbvel%w=part(ipart)%turbvel%w*sigw - else if (cblflag.eq.1) then ! modified by mc - if(-h/ol.gt.5) then - !if (ol.lt.0.) then - !if (ol.gt.0.) then !by mc : only for test correct is lt.0 - call init_cbl_vel( & - iseed1(thread),zt,ust,wst,h,sigw,part(ipart)%turbvel%w,ol,thread) - else - part(ipart)%turbvel%w=part(ipart)%turbvel%w*sigw - end if - end if - - - ! Determine time step for next integration - !***************************************** - - if (turbswitch) then - part(ipart)%idt = int( & - min( tlw, & - h / max( 2.*abs(part(ipart)%turbvel%w*sigw), 1.e-5 ), & - 0.5/abs(dsigwdz), & - 600.)& - *ctl ) - else - part(ipart)%idt = int( & - min( tlw, & - h / max( 2.*abs(part(ipart)%turbvel%w), 1.e-5), & - 600. ) & - *ctl) - endif - part(ipart)%idt=max(part(ipart)%idt,mintime) - - ! call interpol_average() - ! usig=(usigprof(indzp)+usigprof(indz))/2. - ! vsig=(vsigprof(indzp)+vsigprof(indz))/2. - ! wsig=(wsigprof(indzp)+wsigprof(indz))/2. - - ! wsigeta=(wsigprofeta(indzpeta)+wsigprofeta(indzeta))/2. - - else - +#include "ini_alloc_domainfill.f90" +#include "ini_dealloc_domainfill.f90" - !********************************************************** - ! 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,xt,yt,zt,zteta,10) - - - ! Compute everything for above the PBL - - ! Assume constant turbulent perturbations - !**************************************** - - part(ipart)%idt=abs(lsynctime) - - if (nrand+1.gt.maxrand) nrand=1 - part(ipart)%turbvel%u=rannumb(nrand)*0.3 - part(ipart)%turbvel%v=rannumb(nrand+1)*0.3 - nrand=nrand+2 - part(ipart)%turbvel%w=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 (lmesoscale_turb) then - call interpol_mesoscale(itime,xt,yt,zt,zteta) - if (nrand+2.gt.maxrand) nrand=1 - part(ipart)%mesovel%u=rannumb(nrand)*usig - part(ipart)%mesovel%v=rannumb(nrand+1)*vsig - select case (wind_coord_type) - case ('ETA') - part(ipart)%mesovel%w=rannumb(nrand+2)*wsigeta - case ('METER') - part(ipart)%mesovel%w=rannumb(nrand+2)*wsig - case default - part(ipart)%mesovel%w=rannumb(nrand+2)*wsig - end select - endif -end subroutine init_particle - -subroutine init_domainfill - ! - !***************************************************************************** - ! * - ! 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 * - ! * - ! Changes * - ! 2022, L. Bakels: OpenMP parallelisation * - ! * - !***************************************************************************** - ! * - ! 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 particle_mod - - implicit none - - integer :: j,kz,lix,ljy,ncolumn,numparttot - real :: pp(nzmax),ylat,ylatp,ylatm,hzone - real :: cosfactm,cosfactp,deltacol,dz1,dz2,dz,pnew,pnew_temp,fractus - real,parameter :: pih=pi/180. - real :: colmasstotal,zposition - - integer :: ixm,ixp,jym,jyp,indzm,indzh,indzp,i,jj,ii - integer :: alive_tmp,allocated_tmp,spawned_tmp,terminated_tmp - real :: pvpart,ddx,ddy,rddx,rddy,p1,p2,p3,p4,y1(2) - integer :: idummy = -11 - - real :: frac,psint,zzlev,zzlev2,ttemp,height_tmp - - logical :: deall - - real,allocatable,dimension(:) :: gridarea ! - real,allocatable,dimension(:,:) :: colmass ! - - ! Determine the release region (only full grid cells), over which particles - ! shall be initialized - ! Use 2 fields for west/east and south/north boundary - !************************************************************************** - call alloc_domainfill - - 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 - write(*,*) 'Global domain: ', gdomainfill - - ! Exit here if resuming a run from particle dump - !*********************************************** - if (gdomainfill.and.ipin.ne.0) return - - ! Allocate grid and column mass - !******************************* - allocate(gridarea(0:nymax-1),colmass(0:nxmax-1,0:nymax-1)) - - ! 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 - !************************************************************ - ! First for the south pole - - if (sglobal) then - 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 - 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 - - - - ! Allocate memory for storing the particles - !****************************************** - call alloc_particles(npart(1)) - - ! Initialise total particle number - numparttot=0 - ! Initialise max column number - numcolumn=0 - - ! Initialise the sum over the total mass of the atmosphere - colmasstotal=0. - -!$OMP PARALLEL PRIVATE(ljy,ylat,ylatp,ylatm,hzone,cosfactp,cosfactm,pp,lix) & -!$OMP REDUCTION(+:colmasstotal) -!$OMP DO - do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes - ylat=ylat0+real(ljy)*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 - gridarea(ljy)=2.*pi*r_earth*hzone*dx/360. - end do -!$OMP END DO -!$OMP BARRIER - - ! Calculate total mass of each grid column and of the whole atmosphere - !********************************************************************* -!$OMP DO - do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes - do lix=nx_we(1),nx_we(2) ! loop about longitudes - pp(1)=prs(lix,ljy,1,1) !rho(lix,ljy,1,1)*r_air*tt(lix,ljy,1,1) - pp(nz)=prs(lix,ljy,nz,1) !rho(lix,ljy,nz,1)*r_air*tt(lix,ljy,nz,1) - colmass(lix,ljy)=(pp(1)-pp(nz))/ga*gridarea(ljy) - colmasstotal=colmasstotal+colmass(lix,ljy) - end do - end do -!$OMP END DO -!$OMP END PARALLEL - - write(*,*) 'Atm. mass: ',colmasstotal - - if (ipin.eq.0) numpart=0 - - ! Determine the particle positions - !********************************* - do ljy=ny_sn(1),ny_sn(2) ! loop about latitudes - ylat=ylat0+real(ljy)*dy - do lix=nx_we(1),nx_we(2) ! loop about longitudes - ncolumn=nint(0.999*real(npart(1))*colmass(lix,ljy)/colmasstotal) - if (ncolumn.eq.0) cycle - 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)=prs(lix,ljy,kz,1)!rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1) - end do - - deltacol=(pp(1)-pp(nz))/real(ncolumn) - pnew=pp(1)+deltacol/2. - jj=0 - - do j=1,ncolumn ! looping over the number of particles within the column - - ! For columns with many particles (i.e. around the equator), distribute - ! the particles equally (1 on a random position within the deltacol range), - ! for columns with few particles (i.e. around the poles), - ! distribute the particles randomly - !*********************************************************************** - - if ((ncolumn.gt.20).and.(ncolumn-j.gt.20)) then - pnew_temp=pnew-ran1(idummy,0)*deltacol - pnew=pnew-deltacol - else if ((ncolumn.gt.20).and.(ncolumn-j.le.20)) then - ! When only few particles are left, distribute them randomly above pnew - pnew_temp=pnew-ran1(idummy,0)*(pnew-pp(nz)) - else - pnew_temp=pp(1)-ran1(idummy,0)*(pp(1)-pp(nz)) - endif - - do kz=1,nz-1 - if ((pp(kz).ge.pnew_temp).and.(pp(kz+1).lt.pnew_temp)) then - dz1=log(pnew_temp)-log(pp(kz)) - dz=1./log(pp(kz+1)/pp(kz)) - - ! Assign particle position - !************************* - ! Do the following steps only if particles are not read in - ! from previous model run - - if (ipin.eq.0) then - ! First spawn the particle into existence - !**************************************** - jj=jj+1 - !THIS WILL CAUSE PROBLEMS WITH OMP! because of dynamical allocatio - call spawn_particle(0,numpart+jj) - if (allocated_tmp.lt.numpart+jj) allocated_tmp=numpart+jj - call set_xlon(numpart+jj, & - real( real(lix)-0.5+ran1(idummy,0), kind=dp ) ) - if (lix.eq.0) call set_xlon(numpart+jj, & - real( ran1(idummy,0), kind=dp ) ) - if (lix.eq.nxmin1) call set_xlon(numpart+jj, & - real( real(nxmin1)-ran1(idummy,0), kind=dp ) ) - call set_ylat(numpart+jj, & - real( real(ljy)-0.5+ran1(idummy,0), kind=dp ) ) - ! logarithmic distribution of particles along pressure levels: - ! hx=h1+(h2-h1)/log(p2/p1)*log(px/p1) - height_tmp=height(kz)+(height(kz+1)-height(kz))*dz*dz1 - call set_z(numpart+jj,height_tmp) - if (real(part(numpart+jj)%z).gt.height(nz)-0.5) & - call set_z(numpart+jj, height(nz)-0.5) - - call update_z_to_zeta(0, numpart+jj) - - ! Interpolate PV to the particle position - !**************************************** - ixm=int(part(numpart+jj)%xlon) - jym=int(part(numpart+jj)%ylat) - ixp=ixm+1 - jyp=jym+1 - ddx=part(numpart+jj)%xlon-real(ixm) - ddy=part(numpart+jj)%ylat-real(jym) - rddx=1.-ddx - rddy=1.-ddy - p1=rddx*rddy - p2=ddx*rddy - p3=rddx*ddy - p4=ddx*ddy - - !*************************************************************************** - indzm=nz-1 - indzp=nz - do i=2,nz - if (real(height(i),kind=dp).gt.part(numpart+jj)%z) then - indzm=i-1 - indzp=i - exit - endif - end do - dz1=real(part(numpart+jj)%z)-height(indzm) - dz2=height(indzp)-real(part(numpart+jj)%z) - dz=1./(dz1+dz2) - do ii=1,2 - indzh=indzm+ii-1 - y1(ii)=p1*pv(ixm,jym,indzh,1) & - + p2*pv(ixp,jym,indzh,1) & - + p3*pv(ixm,jyp,indzh,1) & - + p4*pv(ixp,jyp,indzh,1) - end do - 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 (( part(numpart+jj)%z .gt. 3000. .and. pvpart .gt. pvcrit ) & - .or. mdomainfill .eq. 1) then - - ! Assign certain properties to the particle - !****************************************** - part(numpart+jj)%nclass=min( & - int(ran1(idummy,0)*real(nclassunc))+1, nclassunc ) - numparticlecount=numparticlecount+1 - part(numpart+jj)%npoint=numparticlecount - part(numpart+jj)%idt=mintime - part(numpart+jj)%mass(1)=colmass(lix,ljy)/real(ncolumn) - if (mdomainfill.eq.2) part(numpart+jj)%mass(1)= & - part(numpart+jj)%mass(1)*pvpart*48./29.*ozonescale/10.**9 - part(numpart+jj)%mass_init(1)=part(numpart+jj)%mass(1) - else - call terminate_particle(numpart+jj, 0) - jj=jj-1 - endif - endif - endif - end do - end do - numparttot=numparttot+ncolumn - if (ipin.eq.0) numpart=numpart+jj - end do - end do - - - alive_tmp=count%alive - spawned_tmp=count%spawned - allocated_tmp=count%allocated - terminated_tmp=count%terminated - -!$OMP PARALLEL PRIVATE(j) REDUCTION(+:alive_tmp,spawned_tmp,allocated_tmp,terminated_tmp) - - ! Make sure that all particles are within domain - !*********************************************** -!$OMP DO - do j=1,numpart - if ((part(j)%xlon.lt.0.).or.(part(j)%xlon.ge.real(nxmin1,kind=dp)).or. & - (part(j)%ylat.lt.0.).or.(part(j)%ylat.ge.real(nymin1,kind=dp))) then - call terminate_particle(j,0) - alive_tmp=alive_tmp-1 - terminated_tmp=terminated_tmp+1 - endif - end do -!$OMP END DO -!$OMP END PARALLEL - - count%alive=alive_tmp - count%spawned=spawned_tmp - count%allocated=allocated_tmp - count%terminated=terminated_tmp - ! Check whether numpart is really smaller than maxpart - !***************************************************** - - ! ! ESO :TODO: this warning need to be moved further up, else out-of-bounds error earlier - ! 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) - - - ! 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 ljy=ny_sn(1),ny_sn(2) ! loop about latitudes - do lix=nx_we(1),nx_we(2) ! loop about longitudes - ncolumn=nint(0.999/fractus*real(npart(1))*colmass(lix,ljy) & - /colmasstotal) - if (ncolumn.gt.maxcolumn) stop 'maxcolumn too small' - if (ncolumn.eq.0) cycle - - - ! 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 (lix.eq.nx_we(1)) numcolumn_we(1,ljy)=ncolumn - if (lix.eq.nx_we(2)) numcolumn_we(2,ljy)=ncolumn - if (ljy.eq.ny_sn(1)) numcolumn_sn(1,lix)=ncolumn - if (ljy.eq.ny_sn(2)) numcolumn_sn(2,lix)=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)=prs(lix,ljy,kz,1) !rho(lix,ljy,kz,1)*r_air*tt(lix,ljy,kz,1) - end do - - ! 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 (lix.eq.nx_we(1)) zcolumn_we(1,ljy,j)=zposition - if (lix.eq.nx_we(2)) zcolumn_we(2,ljy,j)=zposition - if (ljy.eq.ny_sn(1)) zcolumn_sn(1,lix,j)=zposition - if (ljy.eq.ny_sn(2)) zcolumn_sn(2,lix,j)=zposition - - ! Initialize mass that has accumulated at boundary to zero - !********************************************************* - - acc_mass_we(1,ljy,j)=0. - acc_mass_we(2,ljy,j)=0. - acc_mass_sn(1,ljy,j)=0. - acc_mass_sn(2,ljy,j)=0. - endif - end do - end do - end do - end do - - ! If there were more particles allocated than used, - ! Deallocate unused memory and update numpart - !************************************************** - deall=.false. - do i=numpart, 1, -1 - if (.not. part(i)%alive) then - deall=.true. - numpart = numpart - 1 - else - exit - endif - end do - - if (deall) call dealloc_particle(numpart) !Deallocates everything above numpart (F2008) +#include "ini_releaseparticle.f90" +#include "ini_readpartpositions.f90" - ! 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. - !*************************************************************************** +#include "ini_readrestart.f90" - if ((ipin.eq.1).and.(.not.gdomainfill)) then - open(unitboundcond,file=path(2)(1:length(2))//'boundcond.bin', & - form='unformatted') - read(unitboundcond) numcolumn_we,numcolumn_sn, & - zcolumn_we,zcolumn_sn,acc_mass_we,acc_mass_sn - close(unitboundcond) - endif +#include "ini_read_heightlevels.f90" - deallocate(gridarea,colmass) -end subroutine init_domainfill +#include "ini_init_particle.f90" -subroutine boundcond_domainfill(itime,loutend) - ! i i - !***************************************************************************** - ! * - ! 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 * - ! * - ! Changes * - ! 2022, L. Bakels: OpenMP parallelisation * - ! * - !***************************************************************************** - ! * - ! 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 -#ifdef _OPENMP - use omp_lib -#endif - implicit none - - real :: dz,dz1,dz2,dt1,dt2,dtt,ylat,xm,cosfact,accmasst - integer :: itime,in,indz,indzp,i,loutend,numparticlecount_tmp - integer :: j,k,ix,jy,m,indzh,indexh,minpart,ipart,mmass,ithread - integer :: numactiveparticles - - real :: windl(2),rhol(2) - 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 - - ! Determine auxiliary variables for time interpolation - !***************************************************** - - dt1=real(itime-memtime(1)) - dt2=real(memtime(2)-itime) - dtt=1./(dt1+dt2) - - numactiveparticles=0 - numparticlecount_tmp=numparticlecount - accmasst=0. - ! Terminate trajectories that have left the domain, if domain-filling - ! trajectory calculation domain is not global - !******************************************************************** - - do i=1,numpart - if (.not. part(i)%alive) cycle - - if ((part(i)%ylat.gt.real(ny_sn(2))).or. & - (part(i)%ylat.lt.real(ny_sn(1)))) call terminate_particle(i,itime) - if (((.not.xglobal).or.(nx_we(2).ne.(nx-2))).and. & - ((part(i)%xlon.lt.real(nx_we(1))).or. & - (part(i)%xlon.gt.real(nx_we(2))))) call terminate_particle(i,itime) - if (part(i)%alive) numactiveparticles = numactiveparticles+1 - end do - - !*************************************** - ! Western and eastern boundary condition - !*************************************** - - ! Loop from south to north - !************************* -!$OMP PARALLEL PRIVATE(i,jy,k,j,deltaz,boundarea,indz,indzp,indexh,windl,rhol, & -!$OMP windhl,rhohl,windx,rhox,fluxofmass,mmass,ixm,jym,ixp,jyp,ddx,ddy,rddx, & -!$OMP rddy,p1,p2,p3,p4,indzm,mm,indzh,pvpart,ylat,ix,cosfact,ipart) & -!$OMP REDUCTION(+:numactiveparticles,numparticlecount_tmp,accmasst) - -#ifdef _OPENMP - ithread = OMP_GET_THREAD_NUM() -#else - ithread = 0 -#endif - -!$OMP DO - do jy=ny_sn(1),ny_sn(2) - - ! Loop over western (index 1) and eastern (index 2) boundary - !*********************************************************** - - do k=1,2 - - ! 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 - ! 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 - 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 - - - ! Interpolate the wind velocity and density to the release location - !****************************************************************** - - ! Determine the model level below the release position - !***************************************************** - indz=nz-1 - indzp=nz - do i=2,nz - if (height(i).gt.zcolumn_we(k,jy,j)) then - indz=i-1 - indzp=i - exit - endif - end do - - ! 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) - 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_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 - call get_newpart_index(ipart) - call spawn_particle(itime, ipart) - - ! Assign particle positions - !************************** - - call set_xlon(ipart,real(nx_we(k),kind=dp)) - if (jy.eq.ny_sn(1)) then - call set_ylat(ipart,real(real(jy)+0.5*ran1(idummy,ithread),kind=dp)) - else if (jy.eq.ny_sn(2)) then - call set_ylat(ipart,real(real(jy)-0.5*ran1(idummy,ithread),kind=dp)) - else - call set_ylat(ipart,real(real(jy)+(ran1(idummy,ithread)-.5),kind=dp)) - endif - if (j.eq.1) then - call set_z(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 - call set_z(ipart,(2.*zcolumn_we(k,jy,j)+ & - zcolumn_we(k,jy,j-1)+height(nz))/4.) - else - call set_z(ipart,zcolumn_we(k,jy,j-1)+ran1(idummy,ithread)* & - (zcolumn_we(k,jy,j+1)-zcolumn_we(k,jy,j-1))) - endif - - call update_z_to_zeta(itime, ipart) - - ! Interpolate PV to the particle position - !**************************************** - ixm=int(part(ipart)%xlon) - jym=int(part(ipart)%ylat) - ixp=ixm+1 - jyp=jym+1 - ddx=part(ipart)%xlon-real(ixm) - ddy=part(ipart)%ylat-real(jym) - rddx=1.-ddx - rddy=1.-ddy - p1=rddx*rddy - p2=ddx*rddy - p3=rddx*ddy - p4=ddx*ddy - indzm=nz-1 - indzp=nz - do i=2,nz - if (real(height(i),kind=dp).gt.part(ipart)%z) then - indzm=i-1 - indzp=i - exit - endif - end do - dz1=real(part(ipart)%z)-height(indzm) - dz2=height(indzp)-real(part(ipart)%z) - 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 - ylat=ylat0+part(ipart)%ylat*dy - if (ylat.lt.0.) pvpart=-1.*pvpart - - - ! For domain-filling option 2 (stratospheric O3), do the rest only in the stratosphere - !***************************************************************************** - - if (((part(ipart)%z.gt.3000.).and. & - (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then - part(ipart)%nclass=min(int(ran1(idummy,ithread)* & - real(nclassunc))+1,nclassunc) - numactiveparticles=numactiveparticles+1 - numparticlecount_tmp=numparticlecount_tmp+1 - part(ipart)%npoint=numparticlecount_tmp - part(ipart)%idt=mintime - part(ipart)%tstart=itime - part(ipart)%mass(1)=xmassperparticle - if (mdomainfill.eq.2) part(ipart)%mass(1)= & - part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9 - part(ipart)%mass_init(1)=part(ipart)%mass(1) - else - stop 'boundcond_domainfill error: look into original to understand what should happen here' - endif - end do ! particles - end do ! release locations in column - end do ! western and eastern boundary - end do ! south to north -!$OMP END DO - - !***************************************** - ! Southern and northern boundary condition - !***************************************** - - ! Loop from west to east - !*********************** -!$OMP DO - do ix=nx_we(1),nx_we(2) - - ! Loop over southern (index 1) and northern (index 2) boundary - !************************************************************* - - do k=1,2 - ylat=ylat0+real(ny_sn(k))*dy - cosfact=cos(ylat*pi180) - - ! 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 - 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 - - - ! Interpolate the wind velocity and density to the release location - !****************************************************************** - - ! Determine the model level below the release position - !***************************************************** - indz=nz-1 - indzp=nz - do i=2,nz - if (height(i).gt.zcolumn_sn(k,ix,j)) then - indz=i-1 - indzp=i - exit - endif - end do - - ! 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 - call get_newpart_index(ipart) - call spawn_particle(itime, ipart) - - ! Assign particle positions - !************************** - call set_ylat(ipart,real(ny_sn(k),kind=dp)) - if (ix.eq.nx_we(1)) then - call set_xlon(ipart,real(real(ix)+0.5*ran1(idummy,ithread),kind=dp)) - else if (ix.eq.nx_we(2)) then - call set_xlon(ipart,real(real(ix)-0.5*ran1(idummy,ithread),kind=dp)) - else - call set_xlon(ipart,real(real(ix)+(ran1(idummy,ithread)-.5),kind=dp)) - endif - if (j.eq.1) then - call set_z(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 - call set_z(ipart,(2.*zcolumn_sn(k,ix,j)+ & - zcolumn_sn(k,ix,j-1)+height(nz))/4.) - else - call set_z(ipart,zcolumn_sn(k,ix,j-1)+ran1(idummy,ithread)* & - (zcolumn_sn(k,ix,j+1)-zcolumn_sn(k,ix,j-1))) - endif - - call update_z_to_zeta(itime, ipart) - - ! Interpolate PV to the particle position - !**************************************** - ixm=int(part(ipart)%xlon) - jym=int(part(ipart)%ylat) - ixp=ixm+1 - jyp=jym+1 - ddx=part(ipart)%xlon-real(ixm) - ddy=part(ipart)%ylat-real(jym) - rddx=1.-ddx - rddy=1.-ddy - p1=rddx*rddy - p2=ddx*rddy - p3=rddx*ddy - p4=ddx*ddy - indzm=nz-1 - indzp=nz - do i=2,nz - if (real(height(i),kind=dp).gt.part(ipart)%z) then - indzm=i-1 - indzp=i - exit - endif - end do - dz1=real(part(ipart)%z)-height(indzm) - dz2=height(indzp)-real(part(ipart)%z) - 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 (((part(ipart)%z.gt.3000.).and. & - (pvpart.gt.pvcrit)).or.(mdomainfill.eq.1)) then - part(ipart)%nclass=min(int(ran1(idummy,ithread)* & - real(nclassunc))+1,nclassunc) - numactiveparticles=numactiveparticles+1 - numparticlecount_tmp=numparticlecount_tmp+1 - part(ipart)%npoint=numparticlecount_tmp - part(ipart)%idt=mintime - part(ipart)%mass(1)=xmassperparticle - if (mdomainfill.eq.2) part(ipart)%mass(1)= & - part(ipart)%mass(1)*pvpart*48./29.*ozonescale/10.**9 - part(ipart)%mass_init(1)=part(ipart)%mass(1) - else - stop 'boundcond_domainfill error: look into original to understand what should happen here' - endif - end do ! particles - end do ! releases per column - end do ! east west - end do ! north south -!$OMP END DO -!$OMP END PARALLEL - numparticlecount = numparticlecount_tmp - ! If particles shall be dumped, then accumulated masses at the domain boundaries - ! must be dumped, too, to be used for later runs - !***************************************************************************** +#include "ini_init_domainfill.f90" - 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 +#include "ini_boundcond_domainfill.f90" end module initialise_mod diff --git a/src/int_alloc_interpol.f90 b/src/int_alloc_interpol.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ccfaa4075661bf12d69bed22cba4a73f91640f11 --- /dev/null +++ b/src/int_alloc_interpol.f90 @@ -0,0 +1,8 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine alloc_interpol + ! allocate(uprof(nzmax),vprof(nzmax),wprof(nzmax),wprofeta(nzmax), & + ! usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax),wsigprofeta(nzmax), & + ! rhoprof(nzmax),rhogradprof(nzmax),indzindicator(nzmax)) +end subroutine alloc_interpol diff --git a/src/int_bilin_spatial_interpol.f90 b/src/int_bilin_spatial_interpol.f90 new file mode 100644 index 0000000000000000000000000000000000000000..aef7d4032b848cf635bcb657a5b3cf709e7fc44c --- /dev/null +++ b/src/int_bilin_spatial_interpol.f90 @@ -0,0 +1,29 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine bilin_spatial_interpol(field,output,zlevel,dz1,dz2,ztot) + + integer, intent(in) :: zlevel,ztot ! interpolation z level + real, intent(in) :: field(0:nxmax-1,0:nymax-1,ztot,numwfmem) + ! input field to interpolate + real, intent(in) :: dz1,dz2 + real, intent(inout) :: output(2) ! interpolated values + integer :: m,n,indzh + real :: output1(2) + + do m=1,2 + + do n=1,2 + indzh=zlevel+n-1 + call hor_interpol_4d(field,output1(n),indzh,memind(m),ztot) + end do + + !********************************** + ! 2.) Linear vertical interpolation on logarithmic scale + !********************************** + + call vert_interpol(output1(1),output1(2),dz1,dz2,output(m)) + + end do + +end subroutine bilin_spatial_interpol diff --git a/src/int_bilin_spatial_interpol_nest.f90 b/src/int_bilin_spatial_interpol_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9670851dd0b02100df246c196b8d5081003a8b9b --- /dev/null +++ b/src/int_bilin_spatial_interpol_nest.f90 @@ -0,0 +1,29 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine bilin_spatial_interpol_nest(field,output,zlevel,dz1,dz2,ztot) + + integer, intent(in) :: zlevel,ztot ! interpolation z level + real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,ztot,numwfmem,numbnests) + ! input field to interpolate + real, intent(in) :: dz1,dz2 + real, intent(inout) :: output(2) ! interpolated values + integer :: m,n,indzh + real :: output1(2) + + do m=1,2 + + do n=1,2 + indzh=zlevel+n-1 + call hor_interpol_4d_nest(field,output1(n),indzh,memind(m),ztot) + end do + + !********************************** + ! 2.) Linear vertical interpolation on logarithmic scale + !********************************** + + call vert_interpol(output1(1),output1(2),dz1,dz2,output(m)) + + end do + +end subroutine bilin_spatial_interpol_nest diff --git a/src/int_compute_sl_sq.f90 b/src/int_compute_sl_sq.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7799e58004a048ba1a7e480f4b7dc69394b65dcb --- /dev/null +++ b/src/int_compute_sl_sq.f90 @@ -0,0 +1,19 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine compute_sl_sq(field,sl,sq,zlevel,indexh,ztot) + + integer, intent(in) :: zlevel,ztot,indexh ! interpolation z levels + real, intent(in) :: field(0:nxmax-1,0:nymax-1,ztot,numwfmem) + ! input field to interpolate + real, intent(inout) :: sl,sq ! standard deviation + + sl=sl+field(ix ,jy ,zlevel,indexh)+field(ixp,jy ,zlevel,indexh) & + +field(ix ,jyp,zlevel,indexh)+field(ixp,jyp,zlevel,indexh) + + sq=sq+field(ix ,jy ,zlevel,indexh)*field(ix ,jy ,zlevel,indexh)+ & + field(ixp,jy ,zlevel,indexh)*field(ixp,jy ,zlevel,indexh)+ & + field(ix ,jyp,zlevel,indexh)*field(ix ,jyp,zlevel,indexh)+ & + field(ixp,jyp,zlevel,indexh)*field(ixp,jyp,zlevel,indexh) + +end subroutine compute_sl_sq diff --git a/src/int_compute_sl_sq_nest.f90 b/src/int_compute_sl_sq_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bb2516212110da82d8a1cd31908adc46359fc323 --- /dev/null +++ b/src/int_compute_sl_sq_nest.f90 @@ -0,0 +1,19 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine compute_sl_sq_nest(field,sl,sq,zlevel,indexh,ztot) + + integer, intent(in) :: zlevel,ztot,indexh ! interpolation z levels + real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,ztot,numwfmem,numbnests) + ! input field to interpolate + real, intent(inout) :: sl,sq ! standard deviation + + sl=sl+field(ix ,jy ,zlevel,indexh,ngrid)+field(ixp,jy ,zlevel,indexh,ngrid) & + +field(ix ,jyp,zlevel,indexh,ngrid)+field(ixp,jyp,zlevel,indexh,ngrid) + + sq=sq+field(ix ,jy ,zlevel,indexh,ngrid)*field(ix ,jy ,zlevel,indexh,ngrid)+ & + field(ixp,jy ,zlevel,indexh,ngrid)*field(ixp,jy ,zlevel,indexh,ngrid)+ & + field(ix ,jyp,zlevel,indexh,ngrid)*field(ix ,jyp,zlevel,indexh,ngrid)+ & + field(ixp,jyp,zlevel,indexh,ngrid)*field(ixp,jyp,zlevel,indexh,ngrid) + +end subroutine compute_sl_sq_nest diff --git a/src/int_dealloc_interpol.f90 b/src/int_dealloc_interpol.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3b2c65322a09aba6111a126f6b626a79083ed477 --- /dev/null +++ b/src/int_dealloc_interpol.f90 @@ -0,0 +1,8 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine dealloc_interpol + ! deallocate(uprof,vprof,wprof,wprofeta, & + ! usigprof,vsigprof,wsigprof,wsigprofeta, & + ! rhoprof,rhogradprof,indzindicator) +end subroutine dealloc_interpol diff --git a/src/int_find_grid_distances.f90 b/src/int_find_grid_distances.f90 new file mode 100644 index 0000000000000000000000000000000000000000..56065952ddfb1cc17b03e06d0959aa812e8d09dd --- /dev/null +++ b/src/int_find_grid_distances.f90 @@ -0,0 +1,24 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_grid_distances(xt,yt) + + implicit none + + real, intent(in) :: xt,yt ! particle positions + + if (ngrid.le.0) then + ddx=xt-real(ix) + ddy=yt-real(jy) + else + ddx=xtn-real(ix) + ddy=ytn-real(jy) + endif + rddx=1.-ddx + rddy=1.-ddy + p1=rddx*rddy + p2=ddx*rddy + p3=rddx*ddy + p4=ddx*ddy + +end subroutine find_grid_distances diff --git a/src/int_find_grid_indices.f90 b/src/int_find_grid_indices.f90 new file mode 100644 index 0000000000000000000000000000000000000000..613ed104893e371a63c133ba2b807d55b69783d1 --- /dev/null +++ b/src/int_find_grid_indices.f90 @@ -0,0 +1,42 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_grid_indices(xt,yt) + + real, intent(in) :: xt,yt ! particle positions + + 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) + nix=max(min(nint(xtn),nxn(ngrid)-1),0) + njy=max(min(nint(ytn),nyn(ngrid)-1),0) + ix=nix + jy=njy + ixp=ix+1 + jyp=jy+1 + return + else + ix=int(xt) + jy=int(yt) + nix=nint(xt) + njy=nint(yt) + ixp=ix+1 + jyp=jy+1 + endif + + ! eso: Temporary fix for particle exactly at north pole + if (jyp.ge.nymax) then + write(*,*) 'WARNING: interpol_mod.f90 jyp >= nymax. xt,yt:',xt,yt + jyp=jyp-1 + end if + + if (ixp.ge.nxmax) then + write(*,*) 'WARNING: interpol_mod.f90 ixp >= nxmax. xt,yt:',xt,yt + ixp=ixp-nxmax + end if + +end subroutine find_grid_indices diff --git a/src/int_find_ngrid_dp.f90 b/src/int_find_ngrid_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..691b7128b4d465fd4da3156f4aa01b56b3e550fc --- /dev/null +++ b/src/int_find_ngrid_dp.f90 @@ -0,0 +1,27 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_ngrid_dp(xt,yt) + + real eps + real(kind=dp), intent(in) :: xt,yt ! particle positions on grid + integer :: j + + eps=nxmax/3.e5 + if (nglobal.and.(real(yt).gt.switchnorthg)) then + ngrid=-1 + else if (sglobal.and.(real(yt).lt.switchsouthg)) then + ngrid=-2 + else + ngrid=0 + ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) + do j=numbnests,1,-1 + if (real(xt).gt.xln(j)+dxn(j) .and. real(xt).lt.xrn(j)-dxn(j) .and. & + real(yt).gt.yln(j)+dyn(j) .and. real(yt).lt.yrn(j)-dyn(j)) then + ngrid=j + exit + endif + end do + endif + +end subroutine find_ngrid_dp diff --git a/src/int_find_ngrid_sp.f90 b/src/int_find_ngrid_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f9766f35a41a74a56f704156d0b79ff46305e18e --- /dev/null +++ b/src/int_find_ngrid_sp.f90 @@ -0,0 +1,27 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_ngrid_sp(xt,yt) + + real :: eps + real, intent(in) :: xt,yt ! particle positions on grid + integer :: j + + eps=nxmax/3.e5 + if (nglobal .and. yt.gt.switchnorthg) then + ngrid=-1 + else if (sglobal .and. yt.lt.switchsouthg) then + ngrid=-2 + else + ngrid=0 + ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) + do j=numbnests,1,-1 + if (xt.gt.xln(j)+dxn(j) .and. xt.lt.xrn(j)-dxn(j) .and. & + yt.gt.yln(j)+dyn(j) .and. yt.lt.yrn(j)-dyn(j)) then + ngrid=j + exit + endif + end do + endif + +end subroutine find_ngrid_sp diff --git a/src/int_find_time_vars.f90 b/src/int_find_time_vars.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e4c5d2b8e2dcbd5a07e6170e02c6c15bf4584028 --- /dev/null +++ b/src/int_find_time_vars.f90 @@ -0,0 +1,12 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_time_vars(itime) + + integer, intent(in) :: itime ! time step + + dt1=real(itime-memtime(1)) + dt2=real(memtime(2)-itime) + dtt=1./(dt1+dt2) + +end subroutine find_time_vars diff --git a/src/int_find_vert_vars.f90 b/src/int_find_vert_vars.f90 new file mode 100644 index 0000000000000000000000000000000000000000..770d5b53ad80a0258cbdbf3dee0951f0e3fe6e4e --- /dev/null +++ b/src/int_find_vert_vars.f90 @@ -0,0 +1,95 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_vert_vars(vertlevels,zpos,zlevel,dz1,dz2,bounds,wlevel) + + !***************************************************************************** + ! * + ! This subroutine computes the vertical interpolation variables * + ! logarithmically, unless log_interpol=.false. in the par_mod * + ! * + ! Author: L. Bakels * + !***************************************************************************** + + real, intent(in) :: vertlevels(:) ! vertical levels in coordinate system + real, intent(in) :: zpos ! verticle particle position + integer, intent(in) :: zlevel ! vertical level of interest + logical, intent(in) :: bounds(2),wlevel ! flag marking if particles are + ! outside bounds + real, intent(inout) :: dz1,dz2 ! fractional distance to point 1 + ! (closer to ground) and 2 + real :: dz,dh1,dh,pfact + real :: psint1(2),psint,pr1,pr2,pr_test + ! pressure of encompassing levels + integer :: m + + ! Only do logarithmic interpolation when using ETA coordinates, since the + ! levels are following pressure, while METER levels are linear. + !############################################################## + + if (.not. log_interpol) then + call find_vert_vars_lin(vertlevels,zpos,zlevel,dz1,dz2,bounds,wlevel) + return + endif + + ! To check if taking the logarithm is safe + if (wlevel) then + pr_test=akm(zlevel+1)+bkm(zlevel+1) + else + pr_test=akz(zlevel+1)+bkz(zlevel+1) + endif + + ! If the particle is below bounds (bounds(1)==.true.): + if (bounds(1)) then + dz1=0. + dz2=1. + ! If above bounds (bounds(2)==.true.): + else if (bounds(2)) then + dz1=1. + dz2=0. + + ! Instead of the linear z variables, we need the ones that correspond to + ! the pressure of the height of the particle in relation to the model levels + !*************************************************************************** + else if (pr_test.eq.0) then + dz=1./(vertlevels(zlevel+1)-vertlevels(zlevel)) + dz1=(zpos-vertlevels(zlevel))*dz + dz2=(vertlevels(zlevel+1)-zpos)*dz + else + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(ps,psint1(m),1,memind(m),1) + end do + else + do m=1,2 + call hor_interpol_nest(psn,psint1(m),1,memind(m),1) + end do + endif + call temp_interpol(psint1(1),psint1(2),psint) + dh = vertlevels(zlevel+1)-vertlevels(zlevel) + dh1 = zpos - vertlevels(zlevel) + if (wlevel) then + pr1=akm(zlevel) + bkm(zlevel)*psint + pr2=akm(zlevel+1) + bkm(zlevel+1)*psint + else + pr1=akz(zlevel) + bkz(zlevel)*psint + pr2=akz(zlevel+1) + bkz(zlevel+1)*psint + endif + pfact = log(pr2/pr1)*dh1/dh + dz = 1./(pr2-pr1) + dz1 = pr1*(exp(pfact)-1.)*dz + dz2 = 1.-dz1 + endif + ! else if ((vertlevels(zlevel).eq.0).or.(vertlevels(zlevel+1).eq.0)) then + ! ! Linear interpolation for bottom or top layer is zero + ! dz=1./(vertlevels(zlevel+1)-vertlevels(zlevel)) + ! dz1=(zpos-vertlevels(zlevel))*dz + ! dz2=(vertlevels(zlevel+1)-zpos)*dz + ! else + ! ! Logaritmic interpolation + ! dz=1./(log(vertlevels(zlevel+1))-log(vertlevels(zlevel))) + ! dz1=(log(zpos)-log(vertlevels(zlevel)))*dz + ! dz2=(log(vertlevels(zlevel+1))-log(zpos))*dz + ! endif + +end subroutine find_vert_vars diff --git a/src/int_find_vert_vars_lin.f90 b/src/int_find_vert_vars_lin.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b393af61e0980a1f07df36374957c9e4d032d5ea --- /dev/null +++ b/src/int_find_vert_vars_lin.f90 @@ -0,0 +1,30 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_vert_vars_lin(vertlevels,zpos,zlevel,dz1,dz2,bounds,wlevel) + + real, intent(in) :: vertlevels(:) ! vertical levels in coordinate system + real, intent(in) :: zpos ! verticle particle position + integer, intent(in) :: zlevel ! vertical level of interest + logical, intent(in) :: bounds(2),wlevel! flag marking if particles are outside + ! bounds + real, intent(inout) :: dz1,dz2 ! fractional distance to point 1 + ! (closer to ground) and 2 + real :: dz,dh1,dh,pfact + real :: psint1(2),psint,pr1,pr2,temp ! pressure of encompassing levels + + ! If the particle is below bounds (bounds(1)==.true.): + if (bounds(1)) then + dz1=0. + dz2=1. + ! If above bounds (bounds(2)==.true.): + else if (bounds(2)) then + dz1=1. + dz2=0. + else + dz=1./(vertlevels(zlevel+1)-vertlevels(zlevel)) + dz1=(zpos-vertlevels(zlevel))*dz + dz2=(vertlevels(zlevel+1)-zpos)*dz + endif + +end subroutine find_vert_vars_lin diff --git a/src/int_find_z_level.f90 b/src/int_find_z_level.f90 new file mode 100644 index 0000000000000000000000000000000000000000..482a54cc4911e9052949c2061ecf82958e9fe16a --- /dev/null +++ b/src/int_find_z_level.f90 @@ -0,0 +1,20 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_z_level(zt,zteta) + + real, intent(in) :: & + zt, & ! height in meters + zteta ! height in eta + + select case (wind_coord_type) + case('ETA') + call find_z_level_meters(zt) + call find_z_level_eta(zteta) + case('METER') + call find_z_level_meters(zt) + case default + call find_z_level_meters(zt) + end select + +end subroutine find_z_level diff --git a/src/int_find_z_level_eta.f90 b/src/int_find_z_level_eta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..52a64c277cbb24d881adc10162855227f92cba10 --- /dev/null +++ b/src/int_find_z_level_eta.f90 @@ -0,0 +1,13 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_z_level_eta(zteta) + + real, intent(in) :: zteta ! height in eta coordinates + integer :: i ! loop variable + + call find_z_level_eta_w(zteta) + + call find_z_level_eta_uv(zteta) + +end subroutine find_z_level_eta diff --git a/src/int_find_z_level_eta_uv.f90 b/src/int_find_z_level_eta_uv.f90 new file mode 100644 index 0000000000000000000000000000000000000000..81da654281ad175d3a868a31481e3f9f9dfb6fd2 --- /dev/null +++ b/src/int_find_z_level_eta_uv.f90 @@ -0,0 +1,31 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_z_level_eta_uv(zteta) + + real, intent(in) :: zteta ! height in eta coordinates + integer :: i ! loop variable + + induv=nz-1 + indpuv=nz + if (zteta.gt.uvheight(1)) then + lbounds_uv(1)=.true. + lbounds_uv(2)=.false. + induv=1 + indpuv=2 + else if (zteta.lt.uvheight(nz)) then + lbounds_uv(1)=.false. + lbounds_uv(2)=.true. + else + lbounds_uv(1)=.false. + lbounds_uv(2)=.false. + do i=2,nz + if (uvheight(i).lt.zteta) then + induv=i-1 + indpuv=i + exit + endif + end do + endif + +end subroutine find_z_level_eta_uv diff --git a/src/int_find_z_level_eta_w.f90 b/src/int_find_z_level_eta_w.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5b1502cddf69632f70dcfa8df68a61b916e8d776 --- /dev/null +++ b/src/int_find_z_level_eta_w.f90 @@ -0,0 +1,32 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_z_level_eta_w(zteta) + + real, intent(in) :: zteta ! height in eta coordinates + integer :: i ! loop variable + + indzeta=nz-1 + indzpeta=nz + ! Flag particles that are above or below bounds + if (zteta.ge.wheight(1)) then + lbounds_w(1)=.true. + lbounds_w(2)=.false. + indzeta=1 + indzpeta=2 + else if (zteta.le.wheight(nz)) then + lbounds_w(1)=.false. + lbounds_w(2)=.true. + else + lbounds_w(1)=.false. + lbounds_w(2)=.false. + do i=2,nz + if (wheight(i).lt.zteta) then + indzeta=i-1 + indzpeta=i + exit + endif + end do + endif + +end subroutine find_z_level_eta_w diff --git a/src/int_find_z_level_meters.f90 b/src/int_find_z_level_meters.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6ba6fc0d2d7f6409dee14202e4f9abbf7785a917 --- /dev/null +++ b/src/int_find_z_level_meters.f90 @@ -0,0 +1,31 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine find_z_level_meters(zt) + + real, intent(in) :: zt ! height in meters + integer :: i + + indz=nz-1 + indzp=nz + if (zt.le.height(1)) then + lbounds(1)=.true. + lbounds(2)=.false. + indz=1 + indzp=2 + else if (zt.ge.height(nz)) then + lbounds(1)=.false. + lbounds(2)=.true. + else + lbounds(1)=.false. + lbounds(2)=.false. + do i=2,nz + if (height(i).gt.zt) then + indz=i-1 + indzp=i + exit + endif + end do + endif + +end subroutine find_z_level_meters diff --git a/src/int_hor_interpol_2d.f90 b/src/int_hor_interpol_2d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e21e9dac2f3a6eafe06162fa39febfdf5ac90411 --- /dev/null +++ b/src/int_hor_interpol_2d.f90 @@ -0,0 +1,13 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine hor_interpol_2d(field,output) + + real, intent(in) :: field(0:nxmax-1,0:nymax-1) ! 2D imput field + real, intent(inout) :: output ! Interpolated value + + output=p1*field(ix ,jy) & + + p2*field(ixp,jy) & + + p3*field(ix ,jyp) & + + p4*field(ixp,jyp) +end subroutine hor_interpol_2d diff --git a/src/int_hor_interpol_2d_nest.f90 b/src/int_hor_interpol_2d_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bc8ae7c5501cc0a4ecd06e27b1cba3fff3ecb9d1 --- /dev/null +++ b/src/int_hor_interpol_2d_nest.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine hor_interpol_2d_nest(field,output) + + real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,numbnests) + ! input field to interpolate + real, intent(inout) :: output ! interpolated values + + output=p1*field(ix ,jy ,ngrid) & + + p2*field(ixp,jy ,ngrid) & + + p3*field(ix ,jyp,ngrid) & + + p4*field(ixp,jyp,ngrid) + +end subroutine hor_interpol_2d_nest diff --git a/src/int_hor_interpol_4d.f90 b/src/int_hor_interpol_4d.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2cba537dab38a04c9cf592ed65fcadd455eee800 --- /dev/null +++ b/src/int_hor_interpol_4d.f90 @@ -0,0 +1,16 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine hor_interpol_4d(field,output,zlevel,indexh,ztot) + + integer, intent(in) :: zlevel,ztot,indexh ! interpolation z level, z + real, intent(in) :: field(0:nxmax-1,0:nymax-1,ztot,numwfmem) + ! input field to interpolate + real, intent(inout) :: output ! interpolated values + + output=p1*field(ix ,jy ,zlevel,indexh) & + + p2*field(ixp,jy ,zlevel,indexh) & + + p3*field(ix ,jyp,zlevel,indexh) & + + p4*field(ixp,jyp,zlevel,indexh) + +end subroutine hor_interpol_4d diff --git a/src/int_hor_interpol_4d_nest.f90 b/src/int_hor_interpol_4d_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5d285e4f48b373ba5760811371b30caf2b6b92e5 --- /dev/null +++ b/src/int_hor_interpol_4d_nest.f90 @@ -0,0 +1,16 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine hor_interpol_4d_nest(field,output,zlevel,indexh,ztot) + + integer, intent(in) :: zlevel,ztot,indexh ! interpolation z level, z + real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,ztot,numwfmem,numbnests) + ! input field to interpolate + real, intent(inout) :: output ! interpolated values + + output=p1*field(ix ,jy ,zlevel,indexh,ngrid) & + + p2*field(ixp,jy ,zlevel,indexh,ngrid) & + + p3*field(ix ,jyp,zlevel,indexh,ngrid) & + + p4*field(ixp,jyp,zlevel,indexh,ngrid) + +end subroutine hor_interpol_4d_nest diff --git a/src/int_init_interpol.f90 b/src/int_init_interpol.f90 new file mode 100644 index 0000000000000000000000000000000000000000..331792fc6464901d34fdf59f5e5949e0b9b674e0 --- /dev/null +++ b/src/int_init_interpol.f90 @@ -0,0 +1,22 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine init_interpol(itime,xt,yt,zt,zteta) + + ! This routine initialises all important values used in the interpol module + ! This includes: + ! - The current grid number in which the particle is positioned + ! - The interpolation fractions of the grid (x,y,z) and of time + + integer, intent(in) :: itime ! time step + real, intent(in) :: xt,yt ! particle positions + real, intent(in) :: zt ! height in meters + real, intent(in) :: zteta ! height in eta coordinates + + call find_ngrid(xt,yt) + call find_grid_indices(xt,yt) + call find_grid_distances(xt,yt) + call find_time_vars(itime) + call find_z_level(zt,zteta) + +end subroutine init_interpol diff --git a/src/int_interpol_density.f90 b/src/int_interpol_density.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e4ce945bb10b83e5e6afbfba521929c48f3543e5 --- /dev/null +++ b/src/int_interpol_density.f90 @@ -0,0 +1,56 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_density(itime,ipart,output) + + integer, intent(in) :: itime,ipart ! time and particle index + real, intent(inout) :: output ! output density (rhoi) + integer :: ind + real :: dz1,dz2,rhoprof(2) + + ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) + !*************************************************************** + call find_ngrid(part(ipart)%xlon,part(ipart)%ylat) + call find_grid_indices(real(part(ipart)%xlon),real(part(ipart)%ylat)) + call find_grid_distances(real(part(ipart)%xlon),real(part(ipart)%ylat)) + call find_time_vars(itime) + + ! Take density from 2nd wind field in memory + !(accurate enough, no time interpolation needed) + !*********************************************** + + select case (wind_coord_type) + case ('ETA') + call find_z_level_eta(real(part(ipart)%zeta)) + call find_vert_vars(uvheight,real(part(ipart)%zeta),induv, & + dz1,dz2,lbounds_uv,.false.) + if (ngrid.le.0) then + do ind=induv,indpuv + call hor_interpol(rhoeta,rhoprof(ind-induv+1),ind,memind(2),nzmax) + end do + else + do ind=induv,indpuv + call hor_interpol_nest(rhoetan,rhoprof(ind-induv+1),ind,memind(2), & + nzmax) + end do + endif + case ('METER') + call find_z_level_meters(real(part(ipart)%z)) + call find_vert_vars(height,real(part(ipart)%z),indz, & + dz1,dz2,lbounds,.false.) + if (ngrid.le.0) then + do ind=indz,indzp + call hor_interpol(rho,rhoprof(ind-indz+1),ind,memind(2),nzmax) + end do + else + do ind=indz,indzp + call hor_interpol_nest(rhon,rhoprof(ind-indz+1),ind,memind(2),nzmax) + end do + endif + case default + stop 'wind_coord_type not defined in conccalc.f90' + end select + + call vert_interpol(rhoprof(1),rhoprof(2),dz1,dz2,output) + +end subroutine interpol_density diff --git a/src/int_interpol_htropo_hmix.f90 b/src/int_interpol_htropo_hmix.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1a91ce6d23dfc5ab5d220e11c5196f8a595835ca --- /dev/null +++ b/src/int_interpol_htropo_hmix.f90 @@ -0,0 +1,43 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_htropo_hmix(tropop,h) + + real, intent(inout) :: tropop ! height of troposphere + real, intent(inout) :: h ! mixing height + real :: h1(2) ! mixing height of 2 timesteps + integer :: mind ! windfield index + integer :: i,j,k,m ! loop variables + + h=0. + if (ngrid.le.0) then + if (interpolhmix) then + do m=1,2 + call hor_interpol(hmix,h1(m),1,memind(m),1) + end do + else + do k=1,2 + mind=memind(k) ! eso: compatibility with 3-field version + do j=jy,jyp + do i=ix,ixp + if (hmix(i,j,1,mind).gt.h) h=hmix(i,j,1,mind) + end do + end do + end do + endif + tropop=tropopause(nix,njy,1,memind(1)) + else + do k=1,2 + mind=memind(k) + do j=jy,jyp + do i=ix,ixp + if (hmixn(i,j,1,mind,ngrid).gt.h) h=hmixn(i,j,1,mind,ngrid) + end do + end do + end do + tropop=tropopausen(nix,njy,1,memind(1),ngrid) + endif + + if (interpolhmix) h= (h1(1)*dt2 + h1(2)*dt1)*dtt + +end subroutine interpol_htropo_hmix diff --git a/src/int_interpol_mesoscale.f90 b/src/int_interpol_mesoscale.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2916681327dfb7f6ffca8ac806b0f0830c0d2b96 --- /dev/null +++ b/src/int_interpol_mesoscale.f90 @@ -0,0 +1,39 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_mesoscale(itime,xt,yt,zt,zteta) + + use turbulence_mod + + integer, intent(in) :: itime + real, intent(in) :: xt,yt,zt,zteta + integer :: iw(2),iuv(2),iweta(2) + integer :: m,indexh + + ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) + !*************************************************************** + call find_ngrid(xt,yt) + + call find_grid_indices(xt,yt) + + ! Determine the level below the current position + !*********************************************** + call find_z_level_meters(zt) + iw(:)=(/ indz, indzp /) + + select case (wind_coord_type) + case ('ETA') + call find_z_level_eta(zteta) + iuv(:)=(/ induv, indpuv /) + iweta(:)=(/ indzeta, indzpeta /) + call stdev_eta(iw,iuv,iweta) + case ('METER') + iw(:)=(/ indz, indzp /) + call stdev_meter(iw) + case default + write(*,*) 'ERROR: wind_coord_type is not allowed ', wind_coord_type + write(*,*) 'Choose ETA or METER.' + stop + end select + +end subroutine interpol_mesoscale diff --git a/src/int_interpol_mixinglayer_eta.f90 b/src/int_interpol_mixinglayer_eta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..02fff3551b41615a22bdbe9de8c1b1d8f5241572 --- /dev/null +++ b/src/int_interpol_mixinglayer_eta.f90 @@ -0,0 +1,21 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_mixinglayer_eta(zt,zteta,rhoa,rhograd) + + real, intent(in) :: zt,zteta + real, intent(inout) :: rhoa,rhograd + real :: dz1w,dz2w,dz1uv,dz2uv,dz1weta,dz2weta + + call find_vert_vars(height,zt,indz,dz1w,dz2w,lbounds,.false.) + call find_vert_vars(uvheight,zteta,induv,dz1uv,dz2uv,lbounds_uv,.false.) + call find_vert_vars(wheight,zteta,indzeta,dz1weta,dz2weta,lbounds_w,.true.) + + call vert_interpol(wprof(indz),wprof(indzp),dz1w,dz2w,w) + call vert_interpol(uprof(induv),uprof(indpuv),dz1uv,dz2uv,u) + call vert_interpol(vprof(induv),vprof(indpuv),dz1uv,dz2uv,v) + call vert_interpol(rhoprof(induv),rhoprof(indpuv),dz1uv,dz2uv,rhoa) + call vert_interpol(rhogradprof(induv),rhogradprof(indpuv),dz1uv,dz2uv,rhograd) + call vert_interpol(wprofeta(indzeta),wprofeta(indzpeta),dz1weta,dz2weta,weta) + +end subroutine interpol_mixinglayer_eta diff --git a/src/int_interpol_partoutput_val.f90 b/src/int_interpol_partoutput_val.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1d3647398f00a74f9ce3090d1481997aa7c2f5bd --- /dev/null +++ b/src/int_interpol_partoutput_val.f90 @@ -0,0 +1,22 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_partoutput_val(fieldname,output,j) + + integer, intent(in) :: j ! particle number + character(2), intent(in) :: fieldname ! input field to interpolate over + real, intent(inout) :: output + + ! Interpolate over the windfields depending on the prefered + ! coordinate system + !********************************************************** + select case (wind_coord_type) + case ('ETA') + call interpol_partoutput_val_eta(fieldname,output,j) + case ('METER') + call interpol_partoutput_val_meter(fieldname,output,j) + case default + call interpol_partoutput_val_meter(fieldname,output,j) + end select + +end subroutine interpol_partoutput_val diff --git a/src/int_interpol_partoutput_val_eta.f90 b/src/int_interpol_partoutput_val_eta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..eed092141bf330db99a75d700c1d24fb2f49a643 --- /dev/null +++ b/src/int_interpol_partoutput_val_eta.f90 @@ -0,0 +1,81 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_partoutput_val_eta(fieldname,output,j) + +!* PRIVATE FUNCTION * + + integer, intent(in) :: j ! particle number + character(2), intent(in) :: fieldname ! input field to interpolate over + real, intent(inout) :: output + real :: field1(2) + + if (int(dz1out).eq.-1) then + call find_z_level_eta(real(part(j)%zeta)) + call find_vert_vars(uvheight,real(part(j)%zeta),induv,dz1out,dz2out, & + lbounds_uv,.false.) + endif + + select case(fieldname) + case('PR','pr') + if (ngrid.le.0) then + call bilin_spatial_interpol(prseta,field1,induv,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(prsetan,field1,induv,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('PV','pv') + if (ngrid.le.0) then + call bilin_spatial_interpol(pveta,field1,induv,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(pvetan,field1,induv,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('QV','qv') + if (ngrid.le.0) then + call bilin_spatial_interpol(qv,field1,induv,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(qvn,field1,induv,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('TT','tt') + if (ngrid.le.0) then + call bilin_spatial_interpol(tteta,field1,induv,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(ttetan,field1,induv,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('UU','uu') + if (ngrid.le.0) then + call bilin_spatial_interpol(uueta,field1,induv,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(uuetan,field1,induv,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('VV','vv') + if (ngrid.le.0) then + call bilin_spatial_interpol(vveta,field1,induv,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(vvetan,field1,induv,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('WW','ww') + call find_z_level_meters(real(part(j)%z)) + call find_vert_vars(height,real(part(j)%z),indz,dz1out,dz2out,lbounds,.false.) + if (ngrid.le.0) then + call bilin_spatial_interpol(ww,field1,induv,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(wwn,field1,induv,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + dz1out = -1 + case('RH','rh') + if (ngrid.le.0) then + call bilin_spatial_interpol(rhoeta,field1,induv,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(rhoetan,field1,induv,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + end select + +end subroutine interpol_partoutput_val_eta diff --git a/src/int_interpol_partoutput_val_meter.f90 b/src/int_interpol_partoutput_val_meter.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fcaa6e7cef3691c799e89b9c6f87f8cc77b57e3e --- /dev/null +++ b/src/int_interpol_partoutput_val_meter.f90 @@ -0,0 +1,77 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_partoutput_val_meter(fieldname,output,j) + +!* PRIVATE FUNCTION * + + integer, intent(in) :: j ! particle number + character(2), intent(in) :: fieldname ! input field to interpolate over + real, intent(inout) :: output + real :: field1(2) + + if (int(dz1out).eq.-1) then + call find_z_level_meters(real(part(j)%z)) + call find_vert_vars(height,real(part(j)%z),indz,dz1out,dz2out,lbounds,.false.) + endif + + select case(fieldname) + case('PR','pr') + if (ngrid.le.0) then + call bilin_spatial_interpol(prs,field1,indz,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(prsn,field1,indz,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('PV','pv') + if (ngrid.le.0) then + call bilin_spatial_interpol(pv,field1,indz,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(pvn,field1,indz,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('QV','qv') + if (ngrid.le.0) then + call bilin_spatial_interpol(qv,field1,indz,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(qvn,field1,indz,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('TT','tt') + if (ngrid.le.0) then + call bilin_spatial_interpol(tt,field1,indz,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(ttn,field1,indz,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('UU','uu') + if (ngrid.le.0) then + call bilin_spatial_interpol(uu,field1,indz,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(uun,field1,indz,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('VV','vv') + if (ngrid.le.0) then + call bilin_spatial_interpol(vv,field1,indz,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(vvn,field1,indz,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('WW','ww') + if (ngrid.le.0) then + call bilin_spatial_interpol(ww,field1,indz,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(wwn,field1,indz,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + case('RH','rh') + if (ngrid.le.0) then + call bilin_spatial_interpol(rho,field1,indz,dz1out,dz2out,nzmax) + else + call bilin_spatial_interpol_nest(rhon,field1,indz,dz1out,dz2out,nzmax) + endif + call temp_interpol(field1(1),field1(2),output) + end select + +end subroutine interpol_partoutput_val_meter diff --git a/src/int_interpol_pbl.f90 b/src/int_interpol_pbl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e1dca440689cf6fe43e643da11d0e8e07c71dc64 --- /dev/null +++ b/src/int_interpol_pbl.f90 @@ -0,0 +1,175 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_pbl(itime,xt,yt,zt,zteta) + ! 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 cal- * + ! culation 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 * + ! culated * + ! * + ! Constants: * + ! * + !***************************************************************************** + + use turbulence_mod + + integer, intent(in) :: itime + real, intent(in) :: xt,yt,zt,zteta + integer :: m,n,indexh + integer :: iw(2),iweta(2) + real :: uh1(2),vh1(2),wh1(2),wetah1(2),rho1(2),rhograd1(2) + real :: dz1weta,dz2weta + real,parameter :: eps=1.0e-30 + + ! Auxiliary variables needed for interpolation + real :: ust1(2),wst1(2),oli1(2),oliaux + + !******************************************** + ! Multilinear interpolation in time and space + !******************************************** + + ! ngrid and grid coordinates have already been definded, and are included + ! in the input (for nested: xtn,ytn; for not nested: xts,yts) + + !************************************************************************ + ! Determine the lower left corner and its distance to the current position + !************************************************************************* + + call find_grid_distances(xt,yt) + + ! Calculate variables for time interpolation + !******************************************* + + call find_time_vars(itime) + + !******************************************************** + ! 1. Interpolate u*, w* and Obukhov length for turbulence + !******************************************************** + + ! a) Bilinear horizontal interpolation + if (ngrid.le.0) then ! No nest + do m=1,2 + indexh=memind(m) + call hor_interpol(ustar,ust1(m),1,memind(m),1) + call hor_interpol(wstar,wst1(m),1,memind(m),1) + call hor_interpol(oli,oli1(m),1,memind(m),1) + end do + else ! Nest + do m=1,2 + indexh=memind(m) + call hor_interpol_nest(ustarn,ust1(m),1,memind(m),1) + call hor_interpol_nest(wstarn,wst1(m),1,memind(m),1) + call hor_interpol_nest(olin,oli1(m),1,memind(m),1) + end do + endif + + ! b) Temporal interpolation + call temp_interpol(ust1(1),ust1(2),ust) + call temp_interpol(wst1(1),wst1(2),wst) + call temp_interpol(oli1(1),oli1(2),oliaux) + + if (oliaux.ne.0.) then + ol=1./oliaux + else + ol=99999. + endif + + ! Within the PBL, only METER coordinates are used + ! with the exception of mesoscale turbulence, + ! which uses wsigeta computed in interpol_mesoscale + !************************************************** + + ! Determine the level below the current position + !*********************************************** + call find_z_level_meters(zt) + + iw(:)=(/ indz, indzp /) + + ! w(eta) velocities are necessary for the Petterssen correction + !************************************************************** + if (wind_coord_type.eq.'ETA') then + call find_z_level_eta(zteta) + iweta(:)=(/ indzeta, indzpeta /) + endif + + !************************************** + ! 1.) Bilinear horizontal interpolation + ! 2.) Temporal interpolation (linear) + !************************************** + + ! Loop over 2 time steps and indz levels + !*************************************** + if (ngrid.le.0) then ! No nest + do n=1,2 + do m=1,2 + call hor_interpol(ww,wh1(m),iw(n),memind(m),nzmax) + if (wind_coord_type.eq.'ETA') & + call hor_interpol(wweta,wetah1(m),iweta(n),memind(m),nzmax) + call hor_interpol(rho,rho1(m),iw(n),memind(m),nzmax) + call hor_interpol(drhodz,rhograd1(m),iw(n),memind(m),nzmax) + if (ngrid.lt.0) then + call hor_interpol(uupol,uh1(m),iw(n),memind(m),nzmax) + call hor_interpol(vvpol,vh1(m),iw(n),memind(m),nzmax) + else + call hor_interpol(uu,uh1(m),iw(n),memind(m),nzmax) + call hor_interpol(vv,vh1(m),iw(n),memind(m),nzmax) + endif + end do + call temp_interpol(wh1(1),wh1(2),wprof(iw(n))) + if (wind_coord_type.eq.'ETA') & + call temp_interpol(wetah1(1),wetah1(2),wprofeta(iweta(n))) + call temp_interpol(uh1(1),uh1(2),uprof(iw(n))) + call temp_interpol(vh1(1),vh1(2),vprof(iw(n))) + call temp_interpol(rho1(1),rho1(2),rhoprof(iw(n))) + call temp_interpol(rhograd1(1),rhograd1(2),rhogradprof(iw(n))) + end do + else ! Nest + do n=1,2 + do m=1,2 + call hor_interpol_nest(wwn,wh1(m),iw(n),memind(m),nzmax) + if (wind_coord_type.eq.'ETA') & + call hor_interpol_nest(wwetan,wetah1(m),iweta(n),memind(m),nzmax) + call hor_interpol_nest(uun,uh1(m),iw(n),memind(m),nzmax) + call hor_interpol_nest(vvn,vh1(m),iw(n),memind(m),nzmax) + call hor_interpol_nest(rhon,rho1(m),iw(n),memind(m),nzmax) + call hor_interpol_nest(drhodzn,rhograd1(m),iw(n),memind(m),nzmax) + end do + call temp_interpol(wh1(1),wh1(2),wprof(iw(n))) + if (wind_coord_type.eq.'ETA') & + call temp_interpol(wetah1(1),wetah1(2),wprofeta(iweta(n))) + call temp_interpol(uh1(1),uh1(2),uprof(iw(n))) + call temp_interpol(vh1(1),vh1(2),vprof(iw(n))) + call temp_interpol(rho1(1),rho1(2),rhoprof(iw(n))) + call temp_interpol(rhograd1(1),rhograd1(2),rhogradprof(iw(n))) + + indzindicator(iw(n))=.false. + end do + endif + + ! Only necessary for the Petterssen correction + if (wind_coord_type.eq.'ETA') then + call find_vert_vars(wheight,zteta,indzeta, & + dz1weta,dz2weta,lbounds_w,.true.) + call vert_interpol(wprofeta(indzeta),wprofeta(indzpeta), & + dz1weta,dz2weta,weta) + endif + +end subroutine interpol_pbl diff --git a/src/int_interpol_pbl_misslev.f90 b/src/int_interpol_pbl_misslev.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6962f8d64b84af86dd433cf0d41b45f47fbd3e1d --- /dev/null +++ b/src/int_interpol_pbl_misslev.f90 @@ -0,0 +1,76 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_pbl_misslev + + !***************************************************************************** + ! * + ! 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 cal- * + ! culation of standard deviation done in this * + ! routine rather than subroutine call in order * + ! to save computation time * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! n level * + ! * + ! Constants: * + ! * + !***************************************************************************** + + real :: uh1(2),vh1(2),wh1(2),rho1(2),rhograd1(2) + integer :: m,n,iw(2) + + ! Within the PBL, only METER coordinates are used + ! with the exception of mesoscale turbulence, + ! which uses wsigeta computed in interpol_mesoscale + !************************************************** + + !******************************************** + ! Multilinear interpolation in time and space + !******************************************** + + iw(:)=(/ indz, indzp /) + do n=1,2 + if (indzindicator(iw(n))) then + if (ngrid.le.0) then ! No nest + do m=1,2 + call hor_interpol(ww,wh1(m),iw(n),memind(m),nzmax) + call hor_interpol(rho,rho1(m),iw(n),memind(m),nzmax) + call hor_interpol(drhodz,rhograd1(m),iw(n),memind(m),nzmax) + if (ngrid.lt.0) then + call hor_interpol(uupol,uh1(m),iw(n),memind(m),nzmax) + call hor_interpol(vvpol,vh1(m),iw(n),memind(m),nzmax) + else + call hor_interpol(uu,uh1(m),iw(n),memind(m),nzmax) + call hor_interpol(vv,vh1(m),iw(n),memind(m),nzmax) + endif + end do + else ! Nest + do m=1,2 + call hor_interpol_nest(wwn,wh1(m),iw(n),memind(m),nzmax) + call hor_interpol_nest(uun,uh1(m),iw(n),memind(m),nzmax) + call hor_interpol_nest(vvn,vh1(m),iw(n),memind(m),nzmax) + call hor_interpol_nest(rhon,rho1(m),iw(n),memind(m),nzmax) + call hor_interpol_nest(drhodzn,rhograd1(m),iw(n),memind(m),nzmax) + end do + endif + call temp_interpol(wh1(1),wh1(2),wprof(iw(n))) + call temp_interpol(uh1(1),uh1(2),uprof(iw(n))) + call temp_interpol(vh1(1),vh1(2),vprof(iw(n))) + call temp_interpol(rho1(1),rho1(2),rhoprof(iw(n))) + call temp_interpol(rhograd1(1),rhograd1(2),rhogradprof(iw(n))) + + indzindicator(iw(n))=.false. + endif + end do + +end subroutine interpol_pbl_misslev diff --git a/src/int_interpol_pbl_short.f90 b/src/int_interpol_pbl_short.f90 new file mode 100644 index 0000000000000000000000000000000000000000..451f2a376c326a20739d06f16c3a94dcc5ee083e --- /dev/null +++ b/src/int_interpol_pbl_short.f90 @@ -0,0 +1,18 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_pbl_short(zt,rhoa,rhograd) + + real, intent(in) :: zt + real, intent(inout) :: rhoa,rhograd + real :: dz1,dz2 + + call find_vert_vars(height,zt,indz,dz1,dz2,lbounds,.false.) + + call vert_interpol(wprof(indz),wprof(indzp),dz1,dz2,w) + call vert_interpol(uprof(indz),uprof(indzp),dz1,dz2,u) + call vert_interpol(vprof(indz),vprof(indzp),dz1,dz2,v) + call vert_interpol(rhoprof(indz),rhoprof(indzp),dz1,dz2,rhoa) + call vert_interpol(rhogradprof(indz),rhogradprof(indzp),dz1,dz2,rhograd) + +end subroutine interpol_pbl_short diff --git a/src/int_interpol_wind.f90 b/src/int_interpol_wind.f90 new file mode 100644 index 0000000000000000000000000000000000000000..39d147c80041964c3f8ece164132f77dbb150fd2 --- /dev/null +++ b/src/int_interpol_wind.f90 @@ -0,0 +1,82 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_wind(itime,xt,yt,zt,zteta,pp) + ! 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: * + ! * + !***************************************************************************** + + integer, intent(in) :: itime,pp + real, intent(in) :: xt,yt,zt,zteta + integer :: iw(2),iuv(2),iweta(2) + + + ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) + !*************************************************************** + call find_ngrid(xt,yt) + + call find_grid_indices(xt,yt) + ! ! Multilinear interpolation in time and space + ! !******************************************** + + ! Determine the lower left corner and its distance to the current position + !************************************************************************* + call find_grid_distances(xt,yt) + + ! Calculate variables for time interpolation + !******************************************* + call find_time_vars(itime) + + ! Interpolate over the windfields depending on the prefered + ! coordinate system + !********************************************************** + select case (wind_coord_type) + case ('ETA') + ! Same for eta coordinates + !************************* + call find_z_level_eta(zteta) + + iuv(:) = (/ induv, indpuv /) + iweta(:)= (/ indzeta, indzpeta /) + call interpol_wind_eta(zteta,iuv,iweta) + !call stdev_wind_eta(iw,iuv,iweta) + case ('METER') + ! Determine the level below the current position for u,v + !******************************************************* + call find_z_level_meters(zt) + + iw(:)=(/ indz, indzp /) + call interpol_wind_meter(zt,iw) + !call stdev_wind_meter(iw) + + case default + write(*,*) 'ERROR: wind_coord_type is not allowed ', wind_coord_type + write(*,*) 'Choose ETA or METER.' + stop + end select + +end subroutine interpol_wind diff --git a/src/int_interpol_wind_eta.f90 b/src/int_interpol_wind_eta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9c469812c91f87e3775be3853675421ca78973d0 --- /dev/null +++ b/src/int_interpol_wind_eta.f90 @@ -0,0 +1,64 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_wind_eta(zteta,iuv,iweta) + +!* PRIVATE FUNCTION * + + real, intent(in) :: zteta + integer,intent(in) :: iuv(2),iweta(2) + integer :: n,m + real :: uh(2),vh(2),wetah(2),uh1(2),vh1(2),wetah1(2) + real :: dz1uv,dz2uv,dz1weta,dz2weta + + !********************************************************************** + ! 1.) Bilinear horizontal interpolation + ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3)) + !********************************************************************** + + ! Vertical distance to the level below and above current position + !**************************************************************** + call find_vert_vars(uvheight,zteta,induv,dz1uv,dz2uv,lbounds_uv,.false.) + call find_vert_vars(wheight,zteta,indzeta,dz1weta,dz2weta,lbounds_w,.true.) + + ! Loop over 2 time steps and 2 levels + !************************************ + if (ngrid.le.0) then ! No nest + do m=1,2 + do n=1,2 + call hor_interpol(wweta,wetah1(n),iweta(n),memind(m),nzmax) + if (ngrid.lt.0) then + call hor_interpol(uupoleta,uh1(n),iuv(n),memind(m),nzmax) + call hor_interpol(vvpoleta,vh1(n),iuv(n),memind(m),nzmax) + else + call hor_interpol(uueta,uh1(n),iuv(n),memind(m),nzmax) + call hor_interpol(vveta,vh1(n),iuv(n),memind(m),nzmax) + endif + end do + call vert_interpol(uh1(1),uh1(2),dz1uv,dz2uv,uh(m)) + call vert_interpol(vh1(1),vh1(2),dz1uv,dz2uv,vh(m)) + call vert_interpol(wetah1(1),wetah1(2),dz1weta,dz2weta,wetah(m)) + end do + else ! Nest + do m=1,2 + do n=1,2 + + ! wetah1(n) = p1*wwetan(ix ,jy ,iweta(n),memind(m),ngrid) & + ! + p2*wwetan(ixp,jy ,iweta(n),memind(m),ngrid) & + ! + p3*wwetan(ix ,jyp,iweta(n),memind(m),ngrid) & + ! + p4*wwetan(ixp,jyp,iweta(n),memind(m),ngrid) + call hor_interpol_nest(wwetan,wetah1(n),iweta(n),memind(m),nzmax) + call hor_interpol_nest(uuetan,uh1(n),iuv(n),memind(m),nzmax) + call hor_interpol_nest(vvetan,vh1(n),iuv(n),memind(m),nzmax) + end do + call vert_interpol(uh1(1),uh1(2),dz1uv,dz2uv,uh(m)) + call vert_interpol(vh1(1),vh1(2),dz1uv,dz2uv,vh(m)) + call vert_interpol(wetah1(1),wetah1(2),dz1weta,dz2weta,wetah(m)) + end do + endif + + call temp_interpol(uh(1),uh(2),u) + call temp_interpol(vh(1),vh(2),v) + call temp_interpol(wetah(1),wetah(2),weta) + +end subroutine interpol_wind_eta diff --git a/src/int_interpol_wind_meter.f90 b/src/int_interpol_wind_meter.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bea88b8bc4b086b006bdefc07510b1e554f1210a --- /dev/null +++ b/src/int_interpol_wind_meter.f90 @@ -0,0 +1,58 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_wind_meter(zt,iw) + +!* PRIVATE FUNCTION * + + real, intent(in) :: zt + integer,intent(in) :: iw(2) + integer :: n,m + real :: uh(2),vh(2),wh(2),uh1(2),vh1(2),wh1(2) + real :: dz1w,dz2w + + !********************************************************************** + ! 1.) Bilinear horizontal interpolation + ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3)) + !********************************************************************** + + ! Vertical distance to the level below and above current position + !**************************************************************** + call find_vert_vars(height,zt,indz,dz1w,dz2w,lbounds,.false.) + + ! Loop over 2 time steps and 2 levels + !************************************ + if (ngrid.le.0) then ! No nest + do m=1,2 + do n=1,2 + call hor_interpol(ww,wh1(n),iw(n),memind(m),nzmax) + if (ngrid.lt.0) then + call hor_interpol(uupol,uh1(n),iw(n),memind(m),nzmax) + call hor_interpol(vvpol,vh1(n),iw(n),memind(m),nzmax) + else + call hor_interpol(uu,uh1(n),iw(n),memind(m),nzmax) + call hor_interpol(vv,vh1(n),iw(n),memind(m),nzmax) + endif + end do + call vert_interpol(wh1(1),wh1(2),dz1w,dz2w,wh(m)) + call vert_interpol(uh1(1),uh1(2),dz1w,dz2w,uh(m)) + call vert_interpol(vh1(1),vh1(2),dz1w,dz2w,vh(m)) + end do + else ! Nest + do m=1,2 + do n=1,2 + call hor_interpol_nest(wwn,wh1(n),iw(n),memind(m),nzmax) + call hor_interpol_nest(uun,uh1(n),iw(n),memind(m),nzmax) + call hor_interpol_nest(vvn,vh1(n),iw(n),memind(m),nzmax) + end do + call vert_interpol(wh1(1),wh1(2),dz1w,dz2w,wh(m)) + call vert_interpol(uh1(1),uh1(2),dz1w,dz2w,uh(m)) + call vert_interpol(vh1(1),vh1(2),dz1w,dz2w,vh(m)) + end do + endif + + call temp_interpol(wh(1),wh(2),w) + call temp_interpol(uh(1),uh(2),u) + call temp_interpol(vh(1),vh(2),v) + +end subroutine interpol_wind_meter diff --git a/src/int_interpol_wind_short.f90 b/src/int_interpol_wind_short.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0eb2833e18dc9e3ecc4c4e2ba3f2265b7fc0d402 --- /dev/null +++ b/src/int_interpol_wind_short.f90 @@ -0,0 +1,76 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine interpol_wind_short(itime,xt,yt,zt,zteta) +! i 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: * + ! * + !***************************************************************************** + + integer, intent(in) :: itime + real, intent(in) :: xt,yt,zt,zteta + integer :: iw(2),iuv(2),iweta(2) + + !******************************************** + ! Multilinear interpolation in time and space + !******************************************** + + ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) + !*************************************************************** + call find_ngrid(xt,yt) + call find_grid_indices(xt,yt) + call find_grid_distances(xt,yt) + + ! Calculate variables for time interpolation + !******************************************* + call find_time_vars(itime) + + ! Interpolate over the windfields depending on the prefered + ! coordinate system + !********************************************************** + select case (wind_coord_type) + case ('ETA') + ! Determine the level below the current position for eta coordinates + !******************************************************************* + call find_z_level_eta(zteta) + + iuv(:)=(/ induv, indpuv /) + iweta(:)=(/ indzeta, indzpeta /) + ! Interpolate the u, v, weta windfields + !************************************** + call interpol_wind_eta(zteta,iuv,iweta) + case ('METER') + + ! Determine the level below the current position for u,v + !******************************************************* + call find_z_level_meters(zt) + + iw(:)=(/ indz, indzp /) + call interpol_wind_meter(zt,iw) + case default + write(*,*) 'ERROR: wind_coord_type is not allowed ', wind_coord_type + write(*,*) 'Choose ETA or METER.' + stop + end select + +end subroutine interpol_wind_short diff --git a/src/int_stdev.f90 b/src/int_stdev.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9545ff70ebff5dabe4048d310b6dc5c4d979f413 --- /dev/null +++ b/src/int_stdev.f90 @@ -0,0 +1,19 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine stdev(sl,sq,divisor,output) + + real, intent(in) :: sl,sq,divisor + real, intent(out) :: output + real :: xaux + real,parameter :: eps=1.0e-30 + + xaux= sq - sl*sl/divisor + + if (xaux.lt.eps) then + output=0. + else + output=sqrt(xaux/(divisor-1.)) + endif + +end subroutine stdev diff --git a/src/int_stdev_eta.f90 b/src/int_stdev_eta.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ec66fea14393ba54b9919542ad8113f78c962faa --- /dev/null +++ b/src/int_stdev_eta.f90 @@ -0,0 +1,58 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine stdev_eta(iw,iuv,iweta) + +!* PRIVATE FUNCTION * + + ! Standard deviation of surrounding grid points + ! Only used in mesoscale turbulence calculations + !*********************************************** + + integer,intent(in) :: iw(2),iuv(2),iweta(2) + real :: wsl,wsq,wxaux,usl,usq,uxaux,vsl,vsq,vxaux,wetasl,wetasq,wetaxaux + integer :: n,m + real,parameter :: eps=1.0e-30 + + ! Standard deviations + !******************** + wsl=0. + wsq=0. + usl=0. + usq=0. + vsl=0. + vsq=0. + wetasl=0. + wetasq=0. + + if (ngrid.le.0) then ! No nest + do m=1,2 + do n=1,2 + call compute_sl_sq(ww,wsl,wsq,iw(n),memind(m),nzmax) + call compute_sl_sq(wweta,wetasl,wetasq,iweta(n),memind(m),nzmax) + if (ngrid.lt.0) then + call compute_sl_sq(uupoleta,usl,usq,iuv(n),memind(m),nzmax) + call compute_sl_sq(vvpoleta,vsl,vsq,iuv(n),memind(m),nzmax) + else + call compute_sl_sq(uueta,usl,usq,iuv(n),memind(m),nzmax) + call compute_sl_sq(vveta,vsl,vsq,iuv(n),memind(m),nzmax) + endif + end do + end do + else ! Nest + do m=1,2 + do n=1,2 + call compute_sl_sq_nest(wwn,wsl,wsq,iw(n),memind(m),nzmax) + call compute_sl_sq_nest(wwetan,wetasl,wetasq,iweta(n),memind(m),nzmax) + call compute_sl_sq_nest(uuetan,usl,usq,iuv(n),memind(m),nzmax) + call compute_sl_sq_nest(vvetan,vsl,vsq,iuv(n),memind(m),nzmax) + end do + end do + endif + + call stdev(wsl,wsq,16.,wsig) + call stdev(usl,usq,16.,usig) + call stdev(vsl,vsq,16.,vsig) + call stdev(wetasl,wetasq,16.,wsigeta) + +end subroutine stdev_eta diff --git a/src/int_stdev_meter.f90 b/src/int_stdev_meter.f90 new file mode 100644 index 0000000000000000000000000000000000000000..369d174fd987121da59b2f354bf4b589a12db32c --- /dev/null +++ b/src/int_stdev_meter.f90 @@ -0,0 +1,53 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine stdev_meter(iw) + +!* PRIVATE FUNCTION * + + ! Standard deviation of surrounding grid points + ! Only used in mesoscale turbulence calculations + !*********************************************** + + integer,intent(in) :: iw(2) + real :: wsl,wsq,wxaux,usl,usq,uxaux,vsl,vsq,vxaux + integer :: n,m + real,parameter :: eps=1.0e-30 + + ! Standard deviations + !******************** + wsl=0. + wsq=0. + usl=0. + usq=0. + vsl=0. + vsq=0. + + if (ngrid.le.0) then ! No nest + do m=1,2 + do n=1,2 + call compute_sl_sq(ww,wsl,wsq,iw(n),memind(m),nzmax) + if (ngrid.lt.0) then + call compute_sl_sq(uupol,usl,usq,iw(n),memind(m),nzmax) + call compute_sl_sq(vvpol,vsl,vsq,iw(n),memind(m),nzmax) + else + call compute_sl_sq(uu,usl,usq,iw(n),memind(m),nzmax) + call compute_sl_sq(vv,vsl,vsq,iw(n),memind(m),nzmax) + endif + end do + end do + else ! Nest + do m=1,2 + do n=1,2 + call compute_sl_sq_nest(wwn,wsl,wsq,iw(n),memind(m),nzmax) + call compute_sl_sq_nest(uun,usl,usq,iw(n),memind(m),nzmax) + call compute_sl_sq_nest(vvn,vsl,vsq,iw(n),memind(m),nzmax) + end do + end do + endif + + call stdev(wsl,wsq,16.,wsig) + call stdev(usl,usq,16.,usig) + call stdev(vsl,vsq,16.,vsig) + +end subroutine stdev_meter diff --git a/src/int_temp_interpol.f90 b/src/int_temp_interpol.f90 new file mode 100644 index 0000000000000000000000000000000000000000..270b291610e05faf08d732d03eb0d7d3e262f15f --- /dev/null +++ b/src/int_temp_interpol.f90 @@ -0,0 +1,11 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine temp_interpol(time1,time2,output) + + real, intent(in) :: time1,time2 ! input data at two timesteps + real, intent(inout) :: output ! interpolated data + + output= (time1*dt2 + time2*dt1) * dtt + +end subroutine temp_interpol diff --git a/src/int_vert_interpol.f90 b/src/int_vert_interpol.f90 new file mode 100644 index 0000000000000000000000000000000000000000..de3a8c3f62a1c658f8d5cc4f35b133c99925852c --- /dev/null +++ b/src/int_vert_interpol.f90 @@ -0,0 +1,13 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine vert_interpol(input1,input2,dz1,dz2,output) + + real, intent(in) :: input1,input2 ! input data at two vertical levels, + ! 1 being closer to ground + real, intent(in) :: dz1,dz2 ! logarithmic interpolation values + real, intent(inout) :: output ! interpolated data + + output = input1*dz2 + input2*dz1 ! input1**dz2 * input2**dz1 + +end subroutine vert_interpol diff --git a/src/interpol_mod.f90 b/src/interpol_mod.f90 index 55e35ec2cd3df655e870b0602ffc995028c5d48d..53b1ee26154eec4bf724f23abdeeab489283e820 100644 --- a/src/interpol_mod.f90 +++ b/src/interpol_mod.f90 @@ -39,7 +39,7 @@ module interpol_mod interface hor_interpol procedure hor_interpol_4d,hor_interpol_2d end interface hor_interpol - + interface hor_interpol_nest procedure hor_interpol_4d_nest,hor_interpol_2d_nest end interface hor_interpol_nest @@ -58,1548 +58,96 @@ module interpol_mod contains -subroutine alloc_interpol - ! allocate(uprof(nzmax),vprof(nzmax),wprof(nzmax),wprofeta(nzmax), & - ! usigprof(nzmax),vsigprof(nzmax),wsigprof(nzmax),wsigprofeta(nzmax), & - ! rhoprof(nzmax),rhogradprof(nzmax),indzindicator(nzmax)) -end subroutine alloc_interpol - -subroutine dealloc_interpol - ! deallocate(uprof,vprof,wprof,wprofeta, & - ! usigprof,vsigprof,wsigprof,wsigprofeta, & - ! rhoprof,rhogradprof,indzindicator) -end subroutine dealloc_interpol - -subroutine init_interpol(itime,xt,yt,zt,zteta) - - ! This routine initialises all important values used in the interpol module - ! This includes: - ! - The current grid number in which the particle is positioned - ! - The interpolation fractions of the grid (x,y,z) and of time - - integer, intent(in) :: itime ! time step - real, intent(in) :: xt,yt ! particle positions - real, intent(in) :: zt ! height in meters - real, intent(in) :: zteta ! height in eta coordinates - - call find_ngrid(xt,yt) - call find_grid_indices(xt,yt) - call find_grid_distances(xt,yt) - call find_time_vars(itime) - call find_z_level(zt,zteta) - -end subroutine init_interpol - -subroutine find_grid_indices(xt,yt) - - real, intent(in) :: xt,yt ! particle positions - - 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) - nix=max(min(nint(xtn),nxn(ngrid)-1),0) - njy=max(min(nint(ytn),nyn(ngrid)-1),0) - ix=nix - jy=njy - ixp=ix+1 - jyp=jy+1 - return - else - ix=int(xt) - jy=int(yt) - nix=nint(xt) - njy=nint(yt) - ixp=ix+1 - jyp=jy+1 - endif - - ! eso: Temporary fix for particle exactly at north pole - if (jyp.ge.nymax) then - write(*,*) 'WARNING: interpol_mod.f90 jyp >= nymax. xt,yt:',xt,yt - jyp=jyp-1 - end if - - if (ixp.ge.nxmax) then - write(*,*) 'WARNING: interpol_mod.f90 ixp >= nxmax. xt,yt:',xt,yt - ixp=ixp-nxmax - end if - -end subroutine find_grid_indices - -subroutine find_grid_distances(xt,yt) - - implicit none - - real, intent(in) :: xt,yt ! particle positions - - if (ngrid.le.0) then - ddx=xt-real(ix) - ddy=yt-real(jy) - else - ddx=xtn-real(ix) - ddy=ytn-real(jy) - endif - rddx=1.-ddx - rddy=1.-ddy - p1=rddx*rddy - p2=ddx*rddy - p3=rddx*ddy - p4=ddx*ddy - -end subroutine find_grid_distances - -subroutine find_time_vars(itime) - - integer, intent(in) :: itime ! time step - - dt1=real(itime-memtime(1)) - dt2=real(memtime(2)-itime) - dtt=1./(dt1+dt2) - -end subroutine find_time_vars - -subroutine find_z_level(zt,zteta) - - real, intent(in) :: & - zt, & ! height in meters - zteta ! height in eta - - select case (wind_coord_type) - case('ETA') - call find_z_level_meters(zt) - call find_z_level_eta(zteta) - case('METER') - call find_z_level_meters(zt) - case default - call find_z_level_meters(zt) - end select - -end subroutine find_z_level - -subroutine find_z_level_meters(zt) - - real, intent(in) :: zt ! height in meters - integer :: i - - indz=nz-1 - indzp=nz - if (zt.le.height(1)) then - lbounds(1)=.true. - lbounds(2)=.false. - indz=1 - indzp=2 - else if (zt.ge.height(nz)) then - lbounds(1)=.false. - lbounds(2)=.true. - else - lbounds(1)=.false. - lbounds(2)=.false. - do i=2,nz - if (height(i).gt.zt) then - indz=i-1 - indzp=i - exit - endif - end do - endif - -end subroutine find_z_level_meters - -subroutine find_z_level_eta(zteta) - - real, intent(in) :: zteta ! height in eta coordinates - integer :: i ! loop variable - - call find_z_level_eta_w(zteta) - - call find_z_level_eta_uv(zteta) - -end subroutine find_z_level_eta - -subroutine find_z_level_eta_w(zteta) - - real, intent(in) :: zteta ! height in eta coordinates - integer :: i ! loop variable - - indzeta=nz-1 - indzpeta=nz - ! Flag particles that are above or below bounds - if (zteta.ge.wheight(1)) then - lbounds_w(1)=.true. - lbounds_w(2)=.false. - indzeta=1 - indzpeta=2 - else if (zteta.le.wheight(nz)) then - lbounds_w(1)=.false. - lbounds_w(2)=.true. - else - lbounds_w(1)=.false. - lbounds_w(2)=.false. - do i=2,nz - if (wheight(i).lt.zteta) then - indzeta=i-1 - indzpeta=i - exit - endif - end do - endif - -end subroutine find_z_level_eta_w - -subroutine find_z_level_eta_uv(zteta) - - real, intent(in) :: zteta ! height in eta coordinates - integer :: i ! loop variable - - induv=nz-1 - indpuv=nz - if (zteta.gt.uvheight(1)) then - lbounds_uv(1)=.true. - lbounds_uv(2)=.false. - induv=1 - indpuv=2 - else if (zteta.lt.uvheight(nz)) then - lbounds_uv(1)=.false. - lbounds_uv(2)=.true. - else - lbounds_uv(1)=.false. - lbounds_uv(2)=.false. - do i=2,nz - if (uvheight(i).lt.zteta) then - induv=i-1 - indpuv=i - exit - endif - end do - endif - -end subroutine find_z_level_eta_uv - -subroutine find_vert_vars(vertlevels,zpos,zlevel,dz1,dz2,bounds,wlevel) - - !***************************************************************************** - ! * - ! This subroutine computes the vertical interpolation variables * - ! logarithmically, unless log_interpol=.false. in the par_mod * - ! * - ! Author: L. Bakels * - !***************************************************************************** - - real, intent(in) :: vertlevels(:) ! vertical levels in coordinate system - real, intent(in) :: zpos ! verticle particle position - integer, intent(in) :: zlevel ! vertical level of interest - logical, intent(in) :: bounds(2),wlevel ! flag marking if particles are - ! outside bounds - real, intent(inout) :: dz1,dz2 ! fractional distance to point 1 - ! (closer to ground) and 2 - real :: dz,dh1,dh,pfact - real :: psint1(2),psint,pr1,pr2,pr_test - ! pressure of encompassing levels - integer :: m - - ! Only do logarithmic interpolation when using ETA coordinates, since the - ! levels are following pressure, while METER levels are linear. - !############################################################## - - if (.not. log_interpol) then - call find_vert_vars_lin(vertlevels,zpos,zlevel,dz1,dz2,bounds,wlevel) - return - endif - - ! To check if taking the logarithm is safe - if (wlevel) then - pr_test=akm(zlevel+1)+bkm(zlevel+1) - else - pr_test=akz(zlevel+1)+bkz(zlevel+1) - endif - - ! If the particle is below bounds (bounds(1)==.true.): - if (bounds(1)) then - dz1=0. - dz2=1. - ! If above bounds (bounds(2)==.true.): - else if (bounds(2)) then - dz1=1. - dz2=0. - - ! Instead of the linear z variables, we need the ones that correspond to - ! the pressure of the height of the particle in relation to the model levels - !*************************************************************************** - else if (pr_test.eq.0) then - dz=1./(vertlevels(zlevel+1)-vertlevels(zlevel)) - dz1=(zpos-vertlevels(zlevel))*dz - dz2=(vertlevels(zlevel+1)-zpos)*dz - else - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(ps,psint1(m),1,memind(m),1) - end do - else - do m=1,2 - call hor_interpol_nest(psn,psint1(m),1,memind(m),1) - end do - endif - call temp_interpol(psint1(1),psint1(2),psint) - dh = vertlevels(zlevel+1)-vertlevels(zlevel) - dh1 = zpos - vertlevels(zlevel) - if (wlevel) then - pr1=akm(zlevel) + bkm(zlevel)*psint - pr2=akm(zlevel+1) + bkm(zlevel+1)*psint - else - pr1=akz(zlevel) + bkz(zlevel)*psint - pr2=akz(zlevel+1) + bkz(zlevel+1)*psint - endif - pfact = log(pr2/pr1)*dh1/dh - dz = 1./(pr2-pr1) - dz1 = pr1*(exp(pfact)-1.)*dz - dz2 = 1.-dz1 - endif - ! else if ((vertlevels(zlevel).eq.0).or.(vertlevels(zlevel+1).eq.0)) then - ! ! Linear interpolation for bottom or top layer is zero - ! dz=1./(vertlevels(zlevel+1)-vertlevels(zlevel)) - ! dz1=(zpos-vertlevels(zlevel))*dz - ! dz2=(vertlevels(zlevel+1)-zpos)*dz - ! else - ! ! Logaritmic interpolation - ! dz=1./(log(vertlevels(zlevel+1))-log(vertlevels(zlevel))) - ! dz1=(log(zpos)-log(vertlevels(zlevel)))*dz - ! dz2=(log(vertlevels(zlevel+1))-log(zpos))*dz - ! endif - -end subroutine find_vert_vars - -subroutine find_vert_vars_lin(vertlevels,zpos,zlevel,dz1,dz2,bounds,wlevel) - - real, intent(in) :: vertlevels(:) ! vertical levels in coordinate system - real, intent(in) :: zpos ! verticle particle position - integer, intent(in) :: zlevel ! vertical level of interest - logical, intent(in) :: bounds(2),wlevel! flag marking if particles are outside - ! bounds - real, intent(inout) :: dz1,dz2 ! fractional distance to point 1 - ! (closer to ground) and 2 - real :: dz,dh1,dh,pfact - real :: psint1(2),psint,pr1,pr2,temp ! pressure of encompassing levels - - ! If the particle is below bounds (bounds(1)==.true.): - if (bounds(1)) then - dz1=0. - dz2=1. - ! If above bounds (bounds(2)==.true.): - else if (bounds(2)) then - dz1=1. - dz2=0. - else - dz=1./(vertlevels(zlevel+1)-vertlevels(zlevel)) - dz1=(zpos-vertlevels(zlevel))*dz - dz2=(vertlevels(zlevel+1)-zpos)*dz - endif - -end subroutine find_vert_vars_lin - -subroutine find_ngrid_dp(xt,yt) - - real eps - real(kind=dp), intent(in) :: xt,yt ! particle positions on grid - integer :: j - - eps=nxmax/3.e5 - if (nglobal.and.(real(yt).gt.switchnorthg)) then - ngrid=-1 - else if (sglobal.and.(real(yt).lt.switchsouthg)) then - ngrid=-2 - else - ngrid=0 - ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) - do j=numbnests,1,-1 - if (real(xt).gt.xln(j)+dxn(j) .and. real(xt).lt.xrn(j)-dxn(j) .and. & - real(yt).gt.yln(j)+dyn(j) .and. real(yt).lt.yrn(j)-dyn(j)) then - ngrid=j - exit - endif - end do - endif - -end subroutine find_ngrid_dp +#include "int_alloc_interpol.f90" -subroutine find_ngrid_sp(xt,yt) +#include "int_dealloc_interpol.f90" - real :: eps - real, intent(in) :: xt,yt ! particle positions on grid - integer :: j +#include "int_init_interpol.f90" - eps=nxmax/3.e5 - if (nglobal .and. yt.gt.switchnorthg) then - ngrid=-1 - else if (sglobal .and. yt.lt.switchsouthg) then - ngrid=-2 - else - ngrid=0 - ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) - do j=numbnests,1,-1 - if (xt.gt.xln(j)+dxn(j) .and. xt.lt.xrn(j)-dxn(j) .and. & - yt.gt.yln(j)+dyn(j) .and. yt.lt.yrn(j)-dyn(j)) then - ngrid=j - exit - endif - end do - endif +#include "int_find_grid_indices.f90" -end subroutine find_ngrid_sp +#include "int_find_grid_distances.f90" -subroutine hor_interpol_4d(field,output,zlevel,indexh,ztot) +#include "int_find_time_vars.f90" - integer, intent(in) :: zlevel,ztot,indexh ! interpolation z level, z - real, intent(in) :: field(0:nxmax-1,0:nymax-1,ztot,numwfmem) - ! input field to interpolate - real, intent(inout) :: output ! interpolated values +#include "int_find_z_level.f90" - output=p1*field(ix ,jy ,zlevel,indexh) & - + p2*field(ixp,jy ,zlevel,indexh) & - + p3*field(ix ,jyp,zlevel,indexh) & - + p4*field(ixp,jyp,zlevel,indexh) +#include "int_find_z_level_meters.f90" -end subroutine hor_interpol_4d +#include "int_find_z_level_eta.f90" -subroutine hor_interpol_2d(field,output) +#include "int_find_z_level_eta_w.f90" - real, intent(in) :: field(0:nxmax-1,0:nymax-1) ! 2D imput field - real, intent(inout) :: output ! Interpolated value +#include "int_find_z_level_eta_uv.f90" - output=p1*field(ix ,jy) & - + p2*field(ixp,jy) & - + p3*field(ix ,jyp) & - + p4*field(ixp,jyp) -end subroutine hor_interpol_2d +#include "int_find_vert_vars.f90" -subroutine hor_interpol_4d_nest(field,output,zlevel,indexh,ztot) +#include "int_find_vert_vars_lin.f90" - integer, intent(in) :: zlevel,ztot,indexh ! interpolation z level, z - real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,ztot,numwfmem,numbnests) - ! input field to interpolate - real, intent(inout) :: output ! interpolated values +#include "int_find_ngrid_dp.f90" - output=p1*field(ix ,jy ,zlevel,indexh,ngrid) & - + p2*field(ixp,jy ,zlevel,indexh,ngrid) & - + p3*field(ix ,jyp,zlevel,indexh,ngrid) & - + p4*field(ixp,jyp,zlevel,indexh,ngrid) +#include "int_find_ngrid_sp.f90" -end subroutine hor_interpol_4d_nest +#include "int_hor_interpol_4d.f90" -subroutine hor_interpol_2d_nest(field,output) +#include "int_hor_interpol_2d.f90" - real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,numbnests) - ! input field to interpolate - real, intent(inout) :: output ! interpolated values +#include "int_hor_interpol_4d_nest.f90" - output=p1*field(ix ,jy ,ngrid) & - + p2*field(ixp,jy ,ngrid) & - + p3*field(ix ,jyp,ngrid) & - + p4*field(ixp,jyp,ngrid) +#include "int_hor_interpol_2d_nest.f90" -end subroutine hor_interpol_2d_nest +#include "int_temp_interpol.f90" -subroutine temp_interpol(time1,time2,output) +#include "int_vert_interpol.f90" - real, intent(in) :: time1,time2 ! input data at two timesteps - real, intent(inout) :: output ! interpolated data +#include "int_bilin_spatial_interpol.f90" - output= (time1*dt2 + time2*dt1) * dtt +#include "int_bilin_spatial_interpol_nest.f90" -end subroutine temp_interpol +#include "int_compute_sl_sq.f90" -subroutine vert_interpol(input1,input2,dz1,dz2,output) +#include "int_compute_sl_sq_nest.f90" - real, intent(in) :: input1,input2 ! input data at two vertical levels, - ! 1 being closer to ground - real, intent(in) :: dz1,dz2 ! logarithmic interpolation values - real, intent(inout) :: output ! interpolated data - - output = input1*dz2 + input2*dz1 ! input1**dz2 * input2**dz1 - -end subroutine vert_interpol - -subroutine bilin_spatial_interpol(field,output,zlevel,dz1,dz2,ztot) - - integer, intent(in) :: zlevel,ztot ! interpolation z level - real, intent(in) :: field(0:nxmax-1,0:nymax-1,ztot,numwfmem) - ! input field to interpolate - real, intent(in) :: dz1,dz2 - real, intent(inout) :: output(2) ! interpolated values - integer :: m,n,indzh - real :: output1(2) - - do m=1,2 - - do n=1,2 - indzh=zlevel+n-1 - call hor_interpol_4d(field,output1(n),indzh,memind(m),ztot) - end do - - !********************************** - ! 2.) Linear vertical interpolation on logarithmic scale - !********************************** - - call vert_interpol(output1(1),output1(2),dz1,dz2,output(m)) - - end do - -end subroutine bilin_spatial_interpol - -subroutine bilin_spatial_interpol_nest(field,output,zlevel,dz1,dz2,ztot) - - integer, intent(in) :: zlevel,ztot ! interpolation z level - real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,ztot,numwfmem,numbnests) - ! input field to interpolate - real, intent(in) :: dz1,dz2 - real, intent(inout) :: output(2) ! interpolated values - integer :: m,n,indzh - real :: output1(2) - - do m=1,2 - - do n=1,2 - indzh=zlevel+n-1 - call hor_interpol_4d_nest(field,output1(n),indzh,memind(m),ztot) - end do - - !********************************** - ! 2.) Linear vertical interpolation on logarithmic scale - !********************************** - - call vert_interpol(output1(1),output1(2),dz1,dz2,output(m)) - - end do - -end subroutine bilin_spatial_interpol_nest - -subroutine compute_sl_sq(field,sl,sq,zlevel,indexh,ztot) - - integer, intent(in) :: zlevel,ztot,indexh ! interpolation z levels - real, intent(in) :: field(0:nxmax-1,0:nymax-1,ztot,numwfmem) - ! input field to interpolate - real, intent(inout) :: sl,sq ! standard deviation - - sl=sl+field(ix ,jy ,zlevel,indexh)+field(ixp,jy ,zlevel,indexh) & - +field(ix ,jyp,zlevel,indexh)+field(ixp,jyp,zlevel,indexh) - - sq=sq+field(ix ,jy ,zlevel,indexh)*field(ix ,jy ,zlevel,indexh)+ & - field(ixp,jy ,zlevel,indexh)*field(ixp,jy ,zlevel,indexh)+ & - field(ix ,jyp,zlevel,indexh)*field(ix ,jyp,zlevel,indexh)+ & - field(ixp,jyp,zlevel,indexh)*field(ixp,jyp,zlevel,indexh) - -end subroutine compute_sl_sq - -subroutine compute_sl_sq_nest(field,sl,sq,zlevel,indexh,ztot) - - integer, intent(in) :: zlevel,ztot,indexh ! interpolation z levels - real, intent(in) :: field(0:nxmaxn-1,0:nymaxn-1,ztot,numwfmem,numbnests) - ! input field to interpolate - real, intent(inout) :: sl,sq ! standard deviation - - sl=sl+field(ix ,jy ,zlevel,indexh,ngrid)+field(ixp,jy ,zlevel,indexh,ngrid) & - +field(ix ,jyp,zlevel,indexh,ngrid)+field(ixp,jyp,zlevel,indexh,ngrid) - - sq=sq+field(ix ,jy ,zlevel,indexh,ngrid)*field(ix ,jy ,zlevel,indexh,ngrid)+ & - field(ixp,jy ,zlevel,indexh,ngrid)*field(ixp,jy ,zlevel,indexh,ngrid)+ & - field(ix ,jyp,zlevel,indexh,ngrid)*field(ix ,jyp,zlevel,indexh,ngrid)+ & - field(ixp,jyp,zlevel,indexh,ngrid)*field(ixp,jyp,zlevel,indexh,ngrid) - -end subroutine compute_sl_sq_nest - -subroutine stdev(sl,sq,divisor,output) - - real, intent(in) :: sl,sq,divisor - real, intent(out) :: output - real :: xaux - real,parameter :: eps=1.0e-30 - - xaux= sq - sl*sl/divisor - - if (xaux.lt.eps) then - output=0. - else - output=sqrt(xaux/(divisor-1.)) - endif - -end subroutine stdev +#include "int_stdev.f90" ! Interpolation functions !************************ -subroutine interpol_pbl(itime,xt,yt,zt,zteta) - ! 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 cal- * - ! culation 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 * - ! culated * - ! * - ! Constants: * - ! * - !***************************************************************************** - - use turbulence_mod - - integer, intent(in) :: itime - real, intent(in) :: xt,yt,zt,zteta - integer :: m,n,indexh - integer :: iw(2),iweta(2) - real :: uh1(2),vh1(2),wh1(2),wetah1(2),rho1(2),rhograd1(2) - real :: dz1weta,dz2weta - real,parameter :: eps=1.0e-30 - - ! Auxiliary variables needed for interpolation - real :: ust1(2),wst1(2),oli1(2),oliaux - - !******************************************** - ! Multilinear interpolation in time and space - !******************************************** - - ! ngrid and grid coordinates have already been definded, and are included - ! in the input (for nested: xtn,ytn; for not nested: xts,yts) - - !************************************************************************ - ! Determine the lower left corner and its distance to the current position - !************************************************************************* - - call find_grid_distances(xt,yt) - - ! Calculate variables for time interpolation - !******************************************* - - call find_time_vars(itime) - - !******************************************************** - ! 1. Interpolate u*, w* and Obukhov length for turbulence - !******************************************************** - - ! a) Bilinear horizontal interpolation - if (ngrid.le.0) then ! No nest - do m=1,2 - indexh=memind(m) - call hor_interpol(ustar,ust1(m),1,memind(m),1) - call hor_interpol(wstar,wst1(m),1,memind(m),1) - call hor_interpol(oli,oli1(m),1,memind(m),1) - end do - else ! Nest - do m=1,2 - indexh=memind(m) - call hor_interpol_nest(ustarn,ust1(m),1,memind(m),1) - call hor_interpol_nest(wstarn,wst1(m),1,memind(m),1) - call hor_interpol_nest(olin,oli1(m),1,memind(m),1) - end do - endif +#include "int_interpol_pbl.f90" - ! b) Temporal interpolation - call temp_interpol(ust1(1),ust1(2),ust) - call temp_interpol(wst1(1),wst1(2),wst) - call temp_interpol(oli1(1),oli1(2),oliaux) +#include "int_interpol_pbl_misslev.f90" - if (oliaux.ne.0.) then - ol=1./oliaux - else - ol=99999. - endif +#include "int_interpol_pbl_short.f90" - ! Within the PBL, only METER coordinates are used - ! with the exception of mesoscale turbulence, - ! which uses wsigeta computed in interpol_mesoscale - !************************************************** +#include "int_interpol_mesoscale.f90" - ! Determine the level below the current position - !*********************************************** - call find_z_level_meters(zt) +#include "int_interpol_wind.f90" - iw(:)=(/ indz, indzp /) +#include "int_interpol_wind_short.f90" - ! w(eta) velocities are necessary for the Petterssen correction - !************************************************************** - if (wind_coord_type.eq.'ETA') then - call find_z_level_eta(zteta) - iweta(:)=(/ indzeta, indzpeta /) - endif +#include "int_interpol_partoutput_val.f90" - !************************************** - ! 1.) Bilinear horizontal interpolation - ! 2.) Temporal interpolation (linear) - !************************************** - - ! Loop over 2 time steps and indz levels - !*************************************** - if (ngrid.le.0) then ! No nest - do n=1,2 - do m=1,2 - call hor_interpol(ww,wh1(m),iw(n),memind(m),nzmax) - if (wind_coord_type.eq.'ETA') & - call hor_interpol(wweta,wetah1(m),iweta(n),memind(m),nzmax) - call hor_interpol(rho,rho1(m),iw(n),memind(m),nzmax) - call hor_interpol(drhodz,rhograd1(m),iw(n),memind(m),nzmax) - if (ngrid.lt.0) then - call hor_interpol(uupol,uh1(m),iw(n),memind(m),nzmax) - call hor_interpol(vvpol,vh1(m),iw(n),memind(m),nzmax) - else - call hor_interpol(uu,uh1(m),iw(n),memind(m),nzmax) - call hor_interpol(vv,vh1(m),iw(n),memind(m),nzmax) - endif - end do - call temp_interpol(wh1(1),wh1(2),wprof(iw(n))) - if (wind_coord_type.eq.'ETA') & - call temp_interpol(wetah1(1),wetah1(2),wprofeta(iweta(n))) - call temp_interpol(uh1(1),uh1(2),uprof(iw(n))) - call temp_interpol(vh1(1),vh1(2),vprof(iw(n))) - call temp_interpol(rho1(1),rho1(2),rhoprof(iw(n))) - call temp_interpol(rhograd1(1),rhograd1(2),rhogradprof(iw(n))) - end do - else ! Nest - do n=1,2 - do m=1,2 - call hor_interpol_nest(wwn,wh1(m),iw(n),memind(m),nzmax) - if (wind_coord_type.eq.'ETA') & - call hor_interpol_nest(wwetan,wetah1(m),iweta(n),memind(m),nzmax) - call hor_interpol_nest(uun,uh1(m),iw(n),memind(m),nzmax) - call hor_interpol_nest(vvn,vh1(m),iw(n),memind(m),nzmax) - call hor_interpol_nest(rhon,rho1(m),iw(n),memind(m),nzmax) - call hor_interpol_nest(drhodzn,rhograd1(m),iw(n),memind(m),nzmax) - end do - call temp_interpol(wh1(1),wh1(2),wprof(iw(n))) - if (wind_coord_type.eq.'ETA') & - call temp_interpol(wetah1(1),wetah1(2),wprofeta(iweta(n))) - call temp_interpol(uh1(1),uh1(2),uprof(iw(n))) - call temp_interpol(vh1(1),vh1(2),vprof(iw(n))) - call temp_interpol(rho1(1),rho1(2),rhoprof(iw(n))) - call temp_interpol(rhograd1(1),rhograd1(2),rhogradprof(iw(n))) +#include "int_interpol_htropo_hmix.f90" - indzindicator(iw(n))=.false. - end do - endif - - ! Only necessary for the Petterssen correction - if (wind_coord_type.eq.'ETA') then - call find_vert_vars(wheight,zteta,indzeta, & - dz1weta,dz2weta,lbounds_w,.true.) - call vert_interpol(wprofeta(indzeta),wprofeta(indzpeta), & - dz1weta,dz2weta,weta) - endif - -end subroutine interpol_pbl - -subroutine interpol_pbl_misslev - - !***************************************************************************** - ! * - ! 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 cal- * - ! culation of standard deviation done in this * - ! routine rather than subroutine call in order * - ! to save computation time * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! n level * - ! * - ! Constants: * - ! * - !***************************************************************************** - - real :: uh1(2),vh1(2),wh1(2),rho1(2),rhograd1(2) - integer :: m,n,iw(2) - - ! Within the PBL, only METER coordinates are used - ! with the exception of mesoscale turbulence, - ! which uses wsigeta computed in interpol_mesoscale - !************************************************** - - !******************************************** - ! Multilinear interpolation in time and space - !******************************************** - - iw(:)=(/ indz, indzp /) - do n=1,2 - if (indzindicator(iw(n))) then - if (ngrid.le.0) then ! No nest - do m=1,2 - call hor_interpol(ww,wh1(m),iw(n),memind(m),nzmax) - call hor_interpol(rho,rho1(m),iw(n),memind(m),nzmax) - call hor_interpol(drhodz,rhograd1(m),iw(n),memind(m),nzmax) - if (ngrid.lt.0) then - call hor_interpol(uupol,uh1(m),iw(n),memind(m),nzmax) - call hor_interpol(vvpol,vh1(m),iw(n),memind(m),nzmax) - else - call hor_interpol(uu,uh1(m),iw(n),memind(m),nzmax) - call hor_interpol(vv,vh1(m),iw(n),memind(m),nzmax) - endif - end do - else ! Nest - do m=1,2 - call hor_interpol_nest(wwn,wh1(m),iw(n),memind(m),nzmax) - call hor_interpol_nest(uun,uh1(m),iw(n),memind(m),nzmax) - call hor_interpol_nest(vvn,vh1(m),iw(n),memind(m),nzmax) - call hor_interpol_nest(rhon,rho1(m),iw(n),memind(m),nzmax) - call hor_interpol_nest(drhodzn,rhograd1(m),iw(n),memind(m),nzmax) - end do - endif - call temp_interpol(wh1(1),wh1(2),wprof(iw(n))) - call temp_interpol(uh1(1),uh1(2),uprof(iw(n))) - call temp_interpol(vh1(1),vh1(2),vprof(iw(n))) - call temp_interpol(rho1(1),rho1(2),rhoprof(iw(n))) - call temp_interpol(rhograd1(1),rhograd1(2),rhogradprof(iw(n))) - - indzindicator(iw(n))=.false. - endif - end do - -end subroutine interpol_pbl_misslev - -subroutine interpol_pbl_short(zt,rhoa,rhograd) - - real, intent(in) :: zt - real, intent(inout) :: rhoa,rhograd - real :: dz1,dz2 - - call find_vert_vars(height,zt,indz,dz1,dz2,lbounds,.false.) - - call vert_interpol(wprof(indz),wprof(indzp),dz1,dz2,w) - call vert_interpol(uprof(indz),uprof(indzp),dz1,dz2,u) - call vert_interpol(vprof(indz),vprof(indzp),dz1,dz2,v) - call vert_interpol(rhoprof(indz),rhoprof(indzp),dz1,dz2,rhoa) - call vert_interpol(rhogradprof(indz),rhogradprof(indzp),dz1,dz2,rhograd) - -end subroutine interpol_pbl_short - -subroutine interpol_mesoscale(itime,xt,yt,zt,zteta) - - use turbulence_mod - - integer, intent(in) :: itime - real, intent(in) :: xt,yt,zt,zteta - integer :: iw(2),iuv(2),iweta(2) - integer :: m,indexh - - ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) - !*************************************************************** - call find_ngrid(xt,yt) - - call find_grid_indices(xt,yt) - - ! Determine the level below the current position - !*********************************************** - call find_z_level_meters(zt) - iw(:)=(/ indz, indzp /) - - select case (wind_coord_type) - case ('ETA') - call find_z_level_eta(zteta) - iuv(:)=(/ induv, indpuv /) - iweta(:)=(/ indzeta, indzpeta /) - call stdev_eta(iw,iuv,iweta) - case ('METER') - iw(:)=(/ indz, indzp /) - call stdev_meter(iw) - case default - write(*,*) 'ERROR: wind_coord_type is not allowed ', wind_coord_type - write(*,*) 'Choose ETA or METER.' - stop - end select - -end subroutine interpol_mesoscale - -subroutine interpol_wind(itime,xt,yt,zt,zteta,pp) - ! 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: * - ! * - !***************************************************************************** - - integer, intent(in) :: itime,pp - real, intent(in) :: xt,yt,zt,zteta - integer :: iw(2),iuv(2),iweta(2) - - - ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) - !*************************************************************** - call find_ngrid(xt,yt) - - call find_grid_indices(xt,yt) - ! ! Multilinear interpolation in time and space - ! !******************************************** - - ! Determine the lower left corner and its distance to the current position - !************************************************************************* - call find_grid_distances(xt,yt) - - ! Calculate variables for time interpolation - !******************************************* - call find_time_vars(itime) - - ! Interpolate over the windfields depending on the prefered - ! coordinate system - !********************************************************** - select case (wind_coord_type) - case ('ETA') - ! Same for eta coordinates - !************************* - call find_z_level_eta(zteta) - - iuv(:) = (/ induv, indpuv /) - iweta(:)= (/ indzeta, indzpeta /) - call interpol_wind_eta(zteta,iuv,iweta) - !call stdev_wind_eta(iw,iuv,iweta) - case ('METER') - ! Determine the level below the current position for u,v - !******************************************************* - call find_z_level_meters(zt) - - iw(:)=(/ indz, indzp /) - call interpol_wind_meter(zt,iw) - !call stdev_wind_meter(iw) - - case default - write(*,*) 'ERROR: wind_coord_type is not allowed ', wind_coord_type - write(*,*) 'Choose ETA or METER.' - stop - end select - -end subroutine interpol_wind - -subroutine interpol_wind_short(itime,xt,yt,zt,zteta) -! i 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: * - ! * - !***************************************************************************** - - integer, intent(in) :: itime - real, intent(in) :: xt,yt,zt,zteta - integer :: iw(2),iuv(2),iweta(2) - - !******************************************** - ! Multilinear interpolation in time and space - !******************************************** - - ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) - !*************************************************************** - call find_ngrid(xt,yt) - call find_grid_indices(xt,yt) - call find_grid_distances(xt,yt) - - ! Calculate variables for time interpolation - !******************************************* - call find_time_vars(itime) - - ! Interpolate over the windfields depending on the prefered - ! coordinate system - !********************************************************** - select case (wind_coord_type) - case ('ETA') - ! Determine the level below the current position for eta coordinates - !******************************************************************* - call find_z_level_eta(zteta) - - iuv(:)=(/ induv, indpuv /) - iweta(:)=(/ indzeta, indzpeta /) - ! Interpolate the u, v, weta windfields - !************************************** - call interpol_wind_eta(zteta,iuv,iweta) - case ('METER') - - ! Determine the level below the current position for u,v - !******************************************************* - call find_z_level_meters(zt) - - iw(:)=(/ indz, indzp /) - call interpol_wind_meter(zt,iw) - case default - write(*,*) 'ERROR: wind_coord_type is not allowed ', wind_coord_type - write(*,*) 'Choose ETA or METER.' - stop - end select - -end subroutine interpol_wind_short - -subroutine interpol_partoutput_val(fieldname,output,j) - - integer, intent(in) :: j ! particle number - character(2), intent(in) :: fieldname ! input field to interpolate over - real, intent(inout) :: output - - ! Interpolate over the windfields depending on the prefered - ! coordinate system - !********************************************************** - select case (wind_coord_type) - case ('ETA') - call interpol_partoutput_val_eta(fieldname,output,j) - case ('METER') - call interpol_partoutput_val_meter(fieldname,output,j) - case default - call interpol_partoutput_val_meter(fieldname,output,j) - end select - -end subroutine interpol_partoutput_val - -subroutine interpol_htropo_hmix(tropop,h) - - real, intent(inout) :: tropop ! height of troposphere - real, intent(inout) :: h ! mixing height - real :: h1(2) ! mixing height of 2 timesteps - integer :: mind ! windfield index - integer :: i,j,k,m ! loop variables - - h=0. - if (ngrid.le.0) then - if (interpolhmix) then - do m=1,2 - call hor_interpol(hmix,h1(m),1,memind(m),1) - end do - else - do k=1,2 - mind=memind(k) ! eso: compatibility with 3-field version - do j=jy,jyp - do i=ix,ixp - if (hmix(i,j,1,mind).gt.h) h=hmix(i,j,1,mind) - end do - end do - end do - endif - tropop=tropopause(nix,njy,1,memind(1)) - else - do k=1,2 - mind=memind(k) - do j=jy,jyp - do i=ix,ixp - if (hmixn(i,j,1,mind,ngrid).gt.h) h=hmixn(i,j,1,mind,ngrid) - end do - end do - end do - tropop=tropopausen(nix,njy,1,memind(1),ngrid) - endif - - if (interpolhmix) h= (h1(1)*dt2 + h1(2)*dt1)*dtt - -end subroutine interpol_htropo_hmix - -subroutine interpol_density(itime,ipart,output) - - integer, intent(in) :: itime,ipart ! time and particle index - real, intent(inout) :: output ! output density (rhoi) - integer :: ind - real :: dz1,dz2,rhoprof(2) - - ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) - !*************************************************************** - call find_ngrid(part(ipart)%xlon,part(ipart)%ylat) - call find_grid_indices(real(part(ipart)%xlon),real(part(ipart)%ylat)) - call find_grid_distances(real(part(ipart)%xlon),real(part(ipart)%ylat)) - call find_time_vars(itime) - - ! Take density from 2nd wind field in memory - !(accurate enough, no time interpolation needed) - !*********************************************** - - select case (wind_coord_type) - case ('ETA') - call find_z_level_eta(real(part(ipart)%zeta)) - call find_vert_vars(uvheight,real(part(ipart)%zeta),induv, & - dz1,dz2,lbounds_uv,.false.) - if (ngrid.le.0) then - do ind=induv,indpuv - call hor_interpol(rhoeta,rhoprof(ind-induv+1),ind,memind(2),nzmax) - end do - else - do ind=induv,indpuv - call hor_interpol_nest(rhoetan,rhoprof(ind-induv+1),ind,memind(2), & - nzmax) - end do - endif - case ('METER') - call find_z_level_meters(real(part(ipart)%z)) - call find_vert_vars(height,real(part(ipart)%z),indz, & - dz1,dz2,lbounds,.false.) - if (ngrid.le.0) then - do ind=indz,indzp - call hor_interpol(rho,rhoprof(ind-indz+1),ind,memind(2),nzmax) - end do - else - do ind=indz,indzp - call hor_interpol_nest(rhon,rhoprof(ind-indz+1),ind,memind(2),nzmax) - end do - endif - case default - stop 'wind_coord_type not defined in conccalc.f90' - end select - - call vert_interpol(rhoprof(1),rhoprof(2),dz1,dz2,output) - -end subroutine interpol_density +#include "int_interpol_density.f90" !********************* !* PRIVATE FUNCTIONS * !********************* ! Interpolation of wind fields !***************************** -subroutine interpol_wind_eta(zteta,iuv,iweta) - -!* PRIVATE FUNCTION * - - real, intent(in) :: zteta - integer,intent(in) :: iuv(2),iweta(2) - integer :: n,m - real :: uh(2),vh(2),wetah(2),uh1(2),vh1(2),wetah1(2) - real :: dz1uv,dz2uv,dz1weta,dz2weta - - !********************************************************************** - ! 1.) Bilinear horizontal interpolation - ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3)) - !********************************************************************** - - ! Vertical distance to the level below and above current position - !**************************************************************** - call find_vert_vars(uvheight,zteta,induv,dz1uv,dz2uv,lbounds_uv,.false.) - call find_vert_vars(wheight,zteta,indzeta,dz1weta,dz2weta,lbounds_w,.true.) - - ! Loop over 2 time steps and 2 levels - !************************************ - if (ngrid.le.0) then ! No nest - do m=1,2 - do n=1,2 - call hor_interpol(wweta,wetah1(n),iweta(n),memind(m),nzmax) - if (ngrid.lt.0) then - call hor_interpol(uupoleta,uh1(n),iuv(n),memind(m),nzmax) - call hor_interpol(vvpoleta,vh1(n),iuv(n),memind(m),nzmax) - else - call hor_interpol(uueta,uh1(n),iuv(n),memind(m),nzmax) - call hor_interpol(vveta,vh1(n),iuv(n),memind(m),nzmax) - endif - end do - call vert_interpol(uh1(1),uh1(2),dz1uv,dz2uv,uh(m)) - call vert_interpol(vh1(1),vh1(2),dz1uv,dz2uv,vh(m)) - call vert_interpol(wetah1(1),wetah1(2),dz1weta,dz2weta,wetah(m)) - end do - else ! Nest - do m=1,2 - do n=1,2 - - ! wetah1(n) = p1*wwetan(ix ,jy ,iweta(n),memind(m),ngrid) & - ! + p2*wwetan(ixp,jy ,iweta(n),memind(m),ngrid) & - ! + p3*wwetan(ix ,jyp,iweta(n),memind(m),ngrid) & - ! + p4*wwetan(ixp,jyp,iweta(n),memind(m),ngrid) - call hor_interpol_nest(wwetan,wetah1(n),iweta(n),memind(m),nzmax) - call hor_interpol_nest(uuetan,uh1(n),iuv(n),memind(m),nzmax) - call hor_interpol_nest(vvetan,vh1(n),iuv(n),memind(m),nzmax) - end do - call vert_interpol(uh1(1),uh1(2),dz1uv,dz2uv,uh(m)) - call vert_interpol(vh1(1),vh1(2),dz1uv,dz2uv,vh(m)) - call vert_interpol(wetah1(1),wetah1(2),dz1weta,dz2weta,wetah(m)) - end do - endif - - call temp_interpol(uh(1),uh(2),u) - call temp_interpol(vh(1),vh(2),v) - call temp_interpol(wetah(1),wetah(2),weta) - -end subroutine interpol_wind_eta - -subroutine interpol_wind_meter(zt,iw) - -!* PRIVATE FUNCTION * - - real, intent(in) :: zt - integer,intent(in) :: iw(2) - integer :: n,m - real :: uh(2),vh(2),wh(2),uh1(2),vh1(2),wh1(2) - real :: dz1w,dz2w - - !********************************************************************** - ! 1.) Bilinear horizontal interpolation - ! This has to be done separately for 6 fields (Temporal(2)*Vertical(3)) - !********************************************************************** - - ! Vertical distance to the level below and above current position - !**************************************************************** - call find_vert_vars(height,zt,indz,dz1w,dz2w,lbounds,.false.) - - ! Loop over 2 time steps and 2 levels - !************************************ - if (ngrid.le.0) then ! No nest - do m=1,2 - do n=1,2 - call hor_interpol(ww,wh1(n),iw(n),memind(m),nzmax) - if (ngrid.lt.0) then - call hor_interpol(uupol,uh1(n),iw(n),memind(m),nzmax) - call hor_interpol(vvpol,vh1(n),iw(n),memind(m),nzmax) - else - call hor_interpol(uu,uh1(n),iw(n),memind(m),nzmax) - call hor_interpol(vv,vh1(n),iw(n),memind(m),nzmax) - endif - end do - call vert_interpol(wh1(1),wh1(2),dz1w,dz2w,wh(m)) - call vert_interpol(uh1(1),uh1(2),dz1w,dz2w,uh(m)) - call vert_interpol(vh1(1),vh1(2),dz1w,dz2w,vh(m)) - end do - else ! Nest - do m=1,2 - do n=1,2 - call hor_interpol_nest(wwn,wh1(n),iw(n),memind(m),nzmax) - call hor_interpol_nest(uun,uh1(n),iw(n),memind(m),nzmax) - call hor_interpol_nest(vvn,vh1(n),iw(n),memind(m),nzmax) - end do - call vert_interpol(wh1(1),wh1(2),dz1w,dz2w,wh(m)) - call vert_interpol(uh1(1),uh1(2),dz1w,dz2w,uh(m)) - call vert_interpol(vh1(1),vh1(2),dz1w,dz2w,vh(m)) - end do - endif - - call temp_interpol(wh(1),wh(2),w) - call temp_interpol(uh(1),uh(2),u) - call temp_interpol(vh(1),vh(2),v) - -end subroutine interpol_wind_meter - -subroutine interpol_partoutput_val_eta(fieldname,output,j) - -!* PRIVATE FUNCTION * - - integer, intent(in) :: j ! particle number - character(2), intent(in) :: fieldname ! input field to interpolate over - real, intent(inout) :: output - real :: field1(2) - - if (int(dz1out).eq.-1) then - call find_z_level_eta(real(part(j)%zeta)) - call find_vert_vars(uvheight,real(part(j)%zeta),induv,dz1out,dz2out, & - lbounds_uv,.false.) - endif - - select case(fieldname) - case('PR','pr') - if (ngrid.le.0) then - call bilin_spatial_interpol(prseta,field1,induv,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(prsetan,field1,induv,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('PV','pv') - if (ngrid.le.0) then - call bilin_spatial_interpol(pveta,field1,induv,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(pvetan,field1,induv,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('QV','qv') - if (ngrid.le.0) then - call bilin_spatial_interpol(qv,field1,induv,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(qvn,field1,induv,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('TT','tt') - if (ngrid.le.0) then - call bilin_spatial_interpol(tteta,field1,induv,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(ttetan,field1,induv,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('UU','uu') - if (ngrid.le.0) then - call bilin_spatial_interpol(uueta,field1,induv,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(uuetan,field1,induv,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('VV','vv') - if (ngrid.le.0) then - call bilin_spatial_interpol(vveta,field1,induv,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(vvetan,field1,induv,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('WW','ww') - call find_z_level_meters(real(part(j)%z)) - call find_vert_vars(height,real(part(j)%z),indz,dz1out,dz2out,lbounds,.false.) - if (ngrid.le.0) then - call bilin_spatial_interpol(ww,field1,induv,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(wwn,field1,induv,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - dz1out = -1 - case('RH','rh') - if (ngrid.le.0) then - call bilin_spatial_interpol(rhoeta,field1,induv,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(rhoetan,field1,induv,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - end select - -end subroutine interpol_partoutput_val_eta - -subroutine interpol_partoutput_val_meter(fieldname,output,j) - -!* PRIVATE FUNCTION * - - integer, intent(in) :: j ! particle number - character(2), intent(in) :: fieldname ! input field to interpolate over - real, intent(inout) :: output - real :: field1(2) - - if (int(dz1out).eq.-1) then - call find_z_level_meters(real(part(j)%z)) - call find_vert_vars(height,real(part(j)%z),indz,dz1out,dz2out,lbounds,.false.) - endif - - select case(fieldname) - case('PR','pr') - if (ngrid.le.0) then - call bilin_spatial_interpol(prs,field1,indz,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(prsn,field1,indz,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('PV','pv') - if (ngrid.le.0) then - call bilin_spatial_interpol(pv,field1,indz,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(pvn,field1,indz,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('QV','qv') - if (ngrid.le.0) then - call bilin_spatial_interpol(qv,field1,indz,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(qvn,field1,indz,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('TT','tt') - if (ngrid.le.0) then - call bilin_spatial_interpol(tt,field1,indz,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(ttn,field1,indz,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('UU','uu') - if (ngrid.le.0) then - call bilin_spatial_interpol(uu,field1,indz,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(uun,field1,indz,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('VV','vv') - if (ngrid.le.0) then - call bilin_spatial_interpol(vv,field1,indz,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(vvn,field1,indz,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('WW','ww') - if (ngrid.le.0) then - call bilin_spatial_interpol(ww,field1,indz,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(wwn,field1,indz,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - case('RH','rh') - if (ngrid.le.0) then - call bilin_spatial_interpol(rho,field1,indz,dz1out,dz2out,nzmax) - else - call bilin_spatial_interpol_nest(rhon,field1,indz,dz1out,dz2out,nzmax) - endif - call temp_interpol(field1(1),field1(2),output) - end select - -end subroutine interpol_partoutput_val_meter - -subroutine interpol_mixinglayer_eta(zt,zteta,rhoa,rhograd) - - real, intent(in) :: zt,zteta - real, intent(inout) :: rhoa,rhograd - real :: dz1w,dz2w,dz1uv,dz2uv,dz1weta,dz2weta - - call find_vert_vars(height,zt,indz,dz1w,dz2w,lbounds,.false.) - call find_vert_vars(uvheight,zteta,induv,dz1uv,dz2uv,lbounds_uv,.false.) - call find_vert_vars(wheight,zteta,indzeta,dz1weta,dz2weta,lbounds_w,.true.) - - call vert_interpol(wprof(indz),wprof(indzp),dz1w,dz2w,w) - call vert_interpol(uprof(induv),uprof(indpuv),dz1uv,dz2uv,u) - call vert_interpol(vprof(induv),vprof(indpuv),dz1uv,dz2uv,v) - call vert_interpol(rhoprof(induv),rhoprof(indpuv),dz1uv,dz2uv,rhoa) - call vert_interpol(rhogradprof(induv),rhogradprof(indpuv),dz1uv,dz2uv,rhograd) - call vert_interpol(wprofeta(indzeta),wprofeta(indzpeta),dz1weta,dz2weta,weta) - -end subroutine interpol_mixinglayer_eta - -subroutine stdev_eta(iw,iuv,iweta) - -!* PRIVATE FUNCTION * - - ! Standard deviation of surrounding grid points - ! Only used in mesoscale turbulence calculations - !*********************************************** - - integer,intent(in) :: iw(2),iuv(2),iweta(2) - real :: wsl,wsq,wxaux,usl,usq,uxaux,vsl,vsq,vxaux,wetasl,wetasq,wetaxaux - integer :: n,m - real,parameter :: eps=1.0e-30 - - ! Standard deviations - !******************** - wsl=0. - wsq=0. - usl=0. - usq=0. - vsl=0. - vsq=0. - wetasl=0. - wetasq=0. - - if (ngrid.le.0) then ! No nest - do m=1,2 - do n=1,2 - call compute_sl_sq(ww,wsl,wsq,iw(n),memind(m),nzmax) - call compute_sl_sq(wweta,wetasl,wetasq,iweta(n),memind(m),nzmax) - if (ngrid.lt.0) then - call compute_sl_sq(uupoleta,usl,usq,iuv(n),memind(m),nzmax) - call compute_sl_sq(vvpoleta,vsl,vsq,iuv(n),memind(m),nzmax) - else - call compute_sl_sq(uueta,usl,usq,iuv(n),memind(m),nzmax) - call compute_sl_sq(vveta,vsl,vsq,iuv(n),memind(m),nzmax) - endif - end do - end do - else ! Nest - do m=1,2 - do n=1,2 - call compute_sl_sq_nest(wwn,wsl,wsq,iw(n),memind(m),nzmax) - call compute_sl_sq_nest(wwetan,wetasl,wetasq,iweta(n),memind(m),nzmax) - call compute_sl_sq_nest(uuetan,usl,usq,iuv(n),memind(m),nzmax) - call compute_sl_sq_nest(vvetan,vsl,vsq,iuv(n),memind(m),nzmax) - end do - end do - endif - - call stdev(wsl,wsq,16.,wsig) - call stdev(usl,usq,16.,usig) - call stdev(vsl,vsq,16.,vsig) - call stdev(wetasl,wetasq,16.,wsigeta) - -end subroutine stdev_eta - -subroutine stdev_meter(iw) - -!* PRIVATE FUNCTION * +#include "int_interpol_wind_eta.f90" - ! Standard deviation of surrounding grid points - ! Only used in mesoscale turbulence calculations - !*********************************************** +#include "int_interpol_wind_meter.f90" - integer,intent(in) :: iw(2) - real :: wsl,wsq,wxaux,usl,usq,uxaux,vsl,vsq,vxaux - integer :: n,m - real,parameter :: eps=1.0e-30 +#include "int_interpol_partoutput_val_eta.f90" - ! Standard deviations - !******************** - wsl=0. - wsq=0. - usl=0. - usq=0. - vsl=0. - vsq=0. +#include "int_interpol_partoutput_val_meter.f90" - if (ngrid.le.0) then ! No nest - do m=1,2 - do n=1,2 - call compute_sl_sq(ww,wsl,wsq,iw(n),memind(m),nzmax) - if (ngrid.lt.0) then - call compute_sl_sq(uupol,usl,usq,iw(n),memind(m),nzmax) - call compute_sl_sq(vvpol,vsl,vsq,iw(n),memind(m),nzmax) - else - call compute_sl_sq(uu,usl,usq,iw(n),memind(m),nzmax) - call compute_sl_sq(vv,vsl,vsq,iw(n),memind(m),nzmax) - endif - end do - end do - else ! Nest - do m=1,2 - do n=1,2 - call compute_sl_sq_nest(wwn,wsl,wsq,iw(n),memind(m),nzmax) - call compute_sl_sq_nest(uun,usl,usq,iw(n),memind(m),nzmax) - call compute_sl_sq_nest(vvn,vsl,vsq,iw(n),memind(m),nzmax) - end do - end do - endif +#include "int_interpol_mixinglayer_eta.f90" - call stdev(wsl,wsq,16.,wsig) - call stdev(usl,usq,16.,usig) - call stdev(vsl,vsq,16.,vsig) +#include "int_stdev_eta.f90" -end subroutine stdev_meter +#include "int_stdev_meter.f90" end module interpol_mod diff --git a/src/mea_mean_dp.f90 b/src/mea_mean_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6471b5578791c128e00536a4fc11f42fed647849 --- /dev/null +++ b/src/mea_mean_dp.f90 @@ -0,0 +1,54 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine mean_dp(x_dp,xm,xs,number) + +!***************************************************************************** +! * +! This subroutine calculates mean and standard deviation of a given element.* +! * +! AUTHOR: Andreas Stohl, 25 January 1994 * +! * +! Double precision version ESO 2016 * +!***************************************************************************** +! * +! Variables: * +! x_dp(number) field of input data * +! xm mean * +! xs standard deviation * +! number number of elements of field x_dp * +! * +! Constants: * +! eps tiny number * +! * +!***************************************************************************** + + use par_mod, only: dp + + implicit none + + integer,intent(in) :: number + real(dp), intent(in) :: x_dp(number) + real(dp), intent(out) ::xm,xs + real(dp) :: xl,xq,xaux + real(dp),parameter :: eps=1.0e-30 + integer :: i + + xl=0._dp + xq=0._dp + do i=1,number + xl=xl+x_dp(i) + xq=xq+x_dp(i)*x_dp(i) + end do + + xm=xl/real(number,kind=dp) + + xaux=xq-xl*xl/real(number,kind=dp) + + if (xaux.lt.eps) then + xs=0._dp + else + xs=sqrt(xaux/real(number-1,kind=dp)) + endif + + end subroutine mean_dp diff --git a/src/mea_mean_mixed_dsd.f90 b/src/mea_mean_mixed_dsd.f90 new file mode 100644 index 0000000000000000000000000000000000000000..04b65e630d53def7fb095bda15025efa82daa4cd --- /dev/null +++ b/src/mea_mean_mixed_dsd.f90 @@ -0,0 +1,55 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine mean_mixed_dsd(x_dp,xm,xs_dp,number) + +!***************************************************************************** +! * +! This subroutine calculates mean and standard deviation of a given element.* +! * +! AUTHOR: Andreas Stohl, 25 January 1994 * +! * +! Mixed precision version ESO 2016 (dp in, sp out, dp out) * +!***************************************************************************** +! * +! Variables: * +! x_dp(number) field of input data * +! xm mean * +! xs_dp standard deviation * +! number number of elements of field x_dp * +! * +! Constants: * +! eps tiny number * +! * +!***************************************************************************** + + use par_mod, only: sp,dp + + implicit none + + integer,intent(in) :: number + real(dp), intent(in) :: x_dp(number) + real(sp), intent(out) ::xm + real(dp), intent(out) ::xs_dp + real(dp) :: xl,xq,xaux + real(dp),parameter :: eps=1.0e-30_dp + integer :: i + + xl=0._dp + xq=0._dp + do i=1,number + xl=xl+x_dp(i) + xq=xq+x_dp(i)*x_dp(i) + end do + + xm=real(xl,kind=sp)/real(number,kind=sp) + + xaux=xq-xl*xl/real(number,kind=dp) + + if (xaux.lt.eps) then + xs_dp=0._dp + else + xs_dp=sqrt(xaux/real(number-1,kind=dp)) + endif + + end subroutine mean_mixed_dsd diff --git a/src/mea_mean_mixed_dss.f90 b/src/mea_mean_mixed_dss.f90 new file mode 100644 index 0000000000000000000000000000000000000000..534fa71ca16f1232494abe342400824d2374fb32 --- /dev/null +++ b/src/mea_mean_mixed_dss.f90 @@ -0,0 +1,54 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine mean_mixed_dss(x_dp,xm,xs,number) + +!***************************************************************************** +! * +! This subroutine calculates mean and standard deviation of a given element.* +! * +! AUTHOR: Andreas Stohl, 25 January 1994 * +! * +! Mixed precision version ESO 2016 (dp in, sp out, sp out) * +!***************************************************************************** +! * +! Variables: * +! x_dp(number) field of input data * +! xm mean * +! xs standard deviation * +! number number of elements of field x_dp * +! * +! Constants: * +! eps tiny number * +! * +!***************************************************************************** + + use par_mod, only: sp,dp + + implicit none + + integer,intent(in) :: number + real(dp), intent(in) :: x_dp(number) + real(sp), intent(out) ::xm,xs + real(sp) :: xl,xq,xaux + real(sp),parameter :: eps=1.0e-30 + integer :: i + + xl=0._sp + xq=0._sp + do i=1,number + xl=xl+real(x_dp(i),kind=sp) + xq=xq+real(x_dp(i),kind=sp)*real(x_dp(i),kind=sp) + end do + + xm=xl/real(number,kind=sp) + + xaux=xq-xl*xl/real(number,kind=sp) + + if (xaux.lt.eps) then + xs=0._sp + else + xs=sqrt(xaux/real(number-1,kind=sp)) + endif + + end subroutine mean_mixed_dss diff --git a/src/mea_mean_sp.f90 b/src/mea_mean_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fdc3f7b92bef9d36c06636f17d1283ddf385c849 --- /dev/null +++ b/src/mea_mean_sp.f90 @@ -0,0 +1,58 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine mean_sp(x_sp,xm,xs,number) + +!***************************************************************************** +! * +! This subroutine calculates mean and standard deviation of a given element.* +! * +! AUTHOR: Andreas Stohl, 25 January 1994 * +! * +! Single precision version ESO 2016 * +!***************************************************************************** +! * +! Variables: * +! x_sp(number) field of input data * +! xm mean * +! xs standard deviation * +! number number of elements of field x_sp * +! * +! Constants: * +! eps tiny number * +! * +!***************************************************************************** + + use par_mod, only: sp + + implicit none + + ! integer :: number,i + ! real(sp) :: x_sp(number),xm,xs,xl,xq,xaux + ! real(sp),parameter :: eps=1.0e-30 + + integer,intent(in) :: number + real(sp), intent(in) :: x_sp(number) + real(sp), intent(out) ::xm,xs + real(sp) :: xl,xq,xaux + real(sp),parameter :: eps=1.0e-30 + integer :: i + + xl=0. + xq=0. + do i=1,number + xl=xl+x_sp(i) + xq=xq+x_sp(i)*x_sp(i) + end do + + xm=xl/real(number,kind=sp) + + xaux=xq-xl*xl/real(number,kind=sp) + + if (xaux.lt.eps) then + xs=0. + else + xs=sqrt(xaux/real(number-1,kind=sp)) + endif + + end subroutine mean_sp diff --git a/src/mean_mod.f90 b/src/mean_mod.f90 index c231f4669a82315a4978acf24191c58990bf6b3e..c8b247ec34e5107e393fcb2354c6f2d16b0fe619 100644 --- a/src/mean_mod.f90 +++ b/src/mean_mod.f90 @@ -17,217 +17,12 @@ module mean_mod contains - subroutine mean_sp(x_sp,xm,xs,number) +#include "mea_mean_sp.f90" -!***************************************************************************** -! * -! This subroutine calculates mean and standard deviation of a given element.* -! * -! AUTHOR: Andreas Stohl, 25 January 1994 * -! * -! Single precision version ESO 2016 * -!***************************************************************************** -! * -! Variables: * -! x_sp(number) field of input data * -! xm mean * -! xs standard deviation * -! number number of elements of field x_sp * -! * -! Constants: * -! eps tiny number * -! * -!***************************************************************************** +#include "mea_mean_dp.f90" - use par_mod, only: sp +#include "mea_mean_mixed_dss.f90" - implicit none - - ! integer :: number,i - ! real(sp) :: x_sp(number),xm,xs,xl,xq,xaux - ! real(sp),parameter :: eps=1.0e-30 - - integer,intent(in) :: number - real(sp), intent(in) :: x_sp(number) - real(sp), intent(out) ::xm,xs - real(sp) :: xl,xq,xaux - real(sp),parameter :: eps=1.0e-30 - integer :: i - - xl=0. - xq=0. - do i=1,number - xl=xl+x_sp(i) - xq=xq+x_sp(i)*x_sp(i) - end do - - xm=xl/real(number,kind=sp) - - xaux=xq-xl*xl/real(number,kind=sp) - - if (xaux.lt.eps) then - xs=0. - else - xs=sqrt(xaux/real(number-1,kind=sp)) - endif - - end subroutine mean_sp - - subroutine mean_dp(x_dp,xm,xs,number) - -!***************************************************************************** -! * -! This subroutine calculates mean and standard deviation of a given element.* -! * -! AUTHOR: Andreas Stohl, 25 January 1994 * -! * -! Double precision version ESO 2016 * -!***************************************************************************** -! * -! Variables: * -! x_dp(number) field of input data * -! xm mean * -! xs standard deviation * -! number number of elements of field x_dp * -! * -! Constants: * -! eps tiny number * -! * -!***************************************************************************** - - use par_mod, only: dp - - implicit none - - integer,intent(in) :: number - real(dp), intent(in) :: x_dp(number) - real(dp), intent(out) ::xm,xs - real(dp) :: xl,xq,xaux - real(dp),parameter :: eps=1.0e-30 - integer :: i - - xl=0._dp - xq=0._dp - do i=1,number - xl=xl+x_dp(i) - xq=xq+x_dp(i)*x_dp(i) - end do - - xm=xl/real(number,kind=dp) - - xaux=xq-xl*xl/real(number,kind=dp) - - if (xaux.lt.eps) then - xs=0._dp - else - xs=sqrt(xaux/real(number-1,kind=dp)) - endif - - end subroutine mean_dp - - subroutine mean_mixed_dss(x_dp,xm,xs,number) - -!***************************************************************************** -! * -! This subroutine calculates mean and standard deviation of a given element.* -! * -! AUTHOR: Andreas Stohl, 25 January 1994 * -! * -! Mixed precision version ESO 2016 (dp in, sp out, sp out) * -!***************************************************************************** -! * -! Variables: * -! x_dp(number) field of input data * -! xm mean * -! xs standard deviation * -! number number of elements of field x_dp * -! * -! Constants: * -! eps tiny number * -! * -!***************************************************************************** - - use par_mod, only: sp,dp - - implicit none - - integer,intent(in) :: number - real(dp), intent(in) :: x_dp(number) - real(sp), intent(out) ::xm,xs - real(sp) :: xl,xq,xaux - real(sp),parameter :: eps=1.0e-30 - integer :: i - - xl=0._sp - xq=0._sp - do i=1,number - xl=xl+real(x_dp(i),kind=sp) - xq=xq+real(x_dp(i),kind=sp)*real(x_dp(i),kind=sp) - end do - - xm=xl/real(number,kind=sp) - - xaux=xq-xl*xl/real(number,kind=sp) - - if (xaux.lt.eps) then - xs=0._sp - else - xs=sqrt(xaux/real(number-1,kind=sp)) - endif - - end subroutine mean_mixed_dss - - subroutine mean_mixed_dsd(x_dp,xm,xs_dp,number) - -!***************************************************************************** -! * -! This subroutine calculates mean and standard deviation of a given element.* -! * -! AUTHOR: Andreas Stohl, 25 January 1994 * -! * -! Mixed precision version ESO 2016 (dp in, sp out, dp out) * -!***************************************************************************** -! * -! Variables: * -! x_dp(number) field of input data * -! xm mean * -! xs_dp standard deviation * -! number number of elements of field x_dp * -! * -! Constants: * -! eps tiny number * -! * -!***************************************************************************** - - use par_mod, only: sp,dp - - implicit none - - integer,intent(in) :: number - real(dp), intent(in) :: x_dp(number) - real(sp), intent(out) ::xm - real(dp), intent(out) ::xs_dp - real(dp) :: xl,xq,xaux - real(dp),parameter :: eps=1.0e-30_dp - integer :: i - - xl=0._dp - xq=0._dp - do i=1,number - xl=xl+x_dp(i) - xq=xq+x_dp(i)*x_dp(i) - end do - - xm=real(xl,kind=sp)/real(number,kind=sp) - - xaux=xq-xl*xl/real(number,kind=dp) - - if (xaux.lt.eps) then - xs_dp=0._dp - else - xs_dp=sqrt(xaux/real(number-1,kind=dp)) - endif - - end subroutine mean_mixed_dsd +#include "mea_mean_mixed_dsd.f90" end module mean_mod diff --git a/src/net_close_partoutput_file.f90 b/src/net_close_partoutput_file.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5ebb11e9e9ade5b18c6a6760c5512125dbb4b9b0 --- /dev/null +++ b/src/net_close_partoutput_file.f90 @@ -0,0 +1,11 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine close_partoutput_file(ncid) + + implicit none + + integer :: ncid + + call nf90_err(nf90_close(ncid)) +end subroutine close_partoutput_file diff --git a/src/net_concoutput_ncf.f90 b/src/net_concoutput_ncf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7e685384efaef406828b66ff0e92e3dedc02885a --- /dev/null +++ b/src/net_concoutput_ncf.f90 @@ -0,0 +1,409 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput_ncf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) + + ! i i o o + ! o + !***************************************************************************** + ! * + ! 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 module 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 * + ! * + ! February 2010, Dominik Brunner, Empa * + ! Adapted for COSMO * + ! Remark: calculation of density could be improved. * + ! Currently, it is calculated for the lower left corner * + ! of each output grid cell rather than for its center. * + ! Furthermore, the average density could be calculated * + ! from the difference in pressure at the top and bottom * + ! of each cell rather than by interpolation. * + ! * + ! April 2013, Dominik Brunner, Empa * + ! Adapted for netcdf output * + ! * + ! 2022, Lucie Bakels: * + ! - OpenMP parallelisation * + ! - Receptor output to NetCDF instead of binary format * + ! * + !***************************************************************************** + ! * + ! 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, only: gridunc,drygridunc,wetgridunc,drygridunc0,wetgridunc0 + + implicit none + + integer, intent(in) :: itime + real, intent(in) :: outnum + real(dep_prec),intent(out):: wetgridtotalunc,drygridtotalunc + real, intent(out) :: gridtotalunc + real :: densityoutrecept(maxreceptor),recout(maxreceptor) + integer :: ncid,kp,ks,kz,ix,jy,iix,jjy,kzz,kzzm1,ngrid + integer :: nage,i,l,jj + real :: tot_mu(maxspec,maxpointspec_act) + real :: halfheight,dz,dz1,dz2 + real :: xl,yl,xlrot,ylrot,zagnd,zagndprev + real(dep_prec) :: auxgrid(nclassunc) + real(dep_prec) :: gridtotal,gridsigmatotal + real(dep_prec) :: wetgridtotal,wetgridsigmatotal + real(dep_prec) :: drygridtotal,drygridsigmatotal + ! real(sp) :: gridtotal,gridsigmatotal + ! real(sp) :: wetgridtotal,wetgridsigmatotal + ! real(sp) :: drygridtotal,drygridsigmatotal + + real, parameter :: weightair=28.97 + + eps=nxmax/3.e5 + + ! open output file + call nf90_err(nf90_open(trim(ncfname), nf90_write, ncid)) + + ! write time + tpointer = tpointer + 1 + call nf90_err(nf90_put_var( ncid, timeID, itime, (/ tpointer /))) + + ! 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.0 + 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 + + + gridtotal=0. + gridsigmatotal=0. + gridtotalunc=0. + wetgridtotal=0._dep_prec + wetgridsigmatotal=0._dep_prec + wetgridtotalunc=0._dep_prec + drygridtotal=0._dep_prec + drygridsigmatotal=0._dep_prec + drygridtotalunc=0._dep_prec + + !******************************************************************* + ! Compute air density: + ! brd134: we now take into account whether we are in the mother or in + ! a nested domain (before only from mother domain) + ! Determine center altitude of output layer, and interpolate density + ! data to that altitude + !******************************************************************* +!$OMP PARALLEL PRIVATE(halfheight,kzz,dz1,dz2,dz,xl,yl,ngrid,iix,jjy, & +!$OMP kz,ix,jy,l,ks,kp,nage,auxgrid) REDUCTION(+:wetgridtotal,wetgridsigmatotal, & +!$OMP drygridtotal,drygridsigmatotal,gridtotal,gridsigmatotal) +!$OMP DO + 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)) exit + end do + 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 + ! grid index in mother domain + xl=(xl-xlon0)/dx + yl=(yl-ylat0)/dx + + ngrid=0 + do jj=numbnests,1,-1 + if ( xl.gt.xln(jj)+eps .and. xl.lt.xrn(jj)-eps .and. & + yl.gt.yln(jj)+eps .and. yl.lt.yrn(jj)-eps ) then + ngrid=jj + exit + end if + end do + + if (ngrid.eq.0) then + iix=max(min(nint(xl),nxmin1),0) ! if output grid cell is outside mother domain + jjy=max(min(nint(yl),nymin1),0) + + densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,memind(2))*dz1+ & + rho(iix,jjy,kzz-1,memind(2))*dz2)/dz + else + xl=(xl-xln(ngrid))*xresoln(ngrid) + yl=(yl-yln(ngrid))*yresoln(ngrid) + iix=max(min(nint(xl),nxn(ngrid)-1),0) + jjy=max(min(nint(yl),nyn(ngrid)-1),0) + + densityoutgrid(ix,jy,kz)=(rhon(iix,jjy,kzz,memind(2), ngrid)*dz1+ & + rhon(iix,jjy,kzz-1,memind(2), ngrid)*dz2)/dz + endif + end do + end do + end do +!$OMP END DO NOWAIT + + ! brd134: for receptor points no option for nests yet to specify density + ! and also altitude zreceptor not considered yet (needs revision) + if (numreceptor.gt.0) then +!$OMP 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,memind(2)) + end do +!$OMP END DO NOWAIT + endif + + ! Output is different for forward and backward simulations + if (ldirect.eq.1) then +!$OMP DO + do kz=1,numzgrid + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum + end do + end do + end do +!$OMP END DO + else +!$OMP DO + do kz=1,numzgrid + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + factor3d(ix,jy,kz)=real(abs(loutaver))/outnum + end do + end do + end do +!$OMP END DO + endif + + !********************************************************************* + ! 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 + + do kp=1,maxpointspec_act + do nage=1,nageclass +!$OMP DO + do jy=0,numygrid-1 + do ix=0,numxgrid-1 + + ! WET DEPOSITION + if ((wetdep).and.(ldirect.gt.0)) then + if (mpi_mode.gt.0) then + do l=1,nclassunc + auxgrid(l)=wetgridunc0(ix,jy,ks,kp,l,nage) + end do + else + do l=1,nclassunc + auxgrid(l)=wetgridunc(ix,jy,ks,kp,l,nage) + end do + end if + 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)*real(nclassunc,kind=sp) + wetgridtotal=wetgridtotal+wetgrid(ix,jy) + ! Calculate standard deviation of the mean + wetgridsigma(ix,jy)= & + wetgridsigma(ix,jy)* & + sqrt(real(nclassunc,kind=dep_prec)) + wetgridsigmatotal=wetgridsigmatotal+ & + wetgridsigma(ix,jy) + endif + + ! DRY DEPOSITION + if ((drydep).and.(ldirect.gt.0)) then + if (mpi_mode.gt.0) then + do l=1,nclassunc + auxgrid(l)=drygridunc0(ix,jy,ks,kp,l,nage) + end do + else + do l=1,nclassunc + auxgrid(l)=drygridunc(ix,jy,ks,kp,l,nage) + end do + end if + 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)*real(nclassunc,kind=sp) + drygridtotal=drygridtotal+drygrid(ix,jy) + ! Calculate standard deviation of the mean + drygridsigma(ix,jy)= & + drygridsigma(ix,jy)* & + sqrt(real(nclassunc, kind=dep_prec)) + 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)*real(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 +!$OMP END DO + ! print*,gridtotal,maxpointspec_act + + !******************************************************************* + ! 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 + !******************************************************************* + + ! Concentration output + !********************* +!$OMP SINGLE + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + + ! Wet deposition + if ((ldirect.eq.1).and.(WETDEP)) then + call nf90_err(nf90_put_var(ncid,wdspecID(ks),1.e12*& + wetgrid(0:numxgrid-1,0:numygrid-1)/area(0:numxgrid-1,0:numygrid-1),& + (/ 1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,1,1,1 /))) + end if + + ! Dry deposition + if ((ldirect.eq.1).and.(DRYDEP)) then + call nf90_err(nf90_put_var(ncid,ddspecID(ks),1.e12*& + drygrid(0:numxgrid-1,0:numygrid-1)/area(0:numxgrid-1,0:numygrid-1),& + (/ 1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,1,1,1 /))) + endif + + ! Concentrations + call nf90_err(nf90_put_var(ncid,specID(ks),grid(0:numxgrid-1,0:numygrid-1,& + 1:numzgrid)*factor3d(0:numxgrid-1,0:numygrid-1,1:numzgrid)/tot_mu(ks,kp),& + (/ 1,1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,numzgrid,1,1,1 /) )) + + endif ! concentration output + + ! Mixing ratio output + !******************** + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + + ! Wet deposition + if ((ldirect.eq.1).and.(WETDEP)) then + call nf90_err(nf90_put_var(ncid,wdspecID(ks),1.e12*& + wetgrid(0:numxgrid-1,0:numygrid-1)/area(0:numxgrid-1,0:numygrid-1),& + (/ 1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,1,1,1 /))) + + endif + + ! Dry deposition + if ((ldirect.eq.1).and.(DRYDEP)) then + call nf90_err(nf90_put_var(ncid,ddspecID(ks),1.e12*& + drygrid(0:numxgrid-1,0:numygrid-1)/area(0:numxgrid-1,0:numygrid-1),& + (/ 1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,1,1,1 /))) + endif + + ! Mixing ratios + call nf90_err(nf90_put_var(ncid,specIDppt(ks),weightair/weightmolar(ks)*& + grid(0:numxgrid-1,0:numygrid-1,1:numzgrid)*& + factor3d(0:numxgrid-1,0:numygrid-1,1:numzgrid)/& + densityoutgrid(0:numxgrid-1,0:numygrid-1,1:numzgrid),& + (/ 1,1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,numzgrid,1,1,1 /))) + + endif ! output for ppt +!$OMP END SINGLE +!$OMP BARRIER + end do + end do + + end do +!$OMP END PARALLEL + + if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal + if (wetgridtotal.gt.0.) wetgridtotalunc=wetgridsigmatotal/ & + wetgridtotal + if (drygridtotal.gt.0.) drygridtotalunc=real(drygridsigmatotal/ & + drygridtotal, kind=dep_prec) + + ! Dump of receptor concentrations + + if (numreceptor.ge.1) then + if (iout.eq.2 .or. iout.eq.3) then + do ks=1,nspec + recout(:)=1.e12*creceptor(:,ks)/outnum*weightair/weightmolar(ks)/densityoutrecept(:) + call nf90_err(nf90_put_var(ncid,recpptvID(ks),recout(1:numreceptor),(/ tpointer,1 /),(/ 1,numreceptor /))) + end do + endif + + ! Dump of receptor concentrations + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + do ks=1,nspec + recout(:)=1.e12*creceptor(:,ks)/outnum + call nf90_err(nf90_put_var(ncid,recconcID(ks),recout(1:numreceptor),(/ tpointer,1 /),(/ 1,numreceptor /))) + end do + endif + endif + + ! Close netCDF file + !************************** + call nf90_err(nf90_close(ncid)) + + ! Reinitialization of grid + !************************* + if (numreceptor.gt.0) creceptor(1:numreceptor,1:nspec) = 0. + gridunc(:,:,:,1:nspec,:,:,1:nageclass) = 0. +end subroutine concoutput_ncf diff --git a/src/net_concoutput_ncf_nest.f90 b/src/net_concoutput_ncf_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8ace4c49a33f6b39e0bb51080b9308c192e29dfc --- /dev/null +++ b/src/net_concoutput_ncf_nest.f90 @@ -0,0 +1,334 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput_ncf_nest(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 module 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 * + ! * + ! 19 February 2010, Dominik Brunner, Empa: Adapted for COSMO * + ! * + ! April 2013, Dominik Brunner, Empa * + ! Adapted for netcdf output * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! itime current simulation time * + ! outnum number of samples * + ! * + !***************************************************************************** + + use unc_mod, only: griduncn,drygriduncn,wetgriduncn,drygriduncn0,wetgriduncn0 + + implicit none + + integer, intent(in) :: itime + real, intent(in) :: outnum + real :: densityoutrecept(maxreceptor) + integer :: ncid,kp,ks,kz,ix,jy,iix,jjy,kzz,kzzm1,ngrid + integer :: nage,i,l, jj + real :: tot_mu(maxspec,maxpointspec_act) + real :: halfheight,dz,dz1,dz2 + real :: xl,yl,xlrot,ylrot,zagnd,zagndprev + real(dep_prec) :: auxgrid(nclassunc) + real :: gridtotal + real, parameter :: weightair=28.97 + + eps=nxmax/3.e5 + + ! open output file + call nf90_err(nf90_open(trim(ncfnamen), nf90_write, ncid)) + + ! write time (do not increase time counter here, done in main output domain) + call nf90_err(nf90_put_var( ncid, timeID, itime, (/ tpointer /))) + + ! 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.0 + 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 + + gridtotal=0. + !******************************************************************* + ! Compute air density: + ! brd134: we now take into account whether we are in the mother or in + ! a nested domain (before only from mother domain) + ! Determine center altitude of output layer, and interpolate density + ! data to that altitude + !******************************************************************* +!$OMP PARALLEL PRIVATE(halfheight,kzz,dz1,dz2,dz,xl,yl,ngrid,iix,jjy, & +!$OMP kz,ix,jy,l,ks,kp,nage,auxgrid) REDUCTION(+:gridtotal) +!$OMP DO + 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)) exit + end do + 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=outlon0n+real(ix)*dxoutn + yl=outlat0n+real(jy)*dyoutn + xl=(xl-xlon0)/dx + yl=(yl-ylat0)/dy + + ngrid=0 + do jj=numbnests,1,-1 + if ( xl.gt.xln(jj)+eps .and. xl.lt.xrn(jj)-eps .and. & + yl.gt.yln(jj)+eps .and. yl.lt.yrn(jj)-eps ) then + ngrid=jj + exit + end if + end do + + if (ngrid.eq.0) then + iix=max(min(nint(xl),nxmin1),0) + jjy=max(min(nint(yl),nymin1),0) + + densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,memind(2))*dz1+ & + rho(iix,jjy,kzz-1,memind(2))*dz2)/dz + else + xl=(xl-xln(ngrid))*xresoln(ngrid) + yl=(yl-yln(ngrid))*yresoln(ngrid) + iix=max(min(nint(xl),nxn(ngrid)-1),0) + jjy=max(min(nint(yl),nyn(ngrid)-1),0) + densityoutgrid(ix,jy,kz)=(rhon(iix,jjy,kzz,memind(2), ngrid)*dz1+ & + rhon(iix,jjy,kzz-1,memind(2), ngrid)*dz2)/dz + endif + + end do + end do + end do +!$OMP END DO NOWAIT + + if (numreceptor.gt.0) then +!$OMP 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,memind(2)) + end do +!$OMP END DO NOWAIT + endif + + ! Output is different for forward and backward simulations + if (ldirect.eq.1) then +!$OMP DO + do kz=1,numzgrid + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + factor3d(ix,jy,kz)=1.e12/volumen(ix,jy,kz)/outnum + end do + end do + end do +!$OMP END DO + else +!$OMP DO + do kz=1,numzgrid + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + factor3d(ix,jy,kz)=real(abs(loutaver))/outnum + end do + end do + end do +!$OMP END DO + endif + + !********************************************************************* + ! 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 + + do kp=1,maxpointspec_act + do nage=1,nageclass +!$OMP DO + do jy=0,numygridn-1 + do ix=0,numxgridn-1 + ! WET DEPOSITION + if ((WETDEP).and.(ldirect.gt.0)) then + if (mpi_mode.gt.0) then + do l=1,nclassunc + auxgrid(l)=wetgriduncn0(ix,jy,ks,kp,l,nage) + end do + else + do l=1,nclassunc + auxgrid(l)=wetgriduncn(ix,jy,ks,kp,l,nage) + end do + end if + 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)*real(nclassunc) + ! Calculate standard deviation of the mean + wetgridsigma(ix,jy)= & + wetgridsigma(ix,jy)* & + sqrt(real(nclassunc,kind=dep_prec)) + endif + + ! DRY DEPOSITION + if ((DRYDEP).and.(ldirect.gt.0)) then + if (mpi_mode.gt.0) then + do l=1,nclassunc + auxgrid(l)=drygriduncn0(ix,jy,ks,kp,l,nage) + end do + else + do l=1,nclassunc + auxgrid(l)=drygriduncn(ix,jy,ks,kp,l,nage) + end do + end if + 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)*real(nclassunc) + ! Calculate standard deviation of the mean + drygridsigma(ix,jy)= & + drygridsigma(ix,jy)* & + sqrt(real(nclassunc,kind=dep_prec)) + 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)*real(nclassunc) + gridtotal=gridtotal+grid(ix,jy,kz) + ! Calculate standard deviation of the mean + gridsigma(ix,jy,kz)= & + gridsigma(ix,jy,kz)* & + sqrt(real(nclassunc)) + end do + end do + end do +!$OMP END DO + ! print*,gridtotal,maxpointspec_act + + !******************************************************************* + ! 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 + !******************************************************************* + + ! Concentration output + !********************* +!$OMP SINGLE + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + + ! Wet deposition + if ((ldirect.eq.1).and.(WETDEP)) then + call nf90_err(nf90_put_var(ncid,wdspecIDn(ks),1.e12*& + wetgrid(0:numxgridn-1,0:numygridn-1)/arean(0:numxgridn-1,0:numygridn-1),& + (/ 1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,1,1,1 /))) + endif + + ! Dry deposition + if ((ldirect.eq.1).and.(DRYDEP)) then + call nf90_err(nf90_put_var(ncid,ddspecIDn(ks),1.e12*& + drygrid(0:numxgridn-1,0:numygridn-1)/arean(0:numxgridn-1,0:numygridn-1),& + (/ 1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,1,1,1 /))) + endif + + ! Concentrations + call nf90_err(nf90_put_var(ncid,specIDn(ks),grid(0:numxgridn-1,0:numygridn-1,& + 1:numzgrid)*factor3d(0:numxgridn-1,0:numygridn-1,1:numzgrid)/tot_mu(ks,kp),& + (/ 1,1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,numzgrid,1,1,1 /))) + + endif ! concentration output + + ! Mixing ratio output + !******************** + + if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio + + ! Wet deposition + if ((ldirect.eq.1).and.(WETDEP)) then + call nf90_err(nf90_put_var(ncid,wdspecIDn(ks),1.e12*& + wetgrid(0:numxgridn-1,0:numygridn-1)/arean(0:numxgridn-1,0:numygridn-1),& + (/ 1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,1,1,1 /))) + endif + + ! Dry deposition + if ((ldirect.eq.1).and.(DRYDEP)) then + call nf90_err(nf90_put_var(ncid,ddspecIDn(ks),1.e12*& + drygrid(0:numxgridn-1,0:numygridn-1)/arean(0:numxgridn-1,0:numygridn-1),& + (/ 1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,1,1,1 /))) + endif + + ! Mixing ratios + call nf90_err(nf90_put_var(ncid,specIDnppt(ks),weightair/weightmolar(ks)*& + grid(0:numxgridn-1,0:numygridn-1,1:numzgrid)*& + factor3d(0:numxgridn-1,0:numygridn-1,1:numzgrid)/& + densityoutgrid(0:numxgridn-1,0:numygridn-1,1:numzgrid),& + (/ 1,1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,numzgrid,1,1,1 /))) + + endif ! output for ppt +!$OMP END SINGLE +!$OMP BARRIER + end do + end do + + end do +!$OMP END PARALLEL + ! Close netCDF file + !************************** + call nf90_err(nf90_close(ncid)) + + ! Reinitialization of grid + !************************* + + if (numreceptor.gt.0) creceptor(1:numreceptor,1:nspec) = 0. + griduncn(:,:,:,1:nspec,:,:,1:nageclass) = 0. +end subroutine concoutput_ncf_nest diff --git a/src/net_concoutput_sfc_ncf.f90 b/src/net_concoutput_sfc_ncf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0707d5294f9e03b379802e70dfec3f7256d62e14 --- /dev/null +++ b/src/net_concoutput_sfc_ncf.f90 @@ -0,0 +1,16 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput_sfc_ncf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) + + use unc_mod, only: gridunc,drygridunc,wetgridunc,drygridunc0,wetgridunc0 + + implicit none + + integer, intent(in) :: itime + real, intent(in) :: outnum + real(sp), intent(out) :: gridtotalunc + real(dep_prec), intent(out) :: wetgridtotalunc,drygridtotalunc + + print*,'Netcdf output for surface only not yet implemented' +end subroutine concoutput_sfc_ncf diff --git a/src/net_concoutput_sfc_ncf_nest.f90 b/src/net_concoutput_sfc_ncf_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3be79faccb56b4f16895a2888d3654b006e114d6 --- /dev/null +++ b/src/net_concoutput_sfc_ncf_nest.f90 @@ -0,0 +1,12 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine concoutput_sfc_ncf_nest(itime,outnum) + + implicit none + + integer, intent(in) :: itime + real, intent(in) :: outnum + + print*,'Netcdf output for surface only not yet implemented' +end subroutine concoutput_sfc_ncf_nest diff --git a/src/net_nf90_err.f90 b/src/net_nf90_err.f90 new file mode 100644 index 0000000000000000000000000000000000000000..47bfa8347166be6fe51ead54ec4207634901bd78 --- /dev/null +++ b/src/net_nf90_err.f90 @@ -0,0 +1,14 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine nf90_err(status) + !**************************************************************** + ! netcdf error message handling + !**************************************************************** + implicit none + integer, intent (in) :: status + if(status /= nf90_noerr) then + print *, trim(nf90_strerror(status)) + stop 'Stopped' + end if +end subroutine nf90_err diff --git a/src/net_open_partinit_file.f90 b/src/net_open_partinit_file.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c466fd613c523ad2f63efe860341ce70ddc7a0ba --- /dev/null +++ b/src/net_open_partinit_file.f90 @@ -0,0 +1,12 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine open_partinit_file(ncid)!,irelease) + + implicit none + + integer, intent(inout) :: ncid + !integer, intent(in) :: irelease + + call nf90_err(nf90_open(trim(ncfname_partinit), nf90_write, ncid)) +end subroutine open_partinit_file diff --git a/src/net_open_partoutput_file.f90 b/src/net_open_partoutput_file.f90 new file mode 100644 index 0000000000000000000000000000000000000000..45f5395e83b82359c44f0824786677435daee82c --- /dev/null +++ b/src/net_open_partoutput_file.f90 @@ -0,0 +1,12 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine open_partoutput_file(ncid)!,irelease) + + implicit none + + integer, intent(inout) :: ncid + !integer, intent(in) :: irelease + + call nf90_err(nf90_open(trim(ncfname_part), nf90_write, ncid)) +end subroutine open_partoutput_file diff --git a/src/net_output_units.f90 b/src/net_output_units.f90 new file mode 100644 index 0000000000000000000000000000000000000000..60f7488bc0e96abb2ef5838864350665485f1d4e --- /dev/null +++ b/src/net_output_units.f90 @@ -0,0 +1,38 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine output_units(units) + implicit none + character(len=15), intent(out) :: units + if (ldirect.eq.1) then + ! forward simulation + if (ind_source.eq.1) then + if (ind_receptor.eq.1) then + units = 'ng m-3' ! hes the kg in Tab1 is only indicating the units of the relase not the output + else + units = 'ng kg-1' + endif + else + if (ind_receptor.eq.1) then + units = 'ng m-3' + else + units = 'ng kg-1' + endif + endif + else + ! backward simulation + if (ind_source.eq.1) then + if (ind_receptor.eq.1) then + units = 's' + else + units = 's m3 kg-1' + endif + else + if (ind_receptor.eq.1) then + units = 's kg m-3' + else + units = 's' + endif + endif + endif +end subroutine output_units diff --git a/src/net_particle_initialpos.f90 b/src/net_particle_initialpos.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d51106aa4ac3c46bcdc19d426b033c9fd08abafe --- /dev/null +++ b/src/net_particle_initialpos.f90 @@ -0,0 +1,140 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine particle_initialpos(itime,idate,itime_start,idate_start) + + !***************************************************************************** + ! * + ! This subroutine creates an initial particle positions and properties * + ! NetCDF file: partinit_xxx.nc * + ! The release time, release number and positions, together with all fields * + ! specified in the PARTOPTIONS option file will saved. * + ! * + ! Author: L. Bakels 2022 * + ! * + !***************************************************************************** + + implicit none + + integer, intent(in) :: itime,idate,itime_start,idate_start + ! integer, intent(in) :: irelease + integer :: cache_size,ncid,j,totpart,np + integer :: partDimID + character(len=11) :: fprefix + character(len=3) :: anspec,arelease + character :: adate*8,atime*6,adate_start*8,atime_start*6,timeunit*32 + character(len=255) :: fname_partoutput + real :: fillval + + write(adate,'(i8.8)') idate + write(atime,'(i6.6)') itime + write(adate_start,'(i8.8)') idate_start + write(atime_start,'(i6.6)') itime_start + ! write(arelease, '(i3.3)') irelease + fprefix = 'partinit_'!rel'//arelease//'_' + + fname_partoutput = path(2)(1:length(2))//trim(fprefix)//adate//atime//'.nc' + !ncfname_part(irelease) = fname_partoutput + ncfname_partinit = fname_partoutput + + call nf90_err(nf90_create(trim(fname_partoutput), cmode = nf90_hdf5, ncid = ncid))!, & + ! cache_size = cache_size)) + + ! create dimensions: + !************************* + + ! particle + partinitpointer=0 + call nf90_err(nf90_def_dim(ncid, 'particle', nf90_unlimited, partDimID)) + + ! create variables + !************************* + + ! particles + call nf90_err(nf90_def_var(ncid, 'particle', nf90_int, (/ partDimID/), partIDi)) + call nf90_err(nf90_put_att(ncid, partIDi, 'long_name', 'particle index')) + + fillval = -1. + ! time + timeunit = 'seconds since '//adate_start(1:4)//'-'//adate_start(5:6)// & + '-'//adate_start(7:8)//' '//atime_start(1:2)//':'//atime_start(3:4) + + call write_to_file(ncid,'time',nf90_int,(/ partDimID /),tIDi,(/ 1 /), & + timeunit,.false.,'time','time of release') + call nf90_err(nf90_put_att(ncid, tIDi, 'axis', 't')) + call nf90_err(nf90_put_att(ncid, tIDi, 'calendar', 'proleptic_gregorian')) + call nf90_err(nf90_put_att(ncid, tIDi, 'description', 'time of release')) + + ! lon + call write_to_file(ncid,'longitude',nf90_float,(/ partDimID /),lonIDi,(/ 1 /), & + 'degrees_east',.false.,'longitude','longitude in degree east') + call nf90_err(nf90_put_att(ncid, lonIDi, 'axis', 'Lon')) + call nf90_err(nf90_put_att(ncid, lonIDi, 'description', 'longitude of particles')) + + ! lat + call write_to_file(ncid,'latitude',nf90_float,(/ partDimID /),latIDi,(/ 1 /), & + 'degrees_north',.false.,'latitude','latitude in degree north') + call nf90_err(nf90_put_att(ncid, latIDi, 'axis', 'Lat')) + call nf90_err(nf90_put_att(ncid, latIDi, 'description', 'latitude of particles')) + + ! height + call write_to_file(ncid,'height',nf90_float,(/ partDimID /),levIDi,(/ 1 /), & + 'meters',.true.,'height','height above ground') + + ! release + call write_to_file(ncid,'release',nf90_int,(/ partDimID /),relIDi,(/ 1 /), & + '',.true.,'release','particle release') + + do np=1,num_partopt + if (.not. partopt(np)%print) cycle + select case(partopt(np)%name) + case ('PV') ! Potential vorticity + call write_to_file(ncid,'pv',nf90_float,(/ partDimID /),pvIDi,(/ 1 /), & + 'pvu',.false.,'potential_vorticity','potential vorticity') + case ('PR') ! Pressure + call write_to_file(ncid,'pr',nf90_float,(/ partDimID /),prIDi,(/ 1 /), & + 'Pa',.false.,'pressure','pressure') + case ('QV') ! Specific humidity + call write_to_file(ncid,'qv',nf90_float,(/ partDimID /),qvIDi,(/ 1 /), & + '',.false.,'specific_humidity','specific humidity') + case ('RH') ! Density + call write_to_file(ncid,'rho',nf90_float,(/ partDimID /),rhoIDi,(/ 1 /), & + 'kg/m3',.true.,'density','density') + case ('TT') ! Temperature + call write_to_file(ncid,'temperature',nf90_float,(/ partDimID /),ttIDi,(/ 1 /), & + 'K',.true.,'temperature','temperature') + case ('UU') + call write_to_file(ncid,'u',nf90_float,(/ partDimID /),uIDi,(/ 1 /), & + 'm/s',.false.,'u','longitudinal velocity') + case ('VV') + call write_to_file(ncid,'v',nf90_float,(/ partDimID /),vIDi,(/ 1 /), & + 'm/s',.false.,'v','latitudinal velocity') + case ('WW') + call write_to_file(ncid,'w',nf90_float,(/ partDimID /),wIDi,(/ 1 /), & + 'm/s',.false.,'w','vertical velocity') + case ('MA') + do j=1,nspec + ! Masses + write(anspec, '(i3.3)') j + call write_to_file(ncid,'mass'//anspec,nf90_float,(/ partDimID /),massIDi(j), & + (/ 1 /),'kg',.true.,'mass'//anspec,'mass for nspec'//anspec) + end do + case ('TO') + call write_to_file(ncid,'topo',nf90_float,(/ partDimID /),topoIDi,(/ 1 /), & + 'meters',.false.,'topography','topography above sealevel') + case ('TR') + call write_to_file(ncid,'tr',nf90_float,(/ partDimID /),trIDi,(/ 1 /), & + 'meters',.true.,'htropo','height above ground of tropopause') + case ('HM') ! Mixing layer height + call write_to_file(ncid,'hmix',nf90_float,(/ partDimID /),hmixIDi,(/ 1 /), & + 'meters',.true.,'hmix','height above ground of mixing layer') + case default + cycle + end select + end do + + ! moves the file from define to data mode + call nf90_err(nf90_enddef(ncid)) + + call nf90_err(nf90_close(ncid)) +end subroutine particle_initialpos diff --git a/src/net_partinit_ncf.f90 b/src/net_partinit_ncf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7c31761c89f18cd8a0bdf2ae06296db2bee61e49 --- /dev/null +++ b/src/net_partinit_ncf.f90 @@ -0,0 +1,66 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine partinit_ncf(itime,field,fieldname,imass,ncid) + + !***************************************************************************** + ! * + ! This subroutine saves properties chosen by the user in PARTOPTIONS * + ! to a NetCDF file created in particle_initialpos. * + ! This happens whenever a new particle is spawned. * + ! * + ! Author: L. Bakels 2022 * + ! * + !***************************************************************************** + + implicit none + + integer, intent(in) :: itime,imass + real, intent(in) :: field(:) + character(2), intent(in) :: fieldname ! input field to interpolate over + integer, allocatable :: partindices(:) + integer :: ncid,newpart,j,iend + + newpart = partinitpointer - (partinitpointer1-1) + + select case(fieldname) + case('TO') ! Topography + call nf90_err(nf90_put_var(ncid,topoIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('PV') ! Potential vorticity + call nf90_err(nf90_put_var(ncid,pvIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('PR') ! Pressure + call nf90_err(nf90_put_var(ncid,prIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('QV') ! Specific humidity + call nf90_err(nf90_put_var(ncid,qvIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('RH') ! Air density + call nf90_err(nf90_put_var(ncid,rhoIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('UU') ! Longitudinal velocity + call nf90_err(nf90_put_var(ncid,uIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('VV') ! Latitudinal velocity + call nf90_err(nf90_put_var(ncid,vIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('WW') ! Vertical velocity + call nf90_err(nf90_put_var(ncid,wIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('TT') ! Temperature + call nf90_err(nf90_put_var(ncid,ttIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('MA') ! Mass + call nf90_err(nf90_put_var(ncid,massIDi(imass),field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('TR') ! Tropopause + call nf90_err(nf90_put_var(ncid,trIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case('HM') ! Mixing height + call nf90_err(nf90_put_var(ncid,hmixIDi,field(partinitpointer1:partinitpointer), & + (/ partinitpointer1 /),(/ newpart /))) + case default + return + end select +end subroutine partinit_ncf diff --git a/src/net_partoutput_ncf.f90 b/src/net_partoutput_ncf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..19a5b54c876c65b0ae15bc5be258adabb693b7d8 --- /dev/null +++ b/src/net_partoutput_ncf.f90 @@ -0,0 +1,156 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine partoutput_ncf(itime,field,fieldname,imass,ncid) + + + !***************************************************************************** + ! * + ! Writing a field from PARTOPTIONS to partoutput_xxx.nc created in * + ! writeheader_partoutput * + ! * + ! Author: L. Bakels 2021 * + ! * + !***************************************************************************** + + implicit none + + integer, intent(in) :: itime,imass + real, intent(in) :: field(:) + character(2), intent(in) :: fieldname ! input field to interpolate over + integer, allocatable :: partindices(:) + integer :: ncid,newpart,j + ! ! open output file + ! call nf90_err(nf90_open(trim(ncfname_part), nf90_write, ncid)) + select case(fieldname) + case('TI') + ! write time + tpointer_part = tpointer_part + 1 + call nf90_err(nf90_put_var(ncid, timeIDpart, itime, (/ tpointer_part /))) + case('PA') + newpart = numpart - ppointer_part + + if (tpointer_part.eq.1) then + allocate ( partindices(numpart) ) + do j=1,numpart + partindices(j)=j + end do + + call nf90_err(nf90_put_var(ncid, partID,partindices, (/ 1 /),(/ numpart /))) + + deallocate (partindices) + + ppointer_part = numpart + + else if (newpart.ge.0) then + + allocate ( partindices(newpart) ) + do j=1,newpart + partindices(j)=j+ppointer_part + end do + + call nf90_err(nf90_put_var(ncid, partID,partindices, (/ ppointer_part+1 /),(/ newpart /))) + + deallocate (partindices) + + ppointer_part = numpart + endif + case('LO') ! Longitude + call nf90_err(nf90_put_var(ncid,lonIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('lo') ! Longitude averaged + call nf90_err(nf90_put_var(ncid,lonavIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('LA') ! Latitude + call nf90_err(nf90_put_var(ncid,latIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('la') ! Latitude averaged + call nf90_err(nf90_put_var(ncid,latavIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('ZZ') ! Height + call nf90_err(nf90_put_var(ncid,levIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('zz') ! Height averaged + call nf90_err(nf90_put_var(ncid,levavIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('IT') ! Itramem (not in use atm) + call nf90_err(nf90_put_var(ncid,itramemID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('TO') ! Topography + if (mdomainfill.ge.1) then + if (topo_written.eqv..false.) call nf90_err(nf90_put_var(ncid,topoID,oro(0:nx-1,0:ny-1), (/ 1,1 /),(/ nx,ny /))) + topo_written=.true. + else + call nf90_err(nf90_put_var(ncid,topoID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + endif + case('to') ! topography averaged + call nf90_err(nf90_put_var(ncid,topoavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('PV') ! Potential vorticity + call nf90_err(nf90_put_var(ncid,pvID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('pv') ! Potential vorticity averaged + call nf90_err(nf90_put_var(ncid,pvavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('PR') ! Pressure + call nf90_err(nf90_put_var(ncid,prID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('pr') ! Pressure averaged + call nf90_err(nf90_put_var(ncid,pravID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('QV') ! Specific humidity + call nf90_err(nf90_put_var(ncid,qvID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('qv') ! Specific humidity averaged + call nf90_err(nf90_put_var(ncid,qvavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('RH') ! Air density + call nf90_err(nf90_put_var(ncid,rhoID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('rh') ! Air density averaged + call nf90_err(nf90_put_var(ncid,rhoavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('UU') ! Longitudinal velocity + call nf90_err(nf90_put_var(ncid,uID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('uu') ! Longitudinal velocity averaged + call nf90_err(nf90_put_var(ncid,uavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('VV') ! Latitudinal velocity + call nf90_err(nf90_put_var(ncid,vID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('vv') ! Latitudinal velocity averaged + call nf90_err(nf90_put_var(ncid,vavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('WW') ! Vertical velocity + call nf90_err(nf90_put_var(ncid,wID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('ww') ! Vertical velocity averaged + call nf90_err(nf90_put_var(ncid,wavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('VS') ! Settling velocity + call nf90_err(nf90_put_var(ncid,vsetID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('vs') ! Settling velocity averaged + call nf90_err(nf90_put_var(ncid,vsetavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('HM') ! Mixing height + if (mdomainfill.ge.1) then + call nf90_err(nf90_put_var(ncid,hmixID,hmix(0:nx-1,0:ny-1,1,memind(1)), & + (/ tpointer_part,1,1 /),(/ 1,nx,ny /))) + else + call nf90_err(nf90_put_var(ncid,hmixID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + endif + case('hm') ! Mixing height averaged + call nf90_err(nf90_put_var(ncid,hmixavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('TR') ! Tropopause + if (mdomainfill.ge.1) then + call nf90_err(nf90_put_var(ncid,trID,tropopause(0:nx-1,0:ny-1,1,memind(1)), & + (/ tpointer_part,1,1 /),(/ 1,nx,ny /))) + else + call nf90_err(nf90_put_var(ncid,trID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + endif + case('tr') ! Tropopause averaged + call nf90_err(nf90_put_var(ncid,travID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('TT') ! Temperature + call nf90_err(nf90_put_var(ncid,ttID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('tt') ! Temperature averaged + call nf90_err(nf90_put_var(ncid,ttavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('MA') ! Mass + if ((mdomainfill.ge.1).and.(imass.eq.1)) then + if (mass_written.eqv..false.) call nf90_err(nf90_put_var(ncid=ncid,varid=massID(1),values=field(1))) + mass_written=.true. + else + call nf90_err(nf90_put_var(ncid,massID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /))) + endif + case('ma') ! Mass averaged + if ((mdomainfill.ge.1).and.(imass.eq.1)) then + if (mass_written.eqv..false.) call nf90_err(nf90_put_var(ncid=ncid,varid=massavID(1),values=field(1))) + massav_written=.true. + else + call nf90_err(nf90_put_var(ncid,massavID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /))) + endif + case('WD') ! Cumulative mass of wet deposition + call nf90_err(nf90_put_var(ncid,wdID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /))) + case('DD') ! Cumulative mass of wet deposition + call nf90_err(nf90_put_var(ncid,ddID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /))) + end select + + ! call nf90_err(nf90_close(ncid)) +end subroutine partoutput_ncf diff --git a/src/net_read_grid_id.f90 b/src/net_read_grid_id.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f5a668673b7fbee466bcd1da290f0b31050f7e1a --- /dev/null +++ b/src/net_read_grid_id.f90 @@ -0,0 +1,62 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine read_grid_id(lnest) + + implicit none + logical, intent(in) :: lnest + + integer :: ncid,i + character(len=3) :: anspec + + if (.not. lnest) then + ! open output file + call nf90_err(nf90_open(trim(ncfname), nf90_write, ncid)) + + call nf90_err(nf90_inq_varid(ncid=ncid,name='time',varid=timeID)) + + do i = 1,nspec + write(anspec,'(i3.3)') i + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_mr',varid=specID(i))) + endif + if ((iout.eq.2).or.(iout.eq.3)) then + call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_pptv',varid=specIDppt(i))) + endif + if ((ldirect.eq.1).and.(wetdep)) then + call nf90_err(nf90_inq_varid(ncid=ncid,name='WD_spec'//anspec,varid=wdspecID(i))) + endif + if ((ldirect.eq.1).and.(drydep)) then + call nf90_err(nf90_inq_varid(ncid=ncid,name='DD_spec'//anspec,varid=ddspecID(i))) + endif + end do + + else + + ! open output file + call nf90_err(nf90_open(trim(ncfnamen), nf90_write, ncid)) + + call nf90_err(nf90_inq_varid(ncid=ncid,name='time',varid=timeIDn)) + + do i = 1,nspec + write(anspec,'(i3.3)') i + + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_mr',varid=specIDn(i))) + endif + if ((iout.eq.2).or.(iout.eq.3)) then + call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_pptv',varid=specIDnppt(i))) + endif + if ((ldirect.eq.1).and.(wetdep)) then + call nf90_err(nf90_inq_varid(ncid=ncid,name='WD_spec'//anspec,varid=wdspecIDn(i))) + endif + if ((ldirect.eq.1).and.(drydep)) then + call nf90_err(nf90_inq_varid(ncid=ncid,name='DD_spec'//anspec,varid=ddspecIDn(i))) + endif + end do + endif + + call nf90_err(nf90_close(ncid)) + +end subroutine read_grid_id diff --git a/src/net_read_init_cond_nc.f90 b/src/net_read_init_cond_nc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..463c485ba2e26a8576d2337b7ac864d84c0862ff --- /dev/null +++ b/src/net_read_init_cond_nc.f90 @@ -0,0 +1,298 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine read_init_cond_nc() + + !***************************************************************************** + ! * + ! IPIN=3: starting a run from a user defined initial particle conditions, * + ! more on how to create such a file can be found in the manual * + ! IPIN=4: restarting a run, while also reading in the initial particle * + ! conditions * + ! * + ! Author: L. Bakels 2022 * + ! * + !***************************************************************************** + + use random_mod + use particle_mod + use date_mod + use coord_ec_mod + use readoptions_mod + use drydepo_mod + + implicit none + + integer :: ncidend,tIDend,pIDend,tempIDend,stat + integer :: plen,tend,i,j,release_max,nsp + integer :: zkind + real :: totmass,cun + integer,allocatable, dimension (:) :: specnum_rel,numpoint_max + real,allocatable,dimension(:,:) :: mass_temp + real,allocatable,dimension(:) :: vsh,fracth,schmih + + integer :: idummy = -8 + + if (mquasilag.ne.0) then + write(*,*) 'Combination of ipin, netcdf partoutput, and mquasilag!=0 does not work yet' + stop + endif + + ! Open part_ic.nc file + call nf90_err(nf90_open(trim(path(2)(1:length(2))//'part_ic.nc'), mode=NF90_NOWRITE,ncid=ncidend)) + + ! allocate with maxspec for first input loop + allocate(specnum_rel(maxspec),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel' + + ! How many species are contained in each particle? + call nf90_err(nf90_inquire_attribute(ncid=ncidend,name='nspecies',varid=NF90_GLOBAL)) + call nf90_err(nf90_get_att(ncid=ncidend,varid=NF90_GLOBAL,name='nspecies',values=nspec)) + + ! Which species? + call nf90_err(nf90_inquire_attribute(ncid=ncidend,name='species',varid=NF90_GLOBAL)) + call nf90_err(nf90_get_att(ncid=ncidend,varid=NF90_GLOBAL,name='species',values=specnum_rel(1:nspec))) + + ! Get the particle dimension + call nf90_err(nf90_inq_dimid(ncid=ncidend,name='particle',dimid=pIDend)) + call nf90_err(nf90_inquire_dimension(ncid=ncidend,dimid=pIDend,len=plen)) + + ! Now spawn the correct number of particles + write(*,*) 'Npart:',plen + call alloc_particles( plen ) + ! allocate temporary mass array + allocate(mass_temp(plen,nspec)) + + ! And give them the correct positions + ! Longitude + call nf90_err(nf90_inq_varid(ncid=ncidend,name='longitude',varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%xlon, & + start=(/ 1 /),count=(/ plen /))) + part(:)%xlon=(part(:)%xlon-xlon0)/dx + ! Latitude + call nf90_err(nf90_inq_varid(ncid=ncidend,name='latitude',varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%ylat, & + start=(/ 1 /),count=(/ plen /))) + part(:)%ylat=(part(:)%ylat-ylat0)/dx + ! Height + call nf90_err(nf90_inq_varid(ncid=ncidend,name='height',varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%z, & + start=(/ 1 /),count=(/ plen /))) + ! Spawning time + call nf90_err(nf90_inq_varid(ncid=ncidend,name='time',varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%tstart, & + start=(/ 1 /),count=(/ plen /))) + ! Mass + call nf90_err(nf90_inq_varid(ncid=ncidend,name='mass',varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=mass_temp, & + start=(/ 1,1 /),count=(/ plen,nspec /))) + do nsp=1,nspec + part(:)%mass(nsp)=mass_temp(1:plen,nsp) + end do + deallocate(mass_temp) + ! Release + call nf90_err(nf90_inq_varid(ncid=ncidend,name='release',varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%npoint, & + start=(/ 1 /),count=(/ plen /))) + ! ! Species + ! call nf90_err(nf90_inq_varid(ncid=ncidend,name='species',varid=tempIDend)) + ! call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%species, & + ! start=(/ 1 /),count=(/ plen /))) + + ! Count number of releases + numpoint=1 + allocate(numpoint_max(plen),stat=stat) + numpoint_max=0 + release_max=0 + + l1: do i=1,plen + l2: do j=1,numpoint + if (part(i)%npoint.eq.numpoint_max(numpoint)) then + cycle l1 + endif + end do l2 + numpoint = numpoint+1 + numpoint_max(numpoint)=part(i)%npoint + if (part(i)%npoint.gt.release_max) release_max=part(i)%npoint + end do l1 + + allocate(kindz(numpoint),stat=stat) + kindz=-1 + if (stat.ne.0) write(*,*)'ERROR: could not allocate kindz' + ! Above sea-level or ground? + call nf90_err(nf90_inquire_attribute(ncid=ncidend,name='kindz',varid=NF90_GLOBAL)) + call nf90_err(nf90_get_att(ncid=ncidend,varid=NF90_GLOBAL,name='kindz',values=zkind)) + kindz=zkind + do nsp=1,nspec + if ((kindz(nsp).le.0).or.(kindz(nsp).ge.4)) then + write(*,*) 'ERROR: kindz should be an integer between 1 and 3, not', kindz(nsp) + stop + endif + end do + + if (ioutputforeachrelease.eq.1) then + maxpointspec_act=numpoint + else + maxpointspec_act=1 + endif + + if (release_max.gt.numpoint) then + write(*,*) "WARNING: release numbers in part_ic.nc are not consecutive:", & + release_max, "is larger than the total number of releases:", numpoint, & + " Releases will be renumbered." + + do j=1,numpoint + do i=1,plen + if (part(i)%npoint.eq.numpoint_max(j)) then + part(i)%npoint=numpoint_max(j) + endif + end do + end do + endif + deallocate(numpoint_max) + + allocate(xmass(numpoint,nspec), npart(numpoint),ireleasestart(numpoint),ireleaseend(numpoint)) + xmass=0 + npart=0 + ireleasestart=-1 + ireleaseend=-1 + do i=1,plen + do j=1,numpoint + do nsp=1,nspec + xmass(j,nsp) = xmass(j,nsp)+part(i)%mass(nsp) + end do + if (part(i)%npoint.eq.j) then + npart(j)=npart(j)+1 + if ((ireleasestart(j).gt.part(i)%tstart).or.(ireleasestart(j).eq.-1)) ireleasestart(j)=part(i)%tstart + if ((ireleaseend(j).le.part(i)%tstart).or.(ireleaseend(j).eq.-1)) ireleaseend(j)=part(i)%tstart + endif + end do + end do + if ((iout.eq.4).or.(iout.eq.5)) then + write(*,*) "ERROR: IPIN=3 or IPIN=4, using the part_ic.nc file, is not possible in combination with plume", & + "computations (IOUT=4 or 5)." + stop + endif + + part(:)%idt=part(:)%tstart + do i=1,plen + part(i)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, & + nclassunc) + part(i)%mass_init=part(i)%mass + ! Activate particles that are alive from the start of the simulation + if (part(i)%tstart.eq.0) then + call spawn_particle(0,i) + endif + end do + write(*,FMT='(A,ES14.7)') ' Total mass to be released:', sum(xmass(1:numpoint,1:nspec)) + call get_totalpart_num(numpart) + numparticlecount=numpart + call nf90_err(nf90_close(ncidend)) + + + ! Read species and derive initial conditions + + !now save the information + DEP=.false. + DRYDEP=.false. + WETDEP=.false. + OHREA=.false. + do nsp=1,maxspec + DRYDEPSPEC(nsp)=.false. + WETDEPSPEC(nsp)=.false. + end do + + do nsp=1,nspec + call readspecies(specnum_rel(nsp),nsp) + ! Allocate temporary memory necessary for the different diameter bins + !******************************************************************** + allocate(vsh(ndia(nsp)),fracth(ndia(nsp)),schmih(ndia(nsp))) + + ! Molecular weight + !***************** + if (((iout.eq.2).or.(iout.eq.3)).and.(weightmolar(nsp).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(nsp)=0.693147/decay(nsp) !conversion half life to decay constant + + ! Dry deposition of gases + !************************ + + if (reldiff(nsp).gt.0.) rm(nsp)=1./(henry(nsp)/3000.+100.*f0(nsp)) ! mesophyll resistance + + ! Dry deposition of particles + !**************************** + + vsetaver(nsp)=0. + cunningham(nsp)=0. + dquer(nsp)=dquer(nsp)*1000000. ! Conversion m to um + if (density(nsp).gt.0.) then ! Additional parameters + call part0(dquer(nsp),dsigma(nsp),density(nsp),ndia(nsp),fracth,schmih,cun,vsh) + do j=1,ndia(nsp) + fract(nsp,j)=fracth(j) + schmi(nsp,j)=schmih(j) + vset(nsp,j)=vsh(j) + cunningham(nsp)=cunningham(nsp)+cun*fract(nsp,j) + vsetaver(nsp)=vsetaver(nsp)-vset(nsp,j)*fract(nsp,j) + end do + if (lroot) write(*,*) 'Average settling velocity: ',i,vsetaver(nsp) + endif + + ! Dry deposition for constant deposition velocity + !************************************************ + + dryvel(nsp)=dryvel(nsp)*0.01 ! conversion to m/s + + ! Check if wet deposition or OH reaction shall be calculated + !*********************************************************** + + ! ESO 04.2016 check for below-cloud scavenging (gas or aerosol) + if ((dquer(nsp).le.0..and.(weta_gas(nsp).gt.0. .or. wetb_gas(nsp).gt.0.)) .or. & + &(dquer(nsp).gt.0. .and. (crain_aero(nsp) .gt. 0. .or. csnow_aero(nsp).gt.0.))) then + WETDEP=.true. + WETDEPSPEC(nsp)=.true. + if (lroot) then + write (*,*) ' Below-cloud scavenging: ON' + end if + else + if (lroot) write (*,*) ' Below-cloud scavenging: OFF' + endif + + ! NIK 31.01.2013 + 10.12.2013 + 15.02.2015 + if (dquer(nsp).gt.0..and.(ccn_aero(nsp).gt.0. .or. in_aero(nsp).gt.0.)) then + WETDEP=.true. + WETDEPSPEC(nsp)=.true. + if (lroot) then + write (*,*) ' In-cloud scavenging: ON' + end if + else + if (lroot) write (*,*) ' In-cloud scavenging: OFF' + endif + + if (ohcconst(nsp).gt.0.) then + OHREA=.true. + if (lroot) write (*,*) ' OHreaction switched on: ',ohcconst(nsp),nsp + endif + + if ((reldiff(nsp).gt.0.).or.(density(nsp).gt.0.).or.(dryvel(nsp).gt.0.)) then + DRYDEP=.true. + DRYDEPSPEC(nsp)=.true. + endif + + deallocate(vsh,fracth,schmih) + end do ! end loop over species + + if (WETDEP.or.DRYDEP) then + DEP=.true. + endif + + + deallocate(specnum_rel) +end subroutine read_init_cond_nc diff --git a/src/net_read_partpos_ncf.f90 b/src/net_read_partpos_ncf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..786f00d2ced0ec97fa2a2515cc13dbf51408e5a3 --- /dev/null +++ b/src/net_read_partpos_ncf.f90 @@ -0,0 +1,117 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine read_partpos_ncf(ibtime,ibdate) + + !***************************************************************************** + ! * + ! IPIN=2: restarting from a partoutput_xxx.nc file written by a previous * + ! run, depending on what PARTOPTIONS the user has chosen, this * + ! option might not be possible to use * + ! * + ! Author: L. Bakels 2022 * + ! * + !***************************************************************************** + + use random_mod + use particle_mod + use date_mod + + implicit none + + integer, intent(in) :: ibtime,ibdate + integer :: ncidend,tIDend,pIDend,tempIDend + integer :: tlen,plen,tend,i,j + integer :: idate_start,itime_start + character :: adate*8,atime*6,timeunit*32,adate_start*8,atime_start*6 + character(len=3) :: anspec + real(kind=dp) :: julin,julcommand,julpartin + + integer :: idummy = -8 + + write(adate,'(i8.8)') ibdate + write(atime,'(i6.6)') ibtime + + if (mquasilag.ne.0) then + write(*,*) 'Combination of ipin, netcdf partoutput, and mquasilag!=0 does not work yet' + stop + endif + + ! Open partoutput_end.nc file + call nf90_err(nf90_open(trim('partoutput_end.nc'), mode=NF90_NOWRITE,ncid=ncidend)) + + ! Take the positions of the particles at the last timestep in the file + ! It needs to be the same as given in the COMMAND file, this is arbitrary + ! and should be removed in the future for easier use + + ! First get the time dimension + call nf90_err(nf90_inq_dimid(ncid=ncidend,name='time',dimid=tIDend)) + call nf90_err(nf90_inquire_dimension(ncid=ncidend,dimid=tIDend,len=tlen)) + + ! Check if the time corresponds to the one given in the COMMAND file + call nf90_err(nf90_inq_varid(ncid=ncidend,name='time',varid=tIDend)) + call nf90_err(nf90_get_att(ncid=ncidend,varid=tIDend,name='units',values=timeunit)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tIDend,values=tend,start=(/ tlen /)))!,count=(/ 1 /))) + adate_start(1:4) = timeunit(15:18) + adate_start(5:6) = timeunit(20:21) + adate_start(7:8) = timeunit(23:24) + atime_start = '000000' + atime_start(1:2) = timeunit(26:27) + atime_start(3:4) = timeunit(29:30) + read(adate_start,*) idate_start + read(atime_start,*) itime_start + julin = juldate(idate_start,itime_start)+real(tend,kind=dp)/86400._dp + julcommand = juldate(ibdate,ibtime) + if (abs(julin-julcommand).gt.1.e-5) then + write(*,*) 'ERROR: The given starting time and date do not correspond to' + write(*,*) 'the last timestep of partoutput_end.nc:' + write(*,*) julin,julcommand,tend + stop + endif + + ! Then the particle dimension + call nf90_err(nf90_inq_dimid(ncid=ncidend,name='particle',dimid=pIDend)) + call nf90_err(nf90_inquire_dimension(ncid=ncidend,dimid=pIDend,len=plen)) + + ! Now spawn the correct number of particles + write(*,*) 'Npart:',plen + call spawn_particles(0,plen) + + ! And give them the correct positions + ! Longitude + call nf90_err(nf90_inq_varid(ncid=ncidend,name='longitude',varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%xlon, & + start=(/ tlen, 1 /),count=(/ 1, plen /))) + part(:)%xlon=(part(:)%xlon-xlon0)/dx + ! Latitude + call nf90_err(nf90_inq_varid(ncid=ncidend,name='latitude',varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%ylat, & + start=(/ tlen, 1 /),count=(/ 1, plen /))) + part(:)%ylat=(part(:)%ylat-ylat0)/dx + ! Height + call nf90_err(nf90_inq_varid(ncid=ncidend,name='height',varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%z, & + start=(/ tlen, 1 /),count=(/ 1, plen /))) + ! Mass + if (mdomainfill.eq.0) then + do j=1,nspec + write(anspec, '(i3.3)') j + call nf90_err(nf90_inq_varid(ncid=ncidend,name='mass'//anspec,varid=tempIDend)) + call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%mass(j), & + start=(/ tlen, 1 /),count=(/ 1, plen /))) + end do + endif + + do i=1,plen + if (part(i)%z.lt.0) then + call terminate_particle(i,0) + write(*,*) 'Particle ',i,'is not alive in the restart file.' + endif + part(i)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, & + nclassunc) + part(i)%idt=mintime + part(i)%npoint=1 + end do + + call nf90_err(nf90_close(ncidend)) +end subroutine read_partpos_ncf diff --git a/src/net_write_to_file.f90 b/src/net_write_to_file.f90 new file mode 100644 index 0000000000000000000000000000000000000000..99b99b1d59766874b3ca51c40c90e74a134007d8 --- /dev/null +++ b/src/net_write_to_file.f90 @@ -0,0 +1,35 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine write_to_file(ncid,short_name,xtype,dimids,varid,chunksizes,units,l_positive, & + standard_name,long_name) + + !***************************************************************************** + ! * + ! Generalised writing data to netcdf file * + ! * + ! Author: L. Bakels 2022 * + ! * + !***************************************************************************** + + implicit none + + integer, intent(in) :: ncid, xtype + integer, intent(out) :: varid + character(len = *), intent(in) :: short_name,standard_name,long_name,units + integer, dimension(:), intent(in) :: dimids,chunksizes + logical, intent(in) :: l_positive + + call nf90_err(nf90_def_var(ncid, short_name, xtype, dimids, varid)) + call nf90_err(nf90_def_var_chunking(ncid,varid,NF90_CHUNKED,chunksizes=chunksizes)) + call nf90_err(nf90_def_var_deflate(ncid,varid,shuffle=0,deflate=1,deflate_level=1)) + call nf90_err(nf90_put_att(ncid, varid, 'units', units)) + if(xtype.eq.nf90_float) then + call nf90_err(nf90_put_att(ncid, varid, '_FillValue', -1.)) + else + call nf90_err(nf90_put_att(ncid, varid, '_FillValue', -1)) + endif + if(l_positive) call nf90_err(nf90_put_att(ncid, varid, 'positive', 'up')) + call nf90_err(nf90_put_att(ncid, varid, 'standard_name', standard_name)) + call nf90_err(nf90_put_att(ncid, varid, 'long_name', long_name)) +end subroutine write_to_file diff --git a/src/net_writeheader_ncf.f90 b/src/net_writeheader_ncf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cc583687f117e377c7cea10c7e23948a6e44429e --- /dev/null +++ b/src/net_writeheader_ncf.f90 @@ -0,0 +1,492 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine writeheader_ncf(lnest) + + !**************************************************************** + ! Create netcdf file and write header/metadata information + ! lnest = .false. : Create main output file + ! lnest = .true. : Create nested output file + !**************************************************************** + implicit none + + logical, intent(in) :: lnest + + integer :: ncid, sID, wdsID, ddsID + integer :: timeDimID, latDimID, lonDimID, levDimID, receptorDimID + integer :: nspecDimID, npointDimID, nageclassDimID, ncharDimID, pointspecDimID + integer :: tID, lonID, latID, levID, poleID, lageID, oroID, ncharrecDimID + integer :: volID, areaID + integer :: rellng1ID, rellng2ID, rellat1ID, rellat2ID, relzz1ID, relzz2ID + integer :: relcomID, relkindzID, relstartID, relendID, relpartID, relxmassID + integer :: nnx, nny + integer, dimension(6) :: dIDs + integer, dimension(5) :: depdIDs + character(len=255) :: fname + character(len=15) :: units + character(len=20) :: fprefix + character(len=3) :: anspec + CHARACTER :: adate*8,atime*6,timeunit*32 + !REAL, DIMENSION(1000) :: coord + real, allocatable, dimension(:) :: coord + + integer :: cache_size + integer, dimension(6) :: chunksizes + integer, dimension(5) :: dep_chunksizes + + integer :: i,ix,jy + integer :: test_unit + + + ! Check if output directory exists (the netcdf library will + ! otherwise give an error which can look confusing). + ! ********************************************************************* + open(unit=unittmp,file=trim(path(2)(1:length(2)))//'test_dir.txt',status='replace',& + &err=100) + close (unittmp, status='delete') + goto 101 +100 write(*,FMT='(80("#"))') + write(*,*) 'ERROR: output directory ', trim(path(2)(1:length(2))), ' does not exist& + & (or failed to write there).' + write(*,*) 'EXITING' + write(*,FMT='(80("#"))') + stop +101 continue + + !************************ + ! Create netcdf file + !************************ + + if (ldirect.eq.1) then + write(adate,'(i8.8)') ibdate + write(atime,'(i6.6)') ibtime + fprefix = 'grid_conc_' + else + write(adate,'(i8.8)') iedate + write(atime,'(i6.6)') ietime + fprefix = 'grid_time_' + endif + if (DRYBKDEP) fprefix='grid_drydep_' + if (WETBKDEP) fprefix='grid_wetdep_' + + if (lnest) then + fname = path(2)(1:length(2))//trim(fprefix)//adate//atime//'_nest.nc' + ncfnamen = fname + nnx = numxgridn + nny = numygridn + else + fname = path(2)(1:length(2))//trim(fprefix)//adate//atime//'.nc' + ncfname = fname + nnx = numxgrid + nny = numygrid + endif + + cache_size = 16 * nnx * nny * numzgrid + + ! If starting from a restart file, new data will be added to the existing grid file + if ((ipin.eq.1).or.(ipin.eq.4)) then + call read_grid_id(lnest) + return + endif + + ! setting cache size in bytes. It is set to 4 times the largest data block that is written + ! size_type x nx x ny x nz + ! create file + call nf90_err(nf90_create(trim(fname), cmode = nf90_hdf5, ncid = ncid, & + cache_size = cache_size)) + + ! create dimensions: + !************************* + ! time + call nf90_err(nf90_def_dim(ncid, 'time', nf90_unlimited, timeDimID)) + timeunit = 'seconds since '//adate(1:4)//'-'//adate(5:6)// & + '-'//adate(7:8)//' '//atime(1:2)//':'//atime(3:4) + + ! lon + call nf90_err(nf90_def_dim(ncid, 'longitude', nnx, lonDimID)) + ! lat + call nf90_err(nf90_def_dim(ncid, 'latitude', nny, latDimID)) + ! level + call nf90_err(nf90_def_dim(ncid, 'height', numzgrid, levDimID)) + ! number of species + call nf90_err(nf90_def_dim(ncid, 'numspec', nspec, nspecDimID)) + ! number of release points + call nf90_err(nf90_def_dim(ncid, 'pointspec', maxpointspec_act, pointspecDimID)) + ! number of age classes + call nf90_err(nf90_def_dim(ncid, 'nageclass', nageclass, nageclassDimID)) + ! dimension for release point characters + call nf90_err(nf90_def_dim(ncid, 'nchar', 45, ncharDimID)) + ! dimension for receptor point characters + call nf90_err(nf90_def_dim(ncid, 'ncharrec', 16, ncharrecDimID)) + ! number of actual release points + call nf90_err(nf90_def_dim(ncid, 'numpoint', numpoint, npointDimID)) + + + ! create variables + !************************* + + ! time + call nf90_err(nf90_def_var(ncid, 'time', nf90_int, (/ timeDimID /), tID)) + call nf90_err(nf90_put_att(ncid, tID, 'units', timeunit)) + call nf90_err(nf90_put_att(ncid, tID, 'calendar', 'proleptic_gregorian')) + if (lnest) then + timeIDn = tID + else + timeID = tID + endif + + ! lon + call nf90_err(nf90_def_var(ncid, 'longitude', nf90_float, (/ lonDimID /), lonID)) + call nf90_err(nf90_put_att(ncid, lonID, 'long_name', 'longitude in degree east')) + call nf90_err(nf90_put_att(ncid, lonID, 'axis', 'Lon')) + call nf90_err(nf90_put_att(ncid, lonID, 'units', 'degrees_east')) + call nf90_err(nf90_put_att(ncid, lonID, 'standard_name', 'grid_longitude')) + call nf90_err(nf90_put_att(ncid, lonID, 'description', 'grid cell centers')) + + ! lat + call nf90_err(nf90_def_var(ncid, 'latitude', nf90_float, (/ latDimID /), latID)) + call nf90_err(nf90_put_att(ncid, latID, 'long_name', 'latitude in degree north')) + call nf90_err(nf90_put_att(ncid, latID, 'axis', 'Lat')) + call nf90_err(nf90_put_att(ncid, latID, 'units', 'degrees_north')) + call nf90_err(nf90_put_att(ncid, latID, 'standard_name', 'grid_latitude')) + call nf90_err(nf90_put_att(ncid, latID, 'description', 'grid cell centers')) + + + ! height + call nf90_err(nf90_def_var(ncid, 'height', nf90_float, (/ levDimID /), levID)) + ! call nf90_err(nf90_put_att(ncid, levID, 'axis', 'Z')) + call nf90_err(nf90_put_att(ncid, levID, 'units', 'meters')) + call nf90_err(nf90_put_att(ncid, levID, 'positive', 'up')) + call nf90_err(nf90_put_att(ncid, levID, 'standard_name', 'height')) + call nf90_err(nf90_put_att(ncid, levID, 'long_name', 'height above ground')) + + ! volume + if (write_vol) call nf90_err(nf90_def_var(ncid, 'volume', nf90_float, & + &(/ lonDimID, latDimID, levDimID /), volID)) + ! area + if (write_area) call nf90_err(nf90_def_var(ncid, 'area', nf90_float, & + &(/ lonDimID, latDimID /), areaID)) + + + if (write_releases.eqv..true.) then + ! release comment + call nf90_err(nf90_def_var(ncid, 'RELCOM', nf90_char, (/ ncharDimID,npointDimID /), & + relcomID)) + call nf90_err(nf90_put_att(ncid, relcomID, 'long_name', 'release point name')) + ! release longitude 1 + call nf90_err(nf90_def_var(ncid, 'RELLNG1', nf90_float, (/ npointDimID /), rellng1ID)) + call nf90_err(nf90_put_att(ncid, rellng1ID, 'units', 'degrees_east')) + call nf90_err(nf90_put_att(ncid, rellng1ID, 'long_name', & + 'release longitude lower left corner')) + ! release longitude 2 + call nf90_err(nf90_def_var(ncid, 'RELLNG2', nf90_float, (/ npointDimID /), rellng2ID)) + call nf90_err(nf90_put_att(ncid, rellng2ID, 'units', 'degrees_east')) + call nf90_err(nf90_put_att(ncid, rellng2ID, 'long_name', & + 'release longitude upper right corner')) + ! release latitude 1 + call nf90_err(nf90_def_var(ncid, 'RELLAT1', nf90_float, (/ npointDimID /), rellat1ID)) + call nf90_err(nf90_put_att(ncid, rellat1ID, 'units', 'degrees_north')) + call nf90_err(nf90_put_att(ncid, rellat1ID, 'long_name', & + 'release latitude lower left corner')) + ! release latitude 2 + call nf90_err(nf90_def_var(ncid, 'RELLAT2', nf90_float, (/ npointDimID /), rellat2ID)) + call nf90_err(nf90_put_att(ncid, rellat2ID, 'units', 'degrees_north')) + call nf90_err(nf90_put_att(ncid, rellat2ID, 'long_name', & + 'release latitude upper right corner')) + + ! hes: if rotated_ll it would be convenient also to write the the release points in rotated_coordinates + + ! release height bottom + call nf90_err(nf90_def_var(ncid, 'RELZZ1', nf90_float, (/ npointDimID /), relzz1ID)) + call nf90_err(nf90_put_att(ncid, relzz1ID, 'units', 'meters')) + call nf90_err(nf90_put_att(ncid, relzz1ID, 'long_name', 'release height bottom')) + ! release height top + call nf90_err(nf90_def_var(ncid, 'RELZZ2', nf90_float, (/ npointDimID /), relzz2ID)) + call nf90_err(nf90_put_att(ncid, relzz2ID, 'units', 'meters')) + call nf90_err(nf90_put_att(ncid, relzz2ID, 'long_name', 'release height top')) + ! release kind + call nf90_err(nf90_def_var(ncid, 'RELKINDZ', nf90_int, (/ npointDimID /), relkindzID)) + call nf90_err(nf90_put_att(ncid, relkindzID, 'long_name', 'release kind')) + ! release start + call nf90_err(nf90_def_var(ncid, 'RELSTART', nf90_int, (/ npointDimID /), relstartID)) + call nf90_err(nf90_put_att(ncid, relstartID, 'units', 'seconds')) + call nf90_err(nf90_put_att(ncid, relstartID, 'long_name', & + 'release start relative to simulation start')) + ! release end + call nf90_err(nf90_def_var(ncid, 'RELEND', nf90_int, (/ npointDimID /), relendID)) + call nf90_err(nf90_put_att(ncid, relendID, 'units', 'seconds')) + call nf90_err(nf90_put_att(ncid, relendID, 'long_name', & + 'release end relative to simulation start')) + ! release particles + call nf90_err(nf90_def_var(ncid, 'RELPART', nf90_int, (/ npointDimID /), relpartID)) + call nf90_err(nf90_put_att(ncid, relpartID, 'long_name', 'number of release particles')) + ! release particle masses + call nf90_err(nf90_def_var(ncid, 'RELXMASS', nf90_float, (/ npointDimID, nspecDimID /), & + relxmassID)) + call nf90_err(nf90_put_att(ncid, relxmassID, 'long_name', 'total release particle mass')) + end if + + ! age classes + call nf90_err(nf90_def_var(ncid, 'LAGE', nf90_int, (/ nageclassDimID /), lageID)) + call nf90_err(nf90_put_att(ncid, lageID, 'units', 'seconds')) + call nf90_err(nf90_put_att(ncid, lageID, 'long_name', 'age class')) + + ! output orography + if (.not. min_size) then + call nf90_err(nf90_def_var(ncid, 'ORO', nf90_int, (/ lonDimID, latDimID /), oroID, & + deflate_level=deflate_level, chunksizes= (/ nnx, nny /))) + call nf90_err(nf90_put_att(ncid, oroID, 'standard_name', 'surface altitude')) + call nf90_err(nf90_put_att(ncid, oroID, 'long_name', 'outgrid surface altitude')) + call nf90_err(nf90_put_att(ncid, oroID, 'units', 'm')) + end if + + ! Receptors + if (numreceptor.ge.1) then + call nf90_err(nf90_def_dim(ncid, 'receptor', nf90_unlimited, receptorDimID)) + call nf90_err(nf90_def_var(ncid, 'receptor', nf90_char, (/ ncharrecDimID,receptorDimID /), sID)) + call nf90_err(nf90_put_var(ncid, sID, receptorname, (/ 1,1 /), (/ 16,numreceptor /))) + call nf90_err(nf90_put_att(ncid, sID, 'long_name', 'receptor name')) + endif + + ! concentration output, wet and dry deposition variables (one per species) + call output_units(units) + + dIDs = (/ londimid, latdimid, levdimid, timedimid, pointspecdimid, nageclassdimid /) + depdIDs = (/ londimid, latdimid, timedimid, pointspecdimid, nageclassdimid /) + if (lnest) then + dimidsn = dIDs + depdimidsn = depdIDs + else + dimids = dIDs + depdimids = depdIDs + endif + + ! set chunksizes according to largest written portion of data in an individual call to + ! nf90_put_var + if (int(nnx,kind=8)*int(nny,kind=8)*int(numzgrid,kind=8).gt.2147483647) then ! Larger than an + chunksizes = (/ nnx, nny, 1, 1, 1, 1 /) + else + chunksizes = (/ nnx, nny, numzgrid, 1, 1, 1 /) + endif + dep_chunksizes = (/ nnx, nny, 1, 1, 1 /) + + do i = 1,nspec + write(anspec,'(i3.3)') i + + ! concentration output + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + call nf90_err(nf90_def_var(ncid,'spec'//anspec//'_mr', nf90_float, dIDs, sID , & + deflate_level = deflate_level, & + chunksizes = chunksizes )) + call nf90_err(nf90_put_att(ncid, sID, 'units', units)) + call nf90_err(nf90_put_att(ncid, sID, 'long_name', species(i))) + call nf90_err(nf90_put_att(ncid, sID, 'decay', decay(i))) + call nf90_err(nf90_put_att(ncid, sID, 'weightmolar', weightmolar(i))) + ! call nf90_err(nf90_put_att(ncid, sID, 'ohreact', ohreact(i))) + call nf90_err(nf90_put_att(ncid, sID, 'ohcconst', ohcconst(i))) + call nf90_err(nf90_put_att(ncid, sID, 'ohdconst', ohdconst(i))) + call nf90_err(nf90_put_att(ncid, sID, 'vsetaver', vsetaver(i))) + + if (lnest) then + specIDn(i) = sID + else + specID(i) = sID + endif + endif + + ! mixing ratio output + if ((iout.eq.2).or.(iout.eq.3)) then + call nf90_err(nf90_def_var(ncid,'spec'//anspec//'_pptv', nf90_float, dIDs, sID , & + deflate_level = deflate_level, & + chunksizes = chunksizes )) + call nf90_err(nf90_put_att(ncid, sID, 'units', 'pptv')) + call nf90_err(nf90_put_att(ncid, sID, 'long_name', species(i))) + call nf90_err(nf90_put_att(ncid, sID, 'decay', decay(i))) + call nf90_err(nf90_put_att(ncid, sID, 'weightmolar', weightmolar(i))) + ! call nf90_err(nf90_put_att(ncid, sID, 'ohreact', ohreact(i))) + call nf90_err(nf90_put_att(ncid, sID, 'ohcconst', ohcconst(i))) + call nf90_err(nf90_put_att(ncid, sID, 'ohdconst', ohdconst(i))) + call nf90_err(nf90_put_att(ncid, sID, 'vsetaver', vsetaver(i))) + + if (lnest) then + specIDnppt(i) = sID + else + specIDppt(i) = sID + endif + endif + + ! wet and dry deposition fields for forward runs + if ((ldirect.eq.1).and.(wetdep)) then + call nf90_err(nf90_def_var(ncid,'WD_spec'//anspec, nf90_float, depdIDs, & + wdsID, deflate_level = deflate_level, & + chunksizes = dep_chunksizes)) + call nf90_err(nf90_put_att(ncid, wdsID, 'units', '1e-12 kg m-2')) + call nf90_err(nf90_put_att(ncid, wdsID, 'weta_gas', weta_gas(i))) + call nf90_err(nf90_put_att(ncid, wdsID, 'wetb_gas', wetb_gas(i))) + call nf90_err(nf90_put_att(ncid, wdsID, 'ccn_aero', ccn_aero(i))) + call nf90_err(nf90_put_att(ncid, wdsID, 'in_aero', in_aero(i))) + ! call nf90_err(nf90_put_att(ncid, wdsID, 'wetc_in', wetc_in(i))) + ! call nf90_err(nf90_put_att(ncid, wdsID, 'wetd_in', wetd_in(i))) + call nf90_err(nf90_put_att(ncid, wdsID, 'dquer', dquer(i))) + call nf90_err(nf90_put_att(ncid, wdsID, 'henry', henry(i))) + if (lnest) then + wdspecIDn(i) = wdsID + else + wdspecID(i) = wdsID + endif + endif + if ((ldirect.eq.1).and.(drydep)) then + call nf90_err(nf90_def_var(ncid,'DD_spec'//anspec, nf90_float, depdIDs, & + ddsID, deflate_level = deflate_level, & + chunksizes = dep_chunksizes)) + call nf90_err(nf90_put_att(ncid, ddsID, 'units', '1e-12 kg m-2')) + call nf90_err(nf90_put_att(ncid, ddsID, 'dryvel', dryvel(i))) + call nf90_err(nf90_put_att(ncid, ddsID, 'reldiff', reldiff(i))) + call nf90_err(nf90_put_att(ncid, ddsID, 'henry', henry(i))) + call nf90_err(nf90_put_att(ncid, ddsID, 'f0', f0(i))) + call nf90_err(nf90_put_att(ncid, ddsID, 'dquer', dquer(i))) + call nf90_err(nf90_put_att(ncid, ddsID, 'density', density(i))) + call nf90_err(nf90_put_att(ncid, ddsID, 'dsigma', dsigma(i))) + if (lnest) then + ddspecIDn(i) = ddsID + else + ddspecID(i) = ddsID + endif + endif + ! RECEPTORS + if (numreceptor.ge.1) then + if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then + call write_to_file(ncid,'receptor_conc'//anspec, nf90_float, (/ timeDimID,receptorDimID /), & + sID, (/ 1, numreceptor /), 'ng m-3', .true., 'receptor_conc', 'receptor_concentration') + recconcID(i)=sID + endif + if ((iout.eq.2).or.(iout.eq.3)) then + call write_to_file(ncid,'receptor_pptv'//anspec, nf90_float, (/ timeDimID,receptorDimID /), & + sID, (/ 1, numreceptor /), 'pptv', .true., 'receptor_pptv', 'receptor_mixingratio') + recpptvID(i)=sID + endif + endif + end do + + ! global (metadata) attributes + !******************************* + call writemetadata(ncid,lnest) + + + ! moves the file from define to data mode + call nf90_err(nf90_enddef(ncid)) + + ! ! hes: inquire var definition + ! do i = 1,nspec + ! write(anspec,'(i3.3)') i + ! + ! ! concentration output + ! if (iout.eq.1.or.iout.eq.3.or.iout.eq.5) then + ! if (lnest) then + ! sID = specIDn(i) + ! else + ! sID = specID(i) + ! endif + ! call nf90_err(nf90_inquire_variable(ncid, sID, chunksizes=inq_chunksizes)) + ! write(*,*) "Chunksizes for var "//anspec//": ", inq_chunksizes + ! endif + ! end do + + + ! fill with data + !****************************** + ! longitudes (grid cell centers) + if (lnest) then + if (.not.allocated(coord)) allocate(coord(numxgridn)) + do i = 1,numxgridn + coord(i) = outlon0n + (i-0.5)*dxoutn + enddo + call nf90_err(nf90_put_var(ncid, lonID, coord(1:numxgridn))) + deallocate(coord) + else + if (.not.allocated(coord)) allocate(coord(numxgrid)) + do i = 1,numxgrid + coord(i) = outlon0 + (i-0.5)*dxout + enddo + call nf90_err(nf90_put_var(ncid, lonID, coord(1:numxgrid))) + deallocate(coord) + endif + ! latitudes (grid cell centers) + if (lnest) then + if (.not.allocated(coord)) allocate(coord(numygridn)) + do i = 1,numygridn + coord(i) = outlat0n + (i-0.5)*dyoutn + enddo + call nf90_err(nf90_put_var(ncid, latID, coord(1:numygridn))) + deallocate(coord) + else + if (.not.allocated(coord)) allocate(coord(numygrid)) + do i = 1,numygrid + coord(i) = outlat0 + (i-0.5)*dyout + enddo + call nf90_err(nf90_put_var(ncid, latID, coord(1:numygrid))) + deallocate(coord) + endif + ! levels + call nf90_err(nf90_put_var(ncid, levID, outheight(1:numzgrid))) + + ! volume + if (write_vol) then + if (lnest) then + call nf90_err(nf90_put_var(ncid, volID, volumen(:,:,:))) + else + call nf90_err(nf90_put_var(ncid, volID, volume(:,:,:))) + end if + end if + + ! area + if (write_area) then + if (lnest) then + call nf90_err(nf90_put_var(ncid, areaID, arean(:,:))) + else + call nf90_err(nf90_put_var(ncid, areaID, area(:,:))) + end if + end if + + if ((write_releases.eqv..true.).and.(ipin.ne.3).and.(ipin.ne.4)) then + ! release point information + do i = 1,numpoint + call nf90_err(nf90_put_var(ncid, relstartID, ireleasestart(i), (/i/))) + call nf90_err(nf90_put_var(ncid, relendID, ireleaseend(i), (/i/))) + call nf90_err(nf90_put_var(ncid, relkindzID, kindz(i), (/i/))) + xp1=xpoint1(i)*dx+xlon0 + yp1=ypoint1(i)*dy+ylat0 + xp2=xpoint2(i)*dx+xlon0 + yp2=ypoint2(i)*dy+ylat0 + call nf90_err(nf90_put_var(ncid, rellng1ID, xp1, (/i/))) + call nf90_err(nf90_put_var(ncid, rellng2ID, xp2, (/i/))) + call nf90_err(nf90_put_var(ncid, rellat1ID, yp1, (/i/))) + call nf90_err(nf90_put_var(ncid, rellat2ID, yp2, (/i/))) + call nf90_err(nf90_put_var(ncid, relzz1ID, zpoint1(i), (/i/))) + call nf90_err(nf90_put_var(ncid, relzz2ID, zpoint2(i), (/i/))) + call nf90_err(nf90_put_var(ncid, relpartID, npart(i), (/i/))) + if ((i .le. 1000).and.(ipin.ne.3).and.(ipin.ne.4)) then + call nf90_err(nf90_put_var(ncid, relcomID, compoint(i), (/1,i/), (/45,1/))) + else + call nf90_err(nf90_put_var(ncid, relcomID, 'NA', (/1,i/), (/45,1/))) + endif + call nf90_err(nf90_put_var(ncid, relxmassID, xmass(i,1:nspec), (/i,1/), (/1,nspec/))) + end do + end if + + ! age classes + call nf90_err(nf90_put_var(ncid, lageID, lage(1:nageclass))) + + ! orography + if (.not. min_size) then + if (lnest) then + call nf90_err(nf90_put_var(ncid, oroID, orooutn(0:(nnx-1), 0:(nny-1)))) + else + call nf90_err(nf90_put_var(ncid, oroID, oroout(0:(nnx-1), 0:(nny-1)))) + endif + end if + + call nf90_err(nf90_close(ncid)) + + return +end subroutine writeheader_ncf diff --git a/src/net_writeheader_partoutput.f90 b/src/net_writeheader_partoutput.f90 new file mode 100644 index 0000000000000000000000000000000000000000..beef33affd85a7ea10fdc164c95a3959968bf842 --- /dev/null +++ b/src/net_writeheader_partoutput.f90 @@ -0,0 +1,315 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine writeheader_partoutput(itime,idate,itime_start,idate_start)!,irelease) + + !***************************************************************************** + ! * + ! This subroutine creates a file (partoutput_xxx.nc), where every time * + ! interval particle properties specified in the PARTOPTIONS option file * + ! are saved to. Running options are saved as header informtion to this * + ! file as well. * + ! * + ! Author: L. Bakels 2021 * + ! * + !***************************************************************************** + + implicit none + + integer, intent(in) :: itime,idate,itime_start,idate_start + ! integer, intent(in) :: irelease + integer :: cache_size,ncid,j,i,totpart,np + integer :: timeDimID,partDimID,tID,memDimID + integer :: latDimID, lonDimID, lonID, latID + character(len=11) :: fprefix + character(len=3) :: anspec,arelease + character :: adate*8,atime*6,adate_start*8,atime_start*6,timeunit*32 + character(len=255) :: fname_partoutput + real :: fillval + real, allocatable, dimension(:) :: coord + + logical,save :: first_time=.true. + + open(unit=unittmp,file=trim(path(2)(1:length(2)))//'test_dir.txt',status='replace',& + &err=110) + close (unittmp, status='delete') + + write(adate,'(i8.8)') idate + write(atime,'(i6.6)') itime + write(adate_start,'(i8.8)') idate_start + write(atime_start,'(i6.6)') itime_start + ! write(arelease, '(i3.3)') irelease + fprefix = 'partoutput_'!rel'//arelease//'_' + + ! Reset logicals that ensure ony 1 write out in case of domainfill + topo_written=.false. + mass_written=.false. + massav_written=.false. + + if (first_time) then + fname_partoutput = path(2)(1:length(2))//trim(fprefix)//adate//atime//'_init.nc' + first_time=.false. + else + fname_partoutput = path(2)(1:length(2))//trim(fprefix)//adate//atime//'.nc' + endif + !ncfname_part(irelease) = fname_partoutput + ncfname_part = fname_partoutput + + totpart=0 + if (ipin.gt.1) then ! Not reading from a release has no npart + totpart=numpart + else + do j=1,numpoint + totpart = totpart+npart(j) + end do + endif + !totpart = maxpart!max(numpart,totpart) + !cache_size = 4 * 1 * (12+nspec) + + write(*,*) 'Write header, nspec,numpart,totpart: ', nspec,numpart,totpart + + call nf90_err(nf90_create(trim(fname_partoutput), cmode = nf90_hdf5, ncid = ncid))!, & + ! cache_size = cache_size)) + + ! create dimensions: + !************************* + ! time + call nf90_err(nf90_def_dim(ncid, 'time', nf90_unlimited, timeDimID)) + timeunit = 'seconds since '//adate_start(1:4)//'-'//adate_start(5:6)// & + '-'//adate_start(7:8)//' '//atime_start(1:2)//':'//atime_start(3:4) + + ! particle + call nf90_err(nf90_def_dim(ncid, 'particle', nf90_unlimited, partDimID)) !totpart needs to be the actual number of particles + + ! If domainfill, save topo, hmix, and htropo to grid to save space + !***************************************************************** + if (mdomainfill.ge.1) then + call nf90_err(nf90_def_dim(ncid, 'lon', nx, lonDimID)) + call nf90_err(nf90_def_dim(ncid, 'lat', ny, latDimID)) + + ! lon + call write_to_file(ncid,'lon',nf90_float,(/ lonDimID /),lonID,(/ 1 /), & + 'degrees_east',.false.,'grid_longitude','longitude in degree east') + call nf90_err(nf90_put_att(ncid, lonID, 'axis', 'Lon')) + call nf90_err(nf90_put_att(ncid, lonID, 'description', 'grid cell centers')) + + ! lat + call write_to_file(ncid,'lat',nf90_float,(/ latDimID /),latID,(/ 1 /), & + 'degrees_east',.false.,'grid_latitude','latitude in degree north') + call nf90_err(nf90_put_att(ncid, latID, 'axis', 'Lat')) + call nf90_err(nf90_put_att(ncid, latID, 'description', 'grid cell centers')) + + if (.not.allocated(coord)) allocate(coord(nx)) + do i = 1,nx + coord(i) = xlon0 + i*dx + enddo + call nf90_err(nf90_put_var(ncid, lonID, coord(1:nx))) + deallocate(coord) + + if (.not.allocated(coord)) allocate(coord(ny)) + do i = 1,ny + coord(i) = ylat0 + i*dy + enddo + call nf90_err(nf90_put_var(ncid, latID, coord(1:ny))) + deallocate(coord) + + endif + ! create variables + !************************* + + ! time + tpointer_part=0 + call nf90_err(nf90_def_var(ncid, 'time', nf90_int, (/ timeDimID /), tID)) + call nf90_err(nf90_put_att(ncid, tID, 'units', timeunit)) + call nf90_err(nf90_put_att(ncid, tID, 'calendar', 'proleptic_gregorian')) + + timeIDpart=tID + ! particles + call nf90_err(nf90_def_var(ncid, 'particle', nf90_int, (/ partDimID/), partID)) + call nf90_err(nf90_put_att(ncid, partID, 'long_name', 'particle index')) + + fillval = -1. + do np=1,num_partopt + if (.not. partopt(np)%print) cycle + select case(partopt(np)%name) + case ('LO') ! Longitude + call write_to_file(ncid,'longitude',nf90_float,(/ timeDimID,partDimID /),lonIDpart,(/ 1,totpart /), & + 'degrees_east',.false.,'longitude','longitude of particles') + call nf90_err(nf90_put_att(ncid, lonIDpart, 'axis', 'Lon')) + call nf90_err(nf90_put_att(ncid, lonIDpart, 'description', 'longitude of particles')) + case ('lo') ! Longitude averaged + call write_to_file(ncid,'longitude_av',nf90_float,(/ timeDimID,partDimID /),lonavIDpart,(/ 1,totpart /), & + 'degrees_east',.false.,'longitude_average','averaged longitude of particles') + call nf90_err(nf90_put_att(ncid, lonavIDpart, 'axis', 'Lon')) + call nf90_err(nf90_put_att(ncid, lonavIDpart, 'description', 'averaged longitude of particles')) + case ('LA') ! Latitude + call write_to_file(ncid,'latitude',nf90_float,(/ timeDimID,partDimID /),latIDpart,(/ 1,totpart /), & + 'degrees_north',.false.,'latitude','latitude in degree north') + call nf90_err(nf90_put_att(ncid, latIDpart, 'axis', 'Lat')) + call nf90_err(nf90_put_att(ncid, latIDpart, 'description', 'latitude of particles')) + case ('la') ! Latitude averaged + call write_to_file(ncid,'latitude_av',nf90_float,(/ timeDimID,partDimID /),latavIDpart,(/ 1,totpart /), & + 'degrees_north',.false.,'latitude_average','averaged latitude in degree north') + call nf90_err(nf90_put_att(ncid, latavIDpart, 'axis', 'Lat')) + call nf90_err(nf90_put_att(ncid, latavIDpart, 'description', 'averaged latitude of particles')) + case ('ZZ') ! Height + call write_to_file(ncid,'height',nf90_float,(/ timeDimID,partDimID /),levIDpart,(/ 1,totpart /), & + 'meters',.false.,'height','height above ground') + case ('zz') ! Heights averaged + call write_to_file(ncid,'height_av',nf90_float,(/ timeDimID,partDimID /),levavIDpart,(/ 1,totpart /), & + 'meters',.false.,'height_average','averaged height above ground') + case ('PV') ! Potential vorticity + call write_to_file(ncid,'pv',nf90_float,(/ timeDimID,partDimID /),pvID,(/ 1,totpart /), & + 'pvu',.false.,'potential_vorticity','potential vorticity') + case ('pv') ! Potential vorticity averaged + call write_to_file(ncid,'pv_av',nf90_float,(/ timeDimID,partDimID /),pvavID,(/ 1,totpart /), & + 'pvu',.false.,'potential_vorticity_average','averaged potential vorticity') + case ('PR') ! Pressure + call write_to_file(ncid,'pr',nf90_float,(/ timeDimID,partDimID /),prID,(/ 1,totpart /), & + 'Pa',.false.,'pressure','pressure') + case ('pr') ! Pressure averaged + call write_to_file(ncid,'pr_av',nf90_float,(/ timeDimID,partDimID /),pravID,(/ 1,totpart /), & + 'Pa',.false.,'pressure_average','averaged pressure') + case ('QV') ! Specific humidity + call write_to_file(ncid,'qv',nf90_float,(/ timeDimID,partDimID /),qvID,(/ 1,totpart /), & + '',.false.,'specific_humidity','specific humidity') + case ('qv') ! Specific humidity averaged + call write_to_file(ncid,'qv_av',nf90_float,(/ timeDimID,partDimID /),qvavID,(/ 1,totpart /), & + '',.false.,'specific_humidity_average','averaged specific humidity') + case ('RH') ! Density + call write_to_file(ncid,'rho',nf90_float,(/ timeDimID,partDimID /),rhoID,(/ 1,totpart /), & + 'kg/m3',.true.,'density','density') + case ('rh') ! Density averaged + call write_to_file(ncid,'rho_av',nf90_float,(/ timeDimID,partDimID /),rhoavID,(/ 1,totpart /), & + 'kg/m3',.true.,'density_average','averaged density') + case ('TT') ! Temperature + call write_to_file(ncid,'temperature',nf90_float,(/ timeDimID,partDimID /),ttID,(/ 1,totpart /), & + 'K',.true.,'temperature','temperature') + case ('tt') ! Temperature averaged + call write_to_file(ncid,'temperature_av',nf90_float,(/ timeDimID,partDimID /),ttavID,(/ 1,totpart /), & + 'K',.true.,'temperature_average','averaged temperature') + case ('UU') + call write_to_file(ncid,'u',nf90_float,(/ timeDimID,partDimID /),uID,(/ 1,totpart /), & + 'm/s',.false.,'u','longitudinal velocity') + case ('uu') + call write_to_file(ncid,'u_av',nf90_float,(/ timeDimID,partDimID /),uavID,(/ 1,totpart /), & + 'm/s',.false.,'u_av','averaged longitudinal velocity') + case ('VV') + call write_to_file(ncid,'v',nf90_float,(/ timeDimID,partDimID /),vID,(/ 1,totpart /), & + 'm/s',.false.,'v','latitudinal velocity') + case ('vv') + call write_to_file(ncid,'v_av',nf90_float,(/ timeDimID,partDimID /),vavID,(/ 1,totpart /), & + 'm/s',.false.,'v_average','latitudinal velocity averaged') + case ('WW') + call write_to_file(ncid,'w',nf90_float,(/ timeDimID,partDimID /),wID,(/ 1,totpart /), & + 'm/s',.false.,'w','vertical velocity') + case ('ww') + call write_to_file(ncid,'w_av',nf90_float,(/ timeDimID,partDimID /),wavID,(/ 1,totpart /), & + 'm/s',.false.,'w_average','vertical velocity averaged') + case ('VS') + call write_to_file(ncid,'settling',nf90_float,(/ timeDimID,partDimID /),vsetID,(/ 1,totpart /), & + 'm/s',.false.,'settling_velocity','settling velocity') + case ('vs') + call write_to_file(ncid,'settling_av',nf90_float,(/ timeDimID,partDimID /),vsetavID,(/ 1,totpart /), & + 'm/s',.false.,'settling_velocity_average','settling velocity averaged') + case ('MA') ! Mass + if (mdomainfill.ge.1) then + call nf90_err(nf90_def_var(ncid=ncid, name='mass', xtype=nf90_float, dimids=1, varid=massID(1))) + call nf90_err(nf90_put_att(ncid, massID(1), 'units', 'kg')) + call nf90_err(nf90_put_att(ncid, massID(1), '_FillValue', fillval)) + call nf90_err(nf90_put_att(ncid, massID(1), 'positive', 'up')) + call nf90_err(nf90_put_att(ncid, massID(1), 'standard_name', 'mass')) + call nf90_err(nf90_put_att(ncid, massID(1), 'long_name', 'mass of each particle')) + else + do j=1,nspec + ! Masses + write(anspec, '(i3.3)') j + call write_to_file(ncid,'mass'//anspec,nf90_float,(/ timeDimID,partDimID /),massID(j), & + (/ 1,totpart /),'kg',.true.,'mass'//anspec,'mass for nspec'//anspec) + end do + endif + case ('ma') ! Mass averaged + if (mdomainfill.ge.1) then + call nf90_err(nf90_def_var(ncid=ncid, name='mass_av', xtype=nf90_float, dimids=1, varid=massavID(1))) + call nf90_err(nf90_put_att(ncid, massavID(1), 'units', 'kg')) + call nf90_err(nf90_put_att(ncid, massavID(1), '_FillValue', fillval)) + call nf90_err(nf90_put_att(ncid, massavID(1), 'positive', 'up')) + call nf90_err(nf90_put_att(ncid, massavID(1), 'standard_name', 'mass')) + call nf90_err(nf90_put_att(ncid, massavID(1), 'long_name', 'averaged mass of each particle')) + else + do j=1,nspec + ! Masses averaged + write(anspec, '(i3.3)') j + call write_to_file(ncid,'mass_av'//anspec,nf90_float,(/ timeDimID,partDimID /),massavID(j), & + (/ 1,totpart /),'kg',.true.,'mass'//anspec,'averaged mass for nspec'//anspec) + end do + endif + case ('WD') ! Cumulative mass of wet deposition + do j=1,nspec + ! Masses + write(anspec, '(i3.3)') j + call write_to_file(ncid,'wetdepo'//anspec,nf90_float,(/ timeDimID,partDimID /),wdID(j), & + (/ 1,totpart /),'kg',.true.,'mass'//anspec,'cumulative wet deposition for nspec'//anspec) + end do + case ('DD') ! Cumulative mass of dry deposition + do j=1,nspec + ! Masses + write(anspec, '(i3.3)') j + call write_to_file(ncid,'drydepo'//anspec,nf90_float,(/ timeDimID,partDimID /),ddID(j), & + (/ 1,totpart /),'kg',.true.,'mass'//anspec,'cumulative dry deposition for nspec'//anspec) + end do + case ('TO') ! Topography, written to grid if domainfill + if (mdomainfill.lt.1) then + call write_to_file(ncid,'topo',nf90_float,(/ timeDimID,partDimID /),topoID,(/ 1,totpart /), & + 'meters',.false.,'topography','topography above sealevel') + else + call write_to_file(ncid,'topo',nf90_float,(/ lonDimID,latDimID /),topoID,(/ nx,ny /), & + 'meters',.false.,'topography','topography above sealevel') + endif + case ('to') ! Topography averaged, no grid when domainfill + call write_to_file(ncid,'topo_av',nf90_float,(/ timeDimID,partDimID /),topoavID,(/ 1,totpart /), & + 'meters',.false.,'topography','averaged topography above sealevel') + case ('HM') ! Mixing layer height + if (mdomainfill.lt.1) then + call write_to_file(ncid,'hmix',nf90_float,(/ timeDimID,partDimID /),hmixID,(/ 1,totpart /), & + 'meters',.true.,'hmix','height above ground of mixing layer') + else + call write_to_file(ncid,'hmix',nf90_float,(/ timeDimID,lonDimID,latDimID /),hmixID,(/ 1,nx,ny /), & + 'meters',.true.,'hmix','height above ground of mixing layer') + endif + case ('hm') ! Mixing layer height averaged + call write_to_file(ncid,'hmix_av',nf90_float,(/ timeDimID,partDimID /),hmixavID,(/ 1,totpart /), & + 'meters',.true.,'hmix_average','averaged height above ground of mixing layer') + case ('TR') ! Tropopause + if (mdomainfill.lt.1) then + call write_to_file(ncid,'tr',nf90_float,(/ timeDimID,partDimID /),trID,(/ 1,totpart /), & + 'meters',.true.,'htropo','height above ground of tropopause') + else + call write_to_file(ncid,'tr',nf90_float,(/ timeDimID,lonDimID,latDimID /),trID,(/ 1,nx,ny /), & + 'meters',.true.,'htropo','height above ground of tropopause') + endif + case ('tr') ! Tropopause averaged + call write_to_file(ncid,'tr_av',nf90_float,(/ timeDimID,partDimID /),travID,(/ 1,totpart /), & + 'meters',.true.,'htropo_average','averaged height above ground of tropopause') + case default + write(*,*) 'The field you are trying to write to file is not coded in yet: ', partopt(np)%long_name + stop + end select + end do + ! global (metadata) attributes + !******************************* + call writemetadata(ncid,lnest=.false.) + + ! moves the file from define to data mode + call nf90_err(nf90_enddef(ncid)) + + call nf90_err(nf90_close(ncid)) + + return +110 write(*,FMT='(80("#"))') + write(*,*) 'ERROR: output directory ', trim(path(2)(1:length(2))), ' does not exist& + & (or failed to write there).' + write(*,*) 'EXITING' + write(*,FMT='(80("#"))') + stop +end subroutine writeheader_partoutput diff --git a/src/net_writemetadata.f90 b/src/net_writemetadata.f90 new file mode 100644 index 0000000000000000000000000000000000000000..1f9b31583e656d9465b98fa1424ea019731fe65c --- /dev/null +++ b/src/net_writemetadata.f90 @@ -0,0 +1,79 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine writemetadata(ncid,lnest) + + implicit none + + integer, intent(in) :: ncid + logical, intent(in) :: lnest + integer :: status + character :: time*10,date*8,adate*8,atime*6 + character(5) :: zone + character(255) :: login_name, host_name + + ! gather system information + call date_and_time(date,time,zone) + call getlog(login_name) + call hostnm(host_name) + + ! hes CF convention requires these attributes + call nf90_err(nf90_put_att(ncid, nf90_global, 'Conventions', 'CF-1.6')) + call nf90_err(nf90_put_att(ncid, nf90_global, 'title', 'FLEXPART model output')) + call nf90_err(nf90_put_att(ncid, nf90_global, 'institution', trim(institution))) + call nf90_err(nf90_put_att(ncid, nf90_global, 'source', trim(flexversion)//' model output')) + call nf90_err(nf90_put_att(ncid, nf90_global, 'history', date(1:4)//'-'//date(5:6)// & + '-'//date(7:8)//' '//time(1:2)//':'//time(3:4)//' '//zone//' created by '// & + trim(login_name)//' on '//trim(host_name))) + call nf90_err(nf90_put_att(ncid, nf90_global, 'references', & + 'Stohl et al., Atmos. Chem. Phys., 2005, doi:10.5194/acp-5-2461-200')) + + ! attributes describing model run + !************************************************************************************ + + if (lnest) then + call nf90_err(nf90_put_att(ncid, nf90_global, 'outlon0', outlon0n)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'outlat0', outlat0n)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'dxout', dxoutn)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'dyout', dyoutn)) + else + call nf90_err(nf90_put_att(ncid, nf90_global, 'outlon0', outlon0)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'outlat0', outlat0)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'dxout', dxout)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'dyout', dyout)) + endif + ! vertical levels stored in grid structure + + ! COMMAND file settings + call nf90_err(nf90_put_att(ncid, nf90_global, 'ldirect', ldirect)) + write(adate,'(i8.8)') ibdate + write(atime,'(i6.6)') ibtime + call nf90_err(nf90_put_att(ncid, nf90_global, 'ibdate', adate)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'ibtime', atime)) + write(adate,'(i8.8)') iedate + write(atime,'(i6.6)') ietime + call nf90_err(nf90_put_att(ncid, nf90_global, 'iedate', adate)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'ietime', atime)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'loutstep', loutstep)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'loutaver', loutaver)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'loutsample', loutsample)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'itsplit', itsplit)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'lsynctime', lsynctime)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'ctl', ctl)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'ifine', ifine)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'iout', iout)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'ipout', ipout)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'lsubgrid', lsubgrid)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'lconvection', lconvection)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'lagespectra', lagespectra)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'ipin', ipin)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'ioutputforeachrelease', ioutputforeachrelease)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'iflux', iflux)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'mdomainfill', mdomainfill)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'ind_source', ind_source)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'ind_receptor', ind_receptor)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'mquasilag', mquasilag)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'nested_output', nested_output)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'surf_only', surf_only)) + call nf90_err(nf90_put_att(ncid, nf90_global, 'linit_cond', linit_cond)) +end subroutine writemetadata diff --git a/src/net_wrt_part_initialpos.f90 b/src/net_wrt_part_initialpos.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0d2b12aec027d8e52d74e807ad95c87b43a170f2 --- /dev/null +++ b/src/net_wrt_part_initialpos.f90 @@ -0,0 +1,54 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine wrt_part_initialpos(itime,istart,iend) + + !***************************************************************************** + ! * + ! This subroutine saves initial particle positions, release time and * + ! releasenumber to a NetCDF file created in particle_initialpos * + ! evertime a new particle is spawned. * + ! * + ! Author: L. Bakels 2022 * + ! * + !***************************************************************************** + + use particle_mod + + implicit none + + integer, intent(in) :: & + itime, & ! time of particle release + istart, & ! index of first newly released particle + iend ! index of last newly released partile + integer, allocatable :: partindices(:),releasetimes(:) + integer :: newpart,ncid,j + + newpart = iend-istart + if (newpart.eq.0) return + write(*,*) newpart, ' particles are being added to partinit.' + call nf90_err(nf90_open(trim(ncfname_partinit), nf90_write, ncid)) + + allocate ( partindices(newpart) ) + + do j=1,newpart + partindices(j)=j+partinitpointer + end do + + partinitpointer1= partinitpointer+1 ! this is also used in partinit_ncf + call nf90_err(nf90_put_var(ncid,partIDi,partindices,(/ partinitpointer1 /),(/ newpart /))) + deallocate (partindices) + + allocate ( releasetimes(newpart) ) + releasetimes=itime + call nf90_err(nf90_put_var(ncid,tIDi,releasetimes,(/ partinitpointer1 /),(/ newpart /))) + deallocate (releasetimes) + call nf90_err(nf90_put_var(ncid,lonIDi,xlon0+part(partinitpointer1:iend)%xlon*dx, (/ partinitpointer1 /),(/ newpart /))) + call nf90_err(nf90_put_var(ncid,latIDi,ylat0+part(partinitpointer1:iend)%ylat*dy, (/ partinitpointer1 /),(/ newpart /))) + call nf90_err(nf90_put_var(ncid,levIDi,part(partinitpointer1:iend)%z, (/ partinitpointer1 /),(/ newpart /))) + call nf90_err(nf90_put_var(ncid,relIDi,part(partinitpointer1:iend)%npoint, (/ partinitpointer1 /),(/ newpart /))) + + call nf90_err(nf90_close(ncid)) + + partinitpointer = partinitpointer+newpart +end subroutine wrt_part_initialpos diff --git a/src/netcdf_output_mod.f90 b/src/netcdf_output_mod.f90 index f96e2f3eb728a0f948750cb2c0e543582bff2215..562c9c26148ff642a534c839384193a90fd511cb 100644 --- a/src/netcdf_output_mod.f90 +++ b/src/netcdf_output_mod.f90 @@ -15,10 +15,10 @@ ! 12 April 2013 * ! * ! HSO: 21 Oct 2014 - ! - added option to not writeout releases information by changing + ! - added option to not writeout releases information by changing ! switch write_releases ! - additional updates for FLEXPART 9.x - ! + ! ! ESO 2016 ! - Deposition fields can be calculated in double precision, see variable ! 'dep_prec' in par_mod @@ -56,12 +56,12 @@ module netcdf_output_mod numparticlecount,receptorname, & memind,xreceptor,yreceptor,numreceptor,creceptor,iout, & itsplit, lsynctime, ctl, ifine, lagespectra, ipin, & - ioutputforeachrelease, iflux, mdomainfill, mquasilag, & + ioutputforeachrelease, iflux, mdomainfill, mquasilag, & nested_output, ipout, surf_only, linit_cond, & flexversion,mpi_mode,DRYBKDEP,WETBKDEP,numpart,numpoint, & partopt,num_partopt use windfields_mod, only: oro,rho,nxmax,height,nxmin1,nymin1,nz,nx,ny,hmix, & - ! for concoutput_ncf and concoutput_ncf_nest + ! for concoutput_ncf and concoutput_ncf_nest tropopause,oron,rhon,xresoln,yresoln,xrn,xln,yrn,yln,nxn,nyn use mean_mod @@ -115,7 +115,7 @@ module netcdf_output_mod real :: xp1,yp1,xp2,yp2 - private + private public :: writeheader_ncf, concoutput_sfc_ncf_nest, concoutput_ncf, & concoutput_ncf_nest, concoutput_sfc_ncf, writeheader_partoutput, partoutput_ncf, & @@ -127,2641 +127,49 @@ contains !**************************************************************** ! determine output units (see table 1 in Stohl et al., ACP 2005 !**************************************************************** -subroutine output_units(units) - implicit none - character(len=15), intent(out) :: units - if (ldirect.eq.1) then - ! forward simulation - if (ind_source.eq.1) then - if (ind_receptor.eq.1) then - units = 'ng m-3' ! hes the kg in Tab1 is only indicating the units of the relase not the output - else - units = 'ng kg-1' - endif - else - if (ind_receptor.eq.1) then - units = 'ng m-3' - else - units = 'ng kg-1' - endif - endif - else - ! backward simulation - if (ind_source.eq.1) then - if (ind_receptor.eq.1) then - units = 's' - else - units = 's m3 kg-1' - endif - else - if (ind_receptor.eq.1) then - units = 's kg m-3' - else - units = 's' - endif - endif - endif -end subroutine output_units +#include "net_output_units.f90" !**************************************************************** -! write metadata to netCDF file +! write metadata to netCDF file !**************************************************************** -subroutine writemetadata(ncid,lnest) - - implicit none - - integer, intent(in) :: ncid - logical, intent(in) :: lnest - integer :: status - character :: time*10,date*8,adate*8,atime*6 - character(5) :: zone - character(255) :: login_name, host_name - - ! gather system information - call date_and_time(date,time,zone) - call getlog(login_name) - call hostnm(host_name) - - ! hes CF convention requires these attributes - call nf90_err(nf90_put_att(ncid, nf90_global, 'Conventions', 'CF-1.6')) - call nf90_err(nf90_put_att(ncid, nf90_global, 'title', 'FLEXPART model output')) - call nf90_err(nf90_put_att(ncid, nf90_global, 'institution', trim(institution))) - call nf90_err(nf90_put_att(ncid, nf90_global, 'source', trim(flexversion)//' model output')) - call nf90_err(nf90_put_att(ncid, nf90_global, 'history', date(1:4)//'-'//date(5:6)// & - '-'//date(7:8)//' '//time(1:2)//':'//time(3:4)//' '//zone//' created by '// & - trim(login_name)//' on '//trim(host_name))) - call nf90_err(nf90_put_att(ncid, nf90_global, 'references', & - 'Stohl et al., Atmos. Chem. Phys., 2005, doi:10.5194/acp-5-2461-200')) - - ! attributes describing model run - !************************************************************************************ - - if (lnest) then - call nf90_err(nf90_put_att(ncid, nf90_global, 'outlon0', outlon0n)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'outlat0', outlat0n)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'dxout', dxoutn)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'dyout', dyoutn)) - else - call nf90_err(nf90_put_att(ncid, nf90_global, 'outlon0', outlon0)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'outlat0', outlat0)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'dxout', dxout)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'dyout', dyout)) - endif - ! vertical levels stored in grid structure - - ! COMMAND file settings - call nf90_err(nf90_put_att(ncid, nf90_global, 'ldirect', ldirect)) - write(adate,'(i8.8)') ibdate - write(atime,'(i6.6)') ibtime - call nf90_err(nf90_put_att(ncid, nf90_global, 'ibdate', adate)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'ibtime', atime)) - write(adate,'(i8.8)') iedate - write(atime,'(i6.6)') ietime - call nf90_err(nf90_put_att(ncid, nf90_global, 'iedate', adate)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'ietime', atime)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'loutstep', loutstep)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'loutaver', loutaver)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'loutsample', loutsample)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'itsplit', itsplit)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'lsynctime', lsynctime)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'ctl', ctl)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'ifine', ifine)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'iout', iout)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'ipout', ipout)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'lsubgrid', lsubgrid)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'lconvection', lconvection)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'lagespectra', lagespectra)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'ipin', ipin)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'ioutputforeachrelease', ioutputforeachrelease)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'iflux', iflux)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'mdomainfill', mdomainfill)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'ind_source', ind_source)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'ind_receptor', ind_receptor)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'mquasilag', mquasilag)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'nested_output', nested_output)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'surf_only', surf_only)) - call nf90_err(nf90_put_att(ncid, nf90_global, 'linit_cond', linit_cond)) -end subroutine writemetadata - - -subroutine nf90_err(status) - !**************************************************************** - ! netcdf error message handling - !**************************************************************** - implicit none - integer, intent (in) :: status - if(status /= nf90_noerr) then - print *, trim(nf90_strerror(status)) - stop 'Stopped' - end if -end subroutine nf90_err - -subroutine writeheader_ncf(lnest) - - !**************************************************************** - ! Create netcdf file and write header/metadata information - ! lnest = .false. : Create main output file - ! lnest = .true. : Create nested output file - !**************************************************************** - implicit none - - logical, intent(in) :: lnest - - integer :: ncid, sID, wdsID, ddsID - integer :: timeDimID, latDimID, lonDimID, levDimID, receptorDimID - integer :: nspecDimID, npointDimID, nageclassDimID, ncharDimID, pointspecDimID - integer :: tID, lonID, latID, levID, poleID, lageID, oroID, ncharrecDimID - integer :: volID, areaID - integer :: rellng1ID, rellng2ID, rellat1ID, rellat2ID, relzz1ID, relzz2ID - integer :: relcomID, relkindzID, relstartID, relendID, relpartID, relxmassID - integer :: nnx, nny - integer, dimension(6) :: dIDs - integer, dimension(5) :: depdIDs - character(len=255) :: fname - character(len=15) :: units - character(len=20) :: fprefix - character(len=3) :: anspec - CHARACTER :: adate*8,atime*6,timeunit*32 - !REAL, DIMENSION(1000) :: coord - real, allocatable, dimension(:) :: coord - - integer :: cache_size - integer, dimension(6) :: chunksizes - integer, dimension(5) :: dep_chunksizes - - integer :: i,ix,jy - integer :: test_unit - - - ! Check if output directory exists (the netcdf library will - ! otherwise give an error which can look confusing). - ! ********************************************************************* - open(unit=unittmp,file=trim(path(2)(1:length(2)))//'test_dir.txt',status='replace',& - &err=100) - close (unittmp, status='delete') - goto 101 -100 write(*,FMT='(80("#"))') - write(*,*) 'ERROR: output directory ', trim(path(2)(1:length(2))), ' does not exist& - & (or failed to write there).' - write(*,*) 'EXITING' - write(*,FMT='(80("#"))') - stop -101 continue - - !************************ - ! Create netcdf file - !************************ - - if (ldirect.eq.1) then - write(adate,'(i8.8)') ibdate - write(atime,'(i6.6)') ibtime - fprefix = 'grid_conc_' - else - write(adate,'(i8.8)') iedate - write(atime,'(i6.6)') ietime - fprefix = 'grid_time_' - endif - if (DRYBKDEP) fprefix='grid_drydep_' - if (WETBKDEP) fprefix='grid_wetdep_' - - if (lnest) then - fname = path(2)(1:length(2))//trim(fprefix)//adate//atime//'_nest.nc' - ncfnamen = fname - nnx = numxgridn - nny = numygridn - else - fname = path(2)(1:length(2))//trim(fprefix)//adate//atime//'.nc' - ncfname = fname - nnx = numxgrid - nny = numygrid - endif - - cache_size = 16 * nnx * nny * numzgrid - - ! If starting from a restart file, new data will be added to the existing grid file - if ((ipin.eq.1).or.(ipin.eq.4)) then - call read_grid_id(lnest) - return - endif - - ! setting cache size in bytes. It is set to 4 times the largest data block that is written - ! size_type x nx x ny x nz - ! create file - call nf90_err(nf90_create(trim(fname), cmode = nf90_hdf5, ncid = ncid, & - cache_size = cache_size)) - - ! create dimensions: - !************************* - ! time - call nf90_err(nf90_def_dim(ncid, 'time', nf90_unlimited, timeDimID)) - timeunit = 'seconds since '//adate(1:4)//'-'//adate(5:6)// & - '-'//adate(7:8)//' '//atime(1:2)//':'//atime(3:4) - - ! lon - call nf90_err(nf90_def_dim(ncid, 'longitude', nnx, lonDimID)) - ! lat - call nf90_err(nf90_def_dim(ncid, 'latitude', nny, latDimID)) - ! level - call nf90_err(nf90_def_dim(ncid, 'height', numzgrid, levDimID)) - ! number of species - call nf90_err(nf90_def_dim(ncid, 'numspec', nspec, nspecDimID)) - ! number of release points - call nf90_err(nf90_def_dim(ncid, 'pointspec', maxpointspec_act, pointspecDimID)) - ! number of age classes - call nf90_err(nf90_def_dim(ncid, 'nageclass', nageclass, nageclassDimID)) - ! dimension for release point characters - call nf90_err(nf90_def_dim(ncid, 'nchar', 45, ncharDimID)) - ! dimension for receptor point characters - call nf90_err(nf90_def_dim(ncid, 'ncharrec', 16, ncharrecDimID)) - ! number of actual release points - call nf90_err(nf90_def_dim(ncid, 'numpoint', numpoint, npointDimID)) - - - ! create variables - !************************* - - ! time - call nf90_err(nf90_def_var(ncid, 'time', nf90_int, (/ timeDimID /), tID)) - call nf90_err(nf90_put_att(ncid, tID, 'units', timeunit)) - call nf90_err(nf90_put_att(ncid, tID, 'calendar', 'proleptic_gregorian')) - if (lnest) then - timeIDn = tID - else - timeID = tID - endif - - ! lon - call nf90_err(nf90_def_var(ncid, 'longitude', nf90_float, (/ lonDimID /), lonID)) - call nf90_err(nf90_put_att(ncid, lonID, 'long_name', 'longitude in degree east')) - call nf90_err(nf90_put_att(ncid, lonID, 'axis', 'Lon')) - call nf90_err(nf90_put_att(ncid, lonID, 'units', 'degrees_east')) - call nf90_err(nf90_put_att(ncid, lonID, 'standard_name', 'grid_longitude')) - call nf90_err(nf90_put_att(ncid, lonID, 'description', 'grid cell centers')) - - ! lat - call nf90_err(nf90_def_var(ncid, 'latitude', nf90_float, (/ latDimID /), latID)) - call nf90_err(nf90_put_att(ncid, latID, 'long_name', 'latitude in degree north')) - call nf90_err(nf90_put_att(ncid, latID, 'axis', 'Lat')) - call nf90_err(nf90_put_att(ncid, latID, 'units', 'degrees_north')) - call nf90_err(nf90_put_att(ncid, latID, 'standard_name', 'grid_latitude')) - call nf90_err(nf90_put_att(ncid, latID, 'description', 'grid cell centers')) - - - ! height - call nf90_err(nf90_def_var(ncid, 'height', nf90_float, (/ levDimID /), levID)) - ! call nf90_err(nf90_put_att(ncid, levID, 'axis', 'Z')) - call nf90_err(nf90_put_att(ncid, levID, 'units', 'meters')) - call nf90_err(nf90_put_att(ncid, levID, 'positive', 'up')) - call nf90_err(nf90_put_att(ncid, levID, 'standard_name', 'height')) - call nf90_err(nf90_put_att(ncid, levID, 'long_name', 'height above ground')) - - ! volume - if (write_vol) call nf90_err(nf90_def_var(ncid, 'volume', nf90_float, & - &(/ lonDimID, latDimID, levDimID /), volID)) - ! area - if (write_area) call nf90_err(nf90_def_var(ncid, 'area', nf90_float, & - &(/ lonDimID, latDimID /), areaID)) - - - if (write_releases.eqv..true.) then - ! release comment - call nf90_err(nf90_def_var(ncid, 'RELCOM', nf90_char, (/ ncharDimID,npointDimID /), & - relcomID)) - call nf90_err(nf90_put_att(ncid, relcomID, 'long_name', 'release point name')) - ! release longitude 1 - call nf90_err(nf90_def_var(ncid, 'RELLNG1', nf90_float, (/ npointDimID /), rellng1ID)) - call nf90_err(nf90_put_att(ncid, rellng1ID, 'units', 'degrees_east')) - call nf90_err(nf90_put_att(ncid, rellng1ID, 'long_name', & - 'release longitude lower left corner')) - ! release longitude 2 - call nf90_err(nf90_def_var(ncid, 'RELLNG2', nf90_float, (/ npointDimID /), rellng2ID)) - call nf90_err(nf90_put_att(ncid, rellng2ID, 'units', 'degrees_east')) - call nf90_err(nf90_put_att(ncid, rellng2ID, 'long_name', & - 'release longitude upper right corner')) - ! release latitude 1 - call nf90_err(nf90_def_var(ncid, 'RELLAT1', nf90_float, (/ npointDimID /), rellat1ID)) - call nf90_err(nf90_put_att(ncid, rellat1ID, 'units', 'degrees_north')) - call nf90_err(nf90_put_att(ncid, rellat1ID, 'long_name', & - 'release latitude lower left corner')) - ! release latitude 2 - call nf90_err(nf90_def_var(ncid, 'RELLAT2', nf90_float, (/ npointDimID /), rellat2ID)) - call nf90_err(nf90_put_att(ncid, rellat2ID, 'units', 'degrees_north')) - call nf90_err(nf90_put_att(ncid, rellat2ID, 'long_name', & - 'release latitude upper right corner')) - - ! hes: if rotated_ll it would be convenient also to write the the release points in rotated_coordinates - - ! release height bottom - call nf90_err(nf90_def_var(ncid, 'RELZZ1', nf90_float, (/ npointDimID /), relzz1ID)) - call nf90_err(nf90_put_att(ncid, relzz1ID, 'units', 'meters')) - call nf90_err(nf90_put_att(ncid, relzz1ID, 'long_name', 'release height bottom')) - ! release height top - call nf90_err(nf90_def_var(ncid, 'RELZZ2', nf90_float, (/ npointDimID /), relzz2ID)) - call nf90_err(nf90_put_att(ncid, relzz2ID, 'units', 'meters')) - call nf90_err(nf90_put_att(ncid, relzz2ID, 'long_name', 'release height top')) - ! release kind - call nf90_err(nf90_def_var(ncid, 'RELKINDZ', nf90_int, (/ npointDimID /), relkindzID)) - call nf90_err(nf90_put_att(ncid, relkindzID, 'long_name', 'release kind')) - ! release start - call nf90_err(nf90_def_var(ncid, 'RELSTART', nf90_int, (/ npointDimID /), relstartID)) - call nf90_err(nf90_put_att(ncid, relstartID, 'units', 'seconds')) - call nf90_err(nf90_put_att(ncid, relstartID, 'long_name', & - 'release start relative to simulation start')) - ! release end - call nf90_err(nf90_def_var(ncid, 'RELEND', nf90_int, (/ npointDimID /), relendID)) - call nf90_err(nf90_put_att(ncid, relendID, 'units', 'seconds')) - call nf90_err(nf90_put_att(ncid, relendID, 'long_name', & - 'release end relative to simulation start')) - ! release particles - call nf90_err(nf90_def_var(ncid, 'RELPART', nf90_int, (/ npointDimID /), relpartID)) - call nf90_err(nf90_put_att(ncid, relpartID, 'long_name', 'number of release particles')) - ! release particle masses - call nf90_err(nf90_def_var(ncid, 'RELXMASS', nf90_float, (/ npointDimID, nspecDimID /), & - relxmassID)) - call nf90_err(nf90_put_att(ncid, relxmassID, 'long_name', 'total release particle mass')) - end if - - ! age classes - call nf90_err(nf90_def_var(ncid, 'LAGE', nf90_int, (/ nageclassDimID /), lageID)) - call nf90_err(nf90_put_att(ncid, lageID, 'units', 'seconds')) - call nf90_err(nf90_put_att(ncid, lageID, 'long_name', 'age class')) - - ! output orography - if (.not. min_size) then - call nf90_err(nf90_def_var(ncid, 'ORO', nf90_int, (/ lonDimID, latDimID /), oroID, & - deflate_level=deflate_level, chunksizes= (/ nnx, nny /))) - call nf90_err(nf90_put_att(ncid, oroID, 'standard_name', 'surface altitude')) - call nf90_err(nf90_put_att(ncid, oroID, 'long_name', 'outgrid surface altitude')) - call nf90_err(nf90_put_att(ncid, oroID, 'units', 'm')) - end if - - ! Receptors - if (numreceptor.ge.1) then - call nf90_err(nf90_def_dim(ncid, 'receptor', nf90_unlimited, receptorDimID)) - call nf90_err(nf90_def_var(ncid, 'receptor', nf90_char, (/ ncharrecDimID,receptorDimID /), sID)) - call nf90_err(nf90_put_var(ncid, sID, receptorname, (/ 1,1 /), (/ 16,numreceptor /))) - call nf90_err(nf90_put_att(ncid, sID, 'long_name', 'receptor name')) - endif - - ! concentration output, wet and dry deposition variables (one per species) - call output_units(units) - - dIDs = (/ londimid, latdimid, levdimid, timedimid, pointspecdimid, nageclassdimid /) - depdIDs = (/ londimid, latdimid, timedimid, pointspecdimid, nageclassdimid /) - if (lnest) then - dimidsn = dIDs - depdimidsn = depdIDs - else - dimids = dIDs - depdimids = depdIDs - endif - - ! set chunksizes according to largest written portion of data in an individual call to - ! nf90_put_var - if (int(nnx,kind=8)*int(nny,kind=8)*int(numzgrid,kind=8).gt.2147483647) then ! Larger than an - chunksizes = (/ nnx, nny, 1, 1, 1, 1 /) - else - chunksizes = (/ nnx, nny, numzgrid, 1, 1, 1 /) - endif - dep_chunksizes = (/ nnx, nny, 1, 1, 1 /) - - do i = 1,nspec - write(anspec,'(i3.3)') i - - ! concentration output - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - call nf90_err(nf90_def_var(ncid,'spec'//anspec//'_mr', nf90_float, dIDs, sID , & - deflate_level = deflate_level, & - chunksizes = chunksizes )) - call nf90_err(nf90_put_att(ncid, sID, 'units', units)) - call nf90_err(nf90_put_att(ncid, sID, 'long_name', species(i))) - call nf90_err(nf90_put_att(ncid, sID, 'decay', decay(i))) - call nf90_err(nf90_put_att(ncid, sID, 'weightmolar', weightmolar(i))) - ! call nf90_err(nf90_put_att(ncid, sID, 'ohreact', ohreact(i))) - call nf90_err(nf90_put_att(ncid, sID, 'ohcconst', ohcconst(i))) - call nf90_err(nf90_put_att(ncid, sID, 'ohdconst', ohdconst(i))) - call nf90_err(nf90_put_att(ncid, sID, 'vsetaver', vsetaver(i))) - - if (lnest) then - specIDn(i) = sID - else - specID(i) = sID - endif - endif - - ! mixing ratio output - if ((iout.eq.2).or.(iout.eq.3)) then - call nf90_err(nf90_def_var(ncid,'spec'//anspec//'_pptv', nf90_float, dIDs, sID , & - deflate_level = deflate_level, & - chunksizes = chunksizes )) - call nf90_err(nf90_put_att(ncid, sID, 'units', 'pptv')) - call nf90_err(nf90_put_att(ncid, sID, 'long_name', species(i))) - call nf90_err(nf90_put_att(ncid, sID, 'decay', decay(i))) - call nf90_err(nf90_put_att(ncid, sID, 'weightmolar', weightmolar(i))) - ! call nf90_err(nf90_put_att(ncid, sID, 'ohreact', ohreact(i))) - call nf90_err(nf90_put_att(ncid, sID, 'ohcconst', ohcconst(i))) - call nf90_err(nf90_put_att(ncid, sID, 'ohdconst', ohdconst(i))) - call nf90_err(nf90_put_att(ncid, sID, 'vsetaver', vsetaver(i))) - - if (lnest) then - specIDnppt(i) = sID - else - specIDppt(i) = sID - endif - endif - - ! wet and dry deposition fields for forward runs - if ((ldirect.eq.1).and.(wetdep)) then - call nf90_err(nf90_def_var(ncid,'WD_spec'//anspec, nf90_float, depdIDs, & - wdsID, deflate_level = deflate_level, & - chunksizes = dep_chunksizes)) - call nf90_err(nf90_put_att(ncid, wdsID, 'units', '1e-12 kg m-2')) - call nf90_err(nf90_put_att(ncid, wdsID, 'weta_gas', weta_gas(i))) - call nf90_err(nf90_put_att(ncid, wdsID, 'wetb_gas', wetb_gas(i))) - call nf90_err(nf90_put_att(ncid, wdsID, 'ccn_aero', ccn_aero(i))) - call nf90_err(nf90_put_att(ncid, wdsID, 'in_aero', in_aero(i))) - ! call nf90_err(nf90_put_att(ncid, wdsID, 'wetc_in', wetc_in(i))) - ! call nf90_err(nf90_put_att(ncid, wdsID, 'wetd_in', wetd_in(i))) - call nf90_err(nf90_put_att(ncid, wdsID, 'dquer', dquer(i))) - call nf90_err(nf90_put_att(ncid, wdsID, 'henry', henry(i))) - if (lnest) then - wdspecIDn(i) = wdsID - else - wdspecID(i) = wdsID - endif - endif - if ((ldirect.eq.1).and.(drydep)) then - call nf90_err(nf90_def_var(ncid,'DD_spec'//anspec, nf90_float, depdIDs, & - ddsID, deflate_level = deflate_level, & - chunksizes = dep_chunksizes)) - call nf90_err(nf90_put_att(ncid, ddsID, 'units', '1e-12 kg m-2')) - call nf90_err(nf90_put_att(ncid, ddsID, 'dryvel', dryvel(i))) - call nf90_err(nf90_put_att(ncid, ddsID, 'reldiff', reldiff(i))) - call nf90_err(nf90_put_att(ncid, ddsID, 'henry', henry(i))) - call nf90_err(nf90_put_att(ncid, ddsID, 'f0', f0(i))) - call nf90_err(nf90_put_att(ncid, ddsID, 'dquer', dquer(i))) - call nf90_err(nf90_put_att(ncid, ddsID, 'density', density(i))) - call nf90_err(nf90_put_att(ncid, ddsID, 'dsigma', dsigma(i))) - if (lnest) then - ddspecIDn(i) = ddsID - else - ddspecID(i) = ddsID - endif - endif - ! RECEPTORS - if (numreceptor.ge.1) then - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - call write_to_file(ncid,'receptor_conc'//anspec, nf90_float, (/ timeDimID,receptorDimID /), & - sID, (/ 1, numreceptor /), 'ng m-3', .true., 'receptor_conc', 'receptor_concentration') - recconcID(i)=sID - endif - if ((iout.eq.2).or.(iout.eq.3)) then - call write_to_file(ncid,'receptor_pptv'//anspec, nf90_float, (/ timeDimID,receptorDimID /), & - sID, (/ 1, numreceptor /), 'pptv', .true., 'receptor_pptv', 'receptor_mixingratio') - recpptvID(i)=sID - endif - endif - end do - - ! global (metadata) attributes - !******************************* - call writemetadata(ncid,lnest) - - - ! moves the file from define to data mode - call nf90_err(nf90_enddef(ncid)) - - ! ! hes: inquire var definition - ! do i = 1,nspec - ! write(anspec,'(i3.3)') i - ! - ! ! concentration output - ! if (iout.eq.1.or.iout.eq.3.or.iout.eq.5) then - ! if (lnest) then - ! sID = specIDn(i) - ! else - ! sID = specID(i) - ! endif - ! call nf90_err(nf90_inquire_variable(ncid, sID, chunksizes=inq_chunksizes)) - ! write(*,*) "Chunksizes for var "//anspec//": ", inq_chunksizes - ! endif - ! end do - - - ! fill with data - !****************************** - ! longitudes (grid cell centers) - if (lnest) then - if (.not.allocated(coord)) allocate(coord(numxgridn)) - do i = 1,numxgridn - coord(i) = outlon0n + (i-0.5)*dxoutn - enddo - call nf90_err(nf90_put_var(ncid, lonID, coord(1:numxgridn))) - deallocate(coord) - else - if (.not.allocated(coord)) allocate(coord(numxgrid)) - do i = 1,numxgrid - coord(i) = outlon0 + (i-0.5)*dxout - enddo - call nf90_err(nf90_put_var(ncid, lonID, coord(1:numxgrid))) - deallocate(coord) - endif - ! latitudes (grid cell centers) - if (lnest) then - if (.not.allocated(coord)) allocate(coord(numygridn)) - do i = 1,numygridn - coord(i) = outlat0n + (i-0.5)*dyoutn - enddo - call nf90_err(nf90_put_var(ncid, latID, coord(1:numygridn))) - deallocate(coord) - else - if (.not.allocated(coord)) allocate(coord(numygrid)) - do i = 1,numygrid - coord(i) = outlat0 + (i-0.5)*dyout - enddo - call nf90_err(nf90_put_var(ncid, latID, coord(1:numygrid))) - deallocate(coord) - endif - ! levels - call nf90_err(nf90_put_var(ncid, levID, outheight(1:numzgrid))) - - ! volume - if (write_vol) then - if (lnest) then - call nf90_err(nf90_put_var(ncid, volID, volumen(:,:,:))) - else - call nf90_err(nf90_put_var(ncid, volID, volume(:,:,:))) - end if - end if - - ! area - if (write_area) then - if (lnest) then - call nf90_err(nf90_put_var(ncid, areaID, arean(:,:))) - else - call nf90_err(nf90_put_var(ncid, areaID, area(:,:))) - end if - end if - - if ((write_releases.eqv..true.).and.(ipin.ne.3).and.(ipin.ne.4)) then - ! release point information - do i = 1,numpoint - call nf90_err(nf90_put_var(ncid, relstartID, ireleasestart(i), (/i/))) - call nf90_err(nf90_put_var(ncid, relendID, ireleaseend(i), (/i/))) - call nf90_err(nf90_put_var(ncid, relkindzID, kindz(i), (/i/))) - xp1=xpoint1(i)*dx+xlon0 - yp1=ypoint1(i)*dy+ylat0 - xp2=xpoint2(i)*dx+xlon0 - yp2=ypoint2(i)*dy+ylat0 - call nf90_err(nf90_put_var(ncid, rellng1ID, xp1, (/i/))) - call nf90_err(nf90_put_var(ncid, rellng2ID, xp2, (/i/))) - call nf90_err(nf90_put_var(ncid, rellat1ID, yp1, (/i/))) - call nf90_err(nf90_put_var(ncid, rellat2ID, yp2, (/i/))) - call nf90_err(nf90_put_var(ncid, relzz1ID, zpoint1(i), (/i/))) - call nf90_err(nf90_put_var(ncid, relzz2ID, zpoint2(i), (/i/))) - call nf90_err(nf90_put_var(ncid, relpartID, npart(i), (/i/))) - if ((i .le. 1000).and.(ipin.ne.3).and.(ipin.ne.4)) then - call nf90_err(nf90_put_var(ncid, relcomID, compoint(i), (/1,i/), (/45,1/))) - else - call nf90_err(nf90_put_var(ncid, relcomID, 'NA', (/1,i/), (/45,1/))) - endif - call nf90_err(nf90_put_var(ncid, relxmassID, xmass(i,1:nspec), (/i,1/), (/1,nspec/))) - end do - end if - - ! age classes - call nf90_err(nf90_put_var(ncid, lageID, lage(1:nageclass))) - - ! orography - if (.not. min_size) then - if (lnest) then - call nf90_err(nf90_put_var(ncid, oroID, orooutn(0:(nnx-1), 0:(nny-1)))) - else - call nf90_err(nf90_put_var(ncid, oroID, oroout(0:(nnx-1), 0:(nny-1)))) - endif - end if - - call nf90_err(nf90_close(ncid)) - - return -end subroutine writeheader_ncf - -subroutine read_grid_id(lnest) - - implicit none - logical, intent(in) :: lnest - - integer :: ncid,i - character(len=3) :: anspec - - if (.not. lnest) then - ! open output file - call nf90_err(nf90_open(trim(ncfname), nf90_write, ncid)) - - call nf90_err(nf90_inq_varid(ncid=ncid,name='time',varid=timeID)) - - do i = 1,nspec - write(anspec,'(i3.3)') i - - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_mr',varid=specID(i))) - endif - if ((iout.eq.2).or.(iout.eq.3)) then - call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_pptv',varid=specIDppt(i))) - endif - if ((ldirect.eq.1).and.(wetdep)) then - call nf90_err(nf90_inq_varid(ncid=ncid,name='WD_spec'//anspec,varid=wdspecID(i))) - endif - if ((ldirect.eq.1).and.(drydep)) then - call nf90_err(nf90_inq_varid(ncid=ncid,name='DD_spec'//anspec,varid=ddspecID(i))) - endif - end do - - else - - ! open output file - call nf90_err(nf90_open(trim(ncfnamen), nf90_write, ncid)) - - call nf90_err(nf90_inq_varid(ncid=ncid,name='time',varid=timeIDn)) - - do i = 1,nspec - write(anspec,'(i3.3)') i - - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_mr',varid=specIDn(i))) - endif - if ((iout.eq.2).or.(iout.eq.3)) then - call nf90_err(nf90_inq_varid(ncid=ncid,name='spec'//anspec//'_pptv',varid=specIDnppt(i))) - endif - if ((ldirect.eq.1).and.(wetdep)) then - call nf90_err(nf90_inq_varid(ncid=ncid,name='WD_spec'//anspec,varid=wdspecIDn(i))) - endif - if ((ldirect.eq.1).and.(drydep)) then - call nf90_err(nf90_inq_varid(ncid=ncid,name='DD_spec'//anspec,varid=ddspecIDn(i))) - endif - end do - endif - - call nf90_err(nf90_close(ncid)) - -end subroutine read_grid_id - -subroutine concoutput_ncf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) - - ! i i o o - ! o - !***************************************************************************** - ! * - ! 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 module 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 * - ! * - ! February 2010, Dominik Brunner, Empa * - ! Adapted for COSMO * - ! Remark: calculation of density could be improved. * - ! Currently, it is calculated for the lower left corner * - ! of each output grid cell rather than for its center. * - ! Furthermore, the average density could be calculated * - ! from the difference in pressure at the top and bottom * - ! of each cell rather than by interpolation. * - ! * - ! April 2013, Dominik Brunner, Empa * - ! Adapted for netcdf output * - ! * - ! 2022, Lucie Bakels: * - ! - OpenMP parallelisation * - ! - Receptor output to NetCDF instead of binary format * - ! * - !***************************************************************************** - ! * - ! 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, only: gridunc,drygridunc,wetgridunc,drygridunc0,wetgridunc0 - - implicit none - - integer, intent(in) :: itime - real, intent(in) :: outnum - real(dep_prec),intent(out):: wetgridtotalunc,drygridtotalunc - real, intent(out) :: gridtotalunc - real :: densityoutrecept(maxreceptor),recout(maxreceptor) - integer :: ncid,kp,ks,kz,ix,jy,iix,jjy,kzz,kzzm1,ngrid - integer :: nage,i,l,jj - real :: tot_mu(maxspec,maxpointspec_act) - real :: halfheight,dz,dz1,dz2 - real :: xl,yl,xlrot,ylrot,zagnd,zagndprev - real(dep_prec) :: auxgrid(nclassunc) - real(dep_prec) :: gridtotal,gridsigmatotal - real(dep_prec) :: wetgridtotal,wetgridsigmatotal - real(dep_prec) :: drygridtotal,drygridsigmatotal - ! real(sp) :: gridtotal,gridsigmatotal - ! real(sp) :: wetgridtotal,wetgridsigmatotal - ! real(sp) :: drygridtotal,drygridsigmatotal - - real, parameter :: weightair=28.97 - - eps=nxmax/3.e5 - - ! open output file - call nf90_err(nf90_open(trim(ncfname), nf90_write, ncid)) - - ! write time - tpointer = tpointer + 1 - call nf90_err(nf90_put_var( ncid, timeID, itime, (/ tpointer /))) - - ! 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.0 - 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 - - - gridtotal=0. - gridsigmatotal=0. - gridtotalunc=0. - wetgridtotal=0._dep_prec - wetgridsigmatotal=0._dep_prec - wetgridtotalunc=0._dep_prec - drygridtotal=0._dep_prec - drygridsigmatotal=0._dep_prec - drygridtotalunc=0._dep_prec - - !******************************************************************* - ! Compute air density: - ! brd134: we now take into account whether we are in the mother or in - ! a nested domain (before only from mother domain) - ! Determine center altitude of output layer, and interpolate density - ! data to that altitude - !******************************************************************* -!$OMP PARALLEL PRIVATE(halfheight,kzz,dz1,dz2,dz,xl,yl,ngrid,iix,jjy, & -!$OMP kz,ix,jy,l,ks,kp,nage,auxgrid) REDUCTION(+:wetgridtotal,wetgridsigmatotal, & -!$OMP drygridtotal,drygridsigmatotal,gridtotal,gridsigmatotal) -!$OMP DO - 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)) exit - end do - 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 - ! grid index in mother domain - xl=(xl-xlon0)/dx - yl=(yl-ylat0)/dx - - ngrid=0 - do jj=numbnests,1,-1 - if ( xl.gt.xln(jj)+eps .and. xl.lt.xrn(jj)-eps .and. & - yl.gt.yln(jj)+eps .and. yl.lt.yrn(jj)-eps ) then - ngrid=jj - exit - end if - end do - - if (ngrid.eq.0) then - iix=max(min(nint(xl),nxmin1),0) ! if output grid cell is outside mother domain - jjy=max(min(nint(yl),nymin1),0) - - densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,memind(2))*dz1+ & - rho(iix,jjy,kzz-1,memind(2))*dz2)/dz - else - xl=(xl-xln(ngrid))*xresoln(ngrid) - yl=(yl-yln(ngrid))*yresoln(ngrid) - iix=max(min(nint(xl),nxn(ngrid)-1),0) - jjy=max(min(nint(yl),nyn(ngrid)-1),0) - - densityoutgrid(ix,jy,kz)=(rhon(iix,jjy,kzz,memind(2), ngrid)*dz1+ & - rhon(iix,jjy,kzz-1,memind(2), ngrid)*dz2)/dz - endif - end do - end do - end do -!$OMP END DO NOWAIT - - ! brd134: for receptor points no option for nests yet to specify density - ! and also altitude zreceptor not considered yet (needs revision) - if (numreceptor.gt.0) then -!$OMP 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,memind(2)) - end do -!$OMP END DO NOWAIT - endif - - ! Output is different for forward and backward simulations - if (ldirect.eq.1) then -!$OMP DO - do kz=1,numzgrid - do jy=0,numygrid-1 - do ix=0,numxgrid-1 - factor3d(ix,jy,kz)=1.e12/volume(ix,jy,kz)/outnum - end do - end do - end do -!$OMP END DO - else -!$OMP DO - do kz=1,numzgrid - do jy=0,numygrid-1 - do ix=0,numxgrid-1 - factor3d(ix,jy,kz)=real(abs(loutaver))/outnum - end do - end do - end do -!$OMP END DO - endif - - !********************************************************************* - ! 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 - - do kp=1,maxpointspec_act - do nage=1,nageclass -!$OMP DO - do jy=0,numygrid-1 - do ix=0,numxgrid-1 - - ! WET DEPOSITION - if ((wetdep).and.(ldirect.gt.0)) then - if (mpi_mode.gt.0) then - do l=1,nclassunc - auxgrid(l)=wetgridunc0(ix,jy,ks,kp,l,nage) - end do - else - do l=1,nclassunc - auxgrid(l)=wetgridunc(ix,jy,ks,kp,l,nage) - end do - end if - 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)*real(nclassunc,kind=sp) - wetgridtotal=wetgridtotal+wetgrid(ix,jy) - ! Calculate standard deviation of the mean - wetgridsigma(ix,jy)= & - wetgridsigma(ix,jy)* & - sqrt(real(nclassunc,kind=dep_prec)) - wetgridsigmatotal=wetgridsigmatotal+ & - wetgridsigma(ix,jy) - endif - - ! DRY DEPOSITION - if ((drydep).and.(ldirect.gt.0)) then - if (mpi_mode.gt.0) then - do l=1,nclassunc - auxgrid(l)=drygridunc0(ix,jy,ks,kp,l,nage) - end do - else - do l=1,nclassunc - auxgrid(l)=drygridunc(ix,jy,ks,kp,l,nage) - end do - end if - 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)*real(nclassunc,kind=sp) - drygridtotal=drygridtotal+drygrid(ix,jy) - ! Calculate standard deviation of the mean - drygridsigma(ix,jy)= & - drygridsigma(ix,jy)* & - sqrt(real(nclassunc, kind=dep_prec)) - 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)*real(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 -!$OMP END DO - ! print*,gridtotal,maxpointspec_act - - !******************************************************************* - ! 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 - !******************************************************************* - - ! Concentration output - !********************* -!$OMP SINGLE - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - - ! Wet deposition - if ((ldirect.eq.1).and.(WETDEP)) then - call nf90_err(nf90_put_var(ncid,wdspecID(ks),1.e12*& - wetgrid(0:numxgrid-1,0:numygrid-1)/area(0:numxgrid-1,0:numygrid-1),& - (/ 1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,1,1,1 /))) - end if - - ! Dry deposition - if ((ldirect.eq.1).and.(DRYDEP)) then - call nf90_err(nf90_put_var(ncid,ddspecID(ks),1.e12*& - drygrid(0:numxgrid-1,0:numygrid-1)/area(0:numxgrid-1,0:numygrid-1),& - (/ 1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,1,1,1 /))) - endif - - ! Concentrations - call nf90_err(nf90_put_var(ncid,specID(ks),grid(0:numxgrid-1,0:numygrid-1,& - 1:numzgrid)*factor3d(0:numxgrid-1,0:numygrid-1,1:numzgrid)/tot_mu(ks,kp),& - (/ 1,1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,numzgrid,1,1,1 /) )) - - endif ! concentration output - - ! Mixing ratio output - !******************** - - if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio - - ! Wet deposition - if ((ldirect.eq.1).and.(WETDEP)) then - call nf90_err(nf90_put_var(ncid,wdspecID(ks),1.e12*& - wetgrid(0:numxgrid-1,0:numygrid-1)/area(0:numxgrid-1,0:numygrid-1),& - (/ 1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,1,1,1 /))) - - endif - - ! Dry deposition - if ((ldirect.eq.1).and.(DRYDEP)) then - call nf90_err(nf90_put_var(ncid,ddspecID(ks),1.e12*& - drygrid(0:numxgrid-1,0:numygrid-1)/area(0:numxgrid-1,0:numygrid-1),& - (/ 1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,1,1,1 /))) - endif - - ! Mixing ratios - call nf90_err(nf90_put_var(ncid,specIDppt(ks),weightair/weightmolar(ks)*& - grid(0:numxgrid-1,0:numygrid-1,1:numzgrid)*& - factor3d(0:numxgrid-1,0:numygrid-1,1:numzgrid)/& - densityoutgrid(0:numxgrid-1,0:numygrid-1,1:numzgrid),& - (/ 1,1,1,tpointer,kp,nage /), (/ numxgrid,numygrid,numzgrid,1,1,1 /))) - - endif ! output for ppt -!$OMP END SINGLE -!$OMP BARRIER - end do - end do - - end do -!$OMP END PARALLEL - - if (gridtotal.gt.0.) gridtotalunc=gridsigmatotal/gridtotal - if (wetgridtotal.gt.0.) wetgridtotalunc=wetgridsigmatotal/ & - wetgridtotal - if (drygridtotal.gt.0.) drygridtotalunc=real(drygridsigmatotal/ & - drygridtotal, kind=dep_prec) - - ! Dump of receptor concentrations - - if (numreceptor.ge.1) then - if (iout.eq.2 .or. iout.eq.3) then - do ks=1,nspec - recout(:)=1.e12*creceptor(:,ks)/outnum*weightair/weightmolar(ks)/densityoutrecept(:) - call nf90_err(nf90_put_var(ncid,recpptvID(ks),recout(1:numreceptor),(/ tpointer,1 /),(/ 1,numreceptor /))) - end do - endif - - ! Dump of receptor concentrations - - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - do ks=1,nspec - recout(:)=1.e12*creceptor(:,ks)/outnum - call nf90_err(nf90_put_var(ncid,recconcID(ks),recout(1:numreceptor),(/ tpointer,1 /),(/ 1,numreceptor /))) - end do - endif - endif - - ! Close netCDF file - !************************** - call nf90_err(nf90_close(ncid)) - - ! Reinitialization of grid - !************************* - if (numreceptor.gt.0) creceptor(1:numreceptor,1:nspec) = 0. - gridunc(:,:,:,1:nspec,:,:,1:nageclass) = 0. -end subroutine concoutput_ncf - -subroutine concoutput_sfc_ncf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) - - use unc_mod, only: gridunc,drygridunc,wetgridunc,drygridunc0,wetgridunc0 - - implicit none - - integer, intent(in) :: itime - real, intent(in) :: outnum - real(sp), intent(out) :: gridtotalunc - real(dep_prec), intent(out) :: wetgridtotalunc,drygridtotalunc - - print*,'Netcdf output for surface only not yet implemented' -end subroutine concoutput_sfc_ncf - -subroutine concoutput_ncf_nest(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 module 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 * - ! * - ! 19 February 2010, Dominik Brunner, Empa: Adapted for COSMO * - ! * - ! April 2013, Dominik Brunner, Empa * - ! Adapted for netcdf output * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! itime current simulation time * - ! outnum number of samples * - ! * - !***************************************************************************** - - use unc_mod, only: griduncn,drygriduncn,wetgriduncn,drygriduncn0,wetgriduncn0 - - implicit none - - integer, intent(in) :: itime - real, intent(in) :: outnum - real :: densityoutrecept(maxreceptor) - integer :: ncid,kp,ks,kz,ix,jy,iix,jjy,kzz,kzzm1,ngrid - integer :: nage,i,l, jj - real :: tot_mu(maxspec,maxpointspec_act) - real :: halfheight,dz,dz1,dz2 - real :: xl,yl,xlrot,ylrot,zagnd,zagndprev - real(dep_prec) :: auxgrid(nclassunc) - real :: gridtotal - real, parameter :: weightair=28.97 - - eps=nxmax/3.e5 - - ! open output file - call nf90_err(nf90_open(trim(ncfnamen), nf90_write, ncid)) - - ! write time (do not increase time counter here, done in main output domain) - call nf90_err(nf90_put_var( ncid, timeID, itime, (/ tpointer /))) - - ! 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.0 - 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 - - gridtotal=0. - !******************************************************************* - ! Compute air density: - ! brd134: we now take into account whether we are in the mother or in - ! a nested domain (before only from mother domain) - ! Determine center altitude of output layer, and interpolate density - ! data to that altitude - !******************************************************************* -!$OMP PARALLEL PRIVATE(halfheight,kzz,dz1,dz2,dz,xl,yl,ngrid,iix,jjy, & -!$OMP kz,ix,jy,l,ks,kp,nage,auxgrid) REDUCTION(+:gridtotal) -!$OMP DO - 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)) exit - end do - 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=outlon0n+real(ix)*dxoutn - yl=outlat0n+real(jy)*dyoutn - xl=(xl-xlon0)/dx - yl=(yl-ylat0)/dy - - ngrid=0 - do jj=numbnests,1,-1 - if ( xl.gt.xln(jj)+eps .and. xl.lt.xrn(jj)-eps .and. & - yl.gt.yln(jj)+eps .and. yl.lt.yrn(jj)-eps ) then - ngrid=jj - exit - end if - end do - - if (ngrid.eq.0) then - iix=max(min(nint(xl),nxmin1),0) - jjy=max(min(nint(yl),nymin1),0) - - densityoutgrid(ix,jy,kz)=(rho(iix,jjy,kzz,memind(2))*dz1+ & - rho(iix,jjy,kzz-1,memind(2))*dz2)/dz - else - xl=(xl-xln(ngrid))*xresoln(ngrid) - yl=(yl-yln(ngrid))*yresoln(ngrid) - iix=max(min(nint(xl),nxn(ngrid)-1),0) - jjy=max(min(nint(yl),nyn(ngrid)-1),0) - densityoutgrid(ix,jy,kz)=(rhon(iix,jjy,kzz,memind(2), ngrid)*dz1+ & - rhon(iix,jjy,kzz-1,memind(2), ngrid)*dz2)/dz - endif - - end do - end do - end do -!$OMP END DO NOWAIT - - if (numreceptor.gt.0) then -!$OMP 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,memind(2)) - end do -!$OMP END DO NOWAIT - endif - - ! Output is different for forward and backward simulations - if (ldirect.eq.1) then -!$OMP DO - do kz=1,numzgrid - do jy=0,numygridn-1 - do ix=0,numxgridn-1 - factor3d(ix,jy,kz)=1.e12/volumen(ix,jy,kz)/outnum - end do - end do - end do -!$OMP END DO - else -!$OMP DO - do kz=1,numzgrid - do jy=0,numygridn-1 - do ix=0,numxgridn-1 - factor3d(ix,jy,kz)=real(abs(loutaver))/outnum - end do - end do - end do -!$OMP END DO - endif - - !********************************************************************* - ! 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 - - do kp=1,maxpointspec_act - do nage=1,nageclass -!$OMP DO - do jy=0,numygridn-1 - do ix=0,numxgridn-1 - ! WET DEPOSITION - if ((WETDEP).and.(ldirect.gt.0)) then - if (mpi_mode.gt.0) then - do l=1,nclassunc - auxgrid(l)=wetgriduncn0(ix,jy,ks,kp,l,nage) - end do - else - do l=1,nclassunc - auxgrid(l)=wetgriduncn(ix,jy,ks,kp,l,nage) - end do - end if - 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)*real(nclassunc) - ! Calculate standard deviation of the mean - wetgridsigma(ix,jy)= & - wetgridsigma(ix,jy)* & - sqrt(real(nclassunc,kind=dep_prec)) - endif - - ! DRY DEPOSITION - if ((DRYDEP).and.(ldirect.gt.0)) then - if (mpi_mode.gt.0) then - do l=1,nclassunc - auxgrid(l)=drygriduncn0(ix,jy,ks,kp,l,nage) - end do - else - do l=1,nclassunc - auxgrid(l)=drygriduncn(ix,jy,ks,kp,l,nage) - end do - end if - 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)*real(nclassunc) - ! Calculate standard deviation of the mean - drygridsigma(ix,jy)= & - drygridsigma(ix,jy)* & - sqrt(real(nclassunc,kind=dep_prec)) - 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)*real(nclassunc) - gridtotal=gridtotal+grid(ix,jy,kz) - ! Calculate standard deviation of the mean - gridsigma(ix,jy,kz)= & - gridsigma(ix,jy,kz)* & - sqrt(real(nclassunc)) - end do - end do - end do -!$OMP END DO - ! print*,gridtotal,maxpointspec_act - - !******************************************************************* - ! 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 - !******************************************************************* - - ! Concentration output - !********************* -!$OMP SINGLE - if ((iout.eq.1).or.(iout.eq.3).or.(iout.eq.5)) then - - ! Wet deposition - if ((ldirect.eq.1).and.(WETDEP)) then - call nf90_err(nf90_put_var(ncid,wdspecIDn(ks),1.e12*& - wetgrid(0:numxgridn-1,0:numygridn-1)/arean(0:numxgridn-1,0:numygridn-1),& - (/ 1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,1,1,1 /))) - endif - - ! Dry deposition - if ((ldirect.eq.1).and.(DRYDEP)) then - call nf90_err(nf90_put_var(ncid,ddspecIDn(ks),1.e12*& - drygrid(0:numxgridn-1,0:numygridn-1)/arean(0:numxgridn-1,0:numygridn-1),& - (/ 1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,1,1,1 /))) - endif - - ! Concentrations - call nf90_err(nf90_put_var(ncid,specIDn(ks),grid(0:numxgridn-1,0:numygridn-1,& - 1:numzgrid)*factor3d(0:numxgridn-1,0:numygridn-1,1:numzgrid)/tot_mu(ks,kp),& - (/ 1,1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,numzgrid,1,1,1 /))) - - endif ! concentration output - - ! Mixing ratio output - !******************** - - if ((iout.eq.2).or.(iout.eq.3)) then ! mixing ratio - - ! Wet deposition - if ((ldirect.eq.1).and.(WETDEP)) then - call nf90_err(nf90_put_var(ncid,wdspecIDn(ks),1.e12*& - wetgrid(0:numxgridn-1,0:numygridn-1)/arean(0:numxgridn-1,0:numygridn-1),& - (/ 1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,1,1,1 /))) - endif - - ! Dry deposition - if ((ldirect.eq.1).and.(DRYDEP)) then - call nf90_err(nf90_put_var(ncid,ddspecIDn(ks),1.e12*& - drygrid(0:numxgridn-1,0:numygridn-1)/arean(0:numxgridn-1,0:numygridn-1),& - (/ 1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,1,1,1 /))) - endif - - ! Mixing ratios - call nf90_err(nf90_put_var(ncid,specIDnppt(ks),weightair/weightmolar(ks)*& - grid(0:numxgridn-1,0:numygridn-1,1:numzgrid)*& - factor3d(0:numxgridn-1,0:numygridn-1,1:numzgrid)/& - densityoutgrid(0:numxgridn-1,0:numygridn-1,1:numzgrid),& - (/ 1,1,1,tpointer,kp,nage /), (/ numxgridn,numygridn,numzgrid,1,1,1 /))) - - endif ! output for ppt -!$OMP END SINGLE -!$OMP BARRIER - end do - end do - - end do -!$OMP END PARALLEL - ! Close netCDF file - !************************** - call nf90_err(nf90_close(ncid)) - - ! Reinitialization of grid - !************************* - - if (numreceptor.gt.0) creceptor(1:numreceptor,1:nspec) = 0. - griduncn(:,:,:,1:nspec,:,:,1:nageclass) = 0. -end subroutine concoutput_ncf_nest - -subroutine concoutput_sfc_ncf_nest(itime,outnum) - - implicit none - - integer, intent(in) :: itime - real, intent(in) :: outnum - - print*,'Netcdf output for surface only not yet implemented' -end subroutine concoutput_sfc_ncf_nest - -subroutine particle_initialpos(itime,idate,itime_start,idate_start) - - !***************************************************************************** - ! * - ! This subroutine creates an initial particle positions and properties * - ! NetCDF file: partinit_xxx.nc * - ! The release time, release number and positions, together with all fields * - ! specified in the PARTOPTIONS option file will saved. * - ! * - ! Author: L. Bakels 2022 * - ! * - !***************************************************************************** - - implicit none - - integer, intent(in) :: itime,idate,itime_start,idate_start - ! integer, intent(in) :: irelease - integer :: cache_size,ncid,j,totpart,np - integer :: partDimID - character(len=11) :: fprefix - character(len=3) :: anspec,arelease - character :: adate*8,atime*6,adate_start*8,atime_start*6,timeunit*32 - character(len=255) :: fname_partoutput - real :: fillval - - write(adate,'(i8.8)') idate - write(atime,'(i6.6)') itime - write(adate_start,'(i8.8)') idate_start - write(atime_start,'(i6.6)') itime_start - ! write(arelease, '(i3.3)') irelease - fprefix = 'partinit_'!rel'//arelease//'_' - - fname_partoutput = path(2)(1:length(2))//trim(fprefix)//adate//atime//'.nc' - !ncfname_part(irelease) = fname_partoutput - ncfname_partinit = fname_partoutput - - call nf90_err(nf90_create(trim(fname_partoutput), cmode = nf90_hdf5, ncid = ncid))!, & - ! cache_size = cache_size)) - - ! create dimensions: - !************************* - - ! particle - partinitpointer=0 - call nf90_err(nf90_def_dim(ncid, 'particle', nf90_unlimited, partDimID)) - - ! create variables - !************************* - - ! particles - call nf90_err(nf90_def_var(ncid, 'particle', nf90_int, (/ partDimID/), partIDi)) - call nf90_err(nf90_put_att(ncid, partIDi, 'long_name', 'particle index')) - - fillval = -1. - ! time - timeunit = 'seconds since '//adate_start(1:4)//'-'//adate_start(5:6)// & - '-'//adate_start(7:8)//' '//atime_start(1:2)//':'//atime_start(3:4) - - call write_to_file(ncid,'time',nf90_int,(/ partDimID /),tIDi,(/ 1 /), & - timeunit,.false.,'time','time of release') - call nf90_err(nf90_put_att(ncid, tIDi, 'axis', 't')) - call nf90_err(nf90_put_att(ncid, tIDi, 'calendar', 'proleptic_gregorian')) - call nf90_err(nf90_put_att(ncid, tIDi, 'description', 'time of release')) - - ! lon - call write_to_file(ncid,'longitude',nf90_float,(/ partDimID /),lonIDi,(/ 1 /), & - 'degrees_east',.false.,'longitude','longitude in degree east') - call nf90_err(nf90_put_att(ncid, lonIDi, 'axis', 'Lon')) - call nf90_err(nf90_put_att(ncid, lonIDi, 'description', 'longitude of particles')) - - ! lat - call write_to_file(ncid,'latitude',nf90_float,(/ partDimID /),latIDi,(/ 1 /), & - 'degrees_north',.false.,'latitude','latitude in degree north') - call nf90_err(nf90_put_att(ncid, latIDi, 'axis', 'Lat')) - call nf90_err(nf90_put_att(ncid, latIDi, 'description', 'latitude of particles')) - - ! height - call write_to_file(ncid,'height',nf90_float,(/ partDimID /),levIDi,(/ 1 /), & - 'meters',.true.,'height','height above ground') - - ! release - call write_to_file(ncid,'release',nf90_int,(/ partDimID /),relIDi,(/ 1 /), & - '',.true.,'release','particle release') - - do np=1,num_partopt - if (.not. partopt(np)%print) cycle - select case(partopt(np)%name) - case ('PV') ! Potential vorticity - call write_to_file(ncid,'pv',nf90_float,(/ partDimID /),pvIDi,(/ 1 /), & - 'pvu',.false.,'potential_vorticity','potential vorticity') - case ('PR') ! Pressure - call write_to_file(ncid,'pr',nf90_float,(/ partDimID /),prIDi,(/ 1 /), & - 'Pa',.false.,'pressure','pressure') - case ('QV') ! Specific humidity - call write_to_file(ncid,'qv',nf90_float,(/ partDimID /),qvIDi,(/ 1 /), & - '',.false.,'specific_humidity','specific humidity') - case ('RH') ! Density - call write_to_file(ncid,'rho',nf90_float,(/ partDimID /),rhoIDi,(/ 1 /), & - 'kg/m3',.true.,'density','density') - case ('TT') ! Temperature - call write_to_file(ncid,'temperature',nf90_float,(/ partDimID /),ttIDi,(/ 1 /), & - 'K',.true.,'temperature','temperature') - case ('UU') - call write_to_file(ncid,'u',nf90_float,(/ partDimID /),uIDi,(/ 1 /), & - 'm/s',.false.,'u','longitudinal velocity') - case ('VV') - call write_to_file(ncid,'v',nf90_float,(/ partDimID /),vIDi,(/ 1 /), & - 'm/s',.false.,'v','latitudinal velocity') - case ('WW') - call write_to_file(ncid,'w',nf90_float,(/ partDimID /),wIDi,(/ 1 /), & - 'm/s',.false.,'w','vertical velocity') - case ('MA') - do j=1,nspec - ! Masses - write(anspec, '(i3.3)') j - call write_to_file(ncid,'mass'//anspec,nf90_float,(/ partDimID /),massIDi(j), & - (/ 1 /),'kg',.true.,'mass'//anspec,'mass for nspec'//anspec) - end do - case ('TO') - call write_to_file(ncid,'topo',nf90_float,(/ partDimID /),topoIDi,(/ 1 /), & - 'meters',.false.,'topography','topography above sealevel') - case ('TR') - call write_to_file(ncid,'tr',nf90_float,(/ partDimID /),trIDi,(/ 1 /), & - 'meters',.true.,'htropo','height above ground of tropopause') - case ('HM') ! Mixing layer height - call write_to_file(ncid,'hmix',nf90_float,(/ partDimID /),hmixIDi,(/ 1 /), & - 'meters',.true.,'hmix','height above ground of mixing layer') - case default - cycle - end select - end do - - ! moves the file from define to data mode - call nf90_err(nf90_enddef(ncid)) - - call nf90_err(nf90_close(ncid)) -end subroutine particle_initialpos - -subroutine wrt_part_initialpos(itime,istart,iend) - - !***************************************************************************** - ! * - ! This subroutine saves initial particle positions, release time and * - ! releasenumber to a NetCDF file created in particle_initialpos * - ! evertime a new particle is spawned. * - ! * - ! Author: L. Bakels 2022 * - ! * - !***************************************************************************** - - use particle_mod - - implicit none - - integer, intent(in) :: & - itime, & ! time of particle release - istart, & ! index of first newly released particle - iend ! index of last newly released partile - integer, allocatable :: partindices(:),releasetimes(:) - integer :: newpart,ncid,j - - newpart = iend-istart - if (newpart.eq.0) return - write(*,*) newpart, ' particles are being added to partinit.' - call nf90_err(nf90_open(trim(ncfname_partinit), nf90_write, ncid)) - - allocate ( partindices(newpart) ) - - do j=1,newpart - partindices(j)=j+partinitpointer - end do - - partinitpointer1= partinitpointer+1 ! this is also used in partinit_ncf - call nf90_err(nf90_put_var(ncid,partIDi,partindices,(/ partinitpointer1 /),(/ newpart /))) - deallocate (partindices) - - allocate ( releasetimes(newpart) ) - releasetimes=itime - call nf90_err(nf90_put_var(ncid,tIDi,releasetimes,(/ partinitpointer1 /),(/ newpart /))) - deallocate (releasetimes) - call nf90_err(nf90_put_var(ncid,lonIDi,xlon0+part(partinitpointer1:iend)%xlon*dx, (/ partinitpointer1 /),(/ newpart /))) - call nf90_err(nf90_put_var(ncid,latIDi,ylat0+part(partinitpointer1:iend)%ylat*dy, (/ partinitpointer1 /),(/ newpart /))) - call nf90_err(nf90_put_var(ncid,levIDi,part(partinitpointer1:iend)%z, (/ partinitpointer1 /),(/ newpart /))) - call nf90_err(nf90_put_var(ncid,relIDi,part(partinitpointer1:iend)%npoint, (/ partinitpointer1 /),(/ newpart /))) - - call nf90_err(nf90_close(ncid)) - - partinitpointer = partinitpointer+newpart -end subroutine wrt_part_initialpos - -subroutine partinit_ncf(itime,field,fieldname,imass,ncid) - - !***************************************************************************** - ! * - ! This subroutine saves properties chosen by the user in PARTOPTIONS * - ! to a NetCDF file created in particle_initialpos. * - ! This happens whenever a new particle is spawned. * - ! * - ! Author: L. Bakels 2022 * - ! * - !***************************************************************************** - - implicit none - - integer, intent(in) :: itime,imass - real, intent(in) :: field(:) - character(2), intent(in) :: fieldname ! input field to interpolate over - integer, allocatable :: partindices(:) - integer :: ncid,newpart,j,iend - - newpart = partinitpointer - (partinitpointer1-1) - - select case(fieldname) - case('TO') ! Topography - call nf90_err(nf90_put_var(ncid,topoIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('PV') ! Potential vorticity - call nf90_err(nf90_put_var(ncid,pvIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('PR') ! Pressure - call nf90_err(nf90_put_var(ncid,prIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('QV') ! Specific humidity - call nf90_err(nf90_put_var(ncid,qvIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('RH') ! Air density - call nf90_err(nf90_put_var(ncid,rhoIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('UU') ! Longitudinal velocity - call nf90_err(nf90_put_var(ncid,uIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('VV') ! Latitudinal velocity - call nf90_err(nf90_put_var(ncid,vIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('WW') ! Vertical velocity - call nf90_err(nf90_put_var(ncid,wIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('TT') ! Temperature - call nf90_err(nf90_put_var(ncid,ttIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('MA') ! Mass - call nf90_err(nf90_put_var(ncid,massIDi(imass),field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('TR') ! Tropopause - call nf90_err(nf90_put_var(ncid,trIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case('HM') ! Mixing height - call nf90_err(nf90_put_var(ncid,hmixIDi,field(partinitpointer1:partinitpointer), & - (/ partinitpointer1 /),(/ newpart /))) - case default - return - end select -end subroutine partinit_ncf - -subroutine writeheader_partoutput(itime,idate,itime_start,idate_start)!,irelease) - - !***************************************************************************** - ! * - ! This subroutine creates a file (partoutput_xxx.nc), where every time * - ! interval particle properties specified in the PARTOPTIONS option file * - ! are saved to. Running options are saved as header informtion to this * - ! file as well. * - ! * - ! Author: L. Bakels 2021 * - ! * - !***************************************************************************** - - implicit none - - integer, intent(in) :: itime,idate,itime_start,idate_start - ! integer, intent(in) :: irelease - integer :: cache_size,ncid,j,i,totpart,np - integer :: timeDimID,partDimID,tID,memDimID - integer :: latDimID, lonDimID, lonID, latID - character(len=11) :: fprefix - character(len=3) :: anspec,arelease - character :: adate*8,atime*6,adate_start*8,atime_start*6,timeunit*32 - character(len=255) :: fname_partoutput - real :: fillval - real, allocatable, dimension(:) :: coord - - logical,save :: first_time=.true. - - open(unit=unittmp,file=trim(path(2)(1:length(2)))//'test_dir.txt',status='replace',& - &err=110) - close (unittmp, status='delete') - - write(adate,'(i8.8)') idate - write(atime,'(i6.6)') itime - write(adate_start,'(i8.8)') idate_start - write(atime_start,'(i6.6)') itime_start - ! write(arelease, '(i3.3)') irelease - fprefix = 'partoutput_'!rel'//arelease//'_' - - ! Reset logicals that ensure ony 1 write out in case of domainfill - topo_written=.false. - mass_written=.false. - massav_written=.false. - - if (first_time) then - fname_partoutput = path(2)(1:length(2))//trim(fprefix)//adate//atime//'_init.nc' - first_time=.false. - else - fname_partoutput = path(2)(1:length(2))//trim(fprefix)//adate//atime//'.nc' - endif - !ncfname_part(irelease) = fname_partoutput - ncfname_part = fname_partoutput - - totpart=0 - if (ipin.gt.1) then ! Not reading from a release has no npart - totpart=numpart - else - do j=1,numpoint - totpart = totpart+npart(j) - end do - endif - !totpart = maxpart!max(numpart,totpart) - !cache_size = 4 * 1 * (12+nspec) - - write(*,*) 'Write header, nspec,numpart,totpart: ', nspec,numpart,totpart - - call nf90_err(nf90_create(trim(fname_partoutput), cmode = nf90_hdf5, ncid = ncid))!, & - ! cache_size = cache_size)) - - ! create dimensions: - !************************* - ! time - call nf90_err(nf90_def_dim(ncid, 'time', nf90_unlimited, timeDimID)) - timeunit = 'seconds since '//adate_start(1:4)//'-'//adate_start(5:6)// & - '-'//adate_start(7:8)//' '//atime_start(1:2)//':'//atime_start(3:4) - - ! particle - call nf90_err(nf90_def_dim(ncid, 'particle', nf90_unlimited, partDimID)) !totpart needs to be the actual number of particles - - ! If domainfill, save topo, hmix, and htropo to grid to save space - !***************************************************************** - if (mdomainfill.ge.1) then - call nf90_err(nf90_def_dim(ncid, 'lon', nx, lonDimID)) - call nf90_err(nf90_def_dim(ncid, 'lat', ny, latDimID)) - - ! lon - call write_to_file(ncid,'lon',nf90_float,(/ lonDimID /),lonID,(/ 1 /), & - 'degrees_east',.false.,'grid_longitude','longitude in degree east') - call nf90_err(nf90_put_att(ncid, lonID, 'axis', 'Lon')) - call nf90_err(nf90_put_att(ncid, lonID, 'description', 'grid cell centers')) - - ! lat - call write_to_file(ncid,'lat',nf90_float,(/ latDimID /),latID,(/ 1 /), & - 'degrees_east',.false.,'grid_latitude','latitude in degree north') - call nf90_err(nf90_put_att(ncid, latID, 'axis', 'Lat')) - call nf90_err(nf90_put_att(ncid, latID, 'description', 'grid cell centers')) - - if (.not.allocated(coord)) allocate(coord(nx)) - do i = 1,nx - coord(i) = xlon0 + i*dx - enddo - call nf90_err(nf90_put_var(ncid, lonID, coord(1:nx))) - deallocate(coord) - - if (.not.allocated(coord)) allocate(coord(ny)) - do i = 1,ny - coord(i) = ylat0 + i*dy - enddo - call nf90_err(nf90_put_var(ncid, latID, coord(1:ny))) - deallocate(coord) - - endif - ! create variables - !************************* - - ! time - tpointer_part=0 - call nf90_err(nf90_def_var(ncid, 'time', nf90_int, (/ timeDimID /), tID)) - call nf90_err(nf90_put_att(ncid, tID, 'units', timeunit)) - call nf90_err(nf90_put_att(ncid, tID, 'calendar', 'proleptic_gregorian')) - - timeIDpart=tID - ! particles - call nf90_err(nf90_def_var(ncid, 'particle', nf90_int, (/ partDimID/), partID)) - call nf90_err(nf90_put_att(ncid, partID, 'long_name', 'particle index')) - - fillval = -1. - do np=1,num_partopt - if (.not. partopt(np)%print) cycle - select case(partopt(np)%name) - case ('LO') ! Longitude - call write_to_file(ncid,'longitude',nf90_float,(/ timeDimID,partDimID /),lonIDpart,(/ 1,totpart /), & - 'degrees_east',.false.,'longitude','longitude of particles') - call nf90_err(nf90_put_att(ncid, lonIDpart, 'axis', 'Lon')) - call nf90_err(nf90_put_att(ncid, lonIDpart, 'description', 'longitude of particles')) - case ('lo') ! Longitude averaged - call write_to_file(ncid,'longitude_av',nf90_float,(/ timeDimID,partDimID /),lonavIDpart,(/ 1,totpart /), & - 'degrees_east',.false.,'longitude_average','averaged longitude of particles') - call nf90_err(nf90_put_att(ncid, lonavIDpart, 'axis', 'Lon')) - call nf90_err(nf90_put_att(ncid, lonavIDpart, 'description', 'averaged longitude of particles')) - case ('LA') ! Latitude - call write_to_file(ncid,'latitude',nf90_float,(/ timeDimID,partDimID /),latIDpart,(/ 1,totpart /), & - 'degrees_north',.false.,'latitude','latitude in degree north') - call nf90_err(nf90_put_att(ncid, latIDpart, 'axis', 'Lat')) - call nf90_err(nf90_put_att(ncid, latIDpart, 'description', 'latitude of particles')) - case ('la') ! Latitude averaged - call write_to_file(ncid,'latitude_av',nf90_float,(/ timeDimID,partDimID /),latavIDpart,(/ 1,totpart /), & - 'degrees_north',.false.,'latitude_average','averaged latitude in degree north') - call nf90_err(nf90_put_att(ncid, latavIDpart, 'axis', 'Lat')) - call nf90_err(nf90_put_att(ncid, latavIDpart, 'description', 'averaged latitude of particles')) - case ('ZZ') ! Height - call write_to_file(ncid,'height',nf90_float,(/ timeDimID,partDimID /),levIDpart,(/ 1,totpart /), & - 'meters',.false.,'height','height above ground') - case ('zz') ! Heights averaged - call write_to_file(ncid,'height_av',nf90_float,(/ timeDimID,partDimID /),levavIDpart,(/ 1,totpart /), & - 'meters',.false.,'height_average','averaged height above ground') - case ('PV') ! Potential vorticity - call write_to_file(ncid,'pv',nf90_float,(/ timeDimID,partDimID /),pvID,(/ 1,totpart /), & - 'pvu',.false.,'potential_vorticity','potential vorticity') - case ('pv') ! Potential vorticity averaged - call write_to_file(ncid,'pv_av',nf90_float,(/ timeDimID,partDimID /),pvavID,(/ 1,totpart /), & - 'pvu',.false.,'potential_vorticity_average','averaged potential vorticity') - case ('PR') ! Pressure - call write_to_file(ncid,'pr',nf90_float,(/ timeDimID,partDimID /),prID,(/ 1,totpart /), & - 'Pa',.false.,'pressure','pressure') - case ('pr') ! Pressure averaged - call write_to_file(ncid,'pr_av',nf90_float,(/ timeDimID,partDimID /),pravID,(/ 1,totpart /), & - 'Pa',.false.,'pressure_average','averaged pressure') - case ('QV') ! Specific humidity - call write_to_file(ncid,'qv',nf90_float,(/ timeDimID,partDimID /),qvID,(/ 1,totpart /), & - '',.false.,'specific_humidity','specific humidity') - case ('qv') ! Specific humidity averaged - call write_to_file(ncid,'qv_av',nf90_float,(/ timeDimID,partDimID /),qvavID,(/ 1,totpart /), & - '',.false.,'specific_humidity_average','averaged specific humidity') - case ('RH') ! Density - call write_to_file(ncid,'rho',nf90_float,(/ timeDimID,partDimID /),rhoID,(/ 1,totpart /), & - 'kg/m3',.true.,'density','density') - case ('rh') ! Density averaged - call write_to_file(ncid,'rho_av',nf90_float,(/ timeDimID,partDimID /),rhoavID,(/ 1,totpart /), & - 'kg/m3',.true.,'density_average','averaged density') - case ('TT') ! Temperature - call write_to_file(ncid,'temperature',nf90_float,(/ timeDimID,partDimID /),ttID,(/ 1,totpart /), & - 'K',.true.,'temperature','temperature') - case ('tt') ! Temperature averaged - call write_to_file(ncid,'temperature_av',nf90_float,(/ timeDimID,partDimID /),ttavID,(/ 1,totpart /), & - 'K',.true.,'temperature_average','averaged temperature') - case ('UU') - call write_to_file(ncid,'u',nf90_float,(/ timeDimID,partDimID /),uID,(/ 1,totpart /), & - 'm/s',.false.,'u','longitudinal velocity') - case ('uu') - call write_to_file(ncid,'u_av',nf90_float,(/ timeDimID,partDimID /),uavID,(/ 1,totpart /), & - 'm/s',.false.,'u_av','averaged longitudinal velocity') - case ('VV') - call write_to_file(ncid,'v',nf90_float,(/ timeDimID,partDimID /),vID,(/ 1,totpart /), & - 'm/s',.false.,'v','latitudinal velocity') - case ('vv') - call write_to_file(ncid,'v_av',nf90_float,(/ timeDimID,partDimID /),vavID,(/ 1,totpart /), & - 'm/s',.false.,'v_average','latitudinal velocity averaged') - case ('WW') - call write_to_file(ncid,'w',nf90_float,(/ timeDimID,partDimID /),wID,(/ 1,totpart /), & - 'm/s',.false.,'w','vertical velocity') - case ('ww') - call write_to_file(ncid,'w_av',nf90_float,(/ timeDimID,partDimID /),wavID,(/ 1,totpart /), & - 'm/s',.false.,'w_average','vertical velocity averaged') - case ('VS') - call write_to_file(ncid,'settling',nf90_float,(/ timeDimID,partDimID /),vsetID,(/ 1,totpart /), & - 'm/s',.false.,'settling_velocity','settling velocity') - case ('vs') - call write_to_file(ncid,'settling_av',nf90_float,(/ timeDimID,partDimID /),vsetavID,(/ 1,totpart /), & - 'm/s',.false.,'settling_velocity_average','settling velocity averaged') - case ('MA') ! Mass - if (mdomainfill.ge.1) then - call nf90_err(nf90_def_var(ncid=ncid, name='mass', xtype=nf90_float, dimids=1, varid=massID(1))) - call nf90_err(nf90_put_att(ncid, massID(1), 'units', 'kg')) - call nf90_err(nf90_put_att(ncid, massID(1), '_FillValue', fillval)) - call nf90_err(nf90_put_att(ncid, massID(1), 'positive', 'up')) - call nf90_err(nf90_put_att(ncid, massID(1), 'standard_name', 'mass')) - call nf90_err(nf90_put_att(ncid, massID(1), 'long_name', 'mass of each particle')) - else - do j=1,nspec - ! Masses - write(anspec, '(i3.3)') j - call write_to_file(ncid,'mass'//anspec,nf90_float,(/ timeDimID,partDimID /),massID(j), & - (/ 1,totpart /),'kg',.true.,'mass'//anspec,'mass for nspec'//anspec) - end do - endif - case ('ma') ! Mass averaged - if (mdomainfill.ge.1) then - call nf90_err(nf90_def_var(ncid=ncid, name='mass_av', xtype=nf90_float, dimids=1, varid=massavID(1))) - call nf90_err(nf90_put_att(ncid, massavID(1), 'units', 'kg')) - call nf90_err(nf90_put_att(ncid, massavID(1), '_FillValue', fillval)) - call nf90_err(nf90_put_att(ncid, massavID(1), 'positive', 'up')) - call nf90_err(nf90_put_att(ncid, massavID(1), 'standard_name', 'mass')) - call nf90_err(nf90_put_att(ncid, massavID(1), 'long_name', 'averaged mass of each particle')) - else - do j=1,nspec - ! Masses averaged - write(anspec, '(i3.3)') j - call write_to_file(ncid,'mass_av'//anspec,nf90_float,(/ timeDimID,partDimID /),massavID(j), & - (/ 1,totpart /),'kg',.true.,'mass'//anspec,'averaged mass for nspec'//anspec) - end do - endif - case ('WD') ! Cumulative mass of wet deposition - do j=1,nspec - ! Masses - write(anspec, '(i3.3)') j - call write_to_file(ncid,'wetdepo'//anspec,nf90_float,(/ timeDimID,partDimID /),wdID(j), & - (/ 1,totpart /),'kg',.true.,'mass'//anspec,'cumulative wet deposition for nspec'//anspec) - end do - case ('DD') ! Cumulative mass of dry deposition - do j=1,nspec - ! Masses - write(anspec, '(i3.3)') j - call write_to_file(ncid,'drydepo'//anspec,nf90_float,(/ timeDimID,partDimID /),ddID(j), & - (/ 1,totpart /),'kg',.true.,'mass'//anspec,'cumulative dry deposition for nspec'//anspec) - end do - case ('TO') ! Topography, written to grid if domainfill - if (mdomainfill.lt.1) then - call write_to_file(ncid,'topo',nf90_float,(/ timeDimID,partDimID /),topoID,(/ 1,totpart /), & - 'meters',.false.,'topography','topography above sealevel') - else - call write_to_file(ncid,'topo',nf90_float,(/ lonDimID,latDimID /),topoID,(/ nx,ny /), & - 'meters',.false.,'topography','topography above sealevel') - endif - case ('to') ! Topography averaged, no grid when domainfill - call write_to_file(ncid,'topo_av',nf90_float,(/ timeDimID,partDimID /),topoavID,(/ 1,totpart /), & - 'meters',.false.,'topography','averaged topography above sealevel') - case ('HM') ! Mixing layer height - if (mdomainfill.lt.1) then - call write_to_file(ncid,'hmix',nf90_float,(/ timeDimID,partDimID /),hmixID,(/ 1,totpart /), & - 'meters',.true.,'hmix','height above ground of mixing layer') - else - call write_to_file(ncid,'hmix',nf90_float,(/ timeDimID,lonDimID,latDimID /),hmixID,(/ 1,nx,ny /), & - 'meters',.true.,'hmix','height above ground of mixing layer') - endif - case ('hm') ! Mixing layer height averaged - call write_to_file(ncid,'hmix_av',nf90_float,(/ timeDimID,partDimID /),hmixavID,(/ 1,totpart /), & - 'meters',.true.,'hmix_average','averaged height above ground of mixing layer') - case ('TR') ! Tropopause - if (mdomainfill.lt.1) then - call write_to_file(ncid,'tr',nf90_float,(/ timeDimID,partDimID /),trID,(/ 1,totpart /), & - 'meters',.true.,'htropo','height above ground of tropopause') - else - call write_to_file(ncid,'tr',nf90_float,(/ timeDimID,lonDimID,latDimID /),trID,(/ 1,nx,ny /), & - 'meters',.true.,'htropo','height above ground of tropopause') - endif - case ('tr') ! Tropopause averaged - call write_to_file(ncid,'tr_av',nf90_float,(/ timeDimID,partDimID /),travID,(/ 1,totpart /), & - 'meters',.true.,'htropo_average','averaged height above ground of tropopause') - case default - write(*,*) 'The field you are trying to write to file is not coded in yet: ', partopt(np)%long_name - stop - end select - end do - ! global (metadata) attributes - !******************************* - call writemetadata(ncid,lnest=.false.) - - ! moves the file from define to data mode - call nf90_err(nf90_enddef(ncid)) - - call nf90_err(nf90_close(ncid)) - - return -110 write(*,FMT='(80("#"))') - write(*,*) 'ERROR: output directory ', trim(path(2)(1:length(2))), ' does not exist& - & (or failed to write there).' - write(*,*) 'EXITING' - write(*,FMT='(80("#"))') - stop -end subroutine writeheader_partoutput - -subroutine write_to_file(ncid,short_name,xtype,dimids,varid,chunksizes,units,l_positive, & - standard_name,long_name) - - !***************************************************************************** - ! * - ! Generalised writing data to netcdf file * - ! * - ! Author: L. Bakels 2022 * - ! * - !***************************************************************************** - - implicit none - - integer, intent(in) :: ncid, xtype - integer, intent(out) :: varid - character(len = *), intent(in) :: short_name,standard_name,long_name,units - integer, dimension(:), intent(in) :: dimids,chunksizes - logical, intent(in) :: l_positive - - call nf90_err(nf90_def_var(ncid, short_name, xtype, dimids, varid)) - call nf90_err(nf90_def_var_chunking(ncid,varid,NF90_CHUNKED,chunksizes=chunksizes)) - call nf90_err(nf90_def_var_deflate(ncid,varid,shuffle=0,deflate=1,deflate_level=1)) - call nf90_err(nf90_put_att(ncid, varid, 'units', units)) - if(xtype.eq.nf90_float) then - call nf90_err(nf90_put_att(ncid, varid, '_FillValue', -1.)) - else - call nf90_err(nf90_put_att(ncid, varid, '_FillValue', -1)) - endif - if(l_positive) call nf90_err(nf90_put_att(ncid, varid, 'positive', 'up')) - call nf90_err(nf90_put_att(ncid, varid, 'standard_name', standard_name)) - call nf90_err(nf90_put_att(ncid, varid, 'long_name', long_name)) -end subroutine write_to_file - -subroutine open_partoutput_file(ncid)!,irelease) - - implicit none - - integer, intent(inout) :: ncid - !integer, intent(in) :: irelease - - call nf90_err(nf90_open(trim(ncfname_part), nf90_write, ncid)) -end subroutine open_partoutput_file - -subroutine close_partoutput_file(ncid) - - implicit none - - integer :: ncid - - call nf90_err(nf90_close(ncid)) -end subroutine close_partoutput_file - -subroutine open_partinit_file(ncid)!,irelease) - - implicit none - - integer, intent(inout) :: ncid - !integer, intent(in) :: irelease - - call nf90_err(nf90_open(trim(ncfname_partinit), nf90_write, ncid)) -end subroutine open_partinit_file - -subroutine partoutput_ncf(itime,field,fieldname,imass,ncid) - - - !***************************************************************************** - ! * - ! Writing a field from PARTOPTIONS to partoutput_xxx.nc created in * - ! writeheader_partoutput * - ! * - ! Author: L. Bakels 2021 * - ! * - !***************************************************************************** - - implicit none - - integer, intent(in) :: itime,imass - real, intent(in) :: field(:) - character(2), intent(in) :: fieldname ! input field to interpolate over - integer, allocatable :: partindices(:) - integer :: ncid,newpart,j - ! ! open output file - ! call nf90_err(nf90_open(trim(ncfname_part), nf90_write, ncid)) - select case(fieldname) - case('TI') - ! write time - tpointer_part = tpointer_part + 1 - call nf90_err(nf90_put_var(ncid, timeIDpart, itime, (/ tpointer_part /))) - case('PA') - newpart = numpart - ppointer_part - - if (tpointer_part.eq.1) then - allocate ( partindices(numpart) ) - do j=1,numpart - partindices(j)=j - end do - - call nf90_err(nf90_put_var(ncid, partID,partindices, (/ 1 /),(/ numpart /))) - - deallocate (partindices) - - ppointer_part = numpart - - else if (newpart.ge.0) then - - allocate ( partindices(newpart) ) - do j=1,newpart - partindices(j)=j+ppointer_part - end do - - call nf90_err(nf90_put_var(ncid, partID,partindices, (/ ppointer_part+1 /),(/ newpart /))) - - deallocate (partindices) - - ppointer_part = numpart - endif - case('LO') ! Longitude - call nf90_err(nf90_put_var(ncid,lonIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('lo') ! Longitude averaged - call nf90_err(nf90_put_var(ncid,lonavIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('LA') ! Latitude - call nf90_err(nf90_put_var(ncid,latIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('la') ! Latitude averaged - call nf90_err(nf90_put_var(ncid,latavIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('ZZ') ! Height - call nf90_err(nf90_put_var(ncid,levIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('zz') ! Height averaged - call nf90_err(nf90_put_var(ncid,levavIDpart,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('IT') ! Itramem (not in use atm) - call nf90_err(nf90_put_var(ncid,itramemID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('TO') ! Topography - if (mdomainfill.ge.1) then - if (topo_written.eqv..false.) call nf90_err(nf90_put_var(ncid,topoID,oro(0:nx-1,0:ny-1), (/ 1,1 /),(/ nx,ny /))) - topo_written=.true. - else - call nf90_err(nf90_put_var(ncid,topoID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - endif - case('to') ! topography averaged - call nf90_err(nf90_put_var(ncid,topoavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('PV') ! Potential vorticity - call nf90_err(nf90_put_var(ncid,pvID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('pv') ! Potential vorticity averaged - call nf90_err(nf90_put_var(ncid,pvavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('PR') ! Pressure - call nf90_err(nf90_put_var(ncid,prID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('pr') ! Pressure averaged - call nf90_err(nf90_put_var(ncid,pravID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('QV') ! Specific humidity - call nf90_err(nf90_put_var(ncid,qvID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('qv') ! Specific humidity averaged - call nf90_err(nf90_put_var(ncid,qvavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('RH') ! Air density - call nf90_err(nf90_put_var(ncid,rhoID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('rh') ! Air density averaged - call nf90_err(nf90_put_var(ncid,rhoavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('UU') ! Longitudinal velocity - call nf90_err(nf90_put_var(ncid,uID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('uu') ! Longitudinal velocity averaged - call nf90_err(nf90_put_var(ncid,uavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('VV') ! Latitudinal velocity - call nf90_err(nf90_put_var(ncid,vID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('vv') ! Latitudinal velocity averaged - call nf90_err(nf90_put_var(ncid,vavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('WW') ! Vertical velocity - call nf90_err(nf90_put_var(ncid,wID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('ww') ! Vertical velocity averaged - call nf90_err(nf90_put_var(ncid,wavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('VS') ! Settling velocity - call nf90_err(nf90_put_var(ncid,vsetID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('vs') ! Settling velocity averaged - call nf90_err(nf90_put_var(ncid,vsetavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('HM') ! Mixing height - if (mdomainfill.ge.1) then - call nf90_err(nf90_put_var(ncid,hmixID,hmix(0:nx-1,0:ny-1,1,memind(1)), & - (/ tpointer_part,1,1 /),(/ 1,nx,ny /))) - else - call nf90_err(nf90_put_var(ncid,hmixID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - endif - case('hm') ! Mixing height averaged - call nf90_err(nf90_put_var(ncid,hmixavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('TR') ! Tropopause - if (mdomainfill.ge.1) then - call nf90_err(nf90_put_var(ncid,trID,tropopause(0:nx-1,0:ny-1,1,memind(1)), & - (/ tpointer_part,1,1 /),(/ 1,nx,ny /))) - else - call nf90_err(nf90_put_var(ncid,trID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - endif - case('tr') ! Tropopause averaged - call nf90_err(nf90_put_var(ncid,travID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('TT') ! Temperature - call nf90_err(nf90_put_var(ncid,ttID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('tt') ! Temperature averaged - call nf90_err(nf90_put_var(ncid,ttavID,field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('MA') ! Mass - if ((mdomainfill.ge.1).and.(imass.eq.1)) then - if (mass_written.eqv..false.) call nf90_err(nf90_put_var(ncid=ncid,varid=massID(1),values=field(1))) - mass_written=.true. - else - call nf90_err(nf90_put_var(ncid,massID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /))) - endif - case('ma') ! Mass averaged - if ((mdomainfill.ge.1).and.(imass.eq.1)) then - if (mass_written.eqv..false.) call nf90_err(nf90_put_var(ncid=ncid,varid=massavID(1),values=field(1))) - massav_written=.true. - else - call nf90_err(nf90_put_var(ncid,massavID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /))) - endif - case('WD') ! Cumulative mass of wet deposition - call nf90_err(nf90_put_var(ncid,wdID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /))) - case('DD') ! Cumulative mass of wet deposition - call nf90_err(nf90_put_var(ncid,ddID(imass),field, (/ tpointer_part,1 /),(/ 1,numpart /))) - end select - - ! call nf90_err(nf90_close(ncid)) -end subroutine partoutput_ncf - -subroutine read_partpos_ncf(ibtime,ibdate) - - !***************************************************************************** - ! * - ! IPIN=2: restarting from a partoutput_xxx.nc file written by a previous * - ! run, depending on what PARTOPTIONS the user has chosen, this * - ! option might not be possible to use * - ! * - ! Author: L. Bakels 2022 * - ! * - !***************************************************************************** - - use random_mod - use particle_mod - use date_mod - - implicit none - - integer, intent(in) :: ibtime,ibdate - integer :: ncidend,tIDend,pIDend,tempIDend - integer :: tlen,plen,tend,i,j - integer :: idate_start,itime_start - character :: adate*8,atime*6,timeunit*32,adate_start*8,atime_start*6 - character(len=3) :: anspec - real(kind=dp) :: julin,julcommand,julpartin - - integer :: idummy = -8 - - write(adate,'(i8.8)') ibdate - write(atime,'(i6.6)') ibtime - - if (mquasilag.ne.0) then - write(*,*) 'Combination of ipin, netcdf partoutput, and mquasilag!=0 does not work yet' - stop - endif - - ! Open partoutput_end.nc file - call nf90_err(nf90_open(trim('partoutput_end.nc'), mode=NF90_NOWRITE,ncid=ncidend)) - - ! Take the positions of the particles at the last timestep in the file - ! It needs to be the same as given in the COMMAND file, this is arbitrary - ! and should be removed in the future for easier use - - ! First get the time dimension - call nf90_err(nf90_inq_dimid(ncid=ncidend,name='time',dimid=tIDend)) - call nf90_err(nf90_inquire_dimension(ncid=ncidend,dimid=tIDend,len=tlen)) - - ! Check if the time corresponds to the one given in the COMMAND file - call nf90_err(nf90_inq_varid(ncid=ncidend,name='time',varid=tIDend)) - call nf90_err(nf90_get_att(ncid=ncidend,varid=tIDend,name='units',values=timeunit)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tIDend,values=tend,start=(/ tlen /)))!,count=(/ 1 /))) - adate_start(1:4) = timeunit(15:18) - adate_start(5:6) = timeunit(20:21) - adate_start(7:8) = timeunit(23:24) - atime_start = '000000' - atime_start(1:2) = timeunit(26:27) - atime_start(3:4) = timeunit(29:30) - read(adate_start,*) idate_start - read(atime_start,*) itime_start - julin = juldate(idate_start,itime_start)+real(tend,kind=dp)/86400._dp - julcommand = juldate(ibdate,ibtime) - if (abs(julin-julcommand).gt.1.e-5) then - write(*,*) 'ERROR: The given starting time and date do not correspond to' - write(*,*) 'the last timestep of partoutput_end.nc:' - write(*,*) julin,julcommand,tend - stop - endif - - ! Then the particle dimension - call nf90_err(nf90_inq_dimid(ncid=ncidend,name='particle',dimid=pIDend)) - call nf90_err(nf90_inquire_dimension(ncid=ncidend,dimid=pIDend,len=plen)) - - ! Now spawn the correct number of particles - write(*,*) 'Npart:',plen - call spawn_particles(0,plen) - - ! And give them the correct positions - ! Longitude - call nf90_err(nf90_inq_varid(ncid=ncidend,name='longitude',varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%xlon, & - start=(/ tlen, 1 /),count=(/ 1, plen /))) - part(:)%xlon=(part(:)%xlon-xlon0)/dx - ! Latitude - call nf90_err(nf90_inq_varid(ncid=ncidend,name='latitude',varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%ylat, & - start=(/ tlen, 1 /),count=(/ 1, plen /))) - part(:)%ylat=(part(:)%ylat-ylat0)/dx - ! Height - call nf90_err(nf90_inq_varid(ncid=ncidend,name='height',varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%z, & - start=(/ tlen, 1 /),count=(/ 1, plen /))) - ! Mass - if (mdomainfill.eq.0) then - do j=1,nspec - write(anspec, '(i3.3)') j - call nf90_err(nf90_inq_varid(ncid=ncidend,name='mass'//anspec,varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%mass(j), & - start=(/ tlen, 1 /),count=(/ 1, plen /))) - end do - endif - - do i=1,plen - if (part(i)%z.lt.0) then - call terminate_particle(i,0) - write(*,*) 'Particle ',i,'is not alive in the restart file.' - endif - part(i)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, & - nclassunc) - part(i)%idt=mintime - part(i)%npoint=1 - end do - - call nf90_err(nf90_close(ncidend)) -end subroutine read_partpos_ncf - -subroutine read_init_cond_nc() - - !***************************************************************************** - ! * - ! IPIN=3: starting a run from a user defined initial particle conditions, * - ! more on how to create such a file can be found in the manual * - ! IPIN=4: restarting a run, while also reading in the initial particle * - ! conditions * - ! * - ! Author: L. Bakels 2022 * - ! * - !***************************************************************************** - - use random_mod - use particle_mod - use date_mod - use coord_ec_mod - use readoptions_mod - use drydepo_mod - - implicit none - - integer :: ncidend,tIDend,pIDend,tempIDend,stat - integer :: plen,tend,i,j,release_max,nsp - integer :: zkind - real :: totmass,cun - integer,allocatable, dimension (:) :: specnum_rel,numpoint_max - real,allocatable,dimension(:,:) :: mass_temp - real,allocatable,dimension(:) :: vsh,fracth,schmih - - integer :: idummy = -8 - - if (mquasilag.ne.0) then - write(*,*) 'Combination of ipin, netcdf partoutput, and mquasilag!=0 does not work yet' - stop - endif - - ! Open part_ic.nc file - call nf90_err(nf90_open(trim(path(2)(1:length(2))//'part_ic.nc'), mode=NF90_NOWRITE,ncid=ncidend)) - - ! allocate with maxspec for first input loop - allocate(specnum_rel(maxspec),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel' - - ! How many species are contained in each particle? - call nf90_err(nf90_inquire_attribute(ncid=ncidend,name='nspecies',varid=NF90_GLOBAL)) - call nf90_err(nf90_get_att(ncid=ncidend,varid=NF90_GLOBAL,name='nspecies',values=nspec)) - - ! Which species? - call nf90_err(nf90_inquire_attribute(ncid=ncidend,name='species',varid=NF90_GLOBAL)) - call nf90_err(nf90_get_att(ncid=ncidend,varid=NF90_GLOBAL,name='species',values=specnum_rel(1:nspec))) - - ! Get the particle dimension - call nf90_err(nf90_inq_dimid(ncid=ncidend,name='particle',dimid=pIDend)) - call nf90_err(nf90_inquire_dimension(ncid=ncidend,dimid=pIDend,len=plen)) - - ! Now spawn the correct number of particles - write(*,*) 'Npart:',plen - call alloc_particles( plen ) - ! allocate temporary mass array - allocate(mass_temp(plen,nspec)) - - ! And give them the correct positions - ! Longitude - call nf90_err(nf90_inq_varid(ncid=ncidend,name='longitude',varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%xlon, & - start=(/ 1 /),count=(/ plen /))) - part(:)%xlon=(part(:)%xlon-xlon0)/dx - ! Latitude - call nf90_err(nf90_inq_varid(ncid=ncidend,name='latitude',varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%ylat, & - start=(/ 1 /),count=(/ plen /))) - part(:)%ylat=(part(:)%ylat-ylat0)/dx - ! Height - call nf90_err(nf90_inq_varid(ncid=ncidend,name='height',varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%z, & - start=(/ 1 /),count=(/ plen /))) - ! Spawning time - call nf90_err(nf90_inq_varid(ncid=ncidend,name='time',varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%tstart, & - start=(/ 1 /),count=(/ plen /))) - ! Mass - call nf90_err(nf90_inq_varid(ncid=ncidend,name='mass',varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=mass_temp, & - start=(/ 1,1 /),count=(/ plen,nspec /))) - do nsp=1,nspec - part(:)%mass(nsp)=mass_temp(1:plen,nsp) - end do - deallocate(mass_temp) - ! Release - call nf90_err(nf90_inq_varid(ncid=ncidend,name='release',varid=tempIDend)) - call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%npoint, & - start=(/ 1 /),count=(/ plen /))) - ! ! Species - ! call nf90_err(nf90_inq_varid(ncid=ncidend,name='species',varid=tempIDend)) - ! call nf90_err(nf90_get_var(ncid=ncidend,varid=tempIDend,values=part(:)%species, & - ! start=(/ 1 /),count=(/ plen /))) - - ! Count number of releases - numpoint=1 - allocate(numpoint_max(plen),stat=stat) - numpoint_max=0 - release_max=0 - - l1: do i=1,plen - l2: do j=1,numpoint - if (part(i)%npoint.eq.numpoint_max(numpoint)) then - cycle l1 - endif - end do l2 - numpoint = numpoint+1 - numpoint_max(numpoint)=part(i)%npoint - if (part(i)%npoint.gt.release_max) release_max=part(i)%npoint - end do l1 - - allocate(kindz(numpoint),stat=stat) - kindz=-1 - if (stat.ne.0) write(*,*)'ERROR: could not allocate kindz' - ! Above sea-level or ground? - call nf90_err(nf90_inquire_attribute(ncid=ncidend,name='kindz',varid=NF90_GLOBAL)) - call nf90_err(nf90_get_att(ncid=ncidend,varid=NF90_GLOBAL,name='kindz',values=zkind)) - kindz=zkind - do nsp=1,nspec - if ((kindz(nsp).le.0).or.(kindz(nsp).ge.4)) then - write(*,*) 'ERROR: kindz should be an integer between 1 and 3, not', kindz(nsp) - stop - endif - end do - - if (ioutputforeachrelease.eq.1) then - maxpointspec_act=numpoint - else - maxpointspec_act=1 - endif - - if (release_max.gt.numpoint) then - write(*,*) "WARNING: release numbers in part_ic.nc are not consecutive:", & - release_max, "is larger than the total number of releases:", numpoint, & - " Releases will be renumbered." - - do j=1,numpoint - do i=1,plen - if (part(i)%npoint.eq.numpoint_max(j)) then - part(i)%npoint=numpoint_max(j) - endif - end do - end do - endif - deallocate(numpoint_max) - - allocate(xmass(numpoint,nspec), npart(numpoint),ireleasestart(numpoint),ireleaseend(numpoint)) - xmass=0 - npart=0 - ireleasestart=-1 - ireleaseend=-1 - do i=1,plen - do j=1,numpoint - do nsp=1,nspec - xmass(j,nsp) = xmass(j,nsp)+part(i)%mass(nsp) - end do - if (part(i)%npoint.eq.j) then - npart(j)=npart(j)+1 - if ((ireleasestart(j).gt.part(i)%tstart).or.(ireleasestart(j).eq.-1)) ireleasestart(j)=part(i)%tstart - if ((ireleaseend(j).le.part(i)%tstart).or.(ireleaseend(j).eq.-1)) ireleaseend(j)=part(i)%tstart - endif - end do - end do - if ((iout.eq.4).or.(iout.eq.5)) then - write(*,*) "ERROR: IPIN=3 or IPIN=4, using the part_ic.nc file, is not possible in combination with plume", & - "computations (IOUT=4 or 5)." - stop - endif - - part(:)%idt=part(:)%tstart - do i=1,plen - part(i)%nclass=min(int(ran1(idummy,0)*real(nclassunc))+1, & - nclassunc) - part(i)%mass_init=part(i)%mass - ! Activate particles that are alive from the start of the simulation - if (part(i)%tstart.eq.0) then - call spawn_particle(0,i) - endif - end do - write(*,FMT='(A,ES14.7)') ' Total mass to be released:', sum(xmass(1:numpoint,1:nspec)) - call get_totalpart_num(numpart) - numparticlecount=numpart - call nf90_err(nf90_close(ncidend)) - - - ! Read species and derive initial conditions +#include "net_writemetadata.f90" - !now save the information - DEP=.false. - DRYDEP=.false. - WETDEP=.false. - OHREA=.false. - do nsp=1,maxspec - DRYDEPSPEC(nsp)=.false. - WETDEPSPEC(nsp)=.false. - end do - do nsp=1,nspec - call readspecies(specnum_rel(nsp),nsp) - ! Allocate temporary memory necessary for the different diameter bins - !******************************************************************** - allocate(vsh(ndia(nsp)),fracth(ndia(nsp)),schmih(ndia(nsp))) +#include "net_nf90_err.f90" - ! Molecular weight - !***************** - if (((iout.eq.2).or.(iout.eq.3)).and.(weightmolar(nsp).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 +#include "net_writeheader_ncf.f90" - ! Radioactive decay - !****************** - decay(nsp)=0.693147/decay(nsp) !conversion half life to decay constant +#include "net_read_grid_id.f90" - ! Dry deposition of gases - !************************ +#include "net_concoutput_ncf.f90" - if (reldiff(nsp).gt.0.) rm(nsp)=1./(henry(nsp)/3000.+100.*f0(nsp)) ! mesophyll resistance +#include "net_concoutput_sfc_ncf.f90" - ! Dry deposition of particles - !**************************** +#include "net_concoutput_ncf_nest.f90" - vsetaver(nsp)=0. - cunningham(nsp)=0. - dquer(nsp)=dquer(nsp)*1000000. ! Conversion m to um - if (density(nsp).gt.0.) then ! Additional parameters - call part0(dquer(nsp),dsigma(nsp),density(nsp),ndia(nsp),fracth,schmih,cun,vsh) - do j=1,ndia(nsp) - fract(nsp,j)=fracth(j) - schmi(nsp,j)=schmih(j) - vset(nsp,j)=vsh(j) - cunningham(nsp)=cunningham(nsp)+cun*fract(nsp,j) - vsetaver(nsp)=vsetaver(nsp)-vset(nsp,j)*fract(nsp,j) - end do - if (lroot) write(*,*) 'Average settling velocity: ',i,vsetaver(nsp) - endif +#include "net_concoutput_sfc_ncf_nest.f90" - ! Dry deposition for constant deposition velocity - !************************************************ +#include "net_particle_initialpos.f90" - dryvel(nsp)=dryvel(nsp)*0.01 ! conversion to m/s +#include "net_wrt_part_initialpos.f90" - ! Check if wet deposition or OH reaction shall be calculated - !*********************************************************** +#include "net_partinit_ncf.f90" - ! ESO 04.2016 check for below-cloud scavenging (gas or aerosol) - if ((dquer(nsp).le.0..and.(weta_gas(nsp).gt.0. .or. wetb_gas(nsp).gt.0.)) .or. & - &(dquer(nsp).gt.0. .and. (crain_aero(nsp) .gt. 0. .or. csnow_aero(nsp).gt.0.))) then - WETDEP=.true. - WETDEPSPEC(nsp)=.true. - if (lroot) then - write (*,*) ' Below-cloud scavenging: ON' - end if - else - if (lroot) write (*,*) ' Below-cloud scavenging: OFF' - endif +#include "net_writeheader_partoutput.f90" - ! NIK 31.01.2013 + 10.12.2013 + 15.02.2015 - if (dquer(nsp).gt.0..and.(ccn_aero(nsp).gt.0. .or. in_aero(nsp).gt.0.)) then - WETDEP=.true. - WETDEPSPEC(nsp)=.true. - if (lroot) then - write (*,*) ' In-cloud scavenging: ON' - end if - else - if (lroot) write (*,*) ' In-cloud scavenging: OFF' - endif +#include "net_write_to_file.f90" - if (ohcconst(nsp).gt.0.) then - OHREA=.true. - if (lroot) write (*,*) ' OHreaction switched on: ',ohcconst(nsp),nsp - endif +#include "net_open_partoutput_file.f90" - if ((reldiff(nsp).gt.0.).or.(density(nsp).gt.0.).or.(dryvel(nsp).gt.0.)) then - DRYDEP=.true. - DRYDEPSPEC(nsp)=.true. - endif +#include "net_close_partoutput_file.f90" - deallocate(vsh,fracth,schmih) - end do ! end loop over species +#include "net_open_partinit_file.f90" - if (WETDEP.or.DRYDEP) then - DEP=.true. - endif +#include "net_partoutput_ncf.f90" +#include "net_read_partpos_ncf.f90" - deallocate(specnum_rel) -end subroutine read_init_cond_nc +#include "net_read_init_cond_nc.f90" end module netcdf_output_mod diff --git a/src/ohr_gethourlyOH.f90 b/src/ohr_gethourlyOH.f90 new file mode 100644 index 0000000000000000000000000000000000000000..98a41ed29e6942aff2f84f38075cf9bf488d68ee --- /dev/null +++ b/src/ohr_gethourlyOH.f90 @@ -0,0 +1,138 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine gethourlyOH(itime) + ! i + !***************************************************************************** + ! * + ! * + ! Author: R.L. Thompson * + ! * + ! Nov 2014 * + ! * + ! * + !***************************************************************************** + ! Variables: * + ! * + !***************************************************************************** + use par_mod + use com_mod + + implicit none + + integer :: itime + integer :: ix,jy,kz,m1,m2 + integer :: ijx,jjy + integer :: jjjjmmdd,hhmmss + real :: sza,jrate + real(kind=dp) :: jul1,jul2 + + + ! Check hourly OH field is available for the current time step + !************************************************************** + + if ((ldirect*memOHtime(1).le.ldirect*itime).and. & + (ldirect*memOHtime(2).gt.ldirect*itime)) then + + ! The right OH fields are already in memory -> don't do anything + !**************************************************************** + + return + + else if ((ldirect*memOHtime(2).le.ldirect*itime).and. & + (memOHtime(2).ne.0.)) then + + ! Current time is after 2nd OH field + !************************************ + + memOHtime(1)=memOHtime(2) + memOHtime(2)=memOHtime(1)+ldirect*3600. + OH_hourly(:,:,:,1)=OH_hourly(:,:,:,2) + + ! Compute new hourly value of OH + !********************************************************** + + jul2=bdate+memOHtime(2)/86400._dp ! date for next hour + call caldate(jul2,jjjjmmdd,hhmmss) + m2=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100 + +!$OMP PARALLEL PRIVATE(kz,jy,ix,ijx,jjy,sza,jrate) +!$OMP DO COLLAPSE(3) + do kz=1,nzOH + do jy=1,nyOH + do ix=1,nxOH + ijx=minloc(abs(lonjr-lonOH(ix)),dim=1,mask=abs(lonjr-lonOH(ix)).eq.minval(abs(lonjr-lonOH(ix)))) + jjy=minloc(abs(latjr-latOH(jy)),dim=1,mask=abs(latjr-latOH(jy)).eq.minval(abs(latjr-latOH(jy)))) + ! calculate solar zenith angle in degrees (sza) + sza=zenithangle(latOH(jy),lonOH(ix),jul2) + ! calculate J(O1D) (jrate) + jrate=photo_O1D(sza) + ! apply hourly correction to OH + if(jrate_average(ijx,jjy,m2).gt.0.) then + OH_hourly(ix,jy,kz,2)=OH_field(ix,jy,kz,m2)*jrate/jrate_average(ijx,jjy,m2) + else + OH_hourly(ix,jy,kz,2)=0. + endif + !! for testing !! + ! if(jy.eq.36.and.ix.eq.36.and.kz.eq.1) then + ! write(999,fmt='(F6.3)') jrate/jrate_average(ijx,jjy,m2) + ! endif + ! if(jy.eq.11.and.ix.eq.36.and.kz.eq.1) then + ! write(998,fmt='(F6.3)') jrate/jrate_average(ijx,jjy,m2) + ! endif + end do + end do + end do +!$OMP END DO +!$OMP END PARALLEL + + else + + ! No OH fields in memory -> compute both hourly OH fields + !********************************************************** + + jul1=bdate ! begin date of simulation (julian) + call caldate(jul1,jjjjmmdd,hhmmss) + m1=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100 + memOHtime(1)=0. + + jul2=bdate+ldirect*real(1./24.,kind=dp) ! date for next hour + call caldate(jul2,jjjjmmdd,hhmmss) + m2=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100 + memOHtime(2)=ldirect*3600. + +!$OMP PARALLEL PRIVATE(kz,jy,ix,ijx,jjy,sza,jrate) +!$OMP DO COLLAPSE(3) + do kz=1,nzOH + do jy=1,nyOH + do ix=1,nxOH + ijx=minloc(abs(lonjr-lonOH(ix)),dim=1,mask=abs(lonjr-lonOH(ix)).eq.minval(abs(lonjr-lonOH(ix)))) + jjy=minloc(abs(latjr-latOH(jy)),dim=1,mask=abs(latjr-latOH(jy)).eq.minval(abs(latjr-latOH(jy)))) + ! calculate solar zenith angle in degrees (sza), beginning + sza=zenithangle(latOH(jy),lonOH(ix),jul1) + ! calculate J(O1D) (jrate), beginning + jrate=photo_O1D(sza) + ! apply hourly correction to OH + if(jrate_average(ijx,jjy,m1).gt.0.) then + OH_hourly(ix,jy,kz,1)=OH_field(ix,jy,kz,m1)*jrate/jrate_average(ijx,jjy,m1) + else + OH_hourly(ix,jy,kz,1)=0. + endif + ! calculate solar zenith angle in degrees (sza), after 1-hour + sza=zenithangle(latOH(jy),lonOH(ix),jul2) + ! calculate J(O1D) (jrate), after 1-hour + jrate=photo_O1D(sza) + ! apply hourly correction to OH + if(jrate_average(ijx,jjy,m2).gt.0.) then + OH_hourly(ix,jy,kz,2)=OH_field(ix,jy,kz,m2)*jrate/jrate_average(ijx,jjy,m2) + else + OH_hourly(ix,jy,kz,2)=0. + endif + end do + end do + end do +!$OMP END DO +!$OMP END PARALLEL + + endif +end subroutine gethourlyOH diff --git a/src/ohr_mod.f90 b/src/ohr_mod.f90 index 6e92468b47055d7ea7e613102a6c3600ff362968..1f84d4bbae23e9478ce8ec675878f78347eb7c7e 100644 --- a/src/ohr_mod.f90 +++ b/src/ohr_mod.f90 @@ -6,7 +6,7 @@ module ohr_mod !includes OH concentration field as well as the height information !for this field use date_mod - + implicit none integer :: nxOH,nyOH,nzOH @@ -20,433 +20,12 @@ module ohr_mod contains -real function photo_O1D(sza) - - !***************************************************************************** - ! * - ! * - ! Author: A. Stohl * - ! * - ! Nov 2014 * - ! * - ! * - !***************************************************************************** - ! * - ! INPUT: * - ! sza solar zenith angle (degrees) * - ! * - ! OUTPUT: * - ! photo_O1D J(O1D) photoylsis rate * - ! * - !***************************************************************************** - - implicit none - - integer :: iz,ik - real :: sza - real :: z1,z2,zg,f1,f2,dummy - real :: photo_NO2 - integer, parameter :: nzenith=11 - real, parameter :: pi=3.1415927 - real, dimension(nzenith) :: zangle,fact_photo - - ! zangle: zenith angles for which fact_photo is tabulated - ! fact_photo: conversion of photolysis rate of NO2 to photolysis - ! rate of O3 into O1D as a function of solar zenith angle - - zangle=(/0.,10.,20.,30.,40.,50.,60.,70.,78.,86.,90.0001/) - fact_photo=(/0.4616E-02,0.4478E-02,0.4131E-02,0.3583E-02,0.2867E-02,& - &0.2081E-02,0.1235E-02,0.5392E-03,0.2200E-03,0.1302E-03,0.0902E-03/) - - if (sza.lt.90.) then - do iz=1,nzenith-1 - if(sza.ge.zangle(iz)) ik=iz - end do - z1=1./cos(zangle(ik)*pi/180.) - z2=1./cos(zangle(ik+1)*pi/180.) - zg=1./cos(sza*pi/180.) - dummy=(zg-z1)/(z2-z1) - f1=alog(fact_photo(ik)) - f2=alog(fact_photo(ik+1)) - photo_NO2=1.45e-2*exp(-0.4/cos(sza*pi/180.)) - photo_O1D=photo_NO2*exp(f1+(f2-f1)*dummy) - else - photo_O1D=0. - endif - - return - -end function photo_O1D - -real function zenithangle(ylat,xlon,jul) - - !********************************************************************* - ! * - ! Author: G. WOTAWA * - ! Date: 1993-11-17 * - ! Project: POP-M * - ! Last update: * - ! * - !********************************************************************* - ! * - ! DESCRIPTION: This function returns the sinus of solar * - ! elevation as a function of geographic longitude, * - ! latitude and GMT-Time. * - ! * - !********************************************************************* - ! * - ! INPUT: * - ! * - ! ylat geographical latitude [DEG] * - ! xlon geographical longitude [DEG] * - ! jjjj Year * - ! mm Month * - ! dd Day * - ! hh Hour * - ! minute Minute * - ! * - !********************************************************************* - - use par_mod, only: dp - - implicit none - - integer :: jjjj,mm,id,iu,minute,yyyymmdd,hhmmss - integer :: ndaynum - real :: sinsol,solelev,ylat,xlon - real :: rnum,rylat,ttime,dekl,rdekl,eq - real,parameter :: pi=3.1415927 - real(kind=dp) :: jul - - call caldate(jul,yyyymmdd,hhmmss) - jjjj=yyyymmdd/10000 - mm=yyyymmdd/100-jjjj*100 - id=yyyymmdd-jjjj*10000-mm*100 - iu=hhmmss/10000 - minute=hhmmss/100-100*iu - - ndaynum=31*(mm-1)+id - if(mm.gt.2) ndaynum=ndaynum-int(0.4*mm+2.3) - if((mm.gt.2).and.(jjjj/4*4.eq.jjjj)) ndaynum=ndaynum+1 - - rnum=2.*pi*ndaynum/365. - rylat=pi*ylat/180. - ttime=real(iu)+real(minute)/60. - - dekl=0.396+3.631*sin(rnum)+0.038*sin(2.*rnum)+0.077*sin(3.*rnum)- & - 22.97*cos(rnum)-0.389*cos(2.*rnum)-0.158*cos(3.*rnum) - rdekl=pi*dekl/180. - - eq=(0.003-7.343*sin(rnum)-9.47*sin(2.*rnum)- & - 0.329*sin(3.*rnum)-0.196*sin(4.*rnum)+ & - 0.552*cos(rnum)-3.020*cos(2.*rnum)- & - 0.076*cos(3.*rnum)-0.125*cos(4.*rnum))/60. - - sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)* & - cos((ttime-12.+xlon/15.+eq)*pi/12.) - ! Calculate the maximum solar elevation on that day - !sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)* - ! & cos((eq)*pi/12.) - solelev=asin(sinsol)*180./pi - zenithangle=90.-solelev - - return -end function zenithangle - -subroutine ohreaction(itime,ltsample,loutnext) - ! i i i - !***************************************************************************** - ! * - ! * - ! Author: R.L. Thompson * - ! * - ! Nov 2014 * - ! * - ! * - !***************************************************************************** - ! 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 [molecule/cm^3] OH Concentration * - ! ltsample [s] interval over which mass is deposited * - ! * - !***************************************************************************** - use par_mod - use com_mod - use windfields_mod - use particle_mod - - implicit none - - integer :: jpart,itime,ltsample,loutnext,ldeltat,j,k,ix,jy!,ijx,jjy -!PS integer :: ngrid,interp_time,m,n,ih,indz,i!,ia,il - integer :: ngrid,interp_time,n,indz,i!,ia,il -!PS integer :: jjjjmmdd,hhmmss, - integer OHx,OHy,OHz - real, dimension(nzOH) :: altOHtop - real :: xlon,ylat - real :: xtn,ytn - real :: restmass,ohreacted,oh_average - real :: ohrate,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 - !************************************************************************ - - if (itime.le.loutnext) then - ldeltat=itime-(loutnext-loutstep) - else ! first half of next interval - ldeltat=itime-loutnext - endif - -!PS jul=bdate+real(itime,kind=dp)/86400. -!PS call caldate(jul,jjjjmmdd,hhmmss) -!PS m=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100 -!PS h=hhmmss/10000 - - ! Loop over particles - !***************************************** -!$OMP PARALLEL PRIVATE(jpart,xtn,ytn,j,k,ix,jy,interp_time, & -!$OMP n,indz,i,xlon,ylat,OHx,OHy,OHz,oh_average,temp,ohrate, & -!$OMP restmass,ohreacted,altOHtop,ngrid) - -!$OMP DO - do jpart=1,numpart - - ! Determine which nesting level to be used - ngrid=0 - do j=numbnests,1,-1 ! Why is there a +/- eps everywhere else for ngrid but not here? - if ((part(jpart)%xlon.gt.xln(j)).and.(part(jpart)%xlon.lt.xrn(j)).and. & - (part(jpart)%ylat.gt.yln(j)).and.(part(jpart)%ylat.lt.yrn(j))) then - ngrid=j - exit - endif - end do - - ! Determine nested grid coordinates - if (ngrid.gt.0) then - xtn=(part(jpart)%xlon-xln(ngrid))*xresoln(ngrid) - ytn=(part(jpart)%ylat-yln(ngrid))*yresoln(ngrid) - ix=int(xtn) - jy=int(ytn) - else - ix=int(part(jpart)%xlon) - jy=int(part(jpart)%ylat) - endif - - interp_time=nint(itime-0.5*ltsample) - n=2 - if(abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) n=1 - - indz=nz-1 - do i=2,nz - if (height(i).gt.part(jpart)%z) then - indz=i-1 - exit - endif - end do - - ! Get OH from nearest grid-cell and specific month - !************************************************* - - ! world coordinates - xlon=part(jpart)%xlon*dx+xlon0 - if (xlon.gt.180) then - xlon=xlon-360 - endif - ylat=part(jpart)%ylat*dy+ylat0 - - ! get position in the OH field - OHx=minloc(abs(lonOH-xlon),dim=1,mask=abs(lonOH-xlon).eq.minval(abs(lonOH-xlon))) - OHy=minloc(abs(latOH-ylat),dim=1,mask=abs(latOH-ylat).eq.minval(abs(latOH-ylat))) - - ! get the level of the OH field for the particle - ! z is the z-coord of the trajectory above model orography in metres - ! altOH is the height of the centre of the level in the OH field above orography - do i=2,nzOH - altOHtop(i-1)=altOH(i)+0.5*(altOH(i)-altOH(i-1)) - end do - altOHtop(nzOH)=altOH(nzOH)+0.5*(altOH(nzOH)-altOH(nzOH-1)) - OHz=minloc(abs(altOHtop-part(jpart)%z),dim=1,mask=abs(altOHtop-part(jpart)%z) & - .eq.minval(abs(altOHtop-part(jpart)%z))) - - ! Interpolate between hourly OH fields to current time - !***************************************************** - - oh_average=OH_hourly(OHx,OHy,OHz,1)+ & - (OH_hourly(OHx,OHy,OHz,2)-OH_hourly(OHx,OHy,OHz,1))* & - (itime-memOHtime(1))/(memOHtime(2)-memOHtime(1)) - - if (oh_average.gt.smallnum) then - - ! Computation of the OH reaction - !********************************************************** - - temp=tt(ix,jy,indz,n) - - do k=1,nspec - if (ohcconst(k).gt.0.) then - ohrate=ohcconst(k)*temp**ohnconst(k)*exp(-ohdconst(k)/temp)*oh_average - ! new particle mass - restmass = part(jpart)%mass(k)*exp(-1*ohrate*abs(ltsample)) - if (restmass .gt. smallnum) then - part(jpart)%mass(k)=restmass - else - part(jpart)%mass(k)=0. - endif - ohreacted=part(jpart)%mass(k)*(1-exp(-1*ohrate*abs(ltsample))) - if (jpart.eq.1) write(*,*) 'ohreaction', part(jpart)%mass(k),k - else - ohreacted=0. - endif - end do - endif ! oh_average.gt.smallnum - - end do !continue loop over all particles - -!$OMP END DO -!$OMP END PARALLEL -end subroutine ohreaction - -subroutine gethourlyOH(itime) - ! i - !***************************************************************************** - ! * - ! * - ! Author: R.L. Thompson * - ! * - ! Nov 2014 * - ! * - ! * - !***************************************************************************** - ! Variables: * - ! * - !***************************************************************************** - use par_mod - use com_mod - - implicit none - - integer :: itime - integer :: ix,jy,kz,m1,m2 - integer :: ijx,jjy - integer :: jjjjmmdd,hhmmss - real :: sza,jrate - real(kind=dp) :: jul1,jul2 - - - ! Check hourly OH field is available for the current time step - !************************************************************** - - if ((ldirect*memOHtime(1).le.ldirect*itime).and. & - (ldirect*memOHtime(2).gt.ldirect*itime)) then - - ! The right OH fields are already in memory -> don't do anything - !**************************************************************** - - return - - else if ((ldirect*memOHtime(2).le.ldirect*itime).and. & - (memOHtime(2).ne.0.)) then - - ! Current time is after 2nd OH field - !************************************ - - memOHtime(1)=memOHtime(2) - memOHtime(2)=memOHtime(1)+ldirect*3600. - OH_hourly(:,:,:,1)=OH_hourly(:,:,:,2) - - ! Compute new hourly value of OH - !********************************************************** - - jul2=bdate+memOHtime(2)/86400._dp ! date for next hour - call caldate(jul2,jjjjmmdd,hhmmss) - m2=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100 - -!$OMP PARALLEL PRIVATE(kz,jy,ix,ijx,jjy,sza,jrate) -!$OMP DO COLLAPSE(3) - do kz=1,nzOH - do jy=1,nyOH - do ix=1,nxOH - ijx=minloc(abs(lonjr-lonOH(ix)),dim=1,mask=abs(lonjr-lonOH(ix)).eq.minval(abs(lonjr-lonOH(ix)))) - jjy=minloc(abs(latjr-latOH(jy)),dim=1,mask=abs(latjr-latOH(jy)).eq.minval(abs(latjr-latOH(jy)))) - ! calculate solar zenith angle in degrees (sza) - sza=zenithangle(latOH(jy),lonOH(ix),jul2) - ! calculate J(O1D) (jrate) - jrate=photo_O1D(sza) - ! apply hourly correction to OH - if(jrate_average(ijx,jjy,m2).gt.0.) then - OH_hourly(ix,jy,kz,2)=OH_field(ix,jy,kz,m2)*jrate/jrate_average(ijx,jjy,m2) - else - OH_hourly(ix,jy,kz,2)=0. - endif - !! for testing !! - ! if(jy.eq.36.and.ix.eq.36.and.kz.eq.1) then - ! write(999,fmt='(F6.3)') jrate/jrate_average(ijx,jjy,m2) - ! endif - ! if(jy.eq.11.and.ix.eq.36.and.kz.eq.1) then - ! write(998,fmt='(F6.3)') jrate/jrate_average(ijx,jjy,m2) - ! endif - end do - end do - end do -!$OMP END DO -!$OMP END PARALLEL - - else - - ! No OH fields in memory -> compute both hourly OH fields - !********************************************************** - - jul1=bdate ! begin date of simulation (julian) - call caldate(jul1,jjjjmmdd,hhmmss) - m1=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100 - memOHtime(1)=0. +#include "ohr_photo_O1D.f90" - jul2=bdate+ldirect*real(1./24.,kind=dp) ! date for next hour - call caldate(jul2,jjjjmmdd,hhmmss) - m2=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100 - memOHtime(2)=ldirect*3600. +#include "ohr_zenithangle.f90" -!$OMP PARALLEL PRIVATE(kz,jy,ix,ijx,jjy,sza,jrate) -!$OMP DO COLLAPSE(3) - do kz=1,nzOH - do jy=1,nyOH - do ix=1,nxOH - ijx=minloc(abs(lonjr-lonOH(ix)),dim=1,mask=abs(lonjr-lonOH(ix)).eq.minval(abs(lonjr-lonOH(ix)))) - jjy=minloc(abs(latjr-latOH(jy)),dim=1,mask=abs(latjr-latOH(jy)).eq.minval(abs(latjr-latOH(jy)))) - ! calculate solar zenith angle in degrees (sza), beginning - sza=zenithangle(latOH(jy),lonOH(ix),jul1) - ! calculate J(O1D) (jrate), beginning - jrate=photo_O1D(sza) - ! apply hourly correction to OH - if(jrate_average(ijx,jjy,m1).gt.0.) then - OH_hourly(ix,jy,kz,1)=OH_field(ix,jy,kz,m1)*jrate/jrate_average(ijx,jjy,m1) - else - OH_hourly(ix,jy,kz,1)=0. - endif - ! calculate solar zenith angle in degrees (sza), after 1-hour - sza=zenithangle(latOH(jy),lonOH(ix),jul2) - ! calculate J(O1D) (jrate), after 1-hour - jrate=photo_O1D(sza) - ! apply hourly correction to OH - if(jrate_average(ijx,jjy,m2).gt.0.) then - OH_hourly(ix,jy,kz,2)=OH_field(ix,jy,kz,m2)*jrate/jrate_average(ijx,jjy,m2) - else - OH_hourly(ix,jy,kz,2)=0. - endif - end do - end do - end do -!$OMP END DO -!$OMP END PARALLEL +#include "ohr_ohreaction.f90" - endif -end subroutine gethourlyOH +#include "ohr_gethourlyOH.f90" end module ohr_mod diff --git a/src/ohr_ohreaction.f90 b/src/ohr_ohreaction.f90 new file mode 100644 index 0000000000000000000000000000000000000000..aa5c1ee16779dafa589e095aca74720ab802a0f7 --- /dev/null +++ b/src/ohr_ohreaction.f90 @@ -0,0 +1,162 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine ohreaction(itime,ltsample,loutnext) + ! i i i + !***************************************************************************** + ! * + ! * + ! Author: R.L. Thompson * + ! * + ! Nov 2014 * + ! * + ! * + !***************************************************************************** + ! 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 [molecule/cm^3] OH Concentration * + ! ltsample [s] interval over which mass is deposited * + ! * + !***************************************************************************** + use par_mod + use com_mod + use windfields_mod + use particle_mod + + implicit none + + integer :: jpart,itime,ltsample,loutnext,ldeltat,j,k,ix,jy!,ijx,jjy +!PS integer :: ngrid,interp_time,m,n,ih,indz,i!,ia,il + integer :: ngrid,interp_time,n,indz,i!,ia,il +!PS integer :: jjjjmmdd,hhmmss, + integer OHx,OHy,OHz + real, dimension(nzOH) :: altOHtop + real :: xlon,ylat + real :: xtn,ytn + real :: restmass,ohreacted,oh_average + real :: ohrate,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 + !************************************************************************ + + if (itime.le.loutnext) then + ldeltat=itime-(loutnext-loutstep) + else ! first half of next interval + ldeltat=itime-loutnext + endif + +!PS jul=bdate+real(itime,kind=dp)/86400. +!PS call caldate(jul,jjjjmmdd,hhmmss) +!PS m=(jjjjmmdd-(jjjjmmdd/10000)*10000)/100 +!PS h=hhmmss/10000 + + ! Loop over particles + !***************************************** +!$OMP PARALLEL PRIVATE(jpart,xtn,ytn,j,k,ix,jy,interp_time, & +!$OMP n,indz,i,xlon,ylat,OHx,OHy,OHz,oh_average,temp,ohrate, & +!$OMP restmass,ohreacted,altOHtop,ngrid) + +!$OMP DO + do jpart=1,numpart + + ! Determine which nesting level to be used + ngrid=0 + do j=numbnests,1,-1 ! Why is there a +/- eps everywhere else for ngrid but not here? + if ((part(jpart)%xlon.gt.xln(j)).and.(part(jpart)%xlon.lt.xrn(j)).and. & + (part(jpart)%ylat.gt.yln(j)).and.(part(jpart)%ylat.lt.yrn(j))) then + ngrid=j + exit + endif + end do + + ! Determine nested grid coordinates + if (ngrid.gt.0) then + xtn=(part(jpart)%xlon-xln(ngrid))*xresoln(ngrid) + ytn=(part(jpart)%ylat-yln(ngrid))*yresoln(ngrid) + ix=int(xtn) + jy=int(ytn) + else + ix=int(part(jpart)%xlon) + jy=int(part(jpart)%ylat) + endif + + interp_time=nint(itime-0.5*ltsample) + n=2 + if(abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) n=1 + + indz=nz-1 + do i=2,nz + if (height(i).gt.part(jpart)%z) then + indz=i-1 + exit + endif + end do + + ! Get OH from nearest grid-cell and specific month + !************************************************* + + ! world coordinates + xlon=part(jpart)%xlon*dx+xlon0 + if (xlon.gt.180) then + xlon=xlon-360 + endif + ylat=part(jpart)%ylat*dy+ylat0 + + ! get position in the OH field + OHx=minloc(abs(lonOH-xlon),dim=1,mask=abs(lonOH-xlon).eq.minval(abs(lonOH-xlon))) + OHy=minloc(abs(latOH-ylat),dim=1,mask=abs(latOH-ylat).eq.minval(abs(latOH-ylat))) + + ! get the level of the OH field for the particle + ! z is the z-coord of the trajectory above model orography in metres + ! altOH is the height of the centre of the level in the OH field above orography + do i=2,nzOH + altOHtop(i-1)=altOH(i)+0.5*(altOH(i)-altOH(i-1)) + end do + altOHtop(nzOH)=altOH(nzOH)+0.5*(altOH(nzOH)-altOH(nzOH-1)) + OHz=minloc(abs(altOHtop-part(jpart)%z),dim=1,mask=abs(altOHtop-part(jpart)%z) & + .eq.minval(abs(altOHtop-part(jpart)%z))) + + ! Interpolate between hourly OH fields to current time + !***************************************************** + + oh_average=OH_hourly(OHx,OHy,OHz,1)+ & + (OH_hourly(OHx,OHy,OHz,2)-OH_hourly(OHx,OHy,OHz,1))* & + (itime-memOHtime(1))/(memOHtime(2)-memOHtime(1)) + + if (oh_average.gt.smallnum) then + + ! Computation of the OH reaction + !********************************************************** + + temp=tt(ix,jy,indz,n) + + do k=1,nspec + if (ohcconst(k).gt.0.) then + ohrate=ohcconst(k)*temp**ohnconst(k)*exp(-ohdconst(k)/temp)*oh_average + ! new particle mass + restmass = part(jpart)%mass(k)*exp(-1*ohrate*abs(ltsample)) + if (restmass .gt. smallnum) then + part(jpart)%mass(k)=restmass + else + part(jpart)%mass(k)=0. + endif + ohreacted=part(jpart)%mass(k)*(1-exp(-1*ohrate*abs(ltsample))) + if (jpart.eq.1) write(*,*) 'ohreaction', part(jpart)%mass(k),k + else + ohreacted=0. + endif + end do + endif ! oh_average.gt.smallnum + + end do !continue loop over all particles + +!$OMP END DO +!$OMP END PARALLEL +end subroutine ohreaction diff --git a/src/ohr_photo_O1D.f90 b/src/ohr_photo_O1D.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ef8570752c554c451050add2b9108c99a45916b9 --- /dev/null +++ b/src/ohr_photo_O1D.f90 @@ -0,0 +1,60 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function photo_O1D(sza) + + !***************************************************************************** + ! * + ! * + ! Author: A. Stohl * + ! * + ! Nov 2014 * + ! * + ! * + !***************************************************************************** + ! * + ! INPUT: * + ! sza solar zenith angle (degrees) * + ! * + ! OUTPUT: * + ! photo_O1D J(O1D) photoylsis rate * + ! * + !***************************************************************************** + + implicit none + + integer :: iz,ik + real :: sza + real :: z1,z2,zg,f1,f2,dummy + real :: photo_NO2 + integer, parameter :: nzenith=11 + real, parameter :: pi=3.1415927 + real, dimension(nzenith) :: zangle,fact_photo + + ! zangle: zenith angles for which fact_photo is tabulated + ! fact_photo: conversion of photolysis rate of NO2 to photolysis + ! rate of O3 into O1D as a function of solar zenith angle + + zangle=(/0.,10.,20.,30.,40.,50.,60.,70.,78.,86.,90.0001/) + fact_photo=(/0.4616E-02,0.4478E-02,0.4131E-02,0.3583E-02,0.2867E-02,& + &0.2081E-02,0.1235E-02,0.5392E-03,0.2200E-03,0.1302E-03,0.0902E-03/) + + if (sza.lt.90.) then + do iz=1,nzenith-1 + if(sza.ge.zangle(iz)) ik=iz + end do + z1=1./cos(zangle(ik)*pi/180.) + z2=1./cos(zangle(ik+1)*pi/180.) + zg=1./cos(sza*pi/180.) + dummy=(zg-z1)/(z2-z1) + f1=alog(fact_photo(ik)) + f2=alog(fact_photo(ik+1)) + photo_NO2=1.45e-2*exp(-0.4/cos(sza*pi/180.)) + photo_O1D=photo_NO2*exp(f1+(f2-f1)*dummy) + else + photo_O1D=0. + endif + + return + +end function photo_O1D diff --git a/src/ohr_zenithangle.f90 b/src/ohr_zenithangle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0e8ea67ffa6b539760ba8a517251ff3d0fa9ef99 --- /dev/null +++ b/src/ohr_zenithangle.f90 @@ -0,0 +1,77 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function zenithangle(ylat,xlon,jul) + + !********************************************************************* + ! * + ! Author: G. WOTAWA * + ! Date: 1993-11-17 * + ! Project: POP-M * + ! Last update: * + ! * + !********************************************************************* + ! * + ! DESCRIPTION: This function returns the sinus of solar * + ! elevation as a function of geographic longitude, * + ! latitude and GMT-Time. * + ! * + !********************************************************************* + ! * + ! INPUT: * + ! * + ! ylat geographical latitude [DEG] * + ! xlon geographical longitude [DEG] * + ! jjjj Year * + ! mm Month * + ! dd Day * + ! hh Hour * + ! minute Minute * + ! * + !********************************************************************* + + use par_mod, only: dp + + implicit none + + integer :: jjjj,mm,id,iu,minute,yyyymmdd,hhmmss + integer :: ndaynum + real :: sinsol,solelev,ylat,xlon + real :: rnum,rylat,ttime,dekl,rdekl,eq + real,parameter :: pi=3.1415927 + real(kind=dp) :: jul + + call caldate(jul,yyyymmdd,hhmmss) + jjjj=yyyymmdd/10000 + mm=yyyymmdd/100-jjjj*100 + id=yyyymmdd-jjjj*10000-mm*100 + iu=hhmmss/10000 + minute=hhmmss/100-100*iu + + ndaynum=31*(mm-1)+id + if(mm.gt.2) ndaynum=ndaynum-int(0.4*mm+2.3) + if((mm.gt.2).and.(jjjj/4*4.eq.jjjj)) ndaynum=ndaynum+1 + + rnum=2.*pi*ndaynum/365. + rylat=pi*ylat/180. + ttime=real(iu)+real(minute)/60. + + dekl=0.396+3.631*sin(rnum)+0.038*sin(2.*rnum)+0.077*sin(3.*rnum)- & + 22.97*cos(rnum)-0.389*cos(2.*rnum)-0.158*cos(3.*rnum) + rdekl=pi*dekl/180. + + eq=(0.003-7.343*sin(rnum)-9.47*sin(2.*rnum)- & + 0.329*sin(3.*rnum)-0.196*sin(4.*rnum)+ & + 0.552*cos(rnum)-3.020*cos(2.*rnum)- & + 0.076*cos(3.*rnum)-0.125*cos(4.*rnum))/60. + + sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)* & + cos((ttime-12.+xlon/15.+eq)*pi/12.) + ! Calculate the maximum solar elevation on that day + !sinsol=sin(rylat)*sin(rdekl)+cos(rylat)*cos(rdekl)* + ! & cos((eq)*pi/12.) + solelev=asin(sinsol)*180./pi + zenithangle=90.-solelev + + return +end function zenithangle diff --git a/src/out_conccalc.f90 b/src/out_conccalc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..06a51df9dea45e6dab135a721a1691b2f2fea84f --- /dev/null +++ b/src/out_conccalc.f90 @@ -0,0 +1,626 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine conccalc(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 * + ! * + ! 2021, LB: OpenMP parallelisation * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! nspeciesdim = nspec for forward runs, 1 for backward runs * + ! * + !***************************************************************************** + + use unc_mod + use prepoutgrid_mod + use par_mod + use com_mod + use omp_lib, only: OMP_GET_THREAD_NUM + use interpol_mod, only: interpol_density + use coord_ec_mod + use particle_mod + + implicit none + + integer,intent(in) :: itime + real,intent(in) :: weight + integer :: itage,i,kz,ks,n,nage,inage,thread,ithread + integer :: il,ind,indz,indzp,nrelpointer + integer :: ix,jy,ixp,jyp + real :: ddx,ddy + real(kind=dp) :: mm3 + real :: hx,hy,hz,hxyz,xd,yd,zd,xkern,r2,c(maxspec) + real :: rhoi + real :: xl,yl,wx,wy,w + real,parameter :: factor=.596831, hxmax=6.0, hymax=4.0, hzmax=150. + ! integer xscav_count + + ! For forward simulations, make a loop over the number of species; + ! for backward simulations, make an additional loop over the + ! releasepoints + !*************************************************************************** + ! xscav_count=0 +#ifdef _OPENMP + call omp_set_num_threads(numthreads_grid) +#endif +!$OMP PARALLEL PRIVATE(i,itage,nage,inage,rhoi,nrelpointer,kz,xl,yl,ks,wx,wy,w,thread,ddx,ddy, & +!$OMP ix,jy,ixp,jyp) +#if (defined _OPENMP) + thread = OMP_GET_THREAD_NUM()+1 ! Starts with 1 +#else + thread = 1 +#endif + +!$OMP DO + do i=1,numpart + if (.not.part(i)%alive) cycle + + ! Determine age class of the particle + itage=abs(itime-part(i)%tstart) + nage=1 + do inage=1,nageclass + nage=inage + if (itage.lt.lage(nage)) exit + end do + + ! if (xscav_frac1(i,1).lt.0) xscav_count=xscav_count+1 + + ! 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 + call update_zeta_to_z(itime,i) + call interpol_density(itime,i,rhoi) + 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=part(i)%npoint + endif + + do kz=1,numzgrid ! determine height of cell + if (outheight(kz).gt.part(i)%z) exit + end do + + if (kz.le.numzgrid) then ! inside output domain + + + !******************************** + ! Do everything for mother domain + !******************************** + + xl=(part(i)%xlon*dx+xoutshift)/dxout + yl=(part(i)%ylat*dy+youtshift)/dyout + 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 ((.not.lusekerneloutput).or.(itage.lt.10800).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 + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0) +#else + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + if (lparticlecountoutput) then + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+1 +#else + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1 +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight +#else + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight +#endif + end do + end if + endif + 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 + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0) +#else + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w +#else + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w +#endif + end do + endif + endif + + if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then + w=wx*(1.-wy) + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#else + gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w +#else + gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w +#endif + end do + endif + endif + endif !ix ge 0 + + + 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) + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0) +#else + gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w +#else + gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w +#endif + end do + endif + endif + + if ((jy.ge.0).and.(jy.le.numygrid-1)) then + w=(1.-wx)*wy + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#else + gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w +#else + gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w +#endif + end do + endif + endif + endif !ixp ge 0 + endif + + !************************************ + ! Do everything for the nested domain + !************************************ + + if (nested_output.eq.1) then + xl=(part(i)%xlon*dx+xoutshiftn)/dxoutn + yl=(part(i)%ylat*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.10800).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).or.((.not.lusekerneloutput))) 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 + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0) +#else + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + if (lparticlecountoutput) then + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+1 +#else + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1 +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight +#else + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight +#endif + end do + endif + endif + 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 + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#else + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w +#else + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w +#endif + end do + endif + endif + + if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then + w=wx*(1.-wy) + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#else + griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w +#else + griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w +#endif + end do + endif + 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) + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#else + griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w +#else + griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w +#endif + end do + endif + endif + + if ((jy.ge.0).and.(jy.le.numygridn-1)) then + w=(1.-wx)*wy + if (DRYBKDEP.or.WETBKDEP) then + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#else + griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) +#endif + end do + else + do ks=1,nspec +#ifdef _OPENMP + griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & + griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & + part(i)%mass(ks)/rhoi*weight*w +#else + griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & + griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & + part(i)%mass(ks)/rhoi*weight*w +#endif + end do + endif + endif + endif + endif + endif + endif + end do +!$OMP END DO +!$OMP END PARALLEL +#ifdef _OPENMP + call omp_set_num_threads(numthreads) +#endif + ! Reduction of gridunc and griduncn +#ifdef _OPENMP + do ithread=1,numthreads_grid + gridunc(:,:,:,:,:,:,:)=gridunc(:,:,:,:,:,:,:)+gridunc_omp(:,:,:,:,:,:,:,ithread) + gridunc_omp(:,:,:,:,:,:,:,ithread)=0. + end do + if (nested_output.eq.1) then + do ithread=1,numthreads_grid + griduncn(:,:,:,:,:,:,:)=griduncn(:,:,:,:,:,:,:)+griduncn_omp(:,:,:,:,:,:,:,ithread) + griduncn_omp(:,:,:,:,:,:,:,ithread)=0. + end do + endif +#endif + + !*********************************************************************** + ! 2. Evaluate concentrations at receptor points, using the kernel method + !*********************************************************************** + if (numreceptor.eq.0) return + + do n=1,numreceptor + + + ! Reset concentrations + !********************* + + do ks=1,nspec + c(ks)=0. + end do + + + ! Estimate concentration at receptor + !*********************************** + + do i=1,numpart + + if (.not. part(i)%alive) cycle + itage=abs(itime-part(i)%tstart) + + hz=min(50.+0.3*sqrt(real(itage)),hzmax) + zd=part(i)%z/hz + if (zd.gt.1.) cycle ! 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=(part(i)%xlon-xreceptor(n))/hx + if (xd*xd.gt.1.) cycle ! 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=(part(i)%ylat-yreceptor(n))/hy + if (yd*yd.gt.1.) cycle ! save computing time, leave loop + hxyz=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)+part(i)%mass(ks)*xkern/hxyz + end do + endif + 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 diff --git a/src/out_finalise_output.f90 b/src/out_finalise_output.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a6bdbaac575da8256642a64623cc53a8e182272d --- /dev/null +++ b/src/out_finalise_output.f90 @@ -0,0 +1,33 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine finalise_output(itime) + ! Complete the calculation of initial conditions for particles not yet terminated + + implicit none + + integer, intent(in) :: itime + integer :: j,ithread + + if (linit_cond.ge.1) then + do j=1,numpart + call initcond_calc(itime,j,1) + end do +#ifdef _OPENMP + do ithread=1,numthreads + init_cond(:,:,:,:,:)=init_cond(:,:,:,:,:)+init_cond_omp(:,:,:,:,:,ithread) + end do +#endif + endif + + + if (ipout.eq.2) call output_particle(itime)!,active_per_rel) ! dump particle positions + + if (linit_cond.ge.1) then + if(linversionout.eq.1) then + call initcond_output_inv(itime) ! dump initial cond. field + else + call initcond_output(itime) ! dump initial cond. fielf + endif + endif +end subroutine finalise_output diff --git a/src/out_init_output.f90 b/src/out_init_output.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9e0f267850f0a6737c1d716376df8780993cb63b --- /dev/null +++ b/src/out_init_output.f90 @@ -0,0 +1,105 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine init_output(itime,filesize) + + implicit none + + integer, intent(in) :: itime + real, intent(inout) :: filesize +#ifdef USE_NCF + real(kind=dp) :: & + jul + integer :: & + jjjjmmdd,ihmmss,i +#endif + + ! Writing header information to either binary or NetCDF format + if (itime.eq.itime_init) then + if (iout.ne.0) then ! No gridded output +#ifdef USE_NCF + if (lnetcdfout.eq.1) then + call writeheader_ncf(lnest=.false.) + else + call writeheader_bin + end if + + if (nested_output.eq.1) then + if (lnetcdfout.eq.1) then + call writeheader_ncf(lnest=.true.) + else if ((nested_output.eq.1).and.(surf_only.ne.1)) then + call writeheader_bin_nest + else if ((nested_output.eq.1).and.(surf_only.eq.1)) then + call writeheader_bin_sfc_nest + else if ((nested_output.ne.1).and.(surf_only.eq.1)) then + call writeheader_bin_sfc + endif + endif +#else + call writeheader_bin + + !if (nested_output.eq.1) call writeheader_nest + if ((nested_output.eq.1).and.(surf_only.ne.1)) call writeheader_bin_nest + if ((nested_output.eq.1).and.(surf_only.eq.1)) call writeheader_bin_sfc_nest + if ((nested_output.ne.1).and.(surf_only.eq.1)) call writeheader_bin_sfc +#endif + endif ! iout.ne.0 + ! FLEXPART 9.2 ticket ?? write header in ASCII format + call writeheader_txt + + ! NetCDF only: Create file for storing initial particle positions. +#ifdef USE_NCF + if (itime_init.ne.0) then + jul=bdate+real(itime,kind=dp)/86400._dp + call caldate(jul,jjjjmmdd,ihmmss) + endif + if ((mdomainfill.eq.0).and.(ipout.ge.1).and.(ipin.le.1)) then + if (itime_init.ne.0) then + if (ldirect.eq.1) then + call particle_initialpos(ihmmss,jjjjmmdd,ibtime,ibdate) + else + call particle_initialpos(ihmmss,jjjjmmdd,ietime,iedate) + endif + else if (ldirect.eq.1) then + call particle_initialpos(ibtime,ibdate,ibtime,ibdate) + else + call particle_initialpos(ietime,iedate,ietime,iedate) + endif + endif + ! Create header files for files that store the particle dump output + if (ipout.ge.1) then + if (itime_init.ne.0) then + if (ldirect.eq.1) then + call writeheader_partoutput(ihmmss,jjjjmmdd,ibtime,ibdate) + else + call writeheader_partoutput(ihmmss,jjjjmmdd,ietime,iedate) + endif + else if (ldirect.eq.1) then + call writeheader_partoutput(ibtime,ibdate,ibtime,ibdate) + else + call writeheader_partoutput(ietime,iedate,ietime,iedate) + endif + endif +#endif + + ! In case the particle output file is becoming larger than the maximum set + ! in par_mod, create a new one while keeping track of the filesize. + ! Also if a new restart file is created. + else if ((mod(itime,ipoutfac*loutstep).eq.0).and.(ipout.ge.1)) then +#ifdef USE_NCF + if ((filesize.ge.max_partoutput_filesize).or.(mod(itime,loutrestart).eq.0)) then + jul=bdate+real(itime,kind=dp)/86400._dp + call caldate(jul,jjjjmmdd,ihmmss) + if (ldirect.eq.1) then + call writeheader_partoutput(ihmmss,jjjjmmdd,ibtime,ibdate) + else + call writeheader_partoutput(ihmmss,jjjjmmdd,ietime,iedate) + endif + filesize = 0. + endif + do i=1,numpoint + filesize = filesize + npart(i)*13.*4./1000000. + end do +#endif + endif +end subroutine init_output diff --git a/src/out_output_conc.f90 b/src/out_output_conc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..280327067429ad04b785b064c1021bc4367e10e5 --- /dev/null +++ b/src/out_output_conc.f90 @@ -0,0 +1,128 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine output_conc(itime,loutstart,loutend,loutnext,outnum) + use unc_mod + use prepoutgrid_mod + use par_mod + use com_mod +!#ifdef USE_NCF +! use netcdf_output_mod, only: concoutput_ncf,concoutput_ncf_nest,& +! &concoutput_sfc_ncf,concoutput_sfc_ncf_nest +!#endif + use binary_output_mod + + implicit none + + integer,intent(in) :: & + itime ! time index + integer,intent(inout) :: & + loutstart,loutend, & ! concentration calculation starting and ending time + loutnext + real,intent(inout) :: & + outnum ! concentration calculation sample number + real(sp) :: & + gridtotalunc ! concentration calculation related + real(dep_prec) :: & + wetgridtotalunc, & ! concentration calculation related + drygridtotalunc ! concentration calculation related + real :: & + weight ! concentration calculation sample weight + + + ! Is the time within the computation interval, if not, return + !************************************************************ + if ((ldirect*itime.lt.ldirect*loutstart).or.(ldirect*itime.gt.ldirect*loutend)) then + return + endif + + ! If we are exactly at the start or end of the concentration averaging interval, + ! give only half the weight to this sample + !***************************************************************************** + if (mod(itime-loutstart,loutsample).eq.0) then + if ((itime.eq.loutstart).or.(itime.eq.loutend)) then + weight=0.5 + else + weight=1.0 + endif + outnum=outnum+weight + if (iout.ne.0) call conccalc(itime,weight) + endif + + ! If no grid is to be written to file, return (LB) + !************************************************* + if (iout.eq.0) then + if (itime.ne.loutend) return + loutnext=loutnext+loutstep + loutstart=loutnext-loutaver/2 + loutend=loutnext+loutaver/2 + if (itime.eq.loutstart) then + weight=0.5 + outnum=outnum+weight + endif + return + endif + + ! If it is not time yet to write outputs, return + !*********************************************** + if ((itime.ne.loutend).or.(outnum.le.0)) then + return + endif + + ! Output and reinitialization of grid + ! If necessary, first sample of new grid is also taken + !***************************************************** + if ((iout.le.3.).or.(iout.eq.5)) then + if (surf_only.ne.1) then +#ifdef USE_NCF + call concoutput_ncf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) +#else + call concoutput(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) +#endif + else +#ifdef USE_NCF + call concoutput_sfc_ncf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) +#else + if (linversionout.eq.1) then + call concoutput_inv(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) + else + call concoutput_sfc(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) + endif +#endif + endif + + if (nested_output .eq. 1) then +#ifdef USE_NCF + if (surf_only.ne.1) then + call concoutput_ncf_nest(itime,outnum) + else + call concoutput_sfc_ncf_nest(itime,outnum) + endif +#else + if (surf_only.ne.1) then + call concoutput_nest(itime,outnum) + else + if(linversionout.eq.1) then + call concoutput_inv_nest(itime,outnum) + else + call concoutput_sfc_nest(itime,outnum) + endif + endif +#endif + endif + outnum=0. + endif + + write(*,45) itime,numpart,gridtotalunc,wetgridtotalunc,drygridtotalunc + +45 format(i13,' Seconds simulated: ',i13, ' Particles: Uncertainty: ',3f7.3) + + loutnext=loutnext+loutstep + loutstart=loutnext-loutaver/2 + loutend=loutnext+loutaver/2 + if (itime.eq.loutstart) then + weight=0.5 + outnum=outnum+weight + call conccalc(itime,weight) + endif +end subroutine output_conc diff --git a/src/out_output_heightlevs.f90 b/src/out_output_heightlevs.f90 new file mode 100644 index 0000000000000000000000000000000000000000..afb9e7e80adde3e40188b84a8b7d635e67c5b0a1 --- /dev/null +++ b/src/out_output_heightlevs.f90 @@ -0,0 +1,25 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine output_heightlevs(height_tmp,nmixz_tmp) + implicit none + + real,intent(in) :: height_tmp(nzmax) + integer,intent(in) :: nmixz_tmp + integer :: kz + character(len=256) :: heightlevels_filename + + heightlevels_filename = path(2)(1:length(2))//'heightlevels.bin' + + write(*,*) 'Writing initialised heightlevels to file', & + trim(heightlevels_filename) + + open(unitheightlevels,file=trim(heightlevels_filename),form='unformatted') + + write(unitheightlevels) nmixz_tmp + + do kz=1,nz + write(unitheightlevels) height_tmp(kz) + end do + close(unitheightlevels) +end subroutine output_heightlevs diff --git a/src/out_output_particle.f90 b/src/out_output_particle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..94c360d068ed56b33885461e8ee02c3ea8ee4c0f --- /dev/null +++ b/src/out_output_particle.f90 @@ -0,0 +1,314 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine output_particle(itime,initial_output) + ! i + !***************************************************************************** + ! * + ! Dump all particle positions * + ! Author: A. Stohl * + ! * + ! 12 March 1999 * + ! * + ! Changes L. Bakels, 2021 * + ! Output is chosen by the fields set in PARTOPTIONS * + ! Binary output is no longer supported. If required, function can be * + ! added below at "Put binary function here" * + !***************************************************************************** + ! * + ! Variables: * + ! * + !***************************************************************************** + + use interpol_mod + use coord_ec_mod + use particle_mod +#ifdef USE_NCF + use netcdf +! use netcdf_output_mod, only: partoutput_ncf,open_partoutput_file, & +! close_partoutput_file,partinitpointer1 + use omp_lib, only: OMP_GET_THREAD_NUM +#endif + + implicit none + + integer,intent(in) :: itime + logical,optional,intent(in) :: initial_output + logical :: init_out + integer :: i,j,m,jjjjmmdd,ihmmss,np,ns,i_av + real(kind=dp) :: jul + real :: tmp(2) + character :: adate*8,atime*6 + + real :: xlon(numpart),ylat(numpart),ztemp1,ztemp2,val_av(numpart,2),z_av(numpart) + real :: tti(numpart),rhoi(numpart),pvi(numpart),qvi(numpart),pri(numpart) + real :: topo(numpart),hmixi(numpart),tri(numpart),ztemp(numpart) + real :: masstemp(numpart,nspec),masstemp_av(numpart,nspec) + real :: wetdepotemp(numpart,nspec),drydepotemp(numpart,nspec) + + real :: output(num_partopt, numpart) + + ! For averaged output + real :: xlon_av(numpart),ylat_av(numpart) + + real :: cartxyz(3) + logical :: cartxyz_comp + +#ifdef USE_NCF + integer :: ncid, mythread, thread_divide(12),mass_divide(nspec) +#else + write(*,*) 'NETCDF missing! Please compile with netcdf if you want the particle dump.' + stop +#endif + +#ifdef USE_NCF + if (present(initial_output)) then + init_out=initial_output + else + init_out=.false. + endif + +!$OMP PARALLEL PRIVATE(i,j,m,tmp,ns,i_av,cartxyz_comp,cartxyz,np) + ! Some variables needed for temporal interpolation + !************************************************* + call find_time_vars(itime) + +!$OMP DO + do i=1,numpart + if (((.not. part(i)%alive).and.(abs(part(i)%tend-itime).ge.ipoutfac*loutstep)) .or. & + (init_out .and. (i.lt.partinitpointer1-1))) then ! Only freshly spawned particles need to be computed for init_out + output(:,i) = -1 + masstemp(i,:) = -1 + masstemp_av(i,:) = -1 + wetdepotemp(i,:) = -1 + drydepotemp(i,:) = -1 + cycle + endif + !***************************************************************************** + ! Interpolate several variables (PV, specific humidity, etc.) to particle position + !***************************************************************************** + ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) + !*************************************************************** + call find_ngrid(real(part(i)%xlon),real(part(i)%ylat)) + call find_grid_indices(real(part(i)%xlon),real(part(i)%ylat)) + call find_grid_distances(real(part(i)%xlon),real(part(i)%ylat)) + ! First set dz1out from interpol_mod to -1 so it only is calculated once per particle + !************************************************************************************ + dz1out=-1 + cartxyz_comp=.false. + do np=1,num_partopt + if (.not. partopt(np)%print) cycle ! Only compute when field should be printed + i_av = partopt(np)%i_average + if (init_out.and.(i_av.ne.0)) cycle ! no averages for initial particle output + if ((i_av.ne.0).and.(part(i)%ntime.eq.0)) then + if (partopt(np)%name.eq.'ma') then + masstemp_av(i,1:nspec) = -1 + else + output(np,i) = -1 + endif + cycle ! no averages for freshly spawned particles + endif + select case (partopt(np)%name) + case ('LO') + output(np,i)=xlon0+part(i)%xlon*dx + cycle + case ('LA') + output(np,i)=ylat0+part(i)%ylat*dy + cycle + case ('TO') ! Topography + if (ngrid.le.0) then + call hor_interpol(oro,output(np,i)) + else + call hor_interpol_nest(oron,output(np,i)) + endif + cycle + case ('TR') ! Tropopause + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(tropopause,tmp(m),1,memind(m),1) + end do + else + do m=1,2 + call hor_interpol_nest(tropopausen,tmp(m),1,memind(m),1) + end do + endif + call temp_interpol(tmp(1),tmp(2),output(np,i)) + cycle + case ('HM') ! PBL height + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(hmix,tmp(m),1,memind(m),1) + end do + else + do m=1,2 + call hor_interpol_nest(hmixn,tmp(m),1,memind(m),1) + end do + endif + call temp_interpol(tmp(1),tmp(2),output(np,i)) + cycle + case ('ZZ') ! Height + call update_zeta_to_z(itime, i) ! Convert eta z coordinate to meters if necessary + output(np,i)=part(i)%z + cycle + ! case ('UU') ! Longitudinal velocity + ! output(np,i)=part(i)%vel%u !This would be preferred, but not implemented yet + ! cycle + case ('VS') ! Settling velocity + output(np,i)=part(i)%settling + cycle + case ('MA') ! Mass + do ns=1,nspec + masstemp(i,ns)=part(i)%mass(ns) + end do + cycle + case ('ma') ! Mass averaged + do ns=1,nspec + masstemp_av(i,ns)=part(i)%val_av(i_av+(ns-1))/part(i)%ntime + end do + cycle + case ('WD') ! Wet deposition + do ns=1,nspec + wetdepotemp(i,ns)=part(i)%wetdepo(ns) + end do + cycle + case ('DD') ! dry deposition + do ns=1,nspec + drydepotemp(i,ns)=part(i)%drydepo(ns) + end do + cycle + case ('lo') + if (.not. cartxyz_comp) then + cartxyz(1) = part(i)%cartx_av/part(i)%ntime + cartxyz(2) = part(i)%carty_av/part(i)%ntime + cartxyz(3) = part(i)%cartz_av/part(i)%ntime + cartxyz_comp=.true. + endif + output(np,i) = atan2(cartxyz(1),-1.*cartxyz(2))/pi180 + if (output(np,i).gt.360.) output(np,i)=output(np,i)-360. + if (output(np,i).lt.0.) output(np,i)=output(np,i)+360. + cycle + case ('la') + if (.not. cartxyz_comp) then + cartxyz(1) = part(i)%cartx_av/part(i)%ntime + cartxyz(2) = part(i)%carty_av/part(i)%ntime + cartxyz(3) = part(i)%cartz_av/part(i)%ntime + cartxyz_comp=.true. + endif + output(np,i) = atan2(cartxyz(3),sqrt(cartxyz(1)*cartxyz(1)+ & + cartxyz(2)*cartxyz(2)))/pi180 + case default + if (.not. partopt(np)%average) then + call interpol_partoutput_val(partopt(np)%name,output(np,i),i) + else + output(np,i) = part(i)%val_av(i_av)/part(i)%ntime + endif + end select + end do + ! Reset dz1out + !************* + dz1out=-1 + cartxyz_comp=.false. + + if ((.not. init_out).and.(n_average.gt.0)) then + part(i)%val_av = 0. + part(i)%ntime = 0. + part(i)%cartx_av = 0. + part(i)%carty_av = 0. + part(i)%cartz_av = 0. + endif + end do + +!$OMP END DO +!$OMP END PARALLEL + + if ((.not. init_out).and.(numpart.gt.0)) then + do np=1,num_partopt + if (.not. partopt(np)%print) cycle + if (partopt(np)%name.eq.'MA') then + write(*,*) partopt(np)%long_name, masstemp(1,:) + else if (partopt(np)%name.eq.'ma') then + write(*,*) partopt(np)%long_name, masstemp_av(1,:) + else if (partopt(np)%name.eq.'WD') then + write(*,*) partopt(np)%long_name, wetdepotemp(1,:) + else if (partopt(np)%name.eq.'DD') then + write(*,*) partopt(np)%long_name, drydepotemp(1,:) + else + write(*,*) partopt(np)%long_name, output(np,1) + endif + end do + write(*,*) part(1)%prob,part(1)%alive + write(*,*) 'Alive: ', count%alive, 'Total spawned: ', count%spawned, 'Terminated: ', count%terminated + endif + + ! 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 + j=1 + if (lnetcdfout.eq.1) then + ! open output file + if (init_out) then + call open_partinit_file(ncid) + else + call open_partoutput_file(ncid) + + ! First allocate the time and particle dimensions within the netcdf file + call partoutput_ncf(itime,xlon,'TI',j,ncid) + call partoutput_ncf(itime,xlon,'PA',j,ncid) + endif + + ! Fill the fields in parallel + if (numpart.gt.0) then +!$OMP PARALLEL PRIVATE(np,ns) +!$OMP DO SCHEDULE(dynamic) + do np=1,num_partopt + !write(*,*) partopt(np)%name, output(np,1) + if (.not. partopt(np)%print) cycle + if (init_out.and.(partopt(np)%i_average.ne.0)) cycle ! no averages for initial particle output + !write(*,*) partopt(np)%name + if (partopt(np)%name.eq.'MA') then + do ns=1,nspec + if (init_out) then + call partinit_ncf(itime,masstemp(:,ns),'MA',ns,ncid) + else + call partoutput_ncf(itime,masstemp(:,ns),'MA',ns,ncid) + endif + end do + else if (partopt(np)%name.eq.'ma') then + do ns=1,nspec + call partoutput_ncf(itime,masstemp_av(:,ns),'ma',ns,ncid) + end do + else if ((.not. init_out).and.(partopt(np)%name.eq.'WD')) then + do ns=1,nspec + call partoutput_ncf(itime,wetdepotemp(:,ns),'WD',ns,ncid) + end do + else if ((.not. init_out).and.(partopt(np)%name.eq.'DD')) then + do ns=1,nspec + call partoutput_ncf(itime,drydepotemp(:,ns),'DD',ns,ncid) + end do + else + if (init_out) then + call partinit_ncf(itime,output(np,:),partopt(np)%name,j,ncid) + else + call partoutput_ncf(itime,output(np,:),partopt(np)%name,j,ncid) + endif + endif + end do +!$OMP END DO +!$OMP END PARALLEL + endif + call close_partoutput_file(ncid) + if (.not. init_out) then + mass_written=.true. ! needs to be reduced within openmp loop + topo_written=.true. ! same + endif + else + ! Put binary function here + endif +#else + ! Put binary function here +#endif +end subroutine output_particle diff --git a/src/out_output_restart.f90 b/src/out_output_restart.f90 new file mode 100644 index 0000000000000000000000000000000000000000..357e4186476f5a8288763869a846ad5d00ff0797 --- /dev/null +++ b/src/out_output_restart.f90 @@ -0,0 +1,105 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine output_restart(itime,loutnext,outnum) + use particle_mod + use coord_ec_mod + use unc_mod + + implicit none + + integer, intent(in) :: itime,loutnext + real, intent(in) :: outnum + integer :: i,j,jjjjmmdd,ihmmss,stat + integer :: ks,kp,kz,nage,jy,ix,l + real(kind=dp) :: jul + character :: adate*8,atime*6 + + + jul=bdate+real(itime,kind=dp)/86400._dp + call caldate(jul,jjjjmmdd,ihmmss) + write(adate,'(i8.8)') jjjjmmdd + write(atime,'(i6.6)') ihmmss + + restart_filename3 = restart_filename2 + restart_filename2 = restart_filename1 + restart_filename1 = path(2)(1:length(2))//'restart_'//adate//atime + + write(*,*) 'Writing Restart file:', trim(restart_filename1) + + open(unitrestart,file=restart_filename1,form='unformatted') + + ! Write current time to file + !*************************** + + write(unitrestart) itime + write(unitrestart) count%allocated + write(unitrestart) loutnext + write(unitrestart) outnum + + do i=1,count%allocated + if (part(i)%alive) then + call update_zeta_to_z(itime,i) + call update_z_to_zeta(itime,i) + endif + write(unitrestart) part(i)%xlon,part(i)%ylat,part(i)%z,part(i)%zeta, & + part(i)%npoint,part(i)%nclass,part(i)%idt,part(i)%tend, & + part(i)%tstart,part(i)%alive,part(i)%turbvel%u, & + part(i)%turbvel%v,part(i)%turbvel%w,part(i)%mesovel%u, & + part(i)%mesovel%v,part(i)%mesovel%w,(part(i)%mass(j),j=1,nspec), & + (part(i)%mass_init(j),j=1,nspec),(part(i)%wetdepo(j),j=1,nspec), & + (part(i)%drydepo(j),j=1,nspec) + end do + if (iout.gt.0) then +#ifdef USE_NCF + write(unitrestart) tpointer +#endif + 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 + do kz=1,numzgrid + write(unitrestart) gridunc(ix,jy,kz,ks,kp,l,nage) + end do + if ((wetdep).and.(ldirect.gt.0)) then + write(unitrestart) wetgridunc(ix,jy,ks,kp,l,nage) + endif + if ((drydep).and.(ldirect.gt.0)) then + write(unitrestart) drygridunc(ix,jy,ks,kp,l,nage) + endif + 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 + do kz=1,numzgrid + write(unitrestart) griduncn(ix,jy,kz,ks,kp,l,nage) + end do + if ((wetdep).and.(ldirect.gt.0)) then + write(unitrestart) wetgriduncn(ix,jy,ks,kp,l,nage) + endif + if ((drydep).and.(ldirect.gt.0)) then + write(unitrestart) drygriduncn(ix,jy,ks,kp,l,nage) + endif + end do + end do + end do + endif + end do + end do + if ((drybkdep).or.(wetbkdep)) then + do i=1,count%allocated + write(unitrestart) xscav_frac1(i,ks) + end do + endif + end do + endif + close(unitrestart) + + open(unit=1234, iostat=stat, file=restart_filename3, status='old') + if(stat == 0) close(1234, status='delete') +end subroutine output_restart diff --git a/src/out_partpos_avg.f90 b/src/out_partpos_avg.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d9f1feba0ac27ecb850a68538e7c29e16827182c --- /dev/null +++ b/src/out_partpos_avg.f90 @@ -0,0 +1,149 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine partpos_avg(itime,j) + + !********************************************************************** + ! This subroutine averages particle quantities, to be used for particle + ! dump (in partoutput.f90). Averaging is done over output interval. + ! Author: A. Stohl + ! Changes L Bakels: + ! - Computing fields defined in PARTOPTIONS + !********************************************************************** + + use par_mod + use com_mod + use interpol_mod + use coord_ec_mod + + implicit none + + integer,intent(in) :: itime,j + integer :: np,i_av,ns,m + real :: xlon,ylat,x,y,z + real :: topo,hm(2),hmixi,pvi,qvi + real :: tti,rhoi,ttemp + real :: uui,vvi,output + real :: tr(2),tri!,energy + + logical :: cart_comp + + if (ipout.eq.0) return ! No need to compute averages since there is no particle output + + if (n_average.eq.0) return + + if (.not. part(j)%alive) return + + if (part(j)%nstop) return ! If particle is to be killed, averages cannot be computed + + ! Some variables needed for temporal interpolation + !************************************************* + call find_time_vars(itime) + + xlon=xlon0+real(part(j)%xlon)*dx + ylat=ylat0+real(part(j)%ylat)*dy + + !***************************************************************************** + ! Interpolate several variables (PV, specific humidity, etc.) to particle position + !***************************************************************************** + ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) + !*************************************************************** + call find_ngrid(real(part(j)%xlon),real(part(j)%ylat)) + call find_grid_indices(real(part(j)%xlon),real(part(j)%ylat)) + call find_grid_distances(real(part(j)%xlon),real(part(j)%ylat)) + + ! First set dz1out from interpol_mod to -1 so it only is calculated once per particle + !************************************************************************************ + part(j)%ntime=part(j)%ntime + 1 + dz1out=-1 + cart_comp=.false. + do np=1,num_partopt + if ((.not. partopt(np)%print) .or. (.not. partopt(np)%average)) cycle + i_av = partopt(np)%i_average + select case (partopt(np)%name) + case ('to') + if (ngrid.le.0) then + call hor_interpol(oro,output) + else + call hor_interpol_nest(oron,output) + endif + part(j)%val_av(i_av)=part(j)%val_av(i_av)+output + case ('tr') + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(tropopause,tr(m),1,memind(m),1) + end do + else + do m=1,2 + call hor_interpol_nest(tropopausen,tr(m),1,memind(m),1) + end do + endif + call temp_interpol(tr(1),tr(2),output) + part(j)%val_av(i_av)=part(j)%val_av(i_av)+output + case ('hm') + if (ngrid.le.0) then + do m=1,2 + call hor_interpol(hmix,hm(m),1,memind(m),1) + end do + else + do m=1,2 + call hor_interpol_nest(hmixn,hm(m),1,memind(m),1) + end do + endif + call temp_interpol(hm(1),hm(2),output) + part(j)%val_av(i_av)=part(j)%val_av(i_av)+output + case ('lo') + if (.not. cart_comp) then + ! Calculate Cartesian 3D coordinates suitable for averaging + !********************************************************** + + xlon=xlon*pi180 + ylat=ylat*pi180 + x = cos(ylat)*sin(xlon) + y = -1.*cos(ylat)*cos(xlon) + z = sin(ylat) + + part(j)%cartx_av=part(j)%cartx_av+x + part(j)%carty_av=part(j)%carty_av+y + part(j)%cartz_av=part(j)%cartz_av+z + cart_comp=.true. + endif + case ('la') + if (.not. cart_comp) then + ! Calculate Cartesian 3D coordinates suitable for averaging + !********************************************************** + + xlon=xlon*pi180 + ylat=ylat*pi180 + x = cos(ylat)*sin(xlon) + y = -1.*cos(ylat)*cos(xlon) + z = sin(ylat) + + part(j)%cartx_av=part(j)%cartx_av+x + part(j)%carty_av=part(j)%carty_av+y + part(j)%cartz_av=part(j)%cartz_av+z + cart_comp=.true. + endif + case ('zz') + ! Convert eta z coordinate to meters if necessary. Can be moved to output only + !************************************************ + call update_zeta_to_z(itime,j) + part(j)%val_av(i_av)=part(j)%val_av(i_av)+part(j)%z + case ('ma') + do ns=1,nspec + part(j)%val_av(i_av+(ns-1))=part(j)%val_av(i_av+(ns-1))+part(j)%mass(ns) + end do + case ('vs') + part(j)%val_av(i_av)=part(j)%val_av(i_av)+part(j)%settling + case default + call interpol_partoutput_val(partopt(np)%name,output,j) + part(j)%val_av(i_av)=part(j)%val_av(i_av)+output + end select + end do + ! Reset dz1out + !************* + dz1out=-1 + cart_comp=.false. + + return +end subroutine partpos_avg diff --git a/src/output_mod.f90 b/src/output_mod.f90 index 3abcdd29ac7b2765ee796b7afcd916c6898c1603..7555406a20edf4068c692c684f85d75182fc4b5e 100644 --- a/src/output_mod.f90 +++ b/src/output_mod.f90 @@ -8,11 +8,11 @@ !***************************************************************************** module output_mod - + use com_mod use par_mod use date_mod -#ifdef USE_NCF +#ifdef USE_NCF use netcdf_output_mod #endif use binary_output_mod @@ -23,1473 +23,20 @@ module output_mod character(len=256) :: restart_filename1,restart_filename2,restart_filename3 contains -subroutine init_output(itime,filesize) - - implicit none - - integer, intent(in) :: itime - real, intent(inout) :: filesize -#ifdef USE_NCF - real(kind=dp) :: & - jul - integer :: & - jjjjmmdd,ihmmss,i -#endif - - ! Writing header information to either binary or NetCDF format - if (itime.eq.itime_init) then - if (iout.ne.0) then ! No gridded output -#ifdef USE_NCF - if (lnetcdfout.eq.1) then - call writeheader_ncf(lnest=.false.) - else - call writeheader_bin - end if - - if (nested_output.eq.1) then - if (lnetcdfout.eq.1) then - call writeheader_ncf(lnest=.true.) - else if ((nested_output.eq.1).and.(surf_only.ne.1)) then - call writeheader_bin_nest - else if ((nested_output.eq.1).and.(surf_only.eq.1)) then - call writeheader_bin_sfc_nest - else if ((nested_output.ne.1).and.(surf_only.eq.1)) then - call writeheader_bin_sfc - endif - endif -#else - call writeheader_bin - - !if (nested_output.eq.1) call writeheader_nest - if ((nested_output.eq.1).and.(surf_only.ne.1)) call writeheader_bin_nest - if ((nested_output.eq.1).and.(surf_only.eq.1)) call writeheader_bin_sfc_nest - if ((nested_output.ne.1).and.(surf_only.eq.1)) call writeheader_bin_sfc -#endif - endif ! iout.ne.0 - ! FLEXPART 9.2 ticket ?? write header in ASCII format - call writeheader_txt - - ! NetCDF only: Create file for storing initial particle positions. -#ifdef USE_NCF - if (itime_init.ne.0) then - jul=bdate+real(itime,kind=dp)/86400._dp - call caldate(jul,jjjjmmdd,ihmmss) - endif - if ((mdomainfill.eq.0).and.(ipout.ge.1).and.(ipin.le.1)) then - if (itime_init.ne.0) then - if (ldirect.eq.1) then - call particle_initialpos(ihmmss,jjjjmmdd,ibtime,ibdate) - else - call particle_initialpos(ihmmss,jjjjmmdd,ietime,iedate) - endif - else if (ldirect.eq.1) then - call particle_initialpos(ibtime,ibdate,ibtime,ibdate) - else - call particle_initialpos(ietime,iedate,ietime,iedate) - endif - endif - ! Create header files for files that store the particle dump output - if (ipout.ge.1) then - if (itime_init.ne.0) then - if (ldirect.eq.1) then - call writeheader_partoutput(ihmmss,jjjjmmdd,ibtime,ibdate) - else - call writeheader_partoutput(ihmmss,jjjjmmdd,ietime,iedate) - endif - else if (ldirect.eq.1) then - call writeheader_partoutput(ibtime,ibdate,ibtime,ibdate) - else - call writeheader_partoutput(ietime,iedate,ietime,iedate) - endif - endif -#endif - - ! In case the particle output file is becoming larger than the maximum set - ! in par_mod, create a new one while keeping track of the filesize. - ! Also if a new restart file is created. - else if ((mod(itime,ipoutfac*loutstep).eq.0).and.(ipout.ge.1)) then -#ifdef USE_NCF - if ((filesize.ge.max_partoutput_filesize).or.(mod(itime,loutrestart).eq.0)) then - jul=bdate+real(itime,kind=dp)/86400._dp - call caldate(jul,jjjjmmdd,ihmmss) - if (ldirect.eq.1) then - call writeheader_partoutput(ihmmss,jjjjmmdd,ibtime,ibdate) - else - call writeheader_partoutput(ihmmss,jjjjmmdd,ietime,iedate) - endif - filesize = 0. - endif - do i=1,numpoint - filesize = filesize + npart(i)*13.*4./1000000. - end do -#endif - endif -end subroutine init_output - -subroutine finalise_output(itime) - ! Complete the calculation of initial conditions for particles not yet terminated - - implicit none - - integer, intent(in) :: itime - integer :: j,ithread - - if (linit_cond.ge.1) then - do j=1,numpart - call initcond_calc(itime,j,1) - end do -#ifdef _OPENMP - do ithread=1,numthreads - init_cond(:,:,:,:,:)=init_cond(:,:,:,:,:)+init_cond_omp(:,:,:,:,:,ithread) - end do -#endif - endif - - - if (ipout.eq.2) call output_particle(itime)!,active_per_rel) ! dump particle positions - - if (linit_cond.ge.1) then - if(linversionout.eq.1) then - call initcond_output_inv(itime) ! dump initial cond. field - else - call initcond_output(itime) ! dump initial cond. fielf - endif - endif -end subroutine finalise_output - -subroutine output_restart(itime,loutnext,outnum) - use particle_mod - use coord_ec_mod - use unc_mod - - implicit none - - integer, intent(in) :: itime,loutnext - real, intent(in) :: outnum - integer :: i,j,jjjjmmdd,ihmmss,stat - integer :: ks,kp,kz,nage,jy,ix,l - real(kind=dp) :: jul - character :: adate*8,atime*6 - - - jul=bdate+real(itime,kind=dp)/86400._dp - call caldate(jul,jjjjmmdd,ihmmss) - write(adate,'(i8.8)') jjjjmmdd - write(atime,'(i6.6)') ihmmss - - restart_filename3 = restart_filename2 - restart_filename2 = restart_filename1 - restart_filename1 = path(2)(1:length(2))//'restart_'//adate//atime - - write(*,*) 'Writing Restart file:', trim(restart_filename1) - - open(unitrestart,file=restart_filename1,form='unformatted') - - ! Write current time to file - !*************************** - - write(unitrestart) itime - write(unitrestart) count%allocated - write(unitrestart) loutnext - write(unitrestart) outnum - - do i=1,count%allocated - if (part(i)%alive) then - call update_zeta_to_z(itime,i) - call update_z_to_zeta(itime,i) - endif - write(unitrestart) part(i)%xlon,part(i)%ylat,part(i)%z,part(i)%zeta, & - part(i)%npoint,part(i)%nclass,part(i)%idt,part(i)%tend, & - part(i)%tstart,part(i)%alive,part(i)%turbvel%u, & - part(i)%turbvel%v,part(i)%turbvel%w,part(i)%mesovel%u, & - part(i)%mesovel%v,part(i)%mesovel%w,(part(i)%mass(j),j=1,nspec), & - (part(i)%mass_init(j),j=1,nspec),(part(i)%wetdepo(j),j=1,nspec), & - (part(i)%drydepo(j),j=1,nspec) - end do - if (iout.gt.0) then -#ifdef USE_NCF - write(unitrestart) tpointer -#endif - 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 - do kz=1,numzgrid - write(unitrestart) gridunc(ix,jy,kz,ks,kp,l,nage) - end do - if ((wetdep).and.(ldirect.gt.0)) then - write(unitrestart) wetgridunc(ix,jy,ks,kp,l,nage) - endif - if ((drydep).and.(ldirect.gt.0)) then - write(unitrestart) drygridunc(ix,jy,ks,kp,l,nage) - endif - 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 - do kz=1,numzgrid - write(unitrestart) griduncn(ix,jy,kz,ks,kp,l,nage) - end do - if ((wetdep).and.(ldirect.gt.0)) then - write(unitrestart) wetgriduncn(ix,jy,ks,kp,l,nage) - endif - if ((drydep).and.(ldirect.gt.0)) then - write(unitrestart) drygriduncn(ix,jy,ks,kp,l,nage) - endif - end do - end do - end do - endif - end do - end do - if ((drybkdep).or.(wetbkdep)) then - do i=1,count%allocated - write(unitrestart) xscav_frac1(i,ks) - end do - endif - end do - endif - close(unitrestart) - - open(unit=1234, iostat=stat, file=restart_filename3, status='old') - if(stat == 0) close(1234, status='delete') -end subroutine output_restart - -subroutine output_heightlevs(height_tmp,nmixz_tmp) - implicit none - - real,intent(in) :: height_tmp(nzmax) - integer,intent(in) :: nmixz_tmp - integer :: kz - character(len=256) :: heightlevels_filename - - heightlevels_filename = path(2)(1:length(2))//'heightlevels.bin' - - write(*,*) 'Writing initialised heightlevels to file', & - trim(heightlevels_filename) - - open(unitheightlevels,file=trim(heightlevels_filename),form='unformatted') - - write(unitheightlevels) nmixz_tmp - - do kz=1,nz - write(unitheightlevels) height_tmp(kz) - end do - close(unitheightlevels) -end subroutine output_heightlevs - -subroutine output_particle(itime,initial_output) - ! i - !***************************************************************************** - ! * - ! Dump all particle positions * - ! Author: A. Stohl * - ! * - ! 12 March 1999 * - ! * - ! Changes L. Bakels, 2021 * - ! Output is chosen by the fields set in PARTOPTIONS * - ! Binary output is no longer supported. If required, function can be * - ! added below at "Put binary function here" * - !***************************************************************************** - ! * - ! Variables: * - ! * - !***************************************************************************** - - use interpol_mod - use coord_ec_mod - use particle_mod -#ifdef USE_NCF - use netcdf -! use netcdf_output_mod, only: partoutput_ncf,open_partoutput_file, & -! close_partoutput_file,partinitpointer1 - use omp_lib, only: OMP_GET_THREAD_NUM -#endif - - implicit none - - integer,intent(in) :: itime - logical,optional,intent(in) :: initial_output - logical :: init_out - integer :: i,j,m,jjjjmmdd,ihmmss,np,ns,i_av - real(kind=dp) :: jul - real :: tmp(2) - character :: adate*8,atime*6 - - real :: xlon(numpart),ylat(numpart),ztemp1,ztemp2,val_av(numpart,2),z_av(numpart) - real :: tti(numpart),rhoi(numpart),pvi(numpart),qvi(numpart),pri(numpart) - real :: topo(numpart),hmixi(numpart),tri(numpart),ztemp(numpart) - real :: masstemp(numpart,nspec),masstemp_av(numpart,nspec) - real :: wetdepotemp(numpart,nspec),drydepotemp(numpart,nspec) - - real :: output(num_partopt, numpart) - - ! For averaged output - real :: xlon_av(numpart),ylat_av(numpart) - - real :: cartxyz(3) - logical :: cartxyz_comp - -#ifdef USE_NCF - integer :: ncid, mythread, thread_divide(12),mass_divide(nspec) -#else - write(*,*) 'NETCDF missing! Please compile with netcdf if you want the particle dump.' - stop -#endif - -#ifdef USE_NCF - if (present(initial_output)) then - init_out=initial_output - else - init_out=.false. - endif - -!$OMP PARALLEL PRIVATE(i,j,m,tmp,ns,i_av,cartxyz_comp,cartxyz,np) - ! Some variables needed for temporal interpolation - !************************************************* - call find_time_vars(itime) - -!$OMP DO - do i=1,numpart - if (((.not. part(i)%alive).and.(abs(part(i)%tend-itime).ge.ipoutfac*loutstep)) .or. & - (init_out .and. (i.lt.partinitpointer1-1))) then ! Only freshly spawned particles need to be computed for init_out - output(:,i) = -1 - masstemp(i,:) = -1 - masstemp_av(i,:) = -1 - wetdepotemp(i,:) = -1 - drydepotemp(i,:) = -1 - cycle - endif - !***************************************************************************** - ! Interpolate several variables (PV, specific humidity, etc.) to particle position - !***************************************************************************** - ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) - !*************************************************************** - call find_ngrid(real(part(i)%xlon),real(part(i)%ylat)) - call find_grid_indices(real(part(i)%xlon),real(part(i)%ylat)) - call find_grid_distances(real(part(i)%xlon),real(part(i)%ylat)) - ! First set dz1out from interpol_mod to -1 so it only is calculated once per particle - !************************************************************************************ - dz1out=-1 - cartxyz_comp=.false. - do np=1,num_partopt - if (.not. partopt(np)%print) cycle ! Only compute when field should be printed - i_av = partopt(np)%i_average - if (init_out.and.(i_av.ne.0)) cycle ! no averages for initial particle output - if ((i_av.ne.0).and.(part(i)%ntime.eq.0)) then - if (partopt(np)%name.eq.'ma') then - masstemp_av(i,1:nspec) = -1 - else - output(np,i) = -1 - endif - cycle ! no averages for freshly spawned particles - endif - select case (partopt(np)%name) - case ('LO') - output(np,i)=xlon0+part(i)%xlon*dx - cycle - case ('LA') - output(np,i)=ylat0+part(i)%ylat*dy - cycle - case ('TO') ! Topography - if (ngrid.le.0) then - call hor_interpol(oro,output(np,i)) - else - call hor_interpol_nest(oron,output(np,i)) - endif - cycle - case ('TR') ! Tropopause - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(tropopause,tmp(m),1,memind(m),1) - end do - else - do m=1,2 - call hor_interpol_nest(tropopausen,tmp(m),1,memind(m),1) - end do - endif - call temp_interpol(tmp(1),tmp(2),output(np,i)) - cycle - case ('HM') ! PBL height - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(hmix,tmp(m),1,memind(m),1) - end do - else - do m=1,2 - call hor_interpol_nest(hmixn,tmp(m),1,memind(m),1) - end do - endif - call temp_interpol(tmp(1),tmp(2),output(np,i)) - cycle - case ('ZZ') ! Height - call update_zeta_to_z(itime, i) ! Convert eta z coordinate to meters if necessary - output(np,i)=part(i)%z - cycle - ! case ('UU') ! Longitudinal velocity - ! output(np,i)=part(i)%vel%u !This would be preferred, but not implemented yet - ! cycle - case ('VS') ! Settling velocity - output(np,i)=part(i)%settling - cycle - case ('MA') ! Mass - do ns=1,nspec - masstemp(i,ns)=part(i)%mass(ns) - end do - cycle - case ('ma') ! Mass averaged - do ns=1,nspec - masstemp_av(i,ns)=part(i)%val_av(i_av+(ns-1))/part(i)%ntime - end do - cycle - case ('WD') ! Wet deposition - do ns=1,nspec - wetdepotemp(i,ns)=part(i)%wetdepo(ns) - end do - cycle - case ('DD') ! dry deposition - do ns=1,nspec - drydepotemp(i,ns)=part(i)%drydepo(ns) - end do - cycle - case ('lo') - if (.not. cartxyz_comp) then - cartxyz(1) = part(i)%cartx_av/part(i)%ntime - cartxyz(2) = part(i)%carty_av/part(i)%ntime - cartxyz(3) = part(i)%cartz_av/part(i)%ntime - cartxyz_comp=.true. - endif - output(np,i) = atan2(cartxyz(1),-1.*cartxyz(2))/pi180 - if (output(np,i).gt.360.) output(np,i)=output(np,i)-360. - if (output(np,i).lt.0.) output(np,i)=output(np,i)+360. - cycle - case ('la') - if (.not. cartxyz_comp) then - cartxyz(1) = part(i)%cartx_av/part(i)%ntime - cartxyz(2) = part(i)%carty_av/part(i)%ntime - cartxyz(3) = part(i)%cartz_av/part(i)%ntime - cartxyz_comp=.true. - endif - output(np,i) = atan2(cartxyz(3),sqrt(cartxyz(1)*cartxyz(1)+ & - cartxyz(2)*cartxyz(2)))/pi180 - case default - if (.not. partopt(np)%average) then - call interpol_partoutput_val(partopt(np)%name,output(np,i),i) - else - output(np,i) = part(i)%val_av(i_av)/part(i)%ntime - endif - end select - end do - ! Reset dz1out - !************* - dz1out=-1 - cartxyz_comp=.false. - - if ((.not. init_out).and.(n_average.gt.0)) then - part(i)%val_av = 0. - part(i)%ntime = 0. - part(i)%cartx_av = 0. - part(i)%carty_av = 0. - part(i)%cartz_av = 0. - endif - end do - -!$OMP END DO -!$OMP END PARALLEL - - if ((.not. init_out).and.(numpart.gt.0)) then - do np=1,num_partopt - if (.not. partopt(np)%print) cycle - if (partopt(np)%name.eq.'MA') then - write(*,*) partopt(np)%long_name, masstemp(1,:) - else if (partopt(np)%name.eq.'ma') then - write(*,*) partopt(np)%long_name, masstemp_av(1,:) - else if (partopt(np)%name.eq.'WD') then - write(*,*) partopt(np)%long_name, wetdepotemp(1,:) - else if (partopt(np)%name.eq.'DD') then - write(*,*) partopt(np)%long_name, drydepotemp(1,:) - else - write(*,*) partopt(np)%long_name, output(np,1) - endif - end do - write(*,*) part(1)%prob,part(1)%alive - write(*,*) 'Alive: ', count%alive, 'Total spawned: ', count%spawned, 'Terminated: ', count%terminated - endif - - ! 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 - j=1 - if (lnetcdfout.eq.1) then - ! open output file - if (init_out) then - call open_partinit_file(ncid) - else - call open_partoutput_file(ncid) - - ! First allocate the time and particle dimensions within the netcdf file - call partoutput_ncf(itime,xlon,'TI',j,ncid) - call partoutput_ncf(itime,xlon,'PA',j,ncid) - endif - - ! Fill the fields in parallel - if (numpart.gt.0) then -!$OMP PARALLEL PRIVATE(np,ns) -!$OMP DO SCHEDULE(dynamic) - do np=1,num_partopt - !write(*,*) partopt(np)%name, output(np,1) - if (.not. partopt(np)%print) cycle - if (init_out.and.(partopt(np)%i_average.ne.0)) cycle ! no averages for initial particle output - !write(*,*) partopt(np)%name - if (partopt(np)%name.eq.'MA') then - do ns=1,nspec - if (init_out) then - call partinit_ncf(itime,masstemp(:,ns),'MA',ns,ncid) - else - call partoutput_ncf(itime,masstemp(:,ns),'MA',ns,ncid) - endif - end do - else if (partopt(np)%name.eq.'ma') then - do ns=1,nspec - call partoutput_ncf(itime,masstemp_av(:,ns),'ma',ns,ncid) - end do - else if ((.not. init_out).and.(partopt(np)%name.eq.'WD')) then - do ns=1,nspec - call partoutput_ncf(itime,wetdepotemp(:,ns),'WD',ns,ncid) - end do - else if ((.not. init_out).and.(partopt(np)%name.eq.'DD')) then - do ns=1,nspec - call partoutput_ncf(itime,drydepotemp(:,ns),'DD',ns,ncid) - end do - else - if (init_out) then - call partinit_ncf(itime,output(np,:),partopt(np)%name,j,ncid) - else - call partoutput_ncf(itime,output(np,:),partopt(np)%name,j,ncid) - endif - endif - end do -!$OMP END DO -!$OMP END PARALLEL - endif - call close_partoutput_file(ncid) - if (.not. init_out) then - mass_written=.true. ! needs to be reduced within openmp loop - topo_written=.true. ! same - endif - else - ! Put binary function here - endif -#else - ! Put binary function here -#endif -end subroutine output_particle - -subroutine output_conc(itime,loutstart,loutend,loutnext,outnum) - use unc_mod - use prepoutgrid_mod - use par_mod - use com_mod -!#ifdef USE_NCF -! use netcdf_output_mod, only: concoutput_ncf,concoutput_ncf_nest,& -! &concoutput_sfc_ncf,concoutput_sfc_ncf_nest -!#endif - use binary_output_mod - - implicit none - - integer,intent(in) :: & - itime ! time index - integer,intent(inout) :: & - loutstart,loutend, & ! concentration calculation starting and ending time - loutnext - real,intent(inout) :: & - outnum ! concentration calculation sample number - real(sp) :: & - gridtotalunc ! concentration calculation related - real(dep_prec) :: & - wetgridtotalunc, & ! concentration calculation related - drygridtotalunc ! concentration calculation related - real :: & - weight ! concentration calculation sample weight - - - ! Is the time within the computation interval, if not, return - !************************************************************ - if ((ldirect*itime.lt.ldirect*loutstart).or.(ldirect*itime.gt.ldirect*loutend)) then - return - endif - - ! If we are exactly at the start or end of the concentration averaging interval, - ! give only half the weight to this sample - !***************************************************************************** - if (mod(itime-loutstart,loutsample).eq.0) then - if ((itime.eq.loutstart).or.(itime.eq.loutend)) then - weight=0.5 - else - weight=1.0 - endif - outnum=outnum+weight - if (iout.ne.0) call conccalc(itime,weight) - endif - - ! If no grid is to be written to file, return (LB) - !************************************************* - if (iout.eq.0) then - if (itime.ne.loutend) return - loutnext=loutnext+loutstep - loutstart=loutnext-loutaver/2 - loutend=loutnext+loutaver/2 - if (itime.eq.loutstart) then - weight=0.5 - outnum=outnum+weight - endif - return - endif - - ! If it is not time yet to write outputs, return - !*********************************************** - if ((itime.ne.loutend).or.(outnum.le.0)) then - return - endif - - ! Output and reinitialization of grid - ! If necessary, first sample of new grid is also taken - !***************************************************** - if ((iout.le.3.).or.(iout.eq.5)) then - if (surf_only.ne.1) then -#ifdef USE_NCF - call concoutput_ncf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) -#else - call concoutput(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) -#endif - else -#ifdef USE_NCF - call concoutput_sfc_ncf(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) -#else - if (linversionout.eq.1) then - call concoutput_inv(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) - else - call concoutput_sfc(itime,outnum,gridtotalunc,wetgridtotalunc,drygridtotalunc) - endif -#endif - endif - - if (nested_output .eq. 1) then -#ifdef USE_NCF - if (surf_only.ne.1) then - call concoutput_ncf_nest(itime,outnum) - else - call concoutput_sfc_ncf_nest(itime,outnum) - endif -#else - if (surf_only.ne.1) then - call concoutput_nest(itime,outnum) - else - if(linversionout.eq.1) then - call concoutput_inv_nest(itime,outnum) - else - call concoutput_sfc_nest(itime,outnum) - endif - endif -#endif - endif - outnum=0. - endif - - write(*,45) itime,numpart,gridtotalunc,wetgridtotalunc,drygridtotalunc - -45 format(i13,' Seconds simulated: ',i13, ' Particles: Uncertainty: ',3f7.3) - - loutnext=loutnext+loutstep - loutstart=loutnext-loutaver/2 - loutend=loutnext+loutaver/2 - if (itime.eq.loutstart) then - weight=0.5 - outnum=outnum+weight - call conccalc(itime,weight) - endif -end subroutine output_conc - -subroutine conccalc(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 * - ! * - ! 2021, LB: OpenMP parallelisation * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! nspeciesdim = nspec for forward runs, 1 for backward runs * - ! * - !***************************************************************************** - - use unc_mod - use prepoutgrid_mod - use par_mod - use com_mod - use omp_lib, only: OMP_GET_THREAD_NUM - use interpol_mod, only: interpol_density - use coord_ec_mod - use particle_mod - - implicit none - - integer,intent(in) :: itime - real,intent(in) :: weight - integer :: itage,i,kz,ks,n,nage,inage,thread,ithread - integer :: il,ind,indz,indzp,nrelpointer - integer :: ix,jy,ixp,jyp - real :: ddx,ddy - real(kind=dp) :: mm3 - real :: hx,hy,hz,hxyz,xd,yd,zd,xkern,r2,c(maxspec) - real :: rhoi - real :: xl,yl,wx,wy,w - real,parameter :: factor=.596831, hxmax=6.0, hymax=4.0, hzmax=150. - ! integer xscav_count - - ! For forward simulations, make a loop over the number of species; - ! for backward simulations, make an additional loop over the - ! releasepoints - !*************************************************************************** - ! xscav_count=0 -#ifdef _OPENMP - call omp_set_num_threads(numthreads_grid) -#endif -!$OMP PARALLEL PRIVATE(i,itage,nage,inage,rhoi,nrelpointer,kz,xl,yl,ks,wx,wy,w,thread,ddx,ddy, & -!$OMP ix,jy,ixp,jyp) -#if (defined _OPENMP) - thread = OMP_GET_THREAD_NUM()+1 ! Starts with 1 -#else - thread = 1 -#endif - -!$OMP DO - do i=1,numpart - if (.not.part(i)%alive) cycle - - ! Determine age class of the particle - itage=abs(itime-part(i)%tstart) - nage=1 - do inage=1,nageclass - nage=inage - if (itage.lt.lage(nage)) exit - end do - - ! if (xscav_frac1(i,1).lt.0) xscav_count=xscav_count+1 - - ! 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 - call update_zeta_to_z(itime,i) - call interpol_density(itime,i,rhoi) - 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=part(i)%npoint - endif - - do kz=1,numzgrid ! determine height of cell - if (outheight(kz).gt.part(i)%z) exit - end do - - if (kz.le.numzgrid) then ! inside output domain - - - !******************************** - ! Do everything for mother domain - !******************************** - - xl=(part(i)%xlon*dx+xoutshift)/dxout - yl=(part(i)%ylat*dy+youtshift)/dyout - 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 ((.not.lusekerneloutput).or.(itage.lt.10800).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 - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0) -#else - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - if (lparticlecountoutput) then - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+1 -#else - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1 -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight -#else - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight -#endif - end do - end if - endif - 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 - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0) -#else - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w -#else - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w -#endif - end do - endif - endif - - if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then - w=wx*(1.-wy) - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#else - gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w -#else - gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w -#endif - end do - endif - endif - endif !ix ge 0 - - - 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) - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0) -#else - gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*w*weight*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w -#else - gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w -#endif - end do - endif - endif - - if ((jy.ge.0).and.(jy.le.numygrid-1)) then - w=(1.-wx)*wy - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#else - gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - gridunc_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w -#else - gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - gridunc(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w -#endif - end do - endif - endif - endif !ixp ge 0 - endif - - !************************************ - ! Do everything for the nested domain - !************************************ - - if (nested_output.eq.1) then - xl=(part(i)%xlon*dx+xoutshiftn)/dxoutn - yl=(part(i)%ylat*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.10800).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).or.((.not.lusekerneloutput))) 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 - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0) -#else - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - if (lparticlecountoutput) then - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+1 -#else - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+1 -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight -#else - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight -#endif - end do - endif - endif - 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 - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#else - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w -#else - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ix,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w -#endif - end do - endif - endif - - if ((jyp.ge.0).and.(jyp.le.numygridn-1)) then - w=wx*(1.-wy) - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#else - griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w -#else - griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ix,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w -#endif - end do - endif - 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) - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#else - griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w -#else - griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ixp,jyp,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w -#endif - end do - endif - endif - - if ((jy.ge.0).and.(jy.le.numygridn-1)) then - w=(1.-wx)*wy - if (DRYBKDEP.or.WETBKDEP) then - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#else - griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w*max(xscav_frac1(i,ks),0.0) -#endif - end do - else - do ks=1,nspec -#ifdef _OPENMP - griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)= & - griduncn_omp(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage,thread)+ & - part(i)%mass(ks)/rhoi*weight*w -#else - griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)= & - griduncn(ixp,jy,kz,ks,nrelpointer,part(i)%nclass,nage)+ & - part(i)%mass(ks)/rhoi*weight*w -#endif - end do - endif - endif - endif - endif - endif - endif - end do -!$OMP END DO -!$OMP END PARALLEL -#ifdef _OPENMP - call omp_set_num_threads(numthreads) -#endif - ! Reduction of gridunc and griduncn -#ifdef _OPENMP - do ithread=1,numthreads_grid - gridunc(:,:,:,:,:,:,:)=gridunc(:,:,:,:,:,:,:)+gridunc_omp(:,:,:,:,:,:,:,ithread) - gridunc_omp(:,:,:,:,:,:,:,ithread)=0. - end do - if (nested_output.eq.1) then - do ithread=1,numthreads_grid - griduncn(:,:,:,:,:,:,:)=griduncn(:,:,:,:,:,:,:)+griduncn_omp(:,:,:,:,:,:,:,ithread) - griduncn_omp(:,:,:,:,:,:,:,ithread)=0. - end do - endif -#endif - - !*********************************************************************** - ! 2. Evaluate concentrations at receptor points, using the kernel method - !*********************************************************************** - if (numreceptor.eq.0) return - - do n=1,numreceptor - - - ! Reset concentrations - !********************* - - do ks=1,nspec - c(ks)=0. - end do - - - ! Estimate concentration at receptor - !*********************************** - - do i=1,numpart - - if (.not. part(i)%alive) cycle - itage=abs(itime-part(i)%tstart) - - hz=min(50.+0.3*sqrt(real(itage)),hzmax) - zd=part(i)%z/hz - if (zd.gt.1.) cycle ! 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=(part(i)%xlon-xreceptor(n))/hx - if (xd*xd.gt.1.) cycle ! 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=(part(i)%ylat-yreceptor(n))/hy - if (yd*yd.gt.1.) cycle ! save computing time, leave loop - hxyz=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)+part(i)%mass(ks)*xkern/hxyz - end do - endif - 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 - -subroutine partpos_avg(itime,j) - - !********************************************************************** - ! This subroutine averages particle quantities, to be used for particle - ! dump (in partoutput.f90). Averaging is done over output interval. - ! Author: A. Stohl - ! Changes L Bakels: - ! - Computing fields defined in PARTOPTIONS - !********************************************************************** - - use par_mod - use com_mod - use interpol_mod - use coord_ec_mod - - implicit none - - integer,intent(in) :: itime,j - integer :: np,i_av,ns,m - real :: xlon,ylat,x,y,z - real :: topo,hm(2),hmixi,pvi,qvi - real :: tti,rhoi,ttemp - real :: uui,vvi,output - real :: tr(2),tri!,energy - - logical :: cart_comp - - if (ipout.eq.0) return ! No need to compute averages since there is no particle output - - if (n_average.eq.0) return - - if (.not. part(j)%alive) return - - if (part(j)%nstop) return ! If particle is to be killed, averages cannot be computed - - ! Some variables needed for temporal interpolation - !************************************************* - call find_time_vars(itime) - - xlon=xlon0+real(part(j)%xlon)*dx - ylat=ylat0+real(part(j)%ylat)*dy +#include "out_init_output.f90" - !***************************************************************************** - ! Interpolate several variables (PV, specific humidity, etc.) to particle position - !***************************************************************************** - ! Where in the grid? Stereographic (ngrid<0) or nested (ngrid>0) - !*************************************************************** - call find_ngrid(real(part(j)%xlon),real(part(j)%ylat)) - call find_grid_indices(real(part(j)%xlon),real(part(j)%ylat)) - call find_grid_distances(real(part(j)%xlon),real(part(j)%ylat)) +#include "out_finalise_output.f90" - ! First set dz1out from interpol_mod to -1 so it only is calculated once per particle - !************************************************************************************ - part(j)%ntime=part(j)%ntime + 1 - dz1out=-1 - cart_comp=.false. - do np=1,num_partopt - if ((.not. partopt(np)%print) .or. (.not. partopt(np)%average)) cycle - i_av = partopt(np)%i_average - select case (partopt(np)%name) - case ('to') - if (ngrid.le.0) then - call hor_interpol(oro,output) - else - call hor_interpol_nest(oron,output) - endif - part(j)%val_av(i_av)=part(j)%val_av(i_av)+output - case ('tr') - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(tropopause,tr(m),1,memind(m),1) - end do - else - do m=1,2 - call hor_interpol_nest(tropopausen,tr(m),1,memind(m),1) - end do - endif - call temp_interpol(tr(1),tr(2),output) - part(j)%val_av(i_av)=part(j)%val_av(i_av)+output - case ('hm') - if (ngrid.le.0) then - do m=1,2 - call hor_interpol(hmix,hm(m),1,memind(m),1) - end do - else - do m=1,2 - call hor_interpol_nest(hmixn,hm(m),1,memind(m),1) - end do - endif - call temp_interpol(hm(1),hm(2),output) - part(j)%val_av(i_av)=part(j)%val_av(i_av)+output - case ('lo') - if (.not. cart_comp) then - ! Calculate Cartesian 3D coordinates suitable for averaging - !********************************************************** +#include "out_output_restart.f90" - xlon=xlon*pi180 - ylat=ylat*pi180 - x = cos(ylat)*sin(xlon) - y = -1.*cos(ylat)*cos(xlon) - z = sin(ylat) +#include "out_output_heightlevs.f90" - part(j)%cartx_av=part(j)%cartx_av+x - part(j)%carty_av=part(j)%carty_av+y - part(j)%cartz_av=part(j)%cartz_av+z - cart_comp=.true. - endif - case ('la') - if (.not. cart_comp) then - ! Calculate Cartesian 3D coordinates suitable for averaging - !********************************************************** +#include "out_output_particle.f90" - xlon=xlon*pi180 - ylat=ylat*pi180 - x = cos(ylat)*sin(xlon) - y = -1.*cos(ylat)*cos(xlon) - z = sin(ylat) +#include "out_output_conc.f90" - part(j)%cartx_av=part(j)%cartx_av+x - part(j)%carty_av=part(j)%carty_av+y - part(j)%cartz_av=part(j)%cartz_av+z - cart_comp=.true. - endif - case ('zz') - ! Convert eta z coordinate to meters if necessary. Can be moved to output only - !************************************************ - call update_zeta_to_z(itime,j) - part(j)%val_av(i_av)=part(j)%val_av(i_av)+part(j)%z - case ('ma') - do ns=1,nspec - part(j)%val_av(i_av+(ns-1))=part(j)%val_av(i_av+(ns-1))+part(j)%mass(ns) - end do - case ('vs') - part(j)%val_av(i_av)=part(j)%val_av(i_av)+part(j)%settling - case default - call interpol_partoutput_val(partopt(np)%name,output,j) - part(j)%val_av(i_av)=part(j)%val_av(i_av)+output - end select - end do - ! Reset dz1out - !************* - dz1out=-1 - cart_comp=.false. +#include "out_conccalc.f90" - return -end subroutine partpos_avg +#include "out_partpos_avg.f90" end module output_mod diff --git a/src/par_alloc_particle.f90 b/src/par_alloc_particle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f7328f7215ee4a88d22283afce1c05d92f3b4d3f --- /dev/null +++ b/src/par_alloc_particle.f90 @@ -0,0 +1,18 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine alloc_particle(ipart) + + implicit none + + integer, intent(in) :: ipart + + ! Keeping track of the allocated memory in case + ! there is a reason for deallocating some of it + if (ipart.gt.count%allocated) then + call alloc_particles(ipart-count%allocated) + else + stop 'Error: You are trying to allocate an already existing particle' + endif + + end subroutine alloc_particle diff --git a/src/par_alloc_particles.f90 b/src/par_alloc_particles.f90 new file mode 100644 index 0000000000000000000000000000000000000000..40b4ce062ca04c5768b89438acacca952ab61505 --- /dev/null +++ b/src/par_alloc_particles.f90 @@ -0,0 +1,66 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine alloc_particles(nmpart) + + integer, intent(in) :: nmpart + + integer, allocatable :: tmpnclust(:) + logical, allocatable :: tmpcount(:) + type(particle),allocatable :: tmppart(:) + real, allocatable :: tmpxscav(:,:) + real, allocatable :: tmpxl(:),tmpyl(:),tmpzl(:) + integer :: i + + if (nmpart.gt.100) write(*,*) 'Allocating ',nmpart,' particles' + + ! Keeping track of the allocated memory in case + ! there is a reason for deallocating some of it + allocate( tmpcount(count%allocated + nmpart) ) + if (count%allocated.gt.0) tmpcount(1:count%allocated) = count%inmem + call move_alloc(tmpcount,count%inmem) + count%inmem(count%allocated + 1 : count%allocated + nmpart) = .true. + + ! Allocating new particle spaces + !******************************* + + allocate( tmppart(count%allocated + nmpart) ) + if (n_average.gt.0) then + do i=1,count%allocated + nmpart + allocate( tmppart(i)%val_av(n_average) ) + tmppart(i)%val_av = 0 + end do + endif + if (count%allocated.gt.0) tmppart(1:count%allocated) = part + call move_alloc(tmppart,part) + + ! If wet or dry deposition backward mode is switched on, xscav_frac1 + ! needs to be allocated + if (wetbkdep.or.drybkdep) then + allocate( tmpxscav(count%allocated + nmpart,maxspec) ) + if (count%allocated.gt.0) tmpxscav(1:count%allocated,:) = xscav_frac1 + call move_alloc(tmpxscav,xscav_frac1) + endif + + if (iout.eq.4 .or. iout.eq.5) then + allocate( tmpxl(count%allocated + nmpart) ) + if (count%allocated.gt.0) tmpxl(1:count%allocated) = xplum + call move_alloc(tmpxl,xplum) + + allocate( tmpyl(count%allocated +nmpart) ) + if (count%allocated.gt.0) tmpyl(1:count%allocated) = yplum + call move_alloc(tmpyl,yplum) + + allocate( tmpzl(count%allocated+nmpart) ) + if (count%allocated.gt.0) tmpzl(1:count%allocated) = zplum + call move_alloc(tmpzl,zplum) + + allocate( tmpnclust(count%allocated + nmpart) ) + if (count%allocated.gt.0) tmpnclust(1:count%allocated) = nclust + call move_alloc(tmpnclust,nclust) + endif + + count%allocated = count%allocated + nmpart + if (nmpart.gt.100) write(*,*) 'Finished allocation' + + end subroutine alloc_particles diff --git a/src/par_dealloc_all_particles.f90 b/src/par_dealloc_all_particles.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3f06da68ee9afc7e27786c9608ddf8aef105a816 --- /dev/null +++ b/src/par_dealloc_all_particles.f90 @@ -0,0 +1,25 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine dealloc_all_particles() + + integer :: i + + if (n_average.gt.0) then + do i=1,count%allocated + deallocate( part(i)%val_av ) + end do + endif + deallocate( part ) + deallocate( count%inmem ) + + if (wetbkdep.or.drybkdep) deallocate( xscav_frac1 ) + + if (iout.eq.4 .or. iout.eq.5) then + deallocate( xplum ) + deallocate( yplum ) + deallocate( zplum ) + deallocate( nclust ) + endif + + end subroutine dealloc_all_particles diff --git a/src/par_dealloc_particle.f90 b/src/par_dealloc_particle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0e92b0930530eb996b0ede53d0c8d8676819f2ce --- /dev/null +++ b/src/par_dealloc_particle.f90 @@ -0,0 +1,12 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine dealloc_particle(ipart) + + integer, intent(in) :: ipart ! particle index + + !deallocate( part(ipart) ) + part = part(1:ipart) ! FORTRAN 2008 only + count%inmem(ipart+1:) = .false. + + end subroutine dealloc_particle diff --git a/src/par_dealloc_particle_range.f90 b/src/par_dealloc_particle_range.f90 new file mode 100644 index 0000000000000000000000000000000000000000..27d8a3ddd4f81fc6f23af711bf2f9a5ffa1676bf --- /dev/null +++ b/src/par_dealloc_particle_range.f90 @@ -0,0 +1,11 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine dealloc_particle_range(istart,iend) + + integer, intent(in) :: istart,iend + + !deallocate( part(istart:iend) ) + count%inmem(istart:iend) = .false. + + end subroutine dealloc_particle_range diff --git a/src/par_get_alivepart_num.f90 b/src/par_get_alivepart_num.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f7a05fb939b43643db8af7a8770f8346f2be6455 --- /dev/null +++ b/src/par_get_alivepart_num.f90 @@ -0,0 +1,14 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine get_alivepart_num(npart) + + !********************************************** + ! Returns number of particles currently alive * + !********************************************** + + integer, intent(inout) :: npart ! Number of particles + + npart = count%alive + + end subroutine get_alivepart_num diff --git a/src/par_get_newpart_index.f90 b/src/par_get_newpart_index.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d753fdf77534a818f1644661b316912caafdc61e --- /dev/null +++ b/src/par_get_newpart_index.f90 @@ -0,0 +1,14 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine get_newpart_index(ipart) + + !************************************************** + ! Returns the first free spot to put a new particle + !************************************************** + + integer, intent(inout) :: ipart ! First free index + + ipart = count%spawned + 1 + + end subroutine get_newpart_index diff --git a/src/par_get_totalpart_num.f90 b/src/par_get_totalpart_num.f90 new file mode 100644 index 0000000000000000000000000000000000000000..492c2d2bd76bfda0fd76a937f9b5ff28063a42a1 --- /dev/null +++ b/src/par_get_totalpart_num.f90 @@ -0,0 +1,14 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine get_totalpart_num(npart) + + !******************************************** + ! Returns total number of particles spawned * + !******************************************** + + integer, intent(inout) :: npart ! Number of particles + + npart = count%spawned + + end subroutine get_totalpart_num diff --git a/src/par_mod.f90 b/src/par_mod.f90 index 38e2e91cc76474f76b71cd3eebee865c9cd4f9f6..2445ebc7bcb33f17a06e3fb52cb952f5eaa1906b 100644 --- a/src/par_mod.f90 +++ b/src/par_mod.f90 @@ -26,7 +26,7 @@ module par_mod integer,parameter :: sp=selected_real_kind(6) !**************************************************************** - ! dep_prec sets the precision for deposition calculations (sp or + ! dep_prec sets the precision for deposition calculations (sp or ! dp). sp is default, dp can be used for increased precision. !**************************************************************** @@ -59,7 +59,7 @@ module par_mod real,parameter :: pi=3.14159265, r_earth=6.371e6, r_air=287.05, ga=9.81 real,parameter :: cpa=1004.6, kappa=0.286, pi180=pi/180., vonkarman=0.4 ! additional constants RLT Aug-2017 - real,parameter :: rgas=8.31447 + real,parameter :: rgas=8.31447 real,parameter :: r_water=461.495 ! pi number "pi" @@ -90,7 +90,7 @@ module par_mod ! d_trop [m2/s] Turbulent diffusivity for horiz components in the troposphere ! d_strat [m2/s] Turbulent diffusivity for vertical component in the stratosphere - + real,parameter :: xmwml=18.016/28.960 ! ratio of molar weights of water vapor and dry air @@ -130,7 +130,7 @@ module par_mod !********************************************* ! Maximum dimensions of the input mother grids !********************************************* - + ! ECMWF ! integer,parameter :: nxmax=361,nymax=181,nuvzmax=92,nwzmax=92,nzmax=92,nxshift=359 ! 1.0 deg 92 levels ! integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138,nxshift=0 ! 1.0 deg 138 levels @@ -140,7 +140,7 @@ module par_mod ! GFS ! integer,parameter :: nxmax=361,nymax=181,nuvzmax=138,nwzmax=138,nzmax=138 -! integer,parameter :: nxshift=0 ! shift not fixed for the executable +! integer,parameter :: nxshift=0 ! shift not fixed for the executable !********************************* ! Parmaters for GRIB file decoding @@ -164,7 +164,7 @@ module par_mod ! nzmax maximum dimension of wind fields in z direction ! for the transformed Cartesian coordinates - + integer,parameter :: nconvlevmax = nuvzmax-1 integer,parameter :: na = nconvlevmax+1 @@ -220,16 +220,16 @@ module par_mod !integer,parameter :: numwfmem=3 ! MPI with 3 fields ! maxwf maximum number of wind fields to be used for simulation - ! maxtable Maximum number of chemical species that can be tabulated + ! maxtable Maximum number of chemical species that can be tabulated ! numclass Number of landuse classes available to FLEXPART ! maxndia Maximum number of diameter classes of particles - ! numwfmem Number of windfields kept in memory. 2 for serial version, + ! numwfmem Number of windfields kept in memory. 2 for serial version, ! 2 or 3 for MPI version !************************************************************************** ! dimension of the OH field !************************************************************************** - + integer,parameter :: maxxOH=72, maxyOH=46, maxzOH=7 !************************************************************************** @@ -247,7 +247,7 @@ module par_mod integer,parameter :: maxrand=6000000 ! maxrand number of random numbers used - + !***************************************************** ! Number of clusters to be used for plume trajectories @@ -265,7 +265,7 @@ module par_mod integer,parameter :: unitrestart=106,unitheightlevels=107 integer,parameter :: unitpartin=93, unitflux=98, unitouttraj=96 integer,parameter :: unitvert=1, unitoro=1, unitpoin=1, unitreceptor=1 - integer,parameter :: unitreceptorout=2 + integer,parameter :: unitreceptorout=2 integer,parameter :: unitoutgrid=97, unitoutgridppt=99, unitoutinfo=1 integer,parameter :: unitspecies=1, unitoutrecept=91, unitoutreceptppt=92 integer,parameter :: unitlsm=1, unitsfcdata=1, unitland=1, unitwesely=1 @@ -284,22 +284,22 @@ module par_mod integer,parameter :: icmv=-9999 !******************************************************************************* -! Maximum output of each partoutput NetCDF-4 file in Mb +! Maximum output of each partoutput NetCDF-4 file in Mb ! before a new one is created !******************************************************************************* integer,parameter :: max_partoutput_filesize=30000 - ! Set maximum number of threads for doing grid computations. + ! Set maximum number of threads for doing grid computations. ! Recommended to set this to max 16 ! High numbers create more overhead and a larger memory footprint !*********************************************************************** integer,parameter :: max_numthreads_grid=16 ! Set the coordinate system. At the moment only ECMWF is possible. This bit - ! needs to be a parameter that can be set at compile time. + ! needs to be a parameter that can be set at compile time. ! Throughout the code there will be SELECT CASE statements or IFDEFs !******************************************************************* - + character(len=256),parameter :: wind_coord_type='ETA' !character(len=256),parameter :: wind_coord_type='METER' @@ -311,10 +311,10 @@ module par_mod !*********************************************************************** logical,parameter :: lmesoscale_turb=.false. - ! Threshold equivalent diameter for interaction with surface sublayer + ! Threshold equivalent diameter for interaction with surface sublayer ! resistance (below 10 meters) in micrometer. Above this diameter there ! is no interaction !********************************************************************** real,parameter :: d_thresheqv=20 - + end module par_mod diff --git a/src/par_particle_allocated.f90 b/src/par_particle_allocated.f90 new file mode 100644 index 0000000000000000000000000000000000000000..454ab31f3f4711757032ca9269829ac5fe96975c --- /dev/null +++ b/src/par_particle_allocated.f90 @@ -0,0 +1,20 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + logical function particle_allocated(ipart) + + !****************************************** + ! Checks if the memory of the particle is * + ! still allocated * + !****************************************** + + integer, intent(in) :: ipart ! particle index + !logical :: particle_allocated + + if (ipart.gt.count%allocated) then + particle_allocated = .false. + else + particle_allocated = count%inmem(ipart) + endif + + end function particle_allocated diff --git a/src/par_set_xlon_dp.f90 b/src/par_set_xlon_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7e99fc044e1b460426c210b2bed8050eab281db2 --- /dev/null +++ b/src/par_set_xlon_dp.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_xlon_dp(ipart,xvalue) + + !************************************** + ! Sets the longitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real(kind=dp), intent(in) :: xvalue + + part(ipart)%xlon = xvalue + + end subroutine set_xlon_dp diff --git a/src/par_set_xlon_int.f90 b/src/par_set_xlon_int.f90 new file mode 100644 index 0000000000000000000000000000000000000000..68547400de7df533477b564762fa9743b242059c --- /dev/null +++ b/src/par_set_xlon_int.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_xlon_int(ipart,xvalue) + + !************************************** + ! Sets the longitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + integer, intent(in) :: xvalue + + part(ipart)%xlon = real(xvalue,kind=dp) + + end subroutine set_xlon_int diff --git a/src/par_set_xlon_sp.f90 b/src/par_set_xlon_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ff284b8839bc2cbc3b84e32dbaca41b72b72be5b --- /dev/null +++ b/src/par_set_xlon_sp.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_xlon_sp(ipart,xvalue) + + !************************************** + ! Sets the longitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real, intent(in) :: xvalue + + part(ipart)%xlon = real(xvalue,kind=dp) + + end subroutine set_xlon_sp diff --git a/src/par_set_ylat_dp.f90 b/src/par_set_ylat_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..93c86b7a22f2060fb854928c3709ae6bb7cdf422 --- /dev/null +++ b/src/par_set_ylat_dp.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_ylat_dp(ipart,yvalue) + + !************************************** + ! Sets the latitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real(kind=dp), intent(in) :: yvalue + + part(ipart)%ylat = yvalue + + end subroutine set_ylat_dp diff --git a/src/par_set_ylat_int.f90 b/src/par_set_ylat_int.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ad7bfba4a8d45d95ab34871abf76fdaebe8ce889 --- /dev/null +++ b/src/par_set_ylat_int.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_ylat_int(ipart,yvalue) + + !************************************** + ! Sets the latitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + integer, intent(in) :: yvalue + + part(ipart)%ylat = real(yvalue,kind=dp) + + end subroutine set_ylat_int diff --git a/src/par_set_ylat_sp.f90 b/src/par_set_ylat_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..104b49bce6b376472ae80bc41e119220dbd06611 --- /dev/null +++ b/src/par_set_ylat_sp.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_ylat_sp(ipart,yvalue) + + !************************************** + ! Sets the latitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real, intent(in) :: yvalue + + part(ipart)%ylat = real(yvalue,kind=dp) + + end subroutine set_ylat_sp diff --git a/src/par_set_z_dp.f90 b/src/par_set_z_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4f7630ddf4e803c3d2eb07a9fd3facff3e7b3b28 --- /dev/null +++ b/src/par_set_z_dp.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_z_dp(ipart,zvalue) + + !************************************** + ! Updates the height of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real(kind=dp), intent(in) :: zvalue + + part(ipart)%z = zvalue + part(ipart)%meterupdate=.false. + part(ipart)%etaupdate=.true. + + end subroutine set_z_dp diff --git a/src/par_set_z_sp.f90 b/src/par_set_z_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2d9000c402f6fbfd60a6ca4805f3b09d731b8120 --- /dev/null +++ b/src/par_set_z_sp.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_z_sp(ipart,zvalue) + + !************************************** + ! Updates the height of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real, intent(in) :: zvalue + + part(ipart)%z = real(zvalue,kind=dp) + part(ipart)%meterupdate=.false. + part(ipart)%etaupdate=.true. + + end subroutine set_z_sp diff --git a/src/par_set_zeta_dp.f90 b/src/par_set_zeta_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b29e54b371ab22685b7d6a737b7c81a7152da0b8 --- /dev/null +++ b/src/par_set_zeta_dp.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_zeta_dp(ipart,zvalue) + + !************************************** + ! Updates the height of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real(kind=dp), intent(in) :: zvalue + + part(ipart)%zeta = zvalue + part(ipart)%etaupdate=.false. + part(ipart)%meterupdate=.true. + + end subroutine set_zeta_dp diff --git a/src/par_set_zeta_sp.f90 b/src/par_set_zeta_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2da5ca4d1cd532ddb2c089a8811a79fae1253628 --- /dev/null +++ b/src/par_set_zeta_sp.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine set_zeta_sp(ipart,zvalue) + + !************************************** + ! Updates the height of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real, intent(in) :: zvalue + + part(ipart)%zeta = real(zvalue,kind=dp) + part(ipart)%etaupdate=.false. + part(ipart)%meterupdate=.true. + + end subroutine set_zeta_sp diff --git a/src/par_spawn_particle.f90 b/src/par_spawn_particle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bbab31edfaa760582171f47cbb0092e0c704f191 --- /dev/null +++ b/src/par_spawn_particle.f90 @@ -0,0 +1,29 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine spawn_particle(itime, ipart) + + !****************************************************** + ! This routine spawns new particles and allocates the + ! memory if necessary. + !****************************************************** + + integer, intent(in) :: itime ! spawning time + integer, intent(in) :: ipart ! number of particles that are being spawned + + ! Check if new memory needs to be allocated + if (.not. particle_allocated(ipart)) call alloc_particle(ipart) + + if (part(ipart)%alive) stop 'Attempting to overwrite existing particle' + + ! Update the number of particles that are currently alive + count%alive = count%alive + 1 + + ! Set the spawning time for each new particle and mark it as alive + part(ipart)%tstart = itime + part(ipart)%alive = .true. + + ! Update the total number of spawned particles + count%spawned = count%spawned + 1 + + end subroutine spawn_particle diff --git a/src/par_spawn_particles.f90 b/src/par_spawn_particles.f90 new file mode 100644 index 0000000000000000000000000000000000000000..41ac50101455655b270ac1631f424c3c43b44b4b --- /dev/null +++ b/src/par_spawn_particles.f90 @@ -0,0 +1,28 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine spawn_particles(itime, nmpart) + + !****************************************************** + ! This routine spawns new particles and allocates the + ! memory if necessary. + !****************************************************** + + integer, intent(in) :: itime ! spawning time + integer, intent(in) :: nmpart ! number of particles that are being spawned + + ! Check if new memory needs to be allocated + if (nmpart + count%spawned .gt. count%allocated) & + call alloc_particles( (nmpart + count%spawned) - count%allocated ) + + ! Update the number of particles that are currently alive + count%alive = count%alive + nmpart + + ! Set the spawning time for each new particle and mark it as alive + part(count%spawned + 1 : count%spawned + nmpart)%tstart = itime + part(count%spawned + 1 : count%spawned + nmpart)%alive = .true. + + ! Update the total number of spawned particles + count%spawned = count%spawned + nmpart + + end subroutine spawn_particles diff --git a/src/par_terminate_particle.f90 b/src/par_terminate_particle.f90 new file mode 100644 index 0000000000000000000000000000000000000000..47ae28257a3ba06b5db0caefcc09f18bd95a7451 --- /dev/null +++ b/src/par_terminate_particle.f90 @@ -0,0 +1,24 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine terminate_particle(ipart,itime) + + !***************************************************** + ! Terminating specified particle + ! This routine terminates a selected particle + !***************************************************** + + integer, intent(in) :: ipart ! to be terminated particle index + integer, intent(in) :: itime ! Time at which particle is terminated + + ! Flagging the particle as having been terminated + part(ipart)%alive=.false. + part(ipart)%tend=itime + + ! Update the number of current particles that are alive + count%alive = count%alive - 1 + + ! Update the total number of terminated particles during the whole run + count%terminated = count%terminated + 1 + + end subroutine terminate_particle diff --git a/src/par_update_xlon_dp.f90 b/src/par_update_xlon_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f7c3887a74791451508797b719b1e0ee479a7d33 --- /dev/null +++ b/src/par_update_xlon_dp.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_xlon_dp(ipart,xchange) + + !************************************** + ! Updates the longitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real(kind=dp), intent(in) :: xchange + + part(ipart)%xlon = part(ipart)%xlon + xchange + + end subroutine update_xlon_dp diff --git a/src/par_update_xlon_int.f90 b/src/par_update_xlon_int.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3e99c5155f610d34679296c6dee997b3ae08f638 --- /dev/null +++ b/src/par_update_xlon_int.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_xlon_int(ipart,xchange) + + !************************************** + ! Updates the longitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + integer, intent(in) :: xchange + + part(ipart)%xlon = part(ipart)%xlon + real(xchange,kind=dp) + + end subroutine update_xlon_int diff --git a/src/par_update_xlon_sp.f90 b/src/par_update_xlon_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..794acc9f234c56d93506299c1f31752a72f135ea --- /dev/null +++ b/src/par_update_xlon_sp.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_xlon_sp(ipart,xchange) + + !************************************** + ! Updates the longitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real, intent(in) :: xchange + + part(ipart)%xlon = part(ipart)%xlon + real(xchange,kind=dp) + + end subroutine update_xlon_sp diff --git a/src/par_update_ylat_dp.f90 b/src/par_update_ylat_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ea71304d907ba7b94c9198915dea91d206ac95ed --- /dev/null +++ b/src/par_update_ylat_dp.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_ylat_dp(ipart,ychange) + + !************************************** + ! Updates the latitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real(kind=dp), intent(in) :: ychange + + part(ipart)%ylat = part(ipart)%ylat + ychange + + end subroutine update_ylat_dp diff --git a/src/par_update_ylat_int.f90 b/src/par_update_ylat_int.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e32302534dfa9cdb6b05587016a4229a807060cd --- /dev/null +++ b/src/par_update_ylat_int.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_ylat_int(ipart,ychange) + + !************************************** + ! Updates the latitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + integer, intent(in) :: ychange + + part(ipart)%ylat = part(ipart)%ylat + real(ychange,kind=dp) + + end subroutine update_ylat_int diff --git a/src/par_update_ylat_sp.f90 b/src/par_update_ylat_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..64def0d8b3686f4eba54e3d9ab484f2de48a07b0 --- /dev/null +++ b/src/par_update_ylat_sp.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_ylat_sp(ipart,ychange) + + !************************************** + ! Updates the latitude of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real, intent(in) :: ychange + + part(ipart)%ylat = part(ipart)%ylat + real(ychange,kind=dp) + + end subroutine update_ylat_sp diff --git a/src/par_update_z_dp.f90 b/src/par_update_z_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7e38ed8c2d18df36cd84effb93fc57fd81d064ef --- /dev/null +++ b/src/par_update_z_dp.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_z_dp(ipart,zchange) + + !************************************** + ! Updates the height of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real(kind=dp), intent(in) :: zchange + + part(ipart)%z = part(ipart)%z + zchange + part(ipart)%meterupdate=.false. + part(ipart)%etaupdate=.true. + + end subroutine update_z_dp diff --git a/src/par_update_z_sp.f90 b/src/par_update_z_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..879f38d9a2ea3d733f7c66e5bd8969bafd6a08bf --- /dev/null +++ b/src/par_update_z_sp.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_z_sp(ipart,zchange) + + !************************************** + ! Updates the height of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real, intent(in) :: zchange + + part(ipart)%z = part(ipart)%z + real(zchange,kind=dp) + part(ipart)%meterupdate=.false. + part(ipart)%etaupdate=.true. + + end subroutine update_z_sp diff --git a/src/par_update_zeta_dp.f90 b/src/par_update_zeta_dp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..058c989b15f3a39c811e4f41ef9cda02d36c3912 --- /dev/null +++ b/src/par_update_zeta_dp.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_zeta_dp(ipart,zchange) + + !************************************** + ! Updates the height of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real(kind=dp), intent(in) :: zchange + + part(ipart)%zeta = part(ipart)%zeta + zchange + part(ipart)%etaupdate=.false. + part(ipart)%meterupdate=.true. + + end subroutine update_zeta_dp diff --git a/src/par_update_zeta_sp.f90 b/src/par_update_zeta_sp.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5f21930bb565cae6dd2c01093667a1f16acc184f --- /dev/null +++ b/src/par_update_zeta_sp.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine update_zeta_sp(ipart,zchange) + + !************************************** + ! Updates the height of the particle + !************************************** + + integer, intent(in) :: ipart ! particle index + real, intent(in) :: zchange + + part(ipart)%zeta = part(ipart)%zeta + real(zchange,kind=dp) + part(ipart)%etaupdate=.false. + part(ipart)%meterupdate=.true. + + end subroutine update_zeta_sp diff --git a/src/particle_mod.f90 b/src/particle_mod.f90 index 0696063a3e9965d488b5214ef1757f99aa4099e0..407e91df0008e1a67347befef8dfbdf42d42bc6a 100644 --- a/src/particle_mod.f90 +++ b/src/particle_mod.f90 @@ -15,7 +15,7 @@ module particle_mod use par_mod, only: dp implicit none - + type :: coordinates real(kind=dp) :: & xlon, & ! longitude in grid coordinates @@ -57,7 +57,7 @@ module particle_mod meterupdate=.false., & ! If false, z(eta) is more up-to-date than z(meter) nstop=.false.!Flag stopping particle, used in advance, stop in timemanager integer(kind=2) :: & - icbt ! Forbidden state flag + icbt ! Forbidden state flag integer :: & tstart, & ! spawning time in seconds after start tend, & ! termination time in seconds after start @@ -71,7 +71,7 @@ module particle_mod wetdepo(maxspec)=0., & ! Wet deposition (cumulative) drydepo(maxspec)=0., & ! Dry deposition (cumulative) prob(maxspec) ! Probability of absorption at ground due to dry deposition - + real,allocatable :: & val_av(:) ! Averaged values; only used when average_output=.true. real :: & @@ -82,7 +82,7 @@ module particle_mod end type particle - type :: particlecount + type :: particlecount integer :: & alive=0, & ! Number of particles that are alive spawned=0, & ! Total number of spawned particles @@ -104,7 +104,7 @@ module particle_mod integer,allocatable :: & nclust(:) ! Only allocated for iout=4 or 5 (plumetraj) ! private :: & - ! count + ! count public :: & particle, & part, & @@ -155,547 +155,84 @@ module particle_mod interface set_zeta procedure set_zeta_dp,set_zeta_sp end interface set_zeta - -contains - - logical function particle_allocated(ipart) - - !****************************************** - ! Checks if the memory of the particle is * - ! still allocated * - !****************************************** - - integer, intent(in) :: ipart ! particle index - !logical :: particle_allocated - - if (ipart.gt.count%allocated) then - particle_allocated = .false. - else - particle_allocated = count%inmem(ipart) - endif - - end function particle_allocated - - subroutine get_newpart_index(ipart) - - !************************************************** - ! Returns the first free spot to put a new particle - !************************************************** - - integer, intent(inout) :: ipart ! First free index - - ipart = count%spawned + 1 - - end subroutine get_newpart_index - - subroutine get_totalpart_num(npart) - - !******************************************** - ! Returns total number of particles spawned * - !******************************************** - - integer, intent(inout) :: npart ! Number of particles - - npart = count%spawned - - end subroutine get_totalpart_num - - subroutine get_alivepart_num(npart) - - !********************************************** - ! Returns number of particles currently alive * - !********************************************** - - integer, intent(inout) :: npart ! Number of particles - - npart = count%alive - - end subroutine get_alivepart_num - - subroutine spawn_particles(itime, nmpart) - - !****************************************************** - ! This routine spawns new particles and allocates the - ! memory if necessary. - !****************************************************** - - integer, intent(in) :: itime ! spawning time - integer, intent(in) :: nmpart ! number of particles that are being spawned - - ! Check if new memory needs to be allocated - if (nmpart + count%spawned .gt. count%allocated) & - call alloc_particles( (nmpart + count%spawned) - count%allocated ) - - ! Update the number of particles that are currently alive - count%alive = count%alive + nmpart - - ! Set the spawning time for each new particle and mark it as alive - part(count%spawned + 1 : count%spawned + nmpart)%tstart = itime - part(count%spawned + 1 : count%spawned + nmpart)%alive = .true. - - ! Update the total number of spawned particles - count%spawned = count%spawned + nmpart - - end subroutine spawn_particles - - subroutine spawn_particle(itime, ipart) - - !****************************************************** - ! This routine spawns new particles and allocates the - ! memory if necessary. - !****************************************************** - - integer, intent(in) :: itime ! spawning time - integer, intent(in) :: ipart ! number of particles that are being spawned - - ! Check if new memory needs to be allocated - if (.not. particle_allocated(ipart)) call alloc_particle(ipart) - - if (part(ipart)%alive) stop 'Attempting to overwrite existing particle' - ! Update the number of particles that are currently alive - count%alive = count%alive + 1 - - ! Set the spawning time for each new particle and mark it as alive - part(ipart)%tstart = itime - part(ipart)%alive = .true. - - ! Update the total number of spawned particles - count%spawned = count%spawned + 1 - - end subroutine spawn_particle - - subroutine terminate_particle(ipart,itime) - - !***************************************************** - ! Terminating specified particle - ! This routine terminates a selected particle - !***************************************************** - - integer, intent(in) :: ipart ! to be terminated particle index - integer, intent(in) :: itime ! Time at which particle is terminated - - ! Flagging the particle as having been terminated - part(ipart)%alive=.false. - part(ipart)%tend=itime - - ! Update the number of current particles that are alive - count%alive = count%alive - 1 - - ! Update the total number of terminated particles during the whole run - count%terminated = count%terminated + 1 - - end subroutine terminate_particle - - subroutine alloc_particles(nmpart) - - integer, intent(in) :: nmpart - - integer, allocatable :: tmpnclust(:) - logical, allocatable :: tmpcount(:) - type(particle),allocatable :: tmppart(:) - real, allocatable :: tmpxscav(:,:) - real, allocatable :: tmpxl(:),tmpyl(:),tmpzl(:) - integer :: i - - if (nmpart.gt.100) write(*,*) 'Allocating ',nmpart,' particles' - - ! Keeping track of the allocated memory in case - ! there is a reason for deallocating some of it - allocate( tmpcount(count%allocated + nmpart) ) - if (count%allocated.gt.0) tmpcount(1:count%allocated) = count%inmem - call move_alloc(tmpcount,count%inmem) - count%inmem(count%allocated + 1 : count%allocated + nmpart) = .true. - - ! Allocating new particle spaces - !******************************* - - allocate( tmppart(count%allocated + nmpart) ) - if (n_average.gt.0) then - do i=1,count%allocated + nmpart - allocate( tmppart(i)%val_av(n_average) ) - tmppart(i)%val_av = 0 - end do - endif - if (count%allocated.gt.0) tmppart(1:count%allocated) = part - call move_alloc(tmppart,part) - - ! If wet or dry deposition backward mode is switched on, xscav_frac1 - ! needs to be allocated - if (wetbkdep.or.drybkdep) then - allocate( tmpxscav(count%allocated + nmpart,maxspec) ) - if (count%allocated.gt.0) tmpxscav(1:count%allocated,:) = xscav_frac1 - call move_alloc(tmpxscav,xscav_frac1) - endif - - if (iout.eq.4 .or. iout.eq.5) then - allocate( tmpxl(count%allocated + nmpart) ) - if (count%allocated.gt.0) tmpxl(1:count%allocated) = xplum - call move_alloc(tmpxl,xplum) - - allocate( tmpyl(count%allocated +nmpart) ) - if (count%allocated.gt.0) tmpyl(1:count%allocated) = yplum - call move_alloc(tmpyl,yplum) - - allocate( tmpzl(count%allocated+nmpart) ) - if (count%allocated.gt.0) tmpzl(1:count%allocated) = zplum - call move_alloc(tmpzl,zplum) - - allocate( tmpnclust(count%allocated + nmpart) ) - if (count%allocated.gt.0) tmpnclust(1:count%allocated) = nclust - call move_alloc(tmpnclust,nclust) - endif - - count%allocated = count%allocated + nmpart - if (nmpart.gt.100) write(*,*) 'Finished allocation' - - end subroutine alloc_particles - - subroutine alloc_particle(ipart) - - implicit none - - integer, intent(in) :: ipart - - ! Keeping track of the allocated memory in case - ! there is a reason for deallocating some of it - if (ipart.gt.count%allocated) then - call alloc_particles(ipart-count%allocated) - else - stop 'Error: You are trying to allocate an already existing particle' - endif - - end subroutine alloc_particle +contains - subroutine dealloc_particle_range(istart,iend) +#include "par_particle_allocated.f90" - integer, intent(in) :: istart,iend +#include "par_get_newpart_index.f90" - !deallocate( part(istart:iend) ) - count%inmem(istart:iend) = .false. +#include "par_get_totalpart_num.f90" - end subroutine dealloc_particle_range +#include "par_get_alivepart_num.f90" - subroutine dealloc_particle(ipart) +#include "par_spawn_particles.f90" - integer, intent(in) :: ipart ! particle index +#include "par_spawn_particle.f90" - !deallocate( part(ipart) ) - part = part(1:ipart) ! FORTRAN 2008 only - count%inmem(ipart+1:) = .false. +#include "par_terminate_particle.f90" - end subroutine dealloc_particle - - subroutine dealloc_all_particles() +#include "par_alloc_particles.f90" - integer :: i - - if (n_average.gt.0) then - do i=1,count%allocated - deallocate( part(i)%val_av ) - end do - endif - deallocate( part ) - deallocate( count%inmem ) +#include "par_alloc_particle.f90" - if (wetbkdep.or.drybkdep) deallocate( xscav_frac1 ) +#include "par_dealloc_particle_range.f90" - if (iout.eq.4 .or. iout.eq.5) then - deallocate( xplum ) - deallocate( yplum ) - deallocate( zplum ) - deallocate( nclust ) - endif +#include "par_dealloc_particle.f90" - end subroutine dealloc_all_particles +#include "par_dealloc_all_particles.f90" ! Update_xlon - subroutine update_xlon_dp(ipart,xchange) - - !************************************** - ! Updates the longitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real(kind=dp), intent(in) :: xchange - - part(ipart)%xlon = part(ipart)%xlon + xchange - - end subroutine update_xlon_dp - - subroutine update_xlon_sp(ipart,xchange) - - !************************************** - ! Updates the longitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real, intent(in) :: xchange - - part(ipart)%xlon = part(ipart)%xlon + real(xchange,kind=dp) - - end subroutine update_xlon_sp - - subroutine update_xlon_int(ipart,xchange) +#include "par_update_xlon_dp.f90" - !************************************** - ! Updates the longitude of the particle - !************************************** +#include "par_update_xlon_sp.f90" - integer, intent(in) :: ipart ! particle index - integer, intent(in) :: xchange - - part(ipart)%xlon = part(ipart)%xlon + real(xchange,kind=dp) - - end subroutine update_xlon_int +#include "par_update_xlon_int.f90" ! End Update_xlon ! Set_xlon - subroutine set_xlon_dp(ipart,xvalue) - - !************************************** - ! Sets the longitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real(kind=dp), intent(in) :: xvalue - - part(ipart)%xlon = xvalue - - end subroutine set_xlon_dp - - subroutine set_xlon_sp(ipart,xvalue) - - !************************************** - ! Sets the longitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real, intent(in) :: xvalue +#include "par_set_xlon_dp.f90" - part(ipart)%xlon = real(xvalue,kind=dp) +#include "par_set_xlon_sp.f90" - end subroutine set_xlon_sp - - subroutine set_xlon_int(ipart,xvalue) - - !************************************** - ! Sets the longitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - integer, intent(in) :: xvalue - - part(ipart)%xlon = real(xvalue,kind=dp) - - end subroutine set_xlon_int -! End Set_xlon +#include "par_set_xlon_int.f90" +! End Set_xlon ! Update_ylat - subroutine update_ylat_dp(ipart,ychange) - - !************************************** - ! Updates the latitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real(kind=dp), intent(in) :: ychange - - part(ipart)%ylat = part(ipart)%ylat + ychange - - end subroutine update_ylat_dp +#include "par_update_ylat_dp.f90" - subroutine update_ylat_sp(ipart,ychange) +#include "par_update_ylat_sp.f90" - !************************************** - ! Updates the latitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real, intent(in) :: ychange - - part(ipart)%ylat = part(ipart)%ylat + real(ychange,kind=dp) - - end subroutine update_ylat_sp - - subroutine update_ylat_int(ipart,ychange) - - !************************************** - ! Updates the latitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - integer, intent(in) :: ychange - - part(ipart)%ylat = part(ipart)%ylat + real(ychange,kind=dp) - - end subroutine update_ylat_int +#include "par_update_ylat_int.f90" ! End Update_ylat ! Set_ylat - subroutine set_ylat_dp(ipart,yvalue) - - !************************************** - ! Sets the latitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real(kind=dp), intent(in) :: yvalue - - part(ipart)%ylat = yvalue - - end subroutine set_ylat_dp - - subroutine set_ylat_sp(ipart,yvalue) - - !************************************** - ! Sets the latitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real, intent(in) :: yvalue - - part(ipart)%ylat = real(yvalue,kind=dp) - - end subroutine set_ylat_sp +#include "par_set_ylat_dp.f90" - subroutine set_ylat_int(ipart,yvalue) +#include "par_set_ylat_sp.f90" - !************************************** - ! Sets the latitude of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - integer, intent(in) :: yvalue - - part(ipart)%ylat = real(yvalue,kind=dp) - - end subroutine set_ylat_int +#include "par_set_ylat_int.f90" ! End Set_ylat ! Update z positions - subroutine update_z_dp(ipart,zchange) - - !************************************** - ! Updates the height of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real(kind=dp), intent(in) :: zchange - - part(ipart)%z = part(ipart)%z + zchange - part(ipart)%meterupdate=.false. - part(ipart)%etaupdate=.true. - - end subroutine update_z_dp - - subroutine update_z_sp(ipart,zchange) - - !************************************** - ! Updates the height of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real, intent(in) :: zchange - - part(ipart)%z = part(ipart)%z + real(zchange,kind=dp) - part(ipart)%meterupdate=.false. - part(ipart)%etaupdate=.true. - - end subroutine update_z_sp - - subroutine update_zeta_dp(ipart,zchange) - - !************************************** - ! Updates the height of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real(kind=dp), intent(in) :: zchange - - part(ipart)%zeta = part(ipart)%zeta + zchange - part(ipart)%etaupdate=.false. - part(ipart)%meterupdate=.true. - - end subroutine update_zeta_dp +#include "par_update_z_dp.f90" - subroutine update_zeta_sp(ipart,zchange) +#include "par_update_z_sp.f90" - !************************************** - ! Updates the height of the particle - !************************************** +#include "par_update_zeta_dp.f90" - integer, intent(in) :: ipart ! particle index - real, intent(in) :: zchange - - part(ipart)%zeta = part(ipart)%zeta + real(zchange,kind=dp) - part(ipart)%etaupdate=.false. - part(ipart)%meterupdate=.true. - - end subroutine update_zeta_sp +#include "par_update_zeta_sp.f90" ! End update z positions ! Update z positions - subroutine set_z_dp(ipart,zvalue) - - !************************************** - ! Updates the height of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real(kind=dp), intent(in) :: zvalue - - part(ipart)%z = zvalue - part(ipart)%meterupdate=.false. - part(ipart)%etaupdate=.true. - - end subroutine set_z_dp - - subroutine set_z_sp(ipart,zvalue) - - !************************************** - ! Updates the height of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real, intent(in) :: zvalue - - part(ipart)%z = real(zvalue,kind=dp) - part(ipart)%meterupdate=.false. - part(ipart)%etaupdate=.true. - - end subroutine set_z_sp - - subroutine set_zeta_dp(ipart,zvalue) - - !************************************** - ! Updates the height of the particle - !************************************** - - integer, intent(in) :: ipart ! particle index - real(kind=dp), intent(in) :: zvalue - - part(ipart)%zeta = zvalue - part(ipart)%etaupdate=.false. - part(ipart)%meterupdate=.true. - - end subroutine set_zeta_dp - - subroutine set_zeta_sp(ipart,zvalue) - - !************************************** - ! Updates the height of the particle - !************************************** +#include "par_set_z_dp.f90" - integer, intent(in) :: ipart ! particle index - real, intent(in) :: zvalue +#include "par_set_z_sp.f90" - part(ipart)%zeta = real(zvalue,kind=dp) - part(ipart)%etaupdate=.false. - part(ipart)%meterupdate=.true. +#include "par_set_zeta_dp.f90" - end subroutine set_zeta_sp +#include "par_set_zeta_sp.f90" ! End update z positions end module particle_mod diff --git a/src/plu_centerofmass.f90 b/src/plu_centerofmass.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f674f34440ee15c5b13e04126045191f1f52b7c7 --- /dev/null +++ b/src/plu_centerofmass.f90 @@ -0,0 +1,70 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine centerofmass(xl,yl,n,xcenter,ycenter) + ! i i i o o + !***************************************************************************** + ! * + ! 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 * + ! * + !***************************************************************************** + + 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 + !******************************************************* + + xll=xl(l)*pi180 + yll=yl(l)*pi180 + + ! Calculate 3D coordinates from longitude and latitude + !***************************************************** + + 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 + end do + + xav=xav/real(n) + yav=yav/real(n) + zav=zav/real(n) + + + ! Project the point back onto Earth's surface + !******************************************** + + xcenter=atan2(xav,-1.*yav) + ycenter=atan2(zav,sqrt(xav*xav+yav*yav)) + + ! Convert back to degrees + !************************ + + xcenter=xcenter/pi180 + ycenter=ycenter/pi180 +end subroutine centerofmass diff --git a/src/plu_clustering.f90 b/src/plu_clustering.f90 new file mode 100644 index 0000000000000000000000000000000000000000..74e9a0c0a1e9840a471e0978649321e1fb1dcda5 --- /dev/null +++ b/src/plu_clustering.f90 @@ -0,0 +1,191 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine clustering(n,xclust,yclust,zclust,fclust,rms, & + rmsclust,zrms) + ! i i i i o o o o o + ! o o + !***************************************************************************** + ! * + ! 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 * + ! * + ! 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 + use particle_mod + + implicit none + + integer :: n,i,j,l,numb(ncluster),ncl + real :: xclust(ncluster),yclust(ncluster),x,y,z + real :: zclust(ncluster),distances,distancemin,rms,rmsold + real :: xav(ncluster),yav(ncluster),zav(ncluster),fclust(ncluster) + real :: rmsclust(ncluster) + real :: zdist,zrms + + + + if (n.lt.ncluster) return + rmsold=-5. + + ! Convert longitude and latitude from degrees to radians + !******************************************************* + + do i=1,n + nclust(i)=i + xplum(i)=xplum(i)*pi180 + yplum(i)=yplum(i)*pi180 + end do + + + ! Generate a seed for each cluster + !********************************* + + do j=1,ncluster + zclust(j)=0. + xclust(j)=xplum(j*n/ncluster) + yclust(j)=yplum(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 + distances=distance2(yplum(i),xplum(i),yclust(j),xclust(j)) + 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 + distances=distance2(yplum(i),xplum(i), & + yclust(nclust(i)),xclust(nclust(i))) + + ! 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 + !*************************************************************** + + x = cos(yplum(i))*sin(xplum(i)) + y = -1.*cos(yplum(i))*cos(xplum(i)) + z = sin(yplum(i)) + xav(nclust(i))=xav(nclust(i))+x + yav(nclust(i))=yav(nclust(i))+y + zav(nclust(i))=zav(nclust(i))+z + 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 + !******************************************** + + xclust(j)=atan2(xav(j),-1.*yav(j)) + yclust(j)=atan2(zav(j),sqrt(xav(j)*xav(j)+yav(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)) exit + rmsold=rms + + end do + + ! Convert longitude and latitude from radians to degrees + !******************************************************* + + do i=1,n + xplum(i)=xplum(i)/pi180 + yplum(i)=yplum(i)/pi180 + zclust(nclust(i))=zclust(nclust(i))+zplum(i) + end do + + do j=1,ncluster + 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=zplum(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/plu_distance.f90 b/src/plu_distance.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5b552109647abce12a42a536bd65df1563399bdd --- /dev/null +++ b/src/plu_distance.f90 @@ -0,0 +1,55 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function distance(rlat1,rlon1,rlat2,rlon2) + + !$$$ SUBPROGRAM DOCUMENTATION BLOCK + ! + ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE + ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10 + ! + ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE + ! BETWEEN TWO POINTS ON THE EARTH. + ! + ! PROGRAM HISTORY LOG: + ! 96-04-10 IREDELL + ! + ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2) + ! + ! INPUT ARGUMENT LIST: + !rlat1 - REAL LATITUDE OF POINT 1 IN DEGREES + !rlon1 - REAL LONGITUDE OF POINT 1 IN DEGREES + !rlat2 - REAL LATITUDE OF POINT 2 IN DEGREES + !rlon2 - REAL LONGITUDE OF POINT 2 IN DEGREES + ! + ! OUTPUT ARGUMENT LIST: + !distance - REAL GREAT CIRCLE DISTANCE IN KILOMETERS + ! + ! ATTRIBUTES: + ! LANGUAGE: Fortran 90 + ! + !$$$ + + use par_mod, only: dp + + implicit none + + real :: rlat1,rlon1,rlat2,rlon2 + real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd + real(kind=dp),parameter :: rerth=6.3712e6_dp + real(kind=dp),parameter :: pi=3.14159265358979_dp, dpr=180.0_dp/pi + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + if ((abs(rlat1-rlat2).lt.0.03).and. & + (abs(rlon1-rlon2).lt.0.03)) then + distance=0. + else + clat1=cos(real(rlat1,kind=dp)/dpr) + slat1=sin(real(rlat1,kind=dp)/dpr) + clat2=cos(real(rlat2,kind=dp)/dpr) + slat2=sin(real(rlat2,kind=dp)/dpr) + cdlon=cos(real((rlon1-rlon2),kind=dp)/dpr) + crd=slat1*slat2+clat1*clat2*cdlon + distance=real(rerth*acos(crd)/1000.0_dp) + endif + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +end function distance diff --git a/src/plu_distance2.f90 b/src/plu_distance2.f90 new file mode 100644 index 0000000000000000000000000000000000000000..91bdca933c008ffc6dc0b43865ebad2a2945a60a --- /dev/null +++ b/src/plu_distance2.f90 @@ -0,0 +1,57 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function distance2(rlat1,rlon1,rlat2,rlon2) + + !$$$ SUBPROGRAM DOCUMENTATION BLOCK + ! + ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE + ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10 + ! + ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE + ! BETWEEN TWO POINTS ON THE EARTH. COORDINATES ARE GIVEN IN RADIANS! + ! + ! PROGRAM HISTORY LOG: + ! 96-04-10 IREDELL + ! + ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2) + ! + ! INPUT ARGUMENT LIST: + !rlat1 - REAL LATITUDE OF POINT 1 IN RADIANS + !rlon1 - REAL LONGITUDE OF POINT 1 IN RADIANS + !rlat2 - REAL LATITUDE OF POINT 2 IN RADIANS + !rlon2 - REAL LONGITUDE OF POINT 2 IN RADIANS + ! + ! OUTPUT ARGUMENT LIST: + !distance2 - REAL GREAT CIRCLE DISTANCE IN KM + ! + ! ATTRIBUTES: + ! LANGUAGE: Fortran 90 + ! + !$$$ + + use par_mod, only: dp + + implicit none + + real :: rlat1,rlon1,rlat2,rlon2 + real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd + real(kind=dp),parameter :: rerth=6.3712e6_dp + real(kind=dp),parameter :: pi=3.14159265358979_dp + + if ((abs(rlat1-rlat2).lt.0.0003).and. & + (abs(rlon1-rlon2).lt.0.0003)) then + distance2=0.0_dp + else + + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + clat1=cos(real(rlat1,kind=dp)) + slat1=sin(real(rlat1,kind=dp)) + clat2=cos(real(rlat2,kind=dp)) + slat2=sin(real(rlat2,kind=dp)) + cdlon=cos(real(rlon1-rlon2,kind=dp)) + crd=slat1*slat2+clat1*clat2*cdlon + distance2=real(rerth*acos(crd)/1000.0_dp) + endif + ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +end function distance2 diff --git a/src/plu_openouttraj.f90 b/src/plu_openouttraj.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fef0d6f647dc0ef5fcd9ab4f5075c98808bbbfe2 --- /dev/null +++ b/src/plu_openouttraj.f90 @@ -0,0 +1,67 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine openouttraj + + !***************************************************************************** + ! * + ! This routine opens the output file for the plume trajectory output * + ! produced by the cluster analysis. * + ! * + ! Author: A. Stohl * + ! * + ! 27 January 2001 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + !***************************************************************************** + + use point_mod + use par_mod + use com_mod + + implicit none + + integer :: i + real :: xp1,yp1,xp2,yp2 + + + ! Open output file for trajectory output + !*************************************** + + open(unitouttraj,file=path(2)(1:length(2))//'trajectories.txt', & + form='formatted',err=998) + + if (ldirect.eq.1) then + write(unitouttraj,'(i8,1x,i6,1x,a)') ibdate,ibtime, trim(flexversion) + else + write(unitouttraj,'(i8,1x,i6,1x,a)') iedate,ietime, trim(flexversion) + endif + write(unitouttraj,*) method,lsubgrid,lconvection + write(unitouttraj,*) numpoint + do i=1,numpoint + xp1=xpoint1(i)*dx+xlon0 + yp1=ypoint1(i)*dy+ylat0 + xp2=xpoint2(i)*dx+xlon0 + yp2=ypoint2(i)*dy+ylat0 + write(unitouttraj,*) ireleasestart(i),ireleaseend(i), & + xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i),kindz(i),npart(i) + if (numpoint.le.1000) then + write(unitouttraj,'(a)') compoint(i)(1:40) + else + write(unitouttraj,'(a)') compoint(1001)(1:40) + endif + end do + + 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/plu_plumetraj.f90 b/src/plu_plumetraj.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d8501545a15b23eeb187553c978f655fc93ac2fa --- /dev/null +++ b/src/plu_plumetraj.f90 @@ -0,0 +1,241 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine plumetraj(itime) + ! i + !***************************************************************************** + ! * + ! 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 * + ! * + ! 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 + use mean_mod + use particle_mod + use coord_ec_mod + use windfields_mod + + implicit none + + integer :: itime,ix,jy,ixp,jyp,indexh,i,j,k,m,n,il,ind,indz,indzp + ! real :: xl(maxpart),yl(maxpart),zl(maxpart) ! moved to particle_mod and now xplum,yplum,zplum + real :: xcenter,ycenter,zcenter,dist,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 + + + 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)) cycle + 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 (.not.part(i)%alive) cycle + if (part(i)%npoint.ne.j) cycle + n=n+1 + xplum(n)=xlon0+part(i)%xlon*dx + yplum(n)=ylat0+part(i)%ylat*dy + call update_zeta_to_z(itime,i) + zplum(n)=part(i)%z + + ! 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(part(i)%xlon) + jy=int(part(i)%ylat) + ixp=ix+1 + jyp=jy+1 + + ! eso: Temporary fix for particle exactly at north pole + if (jyp >= nymax) then + write(*,*) 'WARNING: plume_mod.f90 jyp >= nymax. xt,yt:',part(i)%xlon,part(i)%ylat + jyp=jyp-1 + end if + + if (ixp >= nxmax) then + write(*,*) 'WARNING: plume_mod.f90 ixp >= nxmax. xt,yt:',part(i)%xlon,part(i)%ylat + ixp=ixp-nxmax + end if + + ddx=part(i)%xlon-real(ix) + ddy=part(i)%ylat-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.zplum(n)) then + indz=il-1 + indzp=il + exit + endif + end do + + dz1=zplum(n)-height(indz) + dz2=height(indzp)-zplum(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 (yplum(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 (zplum(n).lt.tri) tropofract=tropofract+1. + tropocenter=tropocenter+tri+topo + if (zplum(n).lt.hmixi) hmixfract=hmixfract+1. + zplum(n)=zplum(n)+topo ! convert to height asl + hmixcenter=hmixcenter+hmixi + + 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(n,xclust,yclust,zclust,fclust,rms, & + rmsclust,zrms) + + + ! Determine center of mass position on earth and average height + !************************************************************** + + call centerofmass(xplum,yplum,n,xcenter,ycenter) + call mean(zplum,zcenter,zrmsdist,n) + + ! Root mean square distance from center of mass + !********************************************** + + do k=1,n + dist=distance(yplum(k),xplum(k),ycenter,xcenter) + rmsdist=rmsdist+dist*dist + end do + if (rmsdist.gt.0.) rmsdist=sqrt(rmsdist/real(n)) + rmsdist=max(rmsdist,0.) + + ! Write out results in trajectory data file + !****************************************** + + write(unitouttraj,'(i5,i8,2f9.4,4f8.1,f8.2,4f8.1,3f6.1,& + &5(2f8.3,f7.0,f6.1,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 + + end do +end subroutine plumetraj diff --git a/src/plume_mod.f90 b/src/plume_mod.f90 index 66edd907136f2b2ded8823afa174ecf362080088..e63f7c29cbf9bc128201de747d5d16b7a6b834f0 100644 --- a/src/plume_mod.f90 +++ b/src/plume_mod.f90 @@ -8,680 +8,23 @@ ! * !***************************************************************************** module plume_mod - + implicit none private :: centerofmass,clustering,distance,distance2 public :: plumetraj,openouttraj contains -subroutine plumetraj(itime) - ! i - !***************************************************************************** - ! * - ! 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 * - ! * - ! 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 - use mean_mod - use particle_mod - use coord_ec_mod - use windfields_mod - - implicit none - - integer :: itime,ix,jy,ixp,jyp,indexh,i,j,k,m,n,il,ind,indz,indzp - ! real :: xl(maxpart),yl(maxpart),zl(maxpart) ! moved to particle_mod and now xplum,yplum,zplum - real :: xcenter,ycenter,zcenter,dist,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 - - - 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)) cycle - 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 (.not.part(i)%alive) cycle - if (part(i)%npoint.ne.j) cycle - n=n+1 - xplum(n)=xlon0+part(i)%xlon*dx - yplum(n)=ylat0+part(i)%ylat*dy - call update_zeta_to_z(itime,i) - zplum(n)=part(i)%z - - ! 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(part(i)%xlon) - jy=int(part(i)%ylat) - ixp=ix+1 - jyp=jy+1 - - ! eso: Temporary fix for particle exactly at north pole - if (jyp >= nymax) then - write(*,*) 'WARNING: plume_mod.f90 jyp >= nymax. xt,yt:',part(i)%xlon,part(i)%ylat - jyp=jyp-1 - end if - - if (ixp >= nxmax) then - write(*,*) 'WARNING: plume_mod.f90 ixp >= nxmax. xt,yt:',part(i)%xlon,part(i)%ylat - ixp=ixp-nxmax - end if - - ddx=part(i)%xlon-real(ix) - ddy=part(i)%ylat-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.zplum(n)) then - indz=il-1 - indzp=il - exit - endif - end do - - dz1=zplum(n)-height(indz) - dz2=height(indzp)-zplum(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 (yplum(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 (zplum(n).lt.tri) tropofract=tropofract+1. - tropocenter=tropocenter+tri+topo - if (zplum(n).lt.hmixi) hmixfract=hmixfract+1. - zplum(n)=zplum(n)+topo ! convert to height asl - hmixcenter=hmixcenter+hmixi - - 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(n,xclust,yclust,zclust,fclust,rms, & - rmsclust,zrms) - - - ! Determine center of mass position on earth and average height - !************************************************************** - - call centerofmass(xplum,yplum,n,xcenter,ycenter) - call mean(zplum,zcenter,zrmsdist,n) - - ! Root mean square distance from center of mass - !********************************************** - - do k=1,n - dist=distance(yplum(k),xplum(k),ycenter,xcenter) - rmsdist=rmsdist+dist*dist - end do - if (rmsdist.gt.0.) rmsdist=sqrt(rmsdist/real(n)) - rmsdist=max(rmsdist,0.) - - ! Write out results in trajectory data file - !****************************************** - - write(unitouttraj,'(i5,i8,2f9.4,4f8.1,f8.2,4f8.1,3f6.1,& - &5(2f8.3,f7.0,f6.1,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 - - end do -end subroutine plumetraj - -subroutine centerofmass(xl,yl,n,xcenter,ycenter) - ! i i i o o - !***************************************************************************** - ! * - ! 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 * - ! * - !***************************************************************************** - - 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 - !******************************************************* - - xll=xl(l)*pi180 - yll=yl(l)*pi180 - - ! Calculate 3D coordinates from longitude and latitude - !***************************************************** - - 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 - end do - - xav=xav/real(n) - yav=yav/real(n) - zav=zav/real(n) - - - ! Project the point back onto Earth's surface - !******************************************** - - xcenter=atan2(xav,-1.*yav) - ycenter=atan2(zav,sqrt(xav*xav+yav*yav)) - - ! Convert back to degrees - !************************ - - xcenter=xcenter/pi180 - ycenter=ycenter/pi180 -end subroutine centerofmass - -subroutine clustering(n,xclust,yclust,zclust,fclust,rms, & - rmsclust,zrms) - ! i i i i o o o o o - ! o o - !***************************************************************************** - ! * - ! 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 * - ! * - ! 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 - use particle_mod - - implicit none - - integer :: n,i,j,l,numb(ncluster),ncl - real :: xclust(ncluster),yclust(ncluster),x,y,z - real :: zclust(ncluster),distances,distancemin,rms,rmsold - real :: xav(ncluster),yav(ncluster),zav(ncluster),fclust(ncluster) - real :: rmsclust(ncluster) - real :: zdist,zrms - - - - if (n.lt.ncluster) return - rmsold=-5. - - ! Convert longitude and latitude from degrees to radians - !******************************************************* - - do i=1,n - nclust(i)=i - xplum(i)=xplum(i)*pi180 - yplum(i)=yplum(i)*pi180 - end do - - - ! Generate a seed for each cluster - !********************************* - - do j=1,ncluster - zclust(j)=0. - xclust(j)=xplum(j*n/ncluster) - yclust(j)=yplum(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 - distances=distance2(yplum(i),xplum(i),yclust(j),xclust(j)) - 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 - distances=distance2(yplum(i),xplum(i), & - yclust(nclust(i)),xclust(nclust(i))) - - ! 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 - !*************************************************************** - - x = cos(yplum(i))*sin(xplum(i)) - y = -1.*cos(yplum(i))*cos(xplum(i)) - z = sin(yplum(i)) - xav(nclust(i))=xav(nclust(i))+x - yav(nclust(i))=yav(nclust(i))+y - zav(nclust(i))=zav(nclust(i))+z - 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 - !******************************************** - - xclust(j)=atan2(xav(j),-1.*yav(j)) - yclust(j)=atan2(zav(j),sqrt(xav(j)*xav(j)+yav(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)) exit - rmsold=rms - - end do - - ! Convert longitude and latitude from radians to degrees - !******************************************************* - - do i=1,n - xplum(i)=xplum(i)/pi180 - yplum(i)=yplum(i)/pi180 - zclust(nclust(i))=zclust(nclust(i))+zplum(i) - end do - - do j=1,ncluster - 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=zplum(i)-zclust(nclust(i)) - zrms=zrms+zdist*zdist - end do - if (zrms.gt.0.) zrms=sqrt(zrms/real(n)) - -end subroutine clustering - -real function distance(rlat1,rlon1,rlat2,rlon2) - - !$$$ SUBPROGRAM DOCUMENTATION BLOCK - ! - ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE - ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10 - ! - ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE - ! BETWEEN TWO POINTS ON THE EARTH. - ! - ! PROGRAM HISTORY LOG: - ! 96-04-10 IREDELL - ! - ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2) - ! - ! INPUT ARGUMENT LIST: - !rlat1 - REAL LATITUDE OF POINT 1 IN DEGREES - !rlon1 - REAL LONGITUDE OF POINT 1 IN DEGREES - !rlat2 - REAL LATITUDE OF POINT 2 IN DEGREES - !rlon2 - REAL LONGITUDE OF POINT 2 IN DEGREES - ! - ! OUTPUT ARGUMENT LIST: - !distance - REAL GREAT CIRCLE DISTANCE IN KILOMETERS - ! - ! ATTRIBUTES: - ! LANGUAGE: Fortran 90 - ! - !$$$ - - use par_mod, only: dp - - implicit none - - real :: rlat1,rlon1,rlat2,rlon2 - real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd - real(kind=dp),parameter :: rerth=6.3712e6_dp - real(kind=dp),parameter :: pi=3.14159265358979_dp, dpr=180.0_dp/pi - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - if ((abs(rlat1-rlat2).lt.0.03).and. & - (abs(rlon1-rlon2).lt.0.03)) then - distance=0. - else - clat1=cos(real(rlat1,kind=dp)/dpr) - slat1=sin(real(rlat1,kind=dp)/dpr) - clat2=cos(real(rlat2,kind=dp)/dpr) - slat2=sin(real(rlat2,kind=dp)/dpr) - cdlon=cos(real((rlon1-rlon2),kind=dp)/dpr) - crd=slat1*slat2+clat1*clat2*cdlon - distance=real(rerth*acos(crd)/1000.0_dp) - endif - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -end function distance - -real function distance2(rlat1,rlon1,rlat2,rlon2) - - !$$$ SUBPROGRAM DOCUMENTATION BLOCK - ! - ! SUBPROGRAM: GCDIST COMPUTE GREAT CIRCLE DISTANCE - ! PRGMMR: IREDELL ORG: W/NMC23 DATE: 96-04-10 - ! - ! ABSTRACT: THIS SUBPROGRAM COMPUTES GREAT CIRCLE DISTANCE - ! BETWEEN TWO POINTS ON THE EARTH. COORDINATES ARE GIVEN IN RADIANS! - ! - ! PROGRAM HISTORY LOG: - ! 96-04-10 IREDELL - ! - ! USAGE: ...GCDIST(RLAT1,RLON1,RLAT2,RLON2) - ! - ! INPUT ARGUMENT LIST: - !rlat1 - REAL LATITUDE OF POINT 1 IN RADIANS - !rlon1 - REAL LONGITUDE OF POINT 1 IN RADIANS - !rlat2 - REAL LATITUDE OF POINT 2 IN RADIANS - !rlon2 - REAL LONGITUDE OF POINT 2 IN RADIANS - ! - ! OUTPUT ARGUMENT LIST: - !distance2 - REAL GREAT CIRCLE DISTANCE IN KM - ! - ! ATTRIBUTES: - ! LANGUAGE: Fortran 90 - ! - !$$$ - - use par_mod, only: dp - - implicit none - - real :: rlat1,rlon1,rlat2,rlon2 - real(kind=dp) :: clat1,clat2,slat1,slat2,cdlon,crd - real(kind=dp),parameter :: rerth=6.3712e6_dp - real(kind=dp),parameter :: pi=3.14159265358979_dp - - if ((abs(rlat1-rlat2).lt.0.0003).and. & - (abs(rlon1-rlon2).lt.0.0003)) then - distance2=0.0_dp - else - - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - clat1=cos(real(rlat1,kind=dp)) - slat1=sin(real(rlat1,kind=dp)) - clat2=cos(real(rlat2,kind=dp)) - slat2=sin(real(rlat2,kind=dp)) - cdlon=cos(real(rlon1-rlon2,kind=dp)) - crd=slat1*slat2+clat1*clat2*cdlon - distance2=real(rerth*acos(crd)/1000.0_dp) - endif - ! - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -end function distance2 - -subroutine openouttraj - - !***************************************************************************** - ! * - ! This routine opens the output file for the plume trajectory output * - ! produced by the cluster analysis. * - ! * - ! Author: A. Stohl * - ! * - ! 27 January 2001 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - !***************************************************************************** - - use point_mod - use par_mod - use com_mod - - implicit none - - integer :: i - real :: xp1,yp1,xp2,yp2 - - - ! Open output file for trajectory output - !*************************************** +#include "plu_plumetraj.f90" - open(unitouttraj,file=path(2)(1:length(2))//'trajectories.txt', & - form='formatted',err=998) +#include "plu_centerofmass.f90" - if (ldirect.eq.1) then - write(unitouttraj,'(i8,1x,i6,1x,a)') ibdate,ibtime, trim(flexversion) - else - write(unitouttraj,'(i8,1x,i6,1x,a)') iedate,ietime, trim(flexversion) - endif - write(unitouttraj,*) method,lsubgrid,lconvection - write(unitouttraj,*) numpoint - do i=1,numpoint - xp1=xpoint1(i)*dx+xlon0 - yp1=ypoint1(i)*dy+ylat0 - xp2=xpoint2(i)*dx+xlon0 - yp2=ypoint2(i)*dy+ylat0 - write(unitouttraj,*) ireleasestart(i),ireleaseend(i), & - xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i),kindz(i),npart(i) - if (numpoint.le.1000) then - write(unitouttraj,'(a)') compoint(i)(1:40) - else - write(unitouttraj,'(a)') compoint(1001)(1:40) - endif - end do +#include "plu_clustering.f90" - return +#include "plu_distance.f90" -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 +#include "plu_distance2.f90" -end subroutine openouttraj +#include "plu_openouttraj.f90" -end module plume_mod \ No newline at end of file +end module plume_mod diff --git a/src/poi_coordtrafo.f90 b/src/poi_coordtrafo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e43ff9e6488d1e73431ce55c52388cd468155742 --- /dev/null +++ b/src/poi_coordtrafo.f90 @@ -0,0 +1,106 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine coordtrafo(nxmin1,nymin1) + + !********************************************************************** + ! * + ! FLEXPART MODEL SUBROUTINE COORDTRAFO * + ! * + !********************************************************************** + ! * + ! AUTHOR: G. WOTAWA * + ! DATE: 1994-02-07 * + ! LAST UPDATE: 1996-05-18 A. STOHL * + ! * + !********************************************************************** + ! * + ! DESCRIPTION: This subroutine transforms x and y coordinates of * + ! particle release points to grid coordinates. * + ! * + !********************************************************************** + + use par_mod + use com_mod + + implicit none + integer,intent(in) :: & + nxmin1, & ! nx-1 + nymin1 ! ny-1 + integer :: i,j,k + real :: yrspc ! small real number relative to x + + if((ipin.eq.3).or.(ipin.eq.4)) return ! Not necessary when using part_ic.nc + + if(numpoint.eq.0) then + write(*,*) ' FLEXPART MODEL SUBROUTINE COORDTRAFO: ERROR ! ' + write(*,*) ' NO PARTICLE RELEASES ARE DEFINED!' + write(*,*) ' CHECK FILE RELEASES...' + stop + endif + + ! TRANSFORM X- AND Y- COORDINATES OF STARTING POINTS TO GRID COORDINATES + !*********************************************************************** + + do i=1,numpoint + xpoint1(i)=(xpoint1(i)-xlon0)/dx + xpoint2(i)=(xpoint2(i)-xlon0)/dx + ypoint1(i)=(ypoint1(i)-ylat0)/dy + ypoint2(i)=(ypoint2(i)-ylat0)/dy + end do + +15 continue + + + ! CHECK IF RELEASE POINTS ARE WITHIN DOMAIN + !****************************************** + + yrspc = spacing(real(nymin1,kind=sp)) + + do i=1,numpoint + if (sglobal.and.(ypoint1(i).lt.1.e-6)) ypoint1(i)=1.e-6 + if (nglobal.and.(ypoint2(i).gt.real(nymin1,kind=dp)-1.e-5)) & + ypoint2(i)=real(nymin1,kind=dp)-10*yrspc + if ((ypoint1(i).lt.1.e-6).or.(ypoint1(i).ge.real(nymin1,kind=dp)-1.e-6) & + .or.(ypoint2(i).lt.1.e-6).or.(ypoint2(i).ge.real(nymin1,kind=dp)-yrspc) & + .or.((.not.xglobal).and.((xpoint1(i).lt.1.e-6).or. & + (xpoint1(i).ge.real(nxmin1,kind=dp)-1.e-6).or.(xpoint2(i).lt.1.e-6).or. & + (xpoint2(i).ge.real(nxmin1,kind=dp)-1.e-6)))) then + write(*,*) ' NOTICE: RELEASE POINT OUT OF DOMAIN DETECTED.' + write(*,*) ' IT IS REMOVED NOW ... ' + if (i.le.1000) then + write(*,*) ' COMMENT: ',compoint(i) + else + write(*,*) ' COMMENT: ',compoint(1001) + endif + 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.1000) compoint(j-1)=compoint(j) + do k=1,nspec + xmass(j-1,k)=xmass(j,k) + end do + end do + endif + + numpoint=numpoint-1 + if (numpoint.gt.0) goto 15 + endif + end do + + 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/point_mod.f90 b/src/point_mod.f90 index 764981c6a8c5815adbeda301b547e44a00392a82..9bff1e2b99301ac384596a2c3257341ce5259adf 100644 --- a/src/point_mod.f90 +++ b/src/point_mod.f90 @@ -28,108 +28,6 @@ module point_mod contains -subroutine coordtrafo(nxmin1,nymin1) - - !********************************************************************** - ! * - ! FLEXPART MODEL SUBROUTINE COORDTRAFO * - ! * - !********************************************************************** - ! * - ! AUTHOR: G. WOTAWA * - ! DATE: 1994-02-07 * - ! LAST UPDATE: 1996-05-18 A. STOHL * - ! * - !********************************************************************** - ! * - ! DESCRIPTION: This subroutine transforms x and y coordinates of * - ! particle release points to grid coordinates. * - ! * - !********************************************************************** - - use par_mod - use com_mod - - implicit none - integer,intent(in) :: & - nxmin1, & ! nx-1 - nymin1 ! ny-1 - integer :: i,j,k - real :: yrspc ! small real number relative to x - - if((ipin.eq.3).or.(ipin.eq.4)) return ! Not necessary when using part_ic.nc - - if(numpoint.eq.0) then - write(*,*) ' FLEXPART MODEL SUBROUTINE COORDTRAFO: ERROR ! ' - write(*,*) ' NO PARTICLE RELEASES ARE DEFINED!' - write(*,*) ' CHECK FILE RELEASES...' - stop - endif - - ! TRANSFORM X- AND Y- COORDINATES OF STARTING POINTS TO GRID COORDINATES - !*********************************************************************** - - do i=1,numpoint - xpoint1(i)=(xpoint1(i)-xlon0)/dx - xpoint2(i)=(xpoint2(i)-xlon0)/dx - ypoint1(i)=(ypoint1(i)-ylat0)/dy - ypoint2(i)=(ypoint2(i)-ylat0)/dy - end do - -15 continue - - - ! CHECK IF RELEASE POINTS ARE WITHIN DOMAIN - !****************************************** - - yrspc = spacing(real(nymin1,kind=sp)) - - do i=1,numpoint - if (sglobal.and.(ypoint1(i).lt.1.e-6)) ypoint1(i)=1.e-6 - if (nglobal.and.(ypoint2(i).gt.real(nymin1,kind=dp)-1.e-5)) & - ypoint2(i)=real(nymin1,kind=dp)-10*yrspc - if ((ypoint1(i).lt.1.e-6).or.(ypoint1(i).ge.real(nymin1,kind=dp)-1.e-6) & - .or.(ypoint2(i).lt.1.e-6).or.(ypoint2(i).ge.real(nymin1,kind=dp)-yrspc) & - .or.((.not.xglobal).and.((xpoint1(i).lt.1.e-6).or. & - (xpoint1(i).ge.real(nxmin1,kind=dp)-1.e-6).or.(xpoint2(i).lt.1.e-6).or. & - (xpoint2(i).ge.real(nxmin1,kind=dp)-1.e-6)))) then - write(*,*) ' NOTICE: RELEASE POINT OUT OF DOMAIN DETECTED.' - write(*,*) ' IT IS REMOVED NOW ... ' - if (i.le.1000) then - write(*,*) ' COMMENT: ',compoint(i) - else - write(*,*) ' COMMENT: ',compoint(1001) - endif - 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.1000) compoint(j-1)=compoint(j) - do k=1,nspec - xmass(j-1,k)=xmass(j,k) - end do - end do - endif - - numpoint=numpoint-1 - if (numpoint.gt.0) goto 15 - endif - end do - - 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 +#include "poi_coordtrafo.f90" end module point_mod diff --git a/src/pre_initcond_calc.f90 b/src/pre_initcond_calc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8b8a8d3c8405fe3552b11de29336efff1049a163 --- /dev/null +++ b/src/pre_initcond_calc.f90 @@ -0,0 +1,194 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine initcond_calc(itime,i,thread) + ! i i + !***************************************************************************** + ! * + ! Calculation of the sensitivity to initial conditions for BW runs * + ! * + ! Author: A. Stohl * + ! * + ! 15 January 2010 * + ! * + ! Changes * + ! 2022 L. Bakels: OpenMP parallelisation * + !***************************************************************************** + + use interpol_mod, only: interpol_density,ix,jy,ixp,jyp + use coord_ec_mod + use particle_mod + + integer, intent(in) :: itime,i,thread + integer :: 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 + integer :: mind2 + ! mind2 eso: pointer to 2nd windfield in memory + + + ! For forward simulations, make a loop over the number of species; + ! for backward simulations, make an additional loop over the release points + !************************************************************************** + + + if (.not. part(i)%alive) 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 + call update_zeta_to_z(itime,i) + call interpol_density(itime,i,rhoi) + 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=part(i)%npoint + endif + + do kz=1,numzgrid ! determine height of cell + if (real(outheight(kz),kind=dp).gt.part(i)%z) exit + end do + + if (kz.le.numzgrid) then ! inside output domain + + + xl=(part(i)%xlon*dx+xoutshift)/dxout + yl=(part(i)%ylat*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 +#ifdef _OPENMP + init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)= & + init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)+ & + part(i)%mass(ks)/rhoi +#else + init_cond(ix,jy,kz,ks,nrelpointer)= & + init_cond(ix,jy,kz,ks,nrelpointer)+ & + part(i)%mass(ks)/rhoi +#endif + 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 +#ifdef _OPENMP + init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)= & + init_cond_omp(ix,jy,kz,ks,nrelpointer,thread) + & + part(i)%mass(ks) / rhoi * w +#else + init_cond(ix,jy,kz,ks,nrelpointer)= & + init_cond(ix,jy,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w +#endif + end do + endif + + if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then + w=wx*(1.-wy) + do ks=1,nspec +#ifdef _OPENMP + init_cond_omp(ix,jyp,kz,ks,nrelpointer,thread)= & + init_cond_omp(ix,jyp,kz,ks,nrelpointer,thread) + & + part(i)%mass(ks) / rhoi * w +#else + init_cond(ix,jyp,kz,ks,nrelpointer)= & + init_cond(ix,jyp,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w +#endif + 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 +#ifdef _OPENMP + init_cond_omp(ixp,jyp,kz,ks,nrelpointer,thread)= & + init_cond_omp(ixp,jyp,kz,ks,nrelpointer,thread) + & + part(i)%mass(ks) / rhoi * w +#else + init_cond(ixp,jyp,kz,ks,nrelpointer)= & + init_cond(ixp,jyp,kz,ks,nrelpointer) + & + part(i)%mass(ks) / rhoi * w +#endif + end do + endif + + if ((jy.ge.0).and.(jy.le.numygrid-1)) then + w=(1.-wx)*wy + do ks=1,nspec +#ifdef _OPENMP + init_cond_omp(ixp,jy,kz,ks,nrelpointer,thread)= & + init_cond_omp(ixp,jy,kz,ks,nrelpointer,thread) + & + part(i)%mass(ks) / rhoi * w +#else + init_cond(ixp,jy,kz,ks,nrelpointer)= & + init_cond(ixp,jy,kz,ks,nrelpointer) + & + part(i)%mass(ks) / rhoi * w +#endif + end do + endif + endif + endif + + endif + +end subroutine initcond_calc diff --git a/src/pre_outgrid_init.f90 b/src/pre_outgrid_init.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f9122e39edae56a86bc6b8db1221bdf7ad8b94e5 --- /dev/null +++ b/src/pre_outgrid_init.f90 @@ -0,0 +1,374 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine outgrid_init + ! + !***************************************************************************** + ! * + ! This routine initializes the output grids * + ! * + ! Author: A. Stohl * + ! * + ! 7 August 2002 * + ! * + ! Changes * + ! 2022 L. Bakels: OpenMP parallelisation * + !***************************************************************************** + ! * + ! 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 ohr_mod + use unc_mod + + integer :: ix,jy,kz,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid + integer :: ks,kp,stat + real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp + real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh + real :: eps + + 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+(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 + + ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360, + ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90 + !************************************************************ + + cosfactp=cos(ylatp*pi180) + cosfactm=cos(ylatm*pi180) + if (cosfactp.lt.cosfactm) then + hzone=sqrt(1-cosfactp**2)- & + sqrt(1-cosfactm**2) + hzone=hzone*r_earth + else + hzone=sqrt(1-cosfactm**2)- & + sqrt(1-cosfactp**2) + hzone=hzone*r_earth + endif + endif + + ! Surface are of a grid cell at a latitude ylat + !********************************************** + + gridarea=2.*pi*r_earth*hzone*dxout/360. + + do ix=0,numxgrid-1 + area(ix,jy)=gridarea + + ! Volume = area x box height + !*************************** + + volume(ix,jy,1)=area(ix,jy)*outheight(1) + areaeast(ix,jy,1)=dyout*r_earth*pi180*outheight(1) + areanorth(ix,jy,1)=cos(ylat*pi180)*dxout*r_earth*pi180* & + 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)) + 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 + ylat=outlat0+(real(jjy)+real(j1)/10.-0.05)*dyout + yl=(ylat-ylat0)/dy + do i1=1,10 + xlon=outlon0+(real(iix)+real(i1)/10.-0.05)*dxout + xl=(xlon-xlon0)/dx + + ! Determine the nest we are in + !***************************** + + ngrid=0 + ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) + do j=numbnests,1,-1 + if ((xl.gt.xln(j)+dxn(j)).and.(xl.lt.xrn(j)-dxn(j)).and. & + (yl.gt.yln(j)+dyn(j)).and.(yl.lt.yrn(j)-dyn(j))) then + ngrid=j + exit + endif + end do + +! Determine (nested) grid coordinates & auxiliary parameters for interpolation +!***************************************************************************** + + if (ngrid.gt.0) then + xtn=(xl-xln(ngrid))*xresoln(ngrid) + ytn=(yl-yln(ngrid))*yresoln(ngrid) + ix=max(min(nint(xtn),nxn(ngrid)-1),0) + jy=max(min(nint(ytn),nyn(ngrid)-1),0) + ! 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 ' +#ifdef _OPENMP + allocate(flux_omp(6,0:numxgrid-1,0:numygrid-1,numzgrid, & + 1:nspec,1:maxpointspec_act,1:nageclass,numthreads)) + if (stat.ne.0) write(*,*)'ERROR: could not allocate flux_omp array ' +#endif + 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' +#ifdef _OPENMP + allocate(gridunc_omp(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, & + maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) + if (stat.ne.0) then + write(*,*)'ERROR: could not allocate gridunc_omp' + write(*,*)'increase the memory or reduce max_numthreads_grid in par_mod.f90.' + stop + endif +#endif + 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 wetgridunc' + allocate(drygridunc(0:numxgrid-1,0:numygrid-1,maxspec, & + maxpointspec_act,nclassunc,maxageclass),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate drygridunc' +#ifdef _OPENMP + allocate(wetgridunc_omp(0:numxgrid-1,0:numygrid-1,maxspec, & + maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate wetgridunc_omp' + allocate(drygridunc_omp(0:numxgrid-1,0:numygrid-1,maxspec, & + maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate drygridunc_omp' +#endif + endif + +#ifdef USE_MPIINPLACE +#else +! Extra field for totals at MPI root process + if (lroot.and.mpi_mode.gt.0) then +! If MPI_IN_PLACE option is not used in mpi_mod.f90::mpif_tm_reduce_grid(), +! then an aux array is needed for parallel grid reduction + allocate(gridunc0(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, & + maxpointspec_act,nclassunc,maxageclass),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc0' + else if (.not.lroot.and.mpi_mode.gt.0) then + allocate(gridunc0(1,1,1,1,1,1,1),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc0' + end if +#endif + if (ldirect.gt.0) then + if (lroot.and.mpi_mode.gt.0) then + allocate(wetgridunc0(0:numxgrid-1,0:numygrid-1,maxspec, & + maxpointspec_act,nclassunc,maxageclass),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate wetgridunc0' + allocate(drygridunc0(0:numxgrid-1,0:numygrid-1,maxspec, & + maxpointspec_act,nclassunc,maxageclass),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate drygridunc0' + + ! allocate a dummy to avoid compilator complaints + else if (.not.lroot.and.mpi_mode.gt.0) then + allocate(wetgridunc0(1,1,1,1,1,1),stat=stat) + allocate(drygridunc0(1,1,1,1,1,1),stat=stat) + end if + end if + + !write (*,*) 'Dimensions for fields', numxgrid,numygrid, & + ! maxspec,maxpointspec_act,nclassunc,maxageclass + + if (lroot) then + write (*,*) 'Allocating fields for global output (x,y): ', & + numxgrid,numygrid + write (*,*) 'Allocating fields for nested output (x,y): ', & + numxgridn,numygridn + end if + + ! 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) + 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' + ! RLT + allocate(densitydrygrid(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1,numzgrid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc' + allocate(factor_drygrid(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_u(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) + if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc' + allocate(drygrid(0:max(numxgrid,numxgridn)-1, & + 0:max(numygrid,numygridn)-1),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' +#ifdef _OPENMP + allocate(init_cond_omp(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, & + maxpointspec_act,numthreads),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate init_cond_omp' +#endif + endif + + !************************ + ! Initialize output grids + !************************ + + do ks=1,nspec + do kp=1,maxpointspec_act + if (numreceptor.gt.0) then + do i=1,numreceptor + ! Receptor points + creceptor(i,ks)=0. + end do + endif + 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. +#ifdef _OPENMP + wetgridunc_omp(ix,jy,ks,kp,l,nage,:)=0. + drygridunc_omp(ix,jy,ks,kp,l,nage,:)=0. +#endif + 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. +#ifdef _OPENMP + flux_omp(i,ix,jy,kz,ks,kp,nage,:)=0. +#endif + end do + endif + ! Initial condition field + if ((l.eq.1).and.(nage.eq.1).and.(linit_cond.gt.0)) then + init_cond(ix,jy,kz,ks,kp)=0. +#ifdef _OPENMP + init_cond_omp(ix,jy,kz,ks,kp,:)=0. +#endif + endif + ! Concentration fields + gridunc(ix,jy,kz,ks,kp,l,nage)=0. +#ifdef _OPENMP + gridunc_omp(ix,jy,kz,ks,kp,l,nage,:)=0. +#endif + end do + end do + end do + end do + end do + end do + end do +end subroutine outgrid_init diff --git a/src/pre_outgrid_init_nest.f90 b/src/pre_outgrid_init_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..bbe43f59135447e97c8e8bd4fa04a596154aa05b --- /dev/null +++ b/src/pre_outgrid_init_nest.f90 @@ -0,0 +1,252 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine outgrid_init_nest + ! + !***************************************************************************** + ! * + ! This routine calculates, for each grid cell of the output nest, the * + ! volume and the surface area. * + ! * + ! Author: A. Stohl * + ! * + ! 30 August 2004 * + ! * + ! Changes * + ! 2022 L. Bakels: OpenMP parallelisation * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! arean surface area of all output nest cells * + ! volumen volumes of all output nest cells * + ! * + !***************************************************************************** + + use unc_mod + + integer :: ix,jy,kz,ks,kp,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid + integer :: stat + real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp + real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh + real :: eps + + eps=nxmax/3.e5 + + ! 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' +#ifdef _OPENMP + allocate(griduncn_omp(0:numxgridn-1,0:numygridn-1,numzgrid,maxspec, & + maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc_omp' +#endif + + 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) + if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc' +#ifdef _OPENMP + allocate(wetgriduncn_omp(0:numxgridn-1,0:numygridn-1,maxspec, & + maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR:could not allocate nested wetgridunc_omp' + allocate(drygriduncn_omp(0:numxgridn-1,0:numygridn-1,maxspec, & + maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR:could not allocate nested drygriduncn_omp' +#endif + endif + +#ifdef USE_MPIINPLACE +#else + ! Extra field for totals at MPI root process + if (lroot.and.mpi_mode.gt.0) then + ! If MPI_IN_PLACE option is not used in mpi_mod.f90::mpif_tm_reduce_grid_nest(), + ! then an aux array is needed for parallel grid reduction + allocate(griduncn0(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' + ! allocate a dummy to avoid compilator complaints + else if (.not.lroot.and.mpi_mode.gt.0) then + allocate(griduncn0(1,1,1,1,1,1,1),stat=stat) + end if +#endif + if (ldirect.gt.0) then + if (lroot.and.mpi_mode.gt.0) then + allocate(wetgriduncn0(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(drygriduncn0(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 + ! allocate a dummy to avoid compilator complaints + else if (.not.lroot.and.mpi_mode.gt.0) then + allocate(wetgriduncn0(1,1,1,1,1,1),stat=stat) + allocate(drygriduncn0(1,1,1,1,1,1),stat=stat) + end if + end if + + ! 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)*dyoutn + ylatp=ylat+0.5*dyoutn + ylatm=ylat-0.5*dyoutn + if ((ylatm.lt.0).and.(ylatp.gt.0.)) then + hzone=dyoutn*r_earth*pi180 + else + + ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360, + ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90 + !************************************************************ + + cosfactp=cos(ylatp*pi180) + cosfactm=cos(ylatm*pi180) + if (cosfactp.lt.cosfactm) then + hzone=sqrt(1-cosfactp**2)- & + sqrt(1-cosfactm**2) + hzone=hzone*r_earth + else + hzone=sqrt(1-cosfactm**2)- & + sqrt(1-cosfactp**2) + hzone=hzone*r_earth + endif + endif + + + + ! Surface are of a grid cell at a latitude ylat + !********************************************** + + gridarea=2.*pi*r_earth*hzone*dxoutn/360. + + 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 nesteed 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 + ylat=outlat0n+(real(jjy)+real(j1)/10.-0.05)*dyoutn + yl=(ylat-ylat0)/dy + do i1=1,10 + xlon=outlon0n+(real(iix)+real(i1)/10.-0.05)*dxoutn + xl=(xlon-xlon0)/dx + + ! Determine the nest we are in + !***************************** + + ngrid=0 + do j=numbnests,1,-1 + ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) + if ((xl.gt.xln(j)+dxn(j)).and.(xl.lt.xrn(j)-dxn(j)).and. & + (yl.gt.yln(j)+dyn(j)).and.(yl.lt.yrn(j)-dyn(j))) then + ngrid=j + exit + endif + end do + + ! 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 + + !******************************* + ! Initialization of 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. +#ifdef _OPENMP + wetgriduncn_omp(ix,jy,ks,kp,l,nage,:)=0. + drygriduncn_omp(ix,jy,ks,kp,l,nage,:)=0. +#endif + 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 diff --git a/src/prepoutgrid_mod.f90 b/src/prepoutgrid_mod.f90 index f0b4e2e19e8e760f9e7286d4385fae799373fd71..4df835c60ec0fe4394e9b98397cc94e5a9ee2814 100644 --- a/src/prepoutgrid_mod.f90 +++ b/src/prepoutgrid_mod.f90 @@ -27,8 +27,8 @@ module prepoutgrid_mod real,allocatable, dimension (:,:,:) :: areaeast real,allocatable, dimension (:,:,:) :: areanorth real,allocatable, dimension (:,:,:) :: densityoutgrid - real,allocatable, dimension (:,:,:) :: densitydrygrid ! added RLT - real,allocatable, dimension (:,:,:) :: factor_drygrid ! added RLT + real,allocatable, dimension (:,:,:) :: densitydrygrid ! added RLT + real,allocatable, dimension (:,:,:) :: factor_drygrid ! added RLT real,allocatable, dimension (:,:,:) :: factor3d real,allocatable, dimension (:,:,:) :: grid real(dep_prec),allocatable, dimension (:,:) :: wetgrid @@ -57,818 +57,10 @@ module prepoutgrid_mod contains -subroutine outgrid_init - ! - !***************************************************************************** - ! * - ! This routine initializes the output grids * - ! * - ! Author: A. Stohl * - ! * - ! 7 August 2002 * - ! * - ! Changes * - ! 2022 L. Bakels: OpenMP parallelisation * - !***************************************************************************** - ! * - ! 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 ohr_mod - use unc_mod - - integer :: ix,jy,kz,i,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid - integer :: ks,kp,stat - real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp - real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh - real :: eps - - 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+(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 - - ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360, - ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90 - !************************************************************ - - cosfactp=cos(ylatp*pi180) - cosfactm=cos(ylatm*pi180) - if (cosfactp.lt.cosfactm) then - hzone=sqrt(1-cosfactp**2)- & - sqrt(1-cosfactm**2) - hzone=hzone*r_earth - else - hzone=sqrt(1-cosfactm**2)- & - sqrt(1-cosfactp**2) - hzone=hzone*r_earth - endif - endif - - ! Surface are of a grid cell at a latitude ylat - !********************************************** - - gridarea=2.*pi*r_earth*hzone*dxout/360. - - do ix=0,numxgrid-1 - area(ix,jy)=gridarea - - ! Volume = area x box height - !*************************** - - volume(ix,jy,1)=area(ix,jy)*outheight(1) - areaeast(ix,jy,1)=dyout*r_earth*pi180*outheight(1) - areanorth(ix,jy,1)=cos(ylat*pi180)*dxout*r_earth*pi180* & - 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)) - 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 - ylat=outlat0+(real(jjy)+real(j1)/10.-0.05)*dyout - yl=(ylat-ylat0)/dy - do i1=1,10 - xlon=outlon0+(real(iix)+real(i1)/10.-0.05)*dxout - xl=(xlon-xlon0)/dx - - ! Determine the nest we are in - !***************************** - - ngrid=0 - ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) - do j=numbnests,1,-1 - if ((xl.gt.xln(j)+dxn(j)).and.(xl.lt.xrn(j)-dxn(j)).and. & - (yl.gt.yln(j)+dyn(j)).and.(yl.lt.yrn(j)-dyn(j))) then - ngrid=j - exit - endif - end do - -! Determine (nested) grid coordinates & auxiliary parameters for interpolation -!***************************************************************************** - - if (ngrid.gt.0) then - xtn=(xl-xln(ngrid))*xresoln(ngrid) - ytn=(yl-yln(ngrid))*yresoln(ngrid) - ix=max(min(nint(xtn),nxn(ngrid)-1),0) - jy=max(min(nint(ytn),nyn(ngrid)-1),0) - ! 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 ' -#ifdef _OPENMP - allocate(flux_omp(6,0:numxgrid-1,0:numygrid-1,numzgrid, & - 1:nspec,1:maxpointspec_act,1:nageclass,numthreads)) - if (stat.ne.0) write(*,*)'ERROR: could not allocate flux_omp array ' -#endif - 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' -#ifdef _OPENMP - allocate(gridunc_omp(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, & - maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) - if (stat.ne.0) then - write(*,*)'ERROR: could not allocate gridunc_omp' - write(*,*)'increase the memory or reduce max_numthreads_grid in par_mod.f90.' - stop - endif -#endif - 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 wetgridunc' - allocate(drygridunc(0:numxgrid-1,0:numygrid-1,maxspec, & - maxpointspec_act,nclassunc,maxageclass),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate drygridunc' -#ifdef _OPENMP - allocate(wetgridunc_omp(0:numxgrid-1,0:numygrid-1,maxspec, & - maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate wetgridunc_omp' - allocate(drygridunc_omp(0:numxgrid-1,0:numygrid-1,maxspec, & - maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate drygridunc_omp' -#endif - endif - -#ifdef USE_MPIINPLACE -#else -! Extra field for totals at MPI root process - if (lroot.and.mpi_mode.gt.0) then -! If MPI_IN_PLACE option is not used in mpi_mod.f90::mpif_tm_reduce_grid(), -! then an aux array is needed for parallel grid reduction - allocate(gridunc0(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, & - maxpointspec_act,nclassunc,maxageclass),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc0' - else if (.not.lroot.and.mpi_mode.gt.0) then - allocate(gridunc0(1,1,1,1,1,1,1),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc0' - end if -#endif - if (ldirect.gt.0) then - if (lroot.and.mpi_mode.gt.0) then - allocate(wetgridunc0(0:numxgrid-1,0:numygrid-1,maxspec, & - maxpointspec_act,nclassunc,maxageclass),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate wetgridunc0' - allocate(drygridunc0(0:numxgrid-1,0:numygrid-1,maxspec, & - maxpointspec_act,nclassunc,maxageclass),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate drygridunc0' - - ! allocate a dummy to avoid compilator complaints - else if (.not.lroot.and.mpi_mode.gt.0) then - allocate(wetgridunc0(1,1,1,1,1,1),stat=stat) - allocate(drygridunc0(1,1,1,1,1,1),stat=stat) - end if - end if - - !write (*,*) 'Dimensions for fields', numxgrid,numygrid, & - ! maxspec,maxpointspec_act,nclassunc,maxageclass - - if (lroot) then - write (*,*) 'Allocating fields for global output (x,y): ', & - numxgrid,numygrid - write (*,*) 'Allocating fields for nested output (x,y): ', & - numxgridn,numygridn - end if - - ! 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) - 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' - ! RLT - allocate(densitydrygrid(0:max(numxgrid,numxgridn)-1, & - 0:max(numygrid,numygridn)-1,numzgrid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc' - allocate(factor_drygrid(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_u(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) - if (stat.ne.0) write(*,*)'ERROR: could not allocate gridunc' - allocate(drygrid(0:max(numxgrid,numxgridn)-1, & - 0:max(numygrid,numygridn)-1),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' -#ifdef _OPENMP - allocate(init_cond_omp(0:numxgrid-1,0:numygrid-1,numzgrid,maxspec, & - maxpointspec_act,numthreads),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate init_cond_omp' -#endif - endif - - !************************ - ! Initialize output grids - !************************ - - do ks=1,nspec - do kp=1,maxpointspec_act - if (numreceptor.gt.0) then - do i=1,numreceptor - ! Receptor points - creceptor(i,ks)=0. - end do - endif - 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. -#ifdef _OPENMP - wetgridunc_omp(ix,jy,ks,kp,l,nage,:)=0. - drygridunc_omp(ix,jy,ks,kp,l,nage,:)=0. -#endif - 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. -#ifdef _OPENMP - flux_omp(i,ix,jy,kz,ks,kp,nage,:)=0. -#endif - end do - endif - ! Initial condition field - if ((l.eq.1).and.(nage.eq.1).and.(linit_cond.gt.0)) then - init_cond(ix,jy,kz,ks,kp)=0. -#ifdef _OPENMP - init_cond_omp(ix,jy,kz,ks,kp,:)=0. -#endif - endif - ! Concentration fields - gridunc(ix,jy,kz,ks,kp,l,nage)=0. -#ifdef _OPENMP - gridunc_omp(ix,jy,kz,ks,kp,l,nage,:)=0. -#endif - end do - end do - end do - end do - end do - end do - end do -end subroutine outgrid_init - -subroutine outgrid_init_nest - ! - !***************************************************************************** - ! * - ! This routine calculates, for each grid cell of the output nest, the * - ! volume and the surface area. * - ! * - ! Author: A. Stohl * - ! * - ! 30 August 2004 * - ! * - ! Changes * - ! 2022 L. Bakels: OpenMP parallelisation * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! arean surface area of all output nest cells * - ! volumen volumes of all output nest cells * - ! * - !***************************************************************************** - - use unc_mod - - integer :: ix,jy,kz,ks,kp,nage,l,iix,jjy,ixp,jyp,i1,j1,j,ngrid - integer :: stat - real :: ylat,gridarea,ylatp,ylatm,hzone,cosfactm,cosfactp - real :: xlon,xl,yl,ddx,ddy,rddx,rddy,p1,p2,p3,p4,xtn,ytn,oroh - real :: eps - - eps=nxmax/3.e5 - - ! 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' -#ifdef _OPENMP - allocate(griduncn_omp(0:numxgridn-1,0:numygridn-1,numzgrid,maxspec, & - maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc_omp' -#endif - - 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) - if (stat.ne.0) write(*,*)'ERROR:could not allocate nested gridunc' -#ifdef _OPENMP - allocate(wetgriduncn_omp(0:numxgridn-1,0:numygridn-1,maxspec, & - maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR:could not allocate nested wetgridunc_omp' - allocate(drygriduncn_omp(0:numxgridn-1,0:numygridn-1,maxspec, & - maxpointspec_act,nclassunc,maxageclass,numthreads_grid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR:could not allocate nested drygriduncn_omp' -#endif - endif - -#ifdef USE_MPIINPLACE -#else - ! Extra field for totals at MPI root process - if (lroot.and.mpi_mode.gt.0) then - ! If MPI_IN_PLACE option is not used in mpi_mod.f90::mpif_tm_reduce_grid_nest(), - ! then an aux array is needed for parallel grid reduction - allocate(griduncn0(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' - ! allocate a dummy to avoid compilator complaints - else if (.not.lroot.and.mpi_mode.gt.0) then - allocate(griduncn0(1,1,1,1,1,1,1),stat=stat) - end if -#endif - if (ldirect.gt.0) then - if (lroot.and.mpi_mode.gt.0) then - allocate(wetgriduncn0(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(drygriduncn0(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 - ! allocate a dummy to avoid compilator complaints - else if (.not.lroot.and.mpi_mode.gt.0) then - allocate(wetgriduncn0(1,1,1,1,1,1),stat=stat) - allocate(drygriduncn0(1,1,1,1,1,1),stat=stat) - end if - end if - - ! 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)*dyoutn - ylatp=ylat+0.5*dyoutn - ylatm=ylat-0.5*dyoutn - if ((ylatm.lt.0).and.(ylatp.gt.0.)) then - hzone=dyoutn*r_earth*pi180 - else - - ! Calculate area of grid cell with formula M=2*pi*R*h*dx/360, - ! see Netz, Formeln der Mathematik, 5. Auflage (1983), p.90 - !************************************************************ - - cosfactp=cos(ylatp*pi180) - cosfactm=cos(ylatm*pi180) - if (cosfactp.lt.cosfactm) then - hzone=sqrt(1-cosfactp**2)- & - sqrt(1-cosfactm**2) - hzone=hzone*r_earth - else - hzone=sqrt(1-cosfactm**2)- & - sqrt(1-cosfactp**2) - hzone=hzone*r_earth - endif - endif - - - - ! Surface are of a grid cell at a latitude ylat - !********************************************** - - gridarea=2.*pi*r_earth*hzone*dxoutn/360. - - 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 nesteed 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 - ylat=outlat0n+(real(jjy)+real(j1)/10.-0.05)*dyoutn - yl=(ylat-ylat0)/dy - do i1=1,10 - xlon=outlon0n+(real(iix)+real(i1)/10.-0.05)*dxoutn - xl=(xlon-xlon0)/dx - - ! Determine the nest we are in - !***************************** - - ngrid=0 - do j=numbnests,1,-1 - ! Temporary fix for nested layer edges: replaced eps with dxn and dyn (LB) - if ((xl.gt.xln(j)+dxn(j)).and.(xl.lt.xrn(j)-dxn(j)).and. & - (yl.gt.yln(j)+dyn(j)).and.(yl.lt.yrn(j)-dyn(j))) then - ngrid=j - exit - endif - end do - - ! 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 - - !******************************* - ! Initialization of 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. -#ifdef _OPENMP - wetgriduncn_omp(ix,jy,ks,kp,l,nage,:)=0. - drygriduncn_omp(ix,jy,ks,kp,l,nage,:)=0. -#endif - 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 - -subroutine initcond_calc(itime,i,thread) - ! i i - !***************************************************************************** - ! * - ! Calculation of the sensitivity to initial conditions for BW runs * - ! * - ! Author: A. Stohl * - ! * - ! 15 January 2010 * - ! * - ! Changes * - ! 2022 L. Bakels: OpenMP parallelisation * - !***************************************************************************** - - use interpol_mod, only: interpol_density,ix,jy,ixp,jyp - use coord_ec_mod - use particle_mod - - integer, intent(in) :: itime,i,thread - integer :: 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 - integer :: mind2 - ! mind2 eso: pointer to 2nd windfield in memory - - - ! For forward simulations, make a loop over the number of species; - ! for backward simulations, make an additional loop over the release points - !************************************************************************** - - - if (.not. part(i)%alive) 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 - call update_zeta_to_z(itime,i) - call interpol_density(itime,i,rhoi) - 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=part(i)%npoint - endif - - do kz=1,numzgrid ! determine height of cell - if (real(outheight(kz),kind=dp).gt.part(i)%z) exit - end do - - if (kz.le.numzgrid) then ! inside output domain - - - xl=(part(i)%xlon*dx+xoutshift)/dxout - yl=(part(i)%ylat*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 -#ifdef _OPENMP - init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)= & - init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)+ & - part(i)%mass(ks)/rhoi -#else - init_cond(ix,jy,kz,ks,nrelpointer)= & - init_cond(ix,jy,kz,ks,nrelpointer)+ & - part(i)%mass(ks)/rhoi -#endif - 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 -#ifdef _OPENMP - init_cond_omp(ix,jy,kz,ks,nrelpointer,thread)= & - init_cond_omp(ix,jy,kz,ks,nrelpointer,thread) + & - part(i)%mass(ks) / rhoi * w -#else - init_cond(ix,jy,kz,ks,nrelpointer)= & - init_cond(ix,jy,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w -#endif - end do - endif - - if ((jyp.ge.0).and.(jyp.le.numygrid-1)) then - w=wx*(1.-wy) - do ks=1,nspec -#ifdef _OPENMP - init_cond_omp(ix,jyp,kz,ks,nrelpointer,thread)= & - init_cond_omp(ix,jyp,kz,ks,nrelpointer,thread) + & - part(i)%mass(ks) / rhoi * w -#else - init_cond(ix,jyp,kz,ks,nrelpointer)= & - init_cond(ix,jyp,kz,ks,nrelpointer)+part(i)%mass(ks)/rhoi*w -#endif - 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 -#ifdef _OPENMP - init_cond_omp(ixp,jyp,kz,ks,nrelpointer,thread)= & - init_cond_omp(ixp,jyp,kz,ks,nrelpointer,thread) + & - part(i)%mass(ks) / rhoi * w -#else - init_cond(ixp,jyp,kz,ks,nrelpointer)= & - init_cond(ixp,jyp,kz,ks,nrelpointer) + & - part(i)%mass(ks) / rhoi * w -#endif - end do - endif - - if ((jy.ge.0).and.(jy.le.numygrid-1)) then - w=(1.-wx)*wy - do ks=1,nspec -#ifdef _OPENMP - init_cond_omp(ixp,jy,kz,ks,nrelpointer,thread)= & - init_cond_omp(ixp,jy,kz,ks,nrelpointer,thread) + & - part(i)%mass(ks) / rhoi * w -#else - init_cond(ixp,jy,kz,ks,nrelpointer)= & - init_cond(ixp,jy,kz,ks,nrelpointer) + & - part(i)%mass(ks) / rhoi * w -#endif - end do - endif - endif - endif +#include "pre_outgrid_init.f90" - endif +#include "pre_outgrid_init_nest.f90" -end subroutine initcond_calc +#include "pre_initcond_calc.f90" end module prepoutgrid_mod diff --git a/src/qvs_ew.f90 b/src/qvs_ew.f90 new file mode 100644 index 0000000000000000000000000000000000000000..f26c083bab15bfd571ff34cd8551e18e8636518c --- /dev/null +++ b/src/qvs_ew.f90 @@ -0,0 +1,56 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function ew(x,p) + + !**************************************************************** + !SAETTIGUNGSDAMPFDRUCK UEBER WASSER IN PA. X IN KELVIN. + !NACH DER GOFF-GRATCH-FORMEL. + !**************************************************************** + + implicit none + + real :: x, y, a, p , c, d + + ew=0. + if(x.le.0.) stop 'sorry: t not in [k]' + ! Formula of Goff and Gratch (after Murray, 1966) + ! if (x.lt.273.15) then + ! ! Above ice + ! a = 273.15/x + ! y = -20.947031*a - 3.56654*log(a) - 2.01889049/a + ! ew = 5.75185606E10*exp(y) + ! else + ! ! Above water + ! a = 373.15/x + ! y = -18.1972839*a + 5.02808*log(a) - 70242.1852*exp(-26.1205253/a) + & + ! 58.0691913*exp(-8.03945282*a) + ! ew = 7.95357242E10*exp(y) + ! endif + + ! ! Formula of Magnus (after Murray, 1966) + ! if (x.lt.273.15) then + ! ! Above ice + ! ew = 6.1078*exp(21.8745584*(x-273.15)/(x-7.66)) + ! else + ! ! Above water + ! ew = 6.1078*exp(17.2693882*(x-273.15)/(x-35.86)) + ! endif + + ! Formula of Buck 1981 + ! ew = f_qvsat(p,x) + + ! ! Original + 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/qvs_f_esi.f90 b/src/qvs_f_esi.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8322f47b09a1e5e5ee72e4f4d8ef6956c9311d2a --- /dev/null +++ b/src/qvs_f_esi.f90 @@ -0,0 +1,37 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function f_esi( p, t ) + ! Saturation water vapor pressure over ice (Pa) + implicit none + + real :: p ! Pressure (Pascal) + real :: t ! Temperature (K) + 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/qvs_f_esl.f90 b/src/qvs_f_esl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..46e57a49d55c0ec15c72d7056f37ec641512c166 --- /dev/null +++ b/src/qvs_f_esl.f90 @@ -0,0 +1,37 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function f_esl( p, t ) + ! Saturation water vapor pressure over liquid water + implicit none + + real :: p ! Pressure (Pascal) + real :: t ! Temperature (K) + 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 diff --git a/src/qvs_f_qvsat.f90 b/src/qvs_f_qvsat.f90 new file mode 100644 index 0000000000000000000000000000000000000000..fe3093ec9c6341ab39038608b9657073c38de068 --- /dev/null +++ b/src/qvs_f_qvsat.f90 @@ -0,0 +1,53 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real 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 :: 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 diff --git a/src/qvsat_mod.f90 b/src/qvsat_mod.f90 index d353b9417f87a1c4d92cf3d6a403c2fece4a03ef..f01b45a0dc8d15d874cfbbb424baeb5f7c17c7bf 100644 --- a/src/qvsat_mod.f90 +++ b/src/qvsat_mod.f90 @@ -11,7 +11,7 @@ !################################################################## !################################################################## module qvsat_mod - + implicit none private @@ -19,180 +19,13 @@ module qvsat_mod contains -real 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 :: 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 - - -real function f_esl( p, t ) - ! Saturation water vapor pressure over liquid water - implicit none - - real :: p ! Pressure (Pascal) - real :: t ! Temperature (K) - 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 - -real function f_esi( p, t ) - ! Saturation water vapor pressure over ice (Pa) - implicit none - - real :: p ! Pressure (Pascal) - real :: t ! Temperature (K) - 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 - -real function ew(x,p) - - !**************************************************************** - !SAETTIGUNGSDAMPFDRUCK UEBER WASSER IN PA. X IN KELVIN. - !NACH DER GOFF-GRATCH-FORMEL. - !**************************************************************** - - implicit none - - real :: x, y, a, p , c, d - - ew=0. - if(x.le.0.) stop 'sorry: t not in [k]' - ! Formula of Goff and Gratch (after Murray, 1966) - ! if (x.lt.273.15) then - ! ! Above ice - ! a = 273.15/x - ! y = -20.947031*a - 3.56654*log(a) - 2.01889049/a - ! ew = 5.75185606E10*exp(y) - ! else - ! ! Above water - ! a = 373.15/x - ! y = -18.1972839*a + 5.02808*log(a) - 70242.1852*exp(-26.1205253/a) + & - ! 58.0691913*exp(-8.03945282*a) - ! ew = 7.95357242E10*exp(y) - ! endif +#include "qvs_f_qvsat.f90" - ! ! Formula of Magnus (after Murray, 1966) - ! if (x.lt.273.15) then - ! ! Above ice - ! ew = 6.1078*exp(21.8745584*(x-273.15)/(x-7.66)) - ! else - ! ! Above water - ! ew = 6.1078*exp(17.2693882*(x-273.15)/(x-35.86)) - ! endif - ! Formula of Buck 1981 - ! ew = f_qvsat(p,x) +#include "qvs_f_esl.f90" - ! ! Original - 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 +#include "qvs_f_esi.f90" -end function ew +#include "qvs_ew.f90" -end module qvsat_mod \ No newline at end of file +end module qvsat_mod diff --git a/src/ran_alloc_random.f90 b/src/ran_alloc_random.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2ed4d3d14b359e38987c4f0bcc553cd41340105e --- /dev/null +++ b/src/ran_alloc_random.f90 @@ -0,0 +1,25 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine alloc_random(num_threads) + + implicit none + + integer :: num_threads, i + + allocate(ran1_iv(ran1_ntab,0:num_threads-1),ran1_iy(0:num_threads-1)) + allocate(gasdev_iset(0:num_threads-1),gasdev_gset(0:num_threads-1)) + allocate(ran3_iff(0:num_threads-1),ran3_inext(0:num_threads-1),ran3_inextp(0:num_threads-1)) + allocate(ma(55,0:num_threads-1)) + allocate(iseed1(0:num_threads-1),iseed2(0:num_threads-1)) + + do i=0,num_threads-1 + iseed1(i) = -7-i + iseed2(i) = -88-i + end do + ran3_iff(0:num_threads-1)=0 + ran1_iv(:,0:num_threads-1)=0 + ran1_iy(0:num_threads-1)=0 + gasdev_iset(0:num_threads-1)=0 + gasdev_gset(0:num_threads-1)=0 + end subroutine alloc_random diff --git a/src/ran_dealloc_random.f90 b/src/ran_dealloc_random.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c3ad0d5a8005b2de5e45fbd8b1e5eae30f455437 --- /dev/null +++ b/src/ran_dealloc_random.f90 @@ -0,0 +1,11 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine dealloc_random() + + deallocate(ran1_iv,ran1_iy) + deallocate(gasdev_iset,gasdev_gset) + deallocate(ran3_iff,ran3_inext,ran3_inextp) + deallocate(ma) + deallocate(iseed1,iseed2) + end subroutine dealloc_random diff --git a/src/ran_gasdev.f90 b/src/ran_gasdev.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6930e50c8052dae06513691b9831542a496879df --- /dev/null +++ b/src/ran_gasdev.f90 @@ -0,0 +1,24 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + function gasdev(idum,ithread) + + implicit none + + integer :: idum,ithread + real :: gasdev, fac, r, v1, v2 + + if (gasdev_iset(ithread).eq.0) then +1 v1=2.*ran3(idum,ithread)-1. + v2=2.*ran3(idum,ithread)-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) + gasdev_gset(ithread)=v1*fac + gasdev=v2*fac + gasdev_iset(ithread)=1 + else + gasdev=gasdev_gset(ithread) + gasdev_iset(ithread)=0 + endif + end function gasdev diff --git a/src/ran_gasdev1.f90 b/src/ran_gasdev1.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8843906870e548e2648710c6b9df4021ba7695ce --- /dev/null +++ b/src/ran_gasdev1.f90 @@ -0,0 +1,24 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + subroutine gasdev1(idum,random1,random2) + + implicit none + + integer :: idum + real :: random1, random2, fac, v1, v2, r + +1 v1=2.*ran3(idum,0)-1. + v2=2.*ran3(idum,0)-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 diff --git a/src/ran_ran1.f90 b/src/ran_ran1.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e3fbf694bf9c7b0ca94766de42d6aadedeb4b6c5 --- /dev/null +++ b/src/ran_ran1.f90 @@ -0,0 +1,32 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + function ran1(idum,ithread) + + implicit none + + integer :: idum,ithread + real :: ran1 + integer,parameter :: ia=16807, im=2147483647, iq=127773, ir=2836 + integer,parameter :: ndiv=1+(im-1)/ran1_ntab + real,parameter :: am=1./im, eps=1.2e-7, rnmx=1.-eps + integer :: j, k + + if (idum.le.0.or.ran1_iy(ithread).eq.0) then + idum=max(-idum,1) + do j=ran1_ntab+8,1,-1 + k=idum/iq + idum=ia*(idum-k*iq)-ir*k + if (idum.lt.0) idum=idum+im + if (j.le.ran1_ntab) ran1_iv(j,ithread)=idum + enddo + ran1_iy(ithread)=ran1_iv(1,ithread) + endif + k=idum/iq + idum=ia*(idum-k*iq)-ir*k + if (idum.lt.0) idum=idum+im + j=1+ran1_iy(ithread)/ndiv + ran1_iy(ithread)=ran1_iv(j,ithread) + ran1_iv(j,ithread)=idum + ran1=min(am*ran1_iy(ithread),rnmx) + end function ran1 diff --git a/src/ran_ran3.f90 b/src/ran_ran3.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0ed39a967ed3bac547feee3151c18c049e4cc4e7 --- /dev/null +++ b/src/ran_ran3.f90 @@ -0,0 +1,47 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + + function ran3(idum,ithread) + + implicit none + + integer :: idum,ithread + real :: ran3 + + integer,parameter :: mbig=1000000000, mseed=161803398, mz=0 + real,parameter :: fac=1./mbig + integer :: i,ii,inext,inextp,k + integer :: mj,mk + + if(idum.lt.0 .or. ran3_iff(ithread).eq.0)then + ran3_iff(ithread)=1 + mj=mseed-iabs(idum) + mj=mod(mj,mbig) + ma(55,ithread)=mj + mk=1 + do i=1,54 + ii=mod(21*i,55) + ma(ii,ithread)=mk + mk=mj-mk + if(mk.lt.mz)mk=mk+mbig + mj=ma(ii,ithread) + end do + do k=1,4 + do i=1,55 + ma(i,ithread)=ma(i,ithread)-ma(1+mod(i+30,55),ithread) + if(ma(i,ithread).lt.mz) ma(i,ithread)=ma(i,ithread)+mbig + end do + end do + ran3_inext(ithread)=0 + ran3_inextp(ithread)=31 + idum=1 + endif + ran3_inext(ithread)=ran3_inext(ithread)+1 + if(ran3_inext(ithread).eq.56) ran3_inext(ithread)=1 + ran3_inextp(ithread)=ran3_inextp(ithread)+1 + if(ran3_inextp(ithread).eq.56) ran3_inextp(ithread)=1 + mj=ma(ran3_inext(ithread),ithread)-ma(ran3_inextp(ithread),ithread) + if(mj.lt.mz)mj=mj+mbig + ma(ran3_inext(ithread),ithread)=mj + ran3=mj*fac + end function ran3 diff --git a/src/random_mod.f90 b/src/random_mod.f90 index 803cc9310d071752286c744536ddbbec2ec7bb71..f42e3b49f2fc341d6195930d81aa208ffac73c08 100644 --- a/src/random_mod.f90 +++ b/src/random_mod.f90 @@ -4,7 +4,7 @@ ! Taken from Press et al., Numerical Recipes module random_mod - + implicit none integer, parameter :: ran1_ntab=32 @@ -20,160 +20,21 @@ module random_mod integer, allocatable :: iseed1(:), iseed2(:) contains - - subroutine alloc_random(num_threads) - - implicit none - - integer :: num_threads, i - - allocate(ran1_iv(ran1_ntab,0:num_threads-1),ran1_iy(0:num_threads-1)) - allocate(gasdev_iset(0:num_threads-1),gasdev_gset(0:num_threads-1)) - allocate(ran3_iff(0:num_threads-1),ran3_inext(0:num_threads-1),ran3_inextp(0:num_threads-1)) - allocate(ma(55,0:num_threads-1)) - allocate(iseed1(0:num_threads-1),iseed2(0:num_threads-1)) - - do i=0,num_threads-1 - iseed1(i) = -7-i - iseed2(i) = -88-i - end do - ran3_iff(0:num_threads-1)=0 - ran1_iv(:,0:num_threads-1)=0 - ran1_iy(0:num_threads-1)=0 - gasdev_iset(0:num_threads-1)=0 - gasdev_gset(0:num_threads-1)=0 - end subroutine alloc_random - - subroutine dealloc_random() - - deallocate(ran1_iv,ran1_iy) - deallocate(gasdev_iset,gasdev_gset) - deallocate(ran3_iff,ran3_inext,ran3_inextp) - deallocate(ma) - deallocate(iseed1,iseed2) - end subroutine dealloc_random - - function ran1(idum,ithread) - - implicit none - - integer :: idum,ithread - real :: ran1 - integer,parameter :: ia=16807, im=2147483647, iq=127773, ir=2836 - integer,parameter :: ndiv=1+(im-1)/ran1_ntab - real,parameter :: am=1./im, eps=1.2e-7, rnmx=1.-eps - integer :: j, k - - if (idum.le.0.or.ran1_iy(ithread).eq.0) then - idum=max(-idum,1) - do j=ran1_ntab+8,1,-1 - k=idum/iq - idum=ia*(idum-k*iq)-ir*k - if (idum.lt.0) idum=idum+im - if (j.le.ran1_ntab) ran1_iv(j,ithread)=idum - enddo - ran1_iy(ithread)=ran1_iv(1,ithread) - endif - k=idum/iq - idum=ia*(idum-k*iq)-ir*k - if (idum.lt.0) idum=idum+im - j=1+ran1_iy(ithread)/ndiv - ran1_iy(ithread)=ran1_iv(j,ithread) - ran1_iv(j,ithread)=idum - ran1=min(am*ran1_iy(ithread),rnmx) - end function ran1 - - - function gasdev(idum,ithread) - - implicit none - - integer :: idum,ithread - real :: gasdev, fac, r, v1, v2 - - if (gasdev_iset(ithread).eq.0) then -1 v1=2.*ran3(idum,ithread)-1. - v2=2.*ran3(idum,ithread)-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) - gasdev_gset(ithread)=v1*fac - gasdev=v2*fac - gasdev_iset(ithread)=1 - else - gasdev=gasdev_gset(ithread) - gasdev_iset(ithread)=0 - endif - end function gasdev - - - subroutine gasdev1(idum,random1,random2) - - implicit none - - integer :: idum - real :: random1, random2, fac, v1, v2, r - -1 v1=2.*ran3(idum,0)-1. - v2=2.*ran3(idum,0)-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,ithread) - - implicit none - - integer :: idum,ithread - real :: ran3 - - integer,parameter :: mbig=1000000000, mseed=161803398, mz=0 - real,parameter :: fac=1./mbig - integer :: i,ii,inext,inextp,k - integer :: mj,mk - - if(idum.lt.0 .or. ran3_iff(ithread).eq.0)then - ran3_iff(ithread)=1 - mj=mseed-iabs(idum) - mj=mod(mj,mbig) - ma(55,ithread)=mj - mk=1 - do i=1,54 - ii=mod(21*i,55) - ma(ii,ithread)=mk - mk=mj-mk - if(mk.lt.mz)mk=mk+mbig - mj=ma(ii,ithread) - end do - do k=1,4 - do i=1,55 - ma(i,ithread)=ma(i,ithread)-ma(1+mod(i+30,55),ithread) - if(ma(i,ithread).lt.mz) ma(i,ithread)=ma(i,ithread)+mbig - end do - end do - ran3_inext(ithread)=0 - ran3_inextp(ithread)=31 - idum=1 - endif - ran3_inext(ithread)=ran3_inext(ithread)+1 - if(ran3_inext(ithread).eq.56) ran3_inext(ithread)=1 - ran3_inextp(ithread)=ran3_inextp(ithread)+1 - if(ran3_inextp(ithread).eq.56) ran3_inextp(ithread)=1 - mj=ma(ran3_inext(ithread),ithread)-ma(ran3_inextp(ithread),ithread) - if(mj.lt.mz)mj=mj+mbig - ma(ran3_inext(ithread),ithread)=mj - ran3=mj*fac - end function ran3 + +#include "ran_alloc_random.f90" + +#include "ran_dealloc_random.f90" + +#include "ran_ran1.f90" + + +#include "ran_gasdev.f90" + + +#include "ran_gasdev1.f90" + + +#include "ran_ran3.f90" ! (C) Copr. 1986-92 Numerical Recipes Software US. end module random_mod diff --git a/src/rea_readOHfield.f90 b/src/rea_readOHfield.f90 new file mode 100644 index 0000000000000000000000000000000000000000..989fb591d587a85baa1da8a936390dc296a0fddf --- /dev/null +++ b/src/rea_readOHfield.f90 @@ -0,0 +1,76 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readOHfield + + !***************************************************************************** + ! * + ! Reads the OH field into memory * + ! * + ! AUTHOR: R.L. Thompson, Nov 2014 * + ! * + ! UPDATES: * + ! 03/2018 SEC: Converted original netCDF files to binary format * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! path(numpath) contains the path names * + ! lonOH(nxOH) longitude of OH fields * + ! latOH(nyOH) latitude of OH fields * + ! altOH(nzOH) altitude of OH fields * + ! etaOH(nzOH) eta-levels of OH fields * + ! OH_field(nxOH,nyOH,nzOH,m) OH concentration (molecules/cm3) * + ! * + ! * + !***************************************************************************** + + use ohr_mod + + implicit none + + integer :: i,j,k,l,ierr + real, dimension(:), allocatable :: etaOH + + ! real, parameter :: gasct=8.314 ! gas constant + ! real, parameter :: mct=0.02894 ! kg mol-1 + ! real, parameter :: g=9.80665 ! m s-2 + ! real, parameter :: lrate=0.0065 ! K m-1 + real, parameter :: scalehgt=7000. ! scale height in metres + + + open(unitOH,file=trim(ohfields_path) & + //'OH_FIELDS/OH_variables.bin',status='old', & + form='UNFORMATTED', iostat=ierr, convert='little_endian') + + if(ierr.ne.0) then + write(*,*) 'Cannot read binary OH fields in ', & + trim(ohfields_path)//'OH_FIELDS/OH_variables.bin' + stop + endif + + read(unitOH) nxOH + read(unitOH) nyOH + read(unitOH) nzOH + write(*,*) nxOH,nyOH,nzOH + + ! allocate variables + allocate(lonOH(nxOH)) + allocate(latOH(nyOH)) + allocate(etaOH(nzOH)) + allocate(altOH(nzOH)) + allocate(OH_field(nxOH,nyOH,nzOH,12)) + allocate(OH_hourly(nxOH,nyOH,nzOH,2)) + + read(unitOH) (lonjr(i),i=1,360) + read(unitOH) (latjr(i),i=1,180) + read(unitOH) (((jrate_average(i,j,k),i=1,360),j=1,180),k=1,12) + read(unitOH) (lonOH(i),i=1,nxOH) + read(unitOH) (latOH(i),i=1,nyOH) + read(unitOH) (lonOH(i),i=1,nxOH) + + read(unitOH) (altOH(i),i=1,nzOH) + read(unitOH) ((((OH_field(i,j,k,l),i=1,nxOH),j=1,nyOH),k=1,nzOH),l=1,12) + read(unitOH) ((((OH_hourly(i,j,k,l),i=1,nxOH),j=1,nyOH),k=1,nzOH),l=1,2) + +end subroutine readOHfield diff --git a/src/rea_readageclasses.f90 b/src/rea_readageclasses.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cf52ae3253cce916f351a83eeab4090966513f82 --- /dev/null +++ b/src/rea_readageclasses.f90 @@ -0,0 +1,119 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readageclasses + + !***************************************************************************** + ! * + ! This routine reads the age classes to be used for the current model * + ! run. * + ! * + ! Author: A. Stohl * + ! 20 March 2000 * + ! HSO, 1 July 2014 * + ! Added optional namelist input * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! Constants: * + ! * + !***************************************************************************** + + implicit none + + integer :: i + + ! namelist help variables + integer :: ios + + ! namelist declaration + namelist /ageclass/ & + nageclass, & + lage + + ! If age spectra calculation is switched off, set number of age classes + ! to 1 and maximum age to a large number + !********************************************************************** + + if (lagespectra.ne.1) then + nageclass=1 + lage(nageclass)=999999999 + return + endif + + ! If age spectra claculation is switched on, + ! open the AGECLASSSES file and read user options + !************************************************ + + open(unitageclasses,file=path(1)(1:length(1))//'AGECLASSES', & + form='formatted',status='old',err=999) + +! try to read in as a namelist + nageclass=-1 ! preset to negative value to identify failed namelist input + read(unitageclasses,ageclass,iostat=ios) + close(unitageclasses) + + if (nageclass.lt.0 .or. ios.ne.0) then + open(unitageclasses,file=path(1)(1:length(1))//'AGECLASSES', & + status='old',err=999) + do i=1,13 + read(unitageclasses,*) + end do + read(unitageclasses,*) nageclass + read(unitageclasses,*) lage(1) + if (nageclass.ge.2) then + do i=2,nageclass + read(unitageclasses,*) lage(i) + end do + endif + close(unitageclasses) + endif + + ! write ageclasses file in namelist format to output directory if requested +! if (nmlout.and.lroot) then + if (nmlout) then + open(unitageclasses,file=path(2)(1:length(2))//'AGECLASSES.namelist', & + err=1000) + write(unitageclasses,nml=ageclass) + close(unitageclasses) + endif + + if (nageclass.gt.maxageclass) then + write(*,*) ' #### FLEXPART MODEL ERROR! NUMBER OF AGE #### ' + write(*,*) ' #### CLASSES GREATER THAN MAXIMUM ALLOWED. #### ' + write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES OR #### ' + write(*,*) ' #### RECOMPILE WITH LARGER MAXAGECLASS IN #### ' + write(*,*) ' #### FILE PAR_MOD. #### ' + 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 FILE AGECLASSES. #### ' + stop + endif + + do i=2,nageclass + 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 FILE AGECLASSES. #### ' + stop + endif + end do + + return + +999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "AGECLASSES" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(1)(1:length(1)) + stop + +1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "AGECLASSES" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(2)(1:length(2)) + stop +end subroutine readageclasses diff --git a/src/rea_readavailable.f90 b/src/rea_readavailable.f90 new file mode 100644 index 0000000000000000000000000000000000000000..22e502f378785ee1ed505c263b43d3f5cd7a6143 --- /dev/null +++ b/src/rea_readavailable.f90 @@ -0,0 +1,270 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readavailable + + !***************************************************************************** + ! * + ! 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 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! bdate beginning date as Julian date * + ! beg beginning date for windfields * + ! endl 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 * + ! * + !***************************************************************************** + + implicit none + + integer :: i,idiff,ldat,ltim,wftime1(maxwf),numbwfn(maxnests),k + integer :: wftime1n(maxnests,maxwf),wftimen(maxnests,maxwf) + logical :: lwarntd=.true. + real(kind=dp) :: jul,beg,endl + character(len=255) :: fname,spec,wfname1(maxwf),wfspec1(maxwf) + character(len=255) :: wfname1n(maxnests,maxwf) + character(len=40) :: wfspec1n(maxnests,maxwf) + + + ! 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._dp + endl=bdate+real(ideltas,kind=dp)/86400._dp+real(idiffmax,kind=dp)/ & + 86400._dp + else ! backward trajectories + beg=bdate+real(ideltas,kind=dp)/86400._dp-real(idiffmax,kind=dp)/ & + 86400._dp + endl=bdate+1._dp + endif + + ! Open the wind field availability file and read available wind fields + ! within the modelling period. + !********************************************************************* + + open(unitavailab,file=path(4)(1:length(4)),status='old', & + err=999) + + do i=1,3 + read(unitavailab,*) + end do + + numbwf=0 +100 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=99) & + ldat,ltim,fname,spec + jul=juldate(ldat,ltim) + if ((jul.ge.beg).and.(jul.le.endl)) 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(1:index(fname,' ')) + wfspec1(numbwf)=spec + wftime1(numbwf)=nint((jul-bdate)*86400._dp) + 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 + !print*,length(numpath+2*(k-1)+1),length(numpath+2*(k-1)+2),length(4),length(3) + !print*,path(numpath+2*(k-1)+2)(1:length(numpath+2*(k-1)+2)) + open(unitavailab,file=path(numpath+2*(k-1)+2) & + (1:length(numpath+2*(k-1)+2)),status='old',err=998) + + do i=1,3 + read(unitavailab,*) + end do + + numbwfn(k)=0 +700 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=699) ldat, & + ltim,fname,spec + jul=juldate(ldat,ltim) + if ((jul.ge.beg).and.(jul.le.endl)) 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._dp) + endif + goto 700 ! next wind field + +699 continue + + close(unitavailab) + end do + + + ! 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 + end do + + ! 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(*,*) 'FLEXPART 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 + end do + + end do + + + ! For backward trajectories, reverse the order of the windfields + !*************************************************************** + + if (ideltas.ge.0) then + do i=1,numbwf + wfname(i)=wfname1(i) + wfspec(i)=wfspec1(i) + wftime(i)=wftime1(i) + end do + 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) + end do + end do + else + do i=1,numbwf + wfname(numbwf-i+1)=wfname1(i) + wfspec(numbwf-i+1)=wfspec1(i) + wftime(numbwf-i+1)=wftime1(i) + end do + 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) + end do + end do + 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.and.lroot) 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.and.lroot.and.lwarntd) then + write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO' + write(*,*) 'WIND FIELDS IS BIG. THIS MAY CAUSE A DEGRADATION' + write(*,*) 'OF SIMULATION QUALITY.' + lwarntd=.false. ! only issue this warning once + endif + end do + + do k=1,numbnests + if (numbwfn(k).ne.numbwf) then + write(*,*) 'FLEXPART 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(*,*) 'FLEXPART 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 + end do + end do + + ! 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 + end do + + return + +998 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE FILE #### ' + write(*,'(a)') ' '//path(numpath+2*(k-1)+2) & + (1:length(numpath+2*(k-1)+2)) + write(*,*) ' #### CANNOT BE OPENED #### ' + stop + +999 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE FILE #### ' + write(*,'(a)') ' '//path(4)(1:length(4)) + write(*,*) ' #### CANNOT BE OPENED #### ' + stop +end subroutine readavailable diff --git a/src/rea_readcommand.f90 b/src/rea_readcommand.f90 new file mode 100644 index 0000000000000000000000000000000000000000..90ed0b1d21913ec48098819231b4b1b020bd874a --- /dev/null +++ b/src/rea_readcommand.f90 @@ -0,0 +1,612 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readcommand + + !***************************************************************************** + ! * + ! This routine reads the user specifications for the current model run. * + ! * + ! Author: A. Stohl * + ! * + ! 18 May 1996 * + ! HSO, 1 July 2014 * + ! Added optional namelist input * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! bdate beginning date as Julian date * + ! ctl factor by which time step must be smaller than * + ! Lagrangian time scale * + ! 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 * + ! outputforeachrel for forward runs it is possible either to create * + ! one outputfield or several for each releasepoint * + ! 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 restart.bin file, * + ! 2 continue simulaion with dumped particle data, 0 no * + ! 3 use self-defined initial conditions in netcdf * + ! 4 initial run using option 3, restart from restart.bin* + ! ipout 0 no particle dump, 1 every output time, 3 only at end* + ! ipoutfac increase particle dump interval by factor (default 1) * + ! 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 * + ! * + ! Constants: * + ! unitcommand unit connected to file COMMAND * + ! * + !***************************************************************************** + + implicit none + + character(len=50) :: line + logical :: old + integer :: ios + + namelist /command/ & + ldirect, & + ibdate,ibtime, & + iedate,ietime, & + loutstep, & + loutaver, & + loutsample, & + loutrestart, & + lsynctime, & + ctl, & + ifine, & + iout, & + ipout, & + ipoutfac, & + lsubgrid, & + lconvection, & + lagespectra, & + ipin, & + ioutputforeachrelease, & + iflux, & + mdomainfill, & + ind_source, & + ind_receptor, & + mquasilag, & + nested_output, & + linit_cond, & + lnetcdfout, & + surf_only, & + cblflag, & + linversionout, & + ohfields_path, & + d_trop, & + d_strat, & + nxshift + + ! Presetting namelist command + ldirect=0 + ibdate=20000101 + ibtime=0 + iedate=20000102 + ietime=0 + loutstep=10800 + loutaver=10800 + loutsample=900 + loutrestart=999999999 + lsynctime=900 + ctl=-5.0 + ifine=4 + iout=3 + ipout=0 + ipoutfac=1 + lsubgrid=1 + lconvection=1 + lagespectra=0 + ipin=0 + ioutputforeachrelease=1 + iflux=1 + mdomainfill=0 + ind_source=1 + ind_receptor=1 + mquasilag=0 + nested_output=0 + linit_cond=0 + lnetcdfout=0 + surf_only=0 + cblflag=0 ! if using old-style COMMAND file, set to 1 here to use mc cbl routine + linversionout=0 + ohfields_path="../../flexin/" + nxshift=-9999 + + !Af set release-switch + WETBKDEP=.false. + DRYBKDEP=.false. + + ! Open the command file and read user options + ! Namelist input first: try to read as namelist file + !************************************************************************** + open(unitcommand,file=path(1)(1:length(1))//'COMMAND',status='old', & + form='formatted',err=999) + + ! try namelist input (default) + read(unitcommand,command,iostat=ios) + close(unitcommand) + + ! distinguish namelist from fixed text input + if (ios.ne.0 .or. ldirect.eq.0) then ! parse as text file format +! if (lroot) + write(*,*) 'COMMAND either having unrecognised entries, & + &or in old format, please update to namelist format.' + stop + endif ! input format + + ! write command file in namelist format to output directory if requested +! if (nmlout.and.lroot) then + if (nmlout) then + open(unitcommand,file=path(2)(1:length(2))//'COMMAND.namelist',err=1000) + write(unitcommand,nml=command) + close(unitcommand) + endif + + ifine=max(ifine,1) + + ! Determine how Markov chain is formulated (for w or for w/sigw) + !*************************************************************** + if (cblflag.eq.1) then ! added by MC to set parameters for CBL simulations + turbswitch=.true. + if (lsynctime .gt. maxtl) lsynctime=maxtl !maxtl defined in com_mod.f90 + if (ctl.lt.5) then + print *,'WARNING: CBL flag active the ratio of TLu/dt has been set to 5' + ctl=5. + end if + if (ifine*ctl.lt.50) then + ifine=int(50./ctl)+1 + + print *,'WARNING: CBL flag active the ratio of TLW/dt was < 50, & + &ifine has been re-set to', ifine + !pause + endif + print *,'WARNING: CBL flag active the ratio of TLW/dt is ',ctl*ifine + print *,'WARNING: CBL flag active lsynctime is ',lsynctime + else !added by MC + if (ctl.ge.0.1) then + turbswitch=.true. + else + turbswitch=.false. + ifine=1 + endif + endif !added by MC + 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 particles 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 + ! 0 = no receptors + !Af 1 = mass units + !Af 2 = mass mixing ratio units + ! 3 = wet deposition in outputfield + ! 4 = dry deposition in outputfield + + 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 .le. 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 + select case (ind_receptor) + case (1) ! 1 .. concentration at receptor + ind_rel = 1 + case (2) ! 2 .. mixing ratio at receptor + ind_rel = 0 + case (3) ! 3 .. wet deposition in outputfield + ind_rel = 3 + if (lroot) then + write(*,*) ' #### FLEXPART WET DEPOSITION BACKWARD MODE #### ' + write(*,*) ' #### Releaseheight is forced to 0 - 20km #### ' + write(*,*) ' #### Release is performed above ground lev #### ' + end if + WETBKDEP=.true. + !allocate(xscav_frac1(maxpart,maxspec)) + case (4) ! 4 .. dry deposition in outputfield + ind_rel = 4 + if (lroot) then + write(*,*) ' #### FLEXPART DRY DEPOSITION BACKWARD MODE #### ' + write(*,*) ' #### Releaseheight is forced to 0 - 2*href #### ' + write(*,*) ' #### Release is performed above ground lev #### ' + end if + DRYBKDEP=.true. + !allocate(xscav_frac1(maxpart,maxspec)) + end select + endif + + !************************************************************* + ! Check whether valid options have been chosen in file COMMAND + !************************************************************* + + ! Check options for initial condition output: Switch off for forward runs + !************************************************************************ + + if (ldirect.eq.1) linit_cond=0 + if (linit_cond.lt.0 .or. linit_cond.gt.2) then + write(*,*) ' #### FLEXPART MODEL ERROR! INVALID OPTION #### ' + write(*,*) ' #### FOR LINIT_COND IN FILE "COMMAND". #### ' + stop + endif + + ! 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 IN FILE #### ' + write(*,*) ' #### "COMMAND". #### ' + 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 IN FILE #### ' + write(*,*) ' #### "COMMAND". #### ' + stop + endif + endif + +#ifndef USE_NCF + if ((loutrestart.ne.999999999).or.(ipin.ne.0)) then + write(*,*) ' WARNING: restart option set with intervals' + write(*,*) ' LOUTRESTART', loutrestart + write(*,*) ' not possible when using binary gridded output' + write(*,*) ' ==> RESTART FUNCTION SWITCHED OFF!' + endif + if (ipin.ne.0) then + write(*,*) ' ERROR: restart option not possible using binary' + write(*,*) ' output.' + write(*,*) ' Please only use IPIN>0 when compiling and running using' + write(*,*) ' netcdf output. ' + endif +#else + if ((surf_only.eq.1).or.(linversionout.eq.1)) then + write(*,*) ' ERROR: NetCDF output for surface only or for inversions' + write(*,*) ' is not yet implemented. Please compile without NetCDF.' + stop + endif +#endif + + ! Determine kind of dispersion method + !************************************ + + if (ctl.gt.0.) then + method=1 + mintime=minstep + else + method=0 + mintime=lsynctime + endif + + ! Check for netcdf output switch + !******************************* +#ifdef USE_NCF + lnetcdfout = 1 +#endif + if (iout.ge.8) then + lnetcdfout = 1 + iout = iout - 8 +#ifndef USE_NCF + write(*,*) 'ERROR: netcdf output not activated during compile time & + &but used in COMMAND file!' + write(*,*) 'Please recompile with netcdf library (`make [...] ncf=yes`) & + &or use standard output format.' + stop +#endif + endif +#ifndef USE_NCF + if (ipout.ne.0) then + write(*,*) 'ERROR: NETCDF missing! Please recompile with the netcdf' + write(*,*) 'library if you want the particle dump or set IPOUT=0.' + stop + endif +#endif + + ! Check whether a valid option for gridded model output has been chosen + !********************************************************************** + + if (iout.eq.0) then + write(*,*) 'WARNING: IOUT set to zero, no gridded information will be & + &written to file' + else if ((iout.lt.0).or.(iout.gt.5)) then + write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### ' + write(*,*) ' #### IOUT MUST BE 1, 2, 3, 4 OR 5 FOR #### ' + write(*,*) ' #### STANDARD FLEXPART OUTPUT OR 9 - 13 #### ' + write(*,*) ' #### FOR NETCDF OUTPUT #### ' + 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! FILE COMMAND: #### ' + 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! FILE COMMAND: ####' + 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! FILE COMMAND: ####' + 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 + !***************************************************************************** + + if ((ldirect.lt.0).and.(ioutputforeachrelease.eq.0)) then + write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####' + 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! FILE COMMAND: ####' + write(*,*) '#### FOR DOMAIN FILLING RUNS OUTPUT FOR ####' + write(*,*) '#### EACH RELEASE IS FORBIDDEN ! ####' + stop + endif + + ! Inversion output format only for backward runs + !***************************************************************************** + + if ((linversionout.eq.1).and.(ldirect.eq.1)) then + write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####' + write(*,*) '#### INVERSION OUTPUT FORMAT ONLY FOR ####' + write(*,*) '#### BACKWARD RUNS ####' + 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! FILE COMMAND: ####' + 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! FILE COMMAND: ####' + 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).and.(ipout.ne.3)) then + write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### ' + write(*,*) ' #### IPOUT MUST BE 0, 1, 2 OR 3! #### ' + stop + endif + + ! Check whether input and output settings don't contradict + !********************************************************* + if (((iout.eq.4).or.(iout.eq.5)).and.((ipin.eq.3).or.(ipin.eq.4))) then + write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### ' + write(*,*) ' #### IOUT CANNOT BE 4 or 5 (plume) WHEN #### ' + write(*,*) ' #### READING FROM part_ic.nc (ipin=4/5) #### ' + stop + endif + + if(lsubgrid.ne.1.and.verbosity.eq.0) then + write(*,*) ' ---------------- ' + write(*,*) ' INFORMATION: SUBGRIDSCALE TERRAIN EFFECT IS' + write(*,*) ' NOT PARAMETERIZED DURING THIS SIMULATION. ' + write(*,*) ' ---------------- ' + endif + + + ! Check whether convection scheme is either turned on or off + !*********************************************************** + + if ((lconvection.ne.0).and.(lconvection.ne.1)) then + write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### ' + write(*,*) ' #### LCONVECTION MUST BE SET TO EITHER 1 OR 0#### ' + 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. #### ' + write(*,*) ' #### MINIMUM HAS TO BE: ', idiffnorm/2 + 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 IN FILE COMMAND. #### ' + 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 IN FILE COMMAND. #### ' + 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 IN FILE COMMAND. #### ' + 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 ((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 + + ! 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(*,*) ' #### FILE "COMMAND" MUST BE EITHER -1 OR 1. #### ' + stop + endif + + return + +999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(1)(1:length(1)) + stop + +1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(2)(1:length(2)) + stop +end subroutine readcommand diff --git a/src/rea_readdepo.f90 b/src/rea_readdepo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a575ec7f4be6d5cc24c13a48d65639c2fd8fbaff --- /dev/null +++ b/src/rea_readdepo.f90 @@ -0,0 +1,122 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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: * + ! * + !***************************************************************************** + + 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))//'sfcdepo.txt', & + 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/rea_readlanduse.f90 b/src/rea_readlanduse.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a7af62f2d58f4aa89b19241e4d8c98d4a2594a52 --- /dev/null +++ b/src/rea_readlanduse.f90 @@ -0,0 +1,141 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 drydepo_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', & + form='UNFORMATTED', err=998, convert='little_endian') + 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(unitsfcdata,file=path(1)(1:length(1))//'sfcdata.txt', & + status='old',err=999) + + do i=1,4 + read(unitsfcdata,*) + end do + do i=1,numclass + read(unitsfcdata,'(45x,f15.3)') z0(i) + end do + close(unitsfcdata) + + return + + ! Issue error messages + !********************* + +998 write(*,*) ' #### FLEXPART ERROR! FILE ####' + write(*,*) ' #### ', path(1)(1:length(1))//'IGBP_int1.dat' + write(*,*) " #### (LANDUSE INVENTORY) COULD NOT BE OPENED ####" + stop + +999 write(*,*) ' #### FLEXPART ERROR! FILE ####' + write(*,*) ' #### ', path(1)(1:length(1))//'sfcdata.txt' + write(*,*) ' #### DOES NOT EXIST. Note that ####' + write(*,*) ' #### file was renamed from surfdata.t ####' + write(*,*) ' #### to sfcdata.txt in v11 ####' + stop + +end subroutine readlanduse diff --git a/src/rea_readoutgrid.f90 b/src/rea_readoutgrid.f90 new file mode 100644 index 0000000000000000000000000000000000000000..472574ee67fcbe8cf666e41c60752d42ee3f38ec --- /dev/null +++ b/src/rea_readoutgrid.f90 @@ -0,0 +1,222 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readoutgrid + + !***************************************************************************** + ! * + ! This routine reads the user specifications for the output grid. * + ! * + ! Author: A. Stohl * + ! * + ! 4 June 1996 * + ! HSO, 1 July 2014 + ! Added optional namelist input + ! * + !***************************************************************************** + ! * + ! Variables: * + ! dxout,dyout grid distance * + ! numxgrid,numygrid,numzgrid grid dimensions * + ! outlon0,outlat0 lower left corner of grid * + ! outheight(maxzgrid) height levels of output grid [m] * + ! * + ! Constants: * + ! unitoutgrid unit connected to file OUTGRID * + ! * + !***************************************************************************** + + use prepoutgrid_mod + + implicit none + + integer :: i,j,stat + real :: outhelp,xr,xr1,yr,yr1 + real,parameter :: eps=1.e-4 + + ! namelist variables + integer, parameter :: maxoutlev=500 + integer :: ios + real,allocatable, dimension (:) :: outheights + + ! declare namelist + namelist /outgrid/ & + outlon0,outlat0, & + numxgrid,numygrid, & + dxout,dyout, & + outheights + + ! allocate large array for reading input + allocate(outheights(maxoutlev),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate outheights' + + + ! Open the OUTGRID file and read output grid specifications + !********************************************************** + + open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID',status='old', & + form='formatted',err=999) + +! try namelist input + dxout=-1. + outheights=-1. +! helps identifying failed namelist input + read (unitoutgrid,outgrid,iostat=ios) + close(unitoutgrid) + + if (dxout.le.0 .or. ios.ne.0) then + + ios=1 + + open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID',status='old',err=999) + + call skplin(5,unitoutgrid) + + ! 1. Read horizontal grid specifications + !**************************************** + + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,f11.4)') outlon0 + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,f11.4)') outlat0 + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,i5)') numxgrid + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,i5)') numygrid + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,f12.5)') dxout + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,f12.5)') dyout + + endif + + ! Check validity of output grid (shall be within model domain) + !************************************************************* + + xr=outlon0+real(numxgrid)*dxout + yr=outlat0+real(numygrid)*dyout + xr1=xlon0+real(nxmin1)*dx + yr1=ylat0+real(nymin1)*dy + if ((outlon0+eps.lt.xlon0).or.(outlat0+eps.lt.ylat0) & + .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then + write(*,*) outlon0,outlat0 + write(*,*) xr1,yr1,xlon0,ylat0,xr,yr,dxout,dyout + write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####' + write(*,*) ' #### GRID IS OUTSIDE MODEL DOMAIN. CHANGE ####' + write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####' + write(*,'(a)') path(1)(1:length(1)) + stop + endif + + ! 2. Count Vertical levels of output grid + !**************************************** + + if (ios.ne.0) then + j=0 +100 j=j+1 + do i=1,3 + read(unitoutgrid,*,end=99) + end do + read(unitoutgrid,'(4x,f7.1)',end=99) outhelp + if (outhelp.eq.0.) goto 99 + goto 100 +99 numzgrid=j-1 + else + do i=1,maxoutlev + if (outheights(i).lt.0) exit + end do + numzgrid=i-1 + end if + + allocate(outheight(numzgrid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate outheight' + allocate(outheighthalf(numzgrid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate outheighthalf' + + ! 2. Vertical levels of output grid + !********************************** + + if (ios.ne.0) then + + rewind(unitoutgrid) + call skplin(29,unitoutgrid) + + do j=1,numzgrid + do i=1,3 + read(unitoutgrid,*) + end do + read(unitoutgrid,'(4x,f7.1)') outhelp + outheight(j)=outhelp + outheights(j)=outhelp + end do + close(unitoutgrid) + + else + + do j=1,numzgrid + outheight(j)=outheights(j) + end do + + endif + + ! write outgrid file in namelist format to output directory if requested + if (nmlout.and.lroot) then + ! reallocate outheights with actually required dimension for namelist writing + deallocate(outheights) + allocate(outheights(numzgrid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate outheights' + + do j=1,numzgrid + outheights(j)=outheight(j) + end do + + open(unitoutgrid,file=path(2)(1:length(2))//'OUTGRID.namelist',err=1000) + write(unitoutgrid,nml=outgrid) + close(unitoutgrid) + endif + + ! 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 FILE OUTGRID. #### ' + endif + end do + + ! 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. + end do + + xoutshift=xlon0-outlon0 + youtshift=ylat0-outlat0 + + allocate(oroout(0:numxgrid-1,0:numygrid-1),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate oroout' + allocate(area(0:numxgrid-1,0:numygrid-1),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate area' + allocate(volume(0:numxgrid-1,0:numygrid-1,numzgrid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate volume' + allocate(areaeast(0:numxgrid-1,0:numygrid-1,numzgrid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate areaeast' + allocate(areanorth(0:numxgrid-1,0:numygrid-1,numzgrid),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate areanorth' + return + +999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(1)(1:length(1)) + stop + +1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(2)(1:length(2)) + stop +end subroutine readoutgrid diff --git a/src/rea_readoutgrid_nest.f90 b/src/rea_readoutgrid_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..109a3e6ae29f055dfa3bc8970aa47e260aa4b48c --- /dev/null +++ b/src/rea_readoutgrid_nest.f90 @@ -0,0 +1,122 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readoutgrid_nest + + !***************************************************************************** + ! * + ! This routine reads the user specifications for the output nest. * + ! * + ! Author: A. Stohl * + ! * + ! 4 June 1996 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! dxoutn,dyoutn grid distances of output nest * + ! numxgridn,numygridn,numzgrid nest dimensions * + ! outlon0n,outlat0n lower left corner of nest * + ! outheight(maxzgrid) height levels of output grid [m] * + ! * + ! Constants: * + ! unitoutgrid unit connected to file OUTGRID * + ! * + !***************************************************************************** + + use prepoutgrid_mod + + implicit none + + integer :: stat + real :: xr,xr1,yr,yr1 + real,parameter :: eps=1.e-4 + + integer :: ios + + ! declare namelist + namelist /outgridn/ & + outlon0n,outlat0n, & + numxgridn,numygridn, & + dxoutn,dyoutn + + ! helps identifying failed namelist input + dxoutn=-1.0 + + ! Open the OUTGRID file and read output grid specifications + !********************************************************** + + open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID_NEST',form='formatted',status='old',err=999) + + ! try namelist input + read(unitoutgrid,outgridn,iostat=ios) + close(unitoutgrid) + + if ((dxoutn.le.0).or. ios.ne.0) then + + open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID_NEST',status='old',err=999) + call skplin(5,unitoutgrid) + + ! 1. Read horizontal grid specifications + !**************************************** + + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,f11.4)') outlon0n + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,f11.4)') outlat0n + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,i5)') numxgridn + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,i5)') numygridn + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,f12.5)') dxoutn + call skplin(3,unitoutgrid) + read(unitoutgrid,'(4x,f12.5)') dyoutn + + close(unitoutgrid) + endif + + ! write outgrid_nest file in namelist format to output directory if requested + if (nmlout.and.lroot) then + open(unitoutgrid,file=path(2)(1:length(2))//'OUTGRID_NEST.namelist',err=1000) + write(unitoutgrid,nml=outgridn) + close(unitoutgrid) + endif + + 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' + + ! Check validity of output grid (shall be within model domain) + !************************************************************* + + xr=outlon0n+real(numxgridn)*dxoutn + yr=outlat0n+real(numygridn)*dyoutn + xr1=xlon0+real(nxmin1)*dx + yr1=ylat0+real(nymin1)*dy + if ((outlon0n+eps.lt.xlon0).or.(outlat0n+eps.lt.ylat0) & + .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(*,*) ' #### FILE OUTGRID IN DIRECTORY ####' + write(*,'(a)') path(1)(1:length(1)) + stop + endif + + xoutshiftn=xlon0-outlon0n + youtshiftn=ylat0-outlat0n + return + +999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(1)(1:length(1)) + stop + +1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(2)(1:length(2)) + stop +end subroutine readoutgrid_nest diff --git a/src/rea_readpartoptions.f90 b/src/rea_readpartoptions.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6651c7428d79efff65449c751fad20d2d0926663 --- /dev/null +++ b/src/rea_readpartoptions.f90 @@ -0,0 +1,318 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readpartoptions + + !***************************************************************************** + ! * + ! This routine reads the age classes to be used for the current model * + ! run. * + ! * + ! Author: A. Stohl * + ! 20 March 2000 * + ! HSO, 1 July 2014 * + ! Added optional namelist input * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! Constants: * + ! * + !***************************************************************************** + + implicit none + + integer :: i,np + + ! namelist help variables + integer :: ios + + logical :: & + longitude=.false., & + longitude_average=.false., & + latitude=.false., & + latitude_average=.false., & + height=.false., & + height_average=.false., & + pv=.false., & + pv_average=.false., & + qv=.false., & + qv_average=.false., & + density=.false., & + density_average=.false., & + temperature=.false., & + temperature_average=.false., & + pressure=.false., & + pressure_average=.false., & + mixingheight=.false., & + mixingheight_average=.false., & + tropopause=.false., & + tropopause_average=.false., & + topography=.false., & + topography_average=.false., & + mass=.false., & + mass_average=.false., & + u=.false., & + u_average=.false., & + v=.false., & + v_average=.false., & + w=.false., & + w_average=.false., & + vsettling=.false., & + vsettling_average=.false., & + wetdeposition=.false., & + drydeposition=.false. + + ! namelist declaration + namelist /partoptions/ & + longitude, & + longitude_average, & + latitude, & + latitude_average, & + height, & + height_average, & + pv, & + pv_average, & + qv, & + qv_average, & + density, & + density_average, & + temperature, & + temperature_average, & + pressure, & + pressure_average, & + mixingheight, & + mixingheight_average, & + tropopause, & + tropopause_average, & + topography, & + topography_average, & + mass, & + mass_average, & + u, & + u_average, & + v, & + v_average, & + w, & + w_average, & + vsettling, & + vsettling_average, & + wetdeposition, & + drydeposition + + ! If age spectra claculation is switched on, + ! open the AGECLASSSES file and read user options + !************************************************ + + open(unitpartoptions,file=path(1)(1:length(1))//'PARTOPTIONS',form='formatted',status='old',err=9999) + + ! try to read in as a namelist + read(unitpartoptions,partoptions,iostat=ios) + close(unitpartoptions) + + if (ios.ne.0) then + write(*,*) 'Namelist error in PARTOPTIONS file', trim(path(1)(1:length(1))//'PARTOPTIONS') + stop + endif + allocate( partopt(num_partopt) ) + ! Save values in particle options derived type + !********************************************* + partopt(1)%long_name='longitude' + partopt(1)%name='LO' + partopt(1)%print=longitude + + partopt(2)%long_name='longitude_average' + partopt(2)%name='lo' + partopt(2)%print=longitude_average + partopt(2)%average=.true. + + partopt(3)%long_name='latitude' + partopt(3)%name='LA' + partopt(3)%print=latitude + + partopt(4)%long_name='latitude_average' + partopt(4)%name='la' + partopt(4)%print=latitude_average + partopt(4)%average=.true. + + partopt(5)%long_name='height' + partopt(5)%name='ZZ' + partopt(5)%print=height + + partopt(6)%long_name='height_average' + partopt(6)%name='zz' + partopt(6)%print=height_average + partopt(6)%average=.true. + + partopt(7)%long_name='pv' + partopt(7)%name='PV' + partopt(7)%print=pv + + partopt(8)%long_name='pv_average' + partopt(8)%name='pv' + partopt(8)%print=pv_average + partopt(8)%average=.true. + + partopt(9)%long_name='qv' + partopt(9)%name='QV' + partopt(9)%print=qv + + partopt(10)%long_name='qv_average' + partopt(10)%name='qv' + partopt(10)%print=qv_average + partopt(10)%average=.true. + + partopt(11)%long_name='density' + partopt(11)%name='RH' + partopt(11)%print=density + + partopt(12)%long_name='density_average' + partopt(12)%name='rh' + partopt(12)%print=density_average + partopt(12)%average=.true. + + partopt(13)%long_name='temperature' + partopt(13)%name='TT' + partopt(13)%print=temperature + + partopt(14)%long_name='temperature_average' + partopt(14)%name='tt' + partopt(14)%print=temperature_average + partopt(14)%average=.true. + + partopt(15)%long_name='pressure' + partopt(15)%name='PR' + partopt(15)%print=pressure + + partopt(16)%long_name='pressure_average' + partopt(16)%name='pr' + partopt(16)%print=pressure_average + partopt(16)%average=.true. + + partopt(17)%long_name='mixingheight' + partopt(17)%name='HM' + partopt(17)%print=mixingheight + + partopt(18)%long_name='mixingheight_average' + partopt(18)%name='hm' + partopt(18)%print=mixingheight_average + partopt(18)%average=.true. + + partopt(19)%long_name='tropopause' + partopt(19)%name='TR' + partopt(19)%print=tropopause + + partopt(20)%long_name='tropopause_average' + partopt(20)%name='tr' + partopt(20)%print=tropopause_average + partopt(20)%average=.true. + + partopt(21)%long_name='topography' + partopt(21)%name='TO' + partopt(21)%print=topography + + partopt(22)%long_name='topography_average' + partopt(22)%name='to' + partopt(22)%print=topography_average + partopt(22)%average=.true. + + partopt(23)%long_name='mass' + partopt(23)%name='MA' + partopt(23)%print=mass + + partopt(24)%long_name='mass_average' + partopt(24)%name='ma' + partopt(24)%print=mass_average + partopt(24)%average=.true. + + partopt(25)%long_name='u' + partopt(25)%name='UU' + partopt(25)%print=u + + partopt(26)%long_name='u_average' + partopt(26)%name='uu' + partopt(26)%print=u_average + partopt(26)%average=.true. + + partopt(27)%long_name='v' + partopt(27)%name='VV' + partopt(27)%print=v + + partopt(28)%long_name='v_average' + partopt(28)%name='vv' + partopt(28)%print=v_average + partopt(28)%average=.true. + + partopt(29)%long_name='w' + partopt(29)%name='WW' + partopt(29)%print=w + + partopt(30)%long_name='w_average' + partopt(30)%name='ww' + partopt(30)%print=w_average + partopt(30)%average=.true. + + partopt(31)%long_name='vsettling' + partopt(31)%name='VS' + partopt(31)%print=vsettling + + partopt(32)%long_name='vsettling_average' + partopt(32)%name='vs' + partopt(32)%print=vsettling_average + partopt(32)%average=.true. + + partopt(33)%long_name='wetdeposition' + partopt(33)%name='WD' + partopt(33)%print=wetdeposition + + partopt(34)%long_name='drydeposition' + partopt(34)%name='DD' + partopt(34)%print=drydeposition + ! Numbers are assigned to the averaged fields for proper + ! allocation and reading in particle_mod and output_mod + !****************************************************** + n_average=0 + do np=1,num_partopt + if (partopt(np)%average .and. partopt(np)%print) then + n_average=n_average+1 + partopt(np)%i_average = n_average + if ((partopt(np)%name.eq.'MA') .or. (partopt(np)%name.eq.'ma')) then + n_average=n_average + (maxspec-1) + endif + endif + end do + + ! write partoptions file in namelist format to output directory if requested + if (nmlout.and.lroot) then + open(unitpartoptions,file=path(2)(1:length(2))//'PARTOPTIONS.namelist',err=10000) + write(unitpartoptions,nml=partoptions) + close(unitpartoptions) + endif + + + ! Restart files, when using in combination with averaged particle output, + ! need to be synchronised to prevent false averages in the first step of + ! the new run + !************************************************************************ + if ((ipout.ne.0).and.(n_average.gt.0).and.(loutrestart.ne.-1)) then + if (mod(loutrestart,ipoutfac*loutstep).ne.0) then + write(*,*) '### FLEXPART MODEL ERROR! FILE COMMAND: ###' + write(*,*) '### LOUTRESTART NEEDS TO BE DIVISABLE BY ###' + write(*,*) '### LOUTSTEP*IPOUTFAC. ###' + stop + endif + endif + + return + +9999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "PARTOPTIONS" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(1)(1:length(1)) + stop + +10000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "PARTOPTIONS" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(2)(1:length(2)) + stop +end subroutine readpartoptions diff --git a/src/rea_readpaths.f90 b/src/rea_readpaths.f90 new file mode 100644 index 0000000000000000000000000000000000000000..79cae87f740a4391989f53cd1a2826adf929738e --- /dev/null +++ b/src/rea_readpaths.f90 @@ -0,0 +1,89 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readpaths + + !***************************************************************************** + ! * + ! 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 * + ! last modified * + ! HS, 7.9.2012 * + ! option to give pathnames file as command line option * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! length(numpath) lengths of the path names * + ! path(numpath) pathnames of input/output files * + ! * + ! Constants: * + ! numpath number of pathnames to be read in * + ! * + !***************************************************************************** + + implicit none + + integer :: i + character(256) :: string_test + character(1) :: character_test + + ! Read the pathname information stored in unitpath + !************************************************* + + open(unitpath,file=trim(pathfile),status='old',err=999) + + do i=1,numpath + read(unitpath,'(a)',err=998) path(i) + length(i)=index(path(i),' ')-1 + + + string_test = path(i) + character_test = string_test(length(i):length(i)) + !print*, 'character_test, string_test ', character_test, string_test + if ((character_test .NE. '/') .AND. (i .LT. 4)) then + print*, 'WARNING: path not ending in /' + print*, path(i) + path(i) = string_test(1:length(i)) // '/' + length(i)=length(i)+1 + print*, 'fix: padded with /' + print*, path(i) + print*, 'length(i) increased 1' + endif + end do + + ! Check whether any nested subdomains are to be used + !*************************************************** + + do i=1,maxnests + ! ESO 2016 Added 'end'/'err' in case user forgot '====' at end of file and + ! maxnests > numbnests + read(unitpath,'(a)', end=30, err=30) path(numpath+2*(i-1)+1) + read(unitpath,'(a)', end=30, err=30) 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 + end do + + + ! Determine number of available nested domains + !********************************************* + +30 numbnests=i-1 + + close(unitpath) + return + +998 write(*,*) ' #### TRAJECTORY MODEL ERROR! ERROR WHILE #### ' + write(*,*) ' #### READING FILE PATHNAMES. #### ' + stop + +999 write(*,*) ' #### TRAJECTORY MODEL ERROR! FILE "pathnames"#### ' + write(*,*) ' #### CANNOT BE OPENED IN THE CURRENT WORKING #### ' + write(*,*) ' #### DIRECTORY. #### ' + stop +end subroutine readpaths diff --git a/src/rea_readreceptors.f90 b/src/rea_readreceptors.f90 new file mode 100644 index 0000000000000000000000000000000000000000..ab1772b2d01ab063321f9e89bf7b6db9749042ec --- /dev/null +++ b/src/rea_readreceptors.f90 @@ -0,0 +1,197 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readreceptors + + !***************************************************************************** + ! * + ! This routine reads the user specifications for the receptor points. * + ! * + ! Author: A. Stohl * + ! 1 August 1996 * + ! * + ! HSO, 14 August 2013: Added optional namelist input + ! PS, 2/2015: access= -> position= + ! PS, 6/2015: variable names, simplify code + ! PS, 3/2023: remove position=append, makes no sense for new file * + ! * + !***************************************************************************** + ! * + ! 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 * + ! * + !***************************************************************************** + + implicit none + + integer :: j + real :: x,y,xm,ym + character(len=10) :: receptor + + integer :: ios + real :: xlon,ylat ! for namelist input, xlon/xlat are used instead of x,y + + ! declare namelist +! namelist /nml_receptors/ receptor, xlon, ylat + namelist /receptors/ receptor, xlon, ylat + +!CPS I comment this out - why should we not have receptor output in bwd runs? + ! For backward runs, do not allow receptor output. Thus, set number of + ! receptors to zero + ! if (ldirect.lt.0) then + ! numreceptor=0 + ! return + ! endif + + + ! Open the RECEPTORS file and read output grid specifications + !************************************************************ + + open (unitreceptor,file=trim(path(1))//'RECEPTORS',form='formatted', & + status='old',err=999) + +! try namelist input + xlon = -999. ! we need this to check namelist reading + ylat = -999. + read (unitreceptor,receptors,iostat=ios) +! read (unitreceptor,nml_receptors,iostat=ios) +! write (*,*) 'nml_receptors iostat',ios +! write (*,nml_receptors) + close(unitreceptor) + + ! prepare namelist output if requested + if (nmlout) open(unitreceptorout,file=trim(path(2))// & + 'RECEPTORS.namelist',status='new',err=1000) + + if (ios .gt. 0) then + + goto 991 ! wrong variable name in namelist + + elseif (ios .eq. 0) then ! read as namelist + + if (nint(xlon) .eq. -999 .or. nint(ylat) .eq. -999) goto 993 + +! PS: reopen file otherwise first receptor is skipped! + open (unitreceptor,file=trim(path(1))//'RECEPTORS',status='old',err=999) + + j=0 + do while (ios .eq. 0) + j=j+1 + read(unitreceptor,receptors,iostat=ios) +! read(unitreceptor,nml_receptors,iostat=ios) + if (ios .eq. 0) then + if (j .gt. maxreceptor) then + write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### ' + write(*,*) ' #### POINTS ARE GIVEN. #### ' + write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### ' + write(*,*) ' #### PLEASE MAKE CHANGES IN FILE RECEPTORS #### ' + endif + receptorname(j)=receptor + xreceptor(j)=(xlon-xlon0)/dx ! transform to grid coordinates + yreceptor(j)=(ylat-ylat0)/dy + xm=r_earth*cos(ylat*pi/180.)*dx/180.*pi + ym=r_earth*dy/180.*pi + receptorarea(j)=xm*ym + ! write receptors in namelist format to output directory if requested + if (nmlout) write(unitreceptorout,nml=receptors) +! if (nmlout) write(unitreceptorout,nml=nml_receptors) + elseif (ios .gt. 0) then + write(*,*) ' ### FLEXPART MODEL ERROR! Error in RECEPTORS namelist ###' + stop 'Error in RECEPTORS namelist' + else + write (*,*) 'receptor read in nml format, ios<0', ios + write (*,receptors) +! write (*,nml_receptors) + endif + end do ! end nml receptors reading loop + + numreceptor=j-1 + + else ! ios<0 = EOF, read as conventional input file + + open (unitreceptor,file=trim(path(1))//'RECEPTORS',status='old',err=999) + call skplin(5,unitreceptor) + + ! Read the names and coordinates of the receptors + !************************************************ + + j=1 +100 continue + read(unitreceptor,*,end=99) + read(unitreceptor,*,end=99) + read(unitreceptor,*,end=99) + read(unitreceptor,'(4x,a16)',end=99) receptor + call skplin(3,unitreceptor) + read(unitreceptor,'(4x,f11.4)',end=99) xlon + call skplin(3,unitreceptor) + read(unitreceptor,'(4x,f11.4)',end=99) ylat + if (xlon.eq.0. .and. ylat.eq.0. .and. & + (receptor .eq. ' ')) then + write(*,*) 'WARNING: looks like empty receptor at south pole;'// & + ' will be skipped' + j=j-1 + goto 100 + endif + + if (j .gt. maxreceptor) goto 992 + + receptorname(j)=receptor + xreceptor(j)=(xlon-xlon0)/dx ! transform to grid coordinates + yreceptor(j)=(ylat-ylat0)/dy + xm=r_earth*cos(ylat*pi/180.)*dx/180.*pi + ym=r_earth*dy/180.*pi + receptorarea(j)=xm*ym + ! write receptors file in namelist format to output directory if requested + if (nmlout) write(unitreceptorout,nml=receptors) +! if (nmlout) write(unitreceptorout,nml=nml_receptors) + goto 100 + +99 numreceptor=j-1 + + endif ! end no-nml / nml bloc + + close (unitreceptor) + if (nmlout) close (unitreceptorout) + + return + +991 continue + write(*,*) '#### FLEXPART ERROR: wrong variable names present' + write(*,*) '#### in namelist in file RECEPTORS' + write(*,*) '#### note that in v11+ coordinate names are xlon and ylat' + + stop + +992 continue + write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### ' + write(*,*) ' #### POINTS ARE GIVEN. #### ' + write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### ' +! write(*,*) ' #### PLEASE MAKE CHANGES IN FILE RECEPTORS #### ' + stop + +993 continue + write(*,*) '#### FLEXPART ERROR: namelist in file RECEPTORS' + write(*,*) '#### first receptor point did not contain xlon and/or ylat' + write(*,*) '#### Check your namelist!' + stop + +999 write(*,*) 'INFORMATION: input file RECEPTORS cannot be opened' + write(*,*) 'in directory '//trim(path(1)) + write(*,*) 'Continuing without RECEPTOR' + + numreceptor=0 + return + +1000 write(*,*) ' #### FLEXPART MODEL ERROR! File "RECEPTORS" #### ' + write(*,*) ' #### cannot be opened in the output directory #### ' + write(*,'(a)') ' #### '//trim(path(2)) + write(*,*) ' #### either write perm missing or old file exists ###' + + stop + +end subroutine readreceptors diff --git a/src/rea_readreleases.f90 b/src/rea_readreleases.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d7e8ba8c72458f10aba623df5226535acd6a36b4 --- /dev/null +++ b/src/rea_readreleases.f90 @@ -0,0 +1,555 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readreleases + + !***************************************************************************** + ! * + ! This routine reads the release point specifications for the current * + ! model run. Several release points can be used at the same time. * + ! * + ! Author: A. Stohl * + ! * + ! 18 May 1996 * + ! * + ! Update: 29 January 2001 * + ! Release altitude can be either in magl or masl * + ! HSO, 12 August 2013 + ! Added optional namelist input + ! * + !***************************************************************************** + ! * + ! 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 * + ! area * + ! weta_gas, wetb_gas parameters for below-cloud scavenging (gas) * + ! crain_aero, csnow_aero parameters for below-cloud scavenging (aerosol) * + ! ccn_aero, in_aero parameters for in-cloud scavenging (aerosol) * + ! zpoint1,zpoint2 height range, over which release takes place * + ! num_min_discrete if less, release cannot be randomized and happens at * + ! time mid-point of release interval * + ! lroot true if serial version, or if MPI and root process * + ! * + !***************************************************************************** + + use point_mod + use xmass_mod + use drydepo_mod + + implicit none + + integer :: numpartmax,i,j,id1,it1,id2,it2,idum,stat,irel,ispc,nsettle + integer,parameter :: num_min_discrete=100 + real :: releaserate,xdum,cun + real(kind=dp) :: jul1,jul2,julm + real,parameter :: eps2=1.e-9 + character(len=50) :: line + logical :: old + + ! help variables for namelist reading + integer :: numpoints, parts, ios + integer*2 :: zkind + integer :: idate1, itime1, idate2, itime2 + real :: lon1,lon2,lat1,lat2,z1,z2 + character*40 :: comment + integer,parameter :: unitreleasesout=2 + real,allocatable, dimension (:) :: mass + integer,allocatable, dimension (:) :: specnum_rel,specnum_rel2 + real,allocatable,dimension(:) :: vsh,fracth,schmih + + ! declare namelists + namelist /releases_ctrl/ & + nspec, & + specnum_rel + + namelist /release/ & + idate1, itime1, & + idate2, itime2, & + lon1, lon2, & + lat1, lat2, & + z1, z2, & + zkind, & + mass, & + parts, & + comment + + numpoint=0 + + ! allocate with maxspec for first input loop + allocate(mass(maxspec),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate mass' + allocate(specnum_rel(maxspec),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel' + + ! presetting namelist releases_ctrl + nspec = -1 ! use negative value to determine failed namelist input + specnum_rel = 0 + + !sec, read release to find how many releasepoints should be allocated + open(unitreleases,file=path(1)(1:length(1))//'RELEASES',status='old', & + form='formatted',err=999) + + ! check if namelist input provided + read(unitreleases,releases_ctrl,iostat=ios) + + ! prepare namelist output if requested +! if (nmlout.and.lroot) then + if (nmlout) & + open(unitreleasesout,file=path(2)(1:length(2))//'RELEASES.namelist', & + access='append',status='replace',err=1000) + + if (ios.ne.0 .or. nspec.lt.0) then +! if (lroot) write(*,*) 'RELEASE either having unrecognised entries, & +! &or in old format, please update to namelist format.' + write(*,*) 'RELEASE either having unrecognised entries, & + &or in old format, please update to namelist format.' + stop + else + if (ipin.ne.3 .and. ipin.ne.4) then + ! Not necessary to read releases when using part_ic.nc + ios=0 + do while (ios.eq.0) + idate1=-1 + read(unitreleases,release,iostat=ios) + if ((idate1.lt.0).or. ios.ne.0) then + ios=1 + else + numpoint=numpoint+1 + endif + end do + ios=0 + else + numpoint=1 + endif + endif + + rewind(unitreleases) + + if (nspec.gt.maxspec) goto 994 + + ! allocate arrays of matching size for number of species (namelist output) + deallocate(mass) + allocate(mass(nspec),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate mass' + allocate(specnum_rel2(nspec),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel2' + specnum_rel2=specnum_rel(1:nspec) + deallocate(specnum_rel) + ! eso: BUG, crashes here for nspec=12 and maxspec=6, + ! TODO: catch error and exit + allocate(specnum_rel(nspec),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel' + specnum_rel=specnum_rel2 + deallocate(specnum_rel2) + + !allocate memory for numpoint releaspoints + allocate(ireleasestart(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate ireleasestart' + allocate(ireleaseend(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate ireleaseend' + allocate(xpoint1(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate xpoint1' + allocate(xpoint2(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate xpoint2' + allocate(ypoint1(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate ypoint1' + allocate(ypoint2(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate ypoint2' + allocate(zpoint1(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate zpoint1' + allocate(zpoint2(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate zpoint2' + allocate(kindz(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate kindz' + allocate(xmass(numpoint,maxspec),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate xmass' + allocate(rho_rel(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate rho_rel' + allocate(npart(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate npart' + allocate(xmasssave(numpoint),stat=stat) + if (stat.ne.0) write(*,*)'ERROR: could not allocate xmasssave' + + if (lroot) write (*,*) 'Releasepoints : ', numpoint + + do i=1,numpoint + xmasssave(i)=0. + end do + + !now save the information + DEP=.false. + DRYDEP=.false. + WETDEP=.false. + OHREA=.false. + do i=1,maxspec + DRYDEPSPEC(i)=.false. + WETDEPSPEC(i)=.false. + end do + + ! namelist output + if (nmlout.and.lroot) then + write(unitreleasesout,nml=releases_ctrl) + endif + + do i=1,nspec + call readspecies(specnum_rel(i),i) + + + ! Allocate temporary memory necessary for the different diameter bins + !******************************************************************** + allocate(vsh(ndia(i)),fracth(ndia(i)),schmih(ndia(i))) + + ! Molecular weight + !***************** + + 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/decay(i) !conversion half life to decay constant + + + ! Dry deposition of gases + !************************ + + if (reldiff(i).gt.0.) rm(i)=1./(henry(i)/3000.+100.*f0(i)) ! mesophyll resistance + + ! Dry deposition of particles + !**************************** + + vsetaver(i)=0. + cunningham(i)=0. + dquer(i)=dquer(i)*1000000. ! Conversion m to um + if (density(i).gt.0.) then ! Additional parameters + call part0(dquer(i),dsigma(i),density(i),ndia(i),fracth,schmih,cun,vsh) + do j=1,ndia(i) + 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) + end do + if (lroot) write(*,*) 'Average settling velocity: ',i,vsetaver(i) + endif + + ! Dry deposition for constant deposition velocity + !************************************************ + + dryvel(i)=dryvel(i)*0.01 ! conversion to m/s + + ! Check if wet deposition or OH reaction shall be calculated + !*********************************************************** + + ! ESO 04.2016 check for below-cloud scavenging (gas or aerosol) + if ((dquer(i).le.0..and.(weta_gas(i).gt.0. .or. wetb_gas(i).gt.0.)) .or. & + &(dquer(i).gt.0. .and. (crain_aero(i) .gt. 0. .or. csnow_aero(i).gt.0.))) then + WETDEP=.true. + WETDEPSPEC(i)=.true. + if (lroot) then + write (*,*) ' Below-cloud scavenging: ON' + ! write (*,*) 'Below-cloud scavenging coefficients: ',weta(i),i + end if + else + if (lroot) write (*,*) ' Below-cloud scavenging: OFF' + endif + + ! NIK 31.01.2013 + 10.12.2013 + 15.02.2015 + if (dquer(i).gt.0..and.(ccn_aero(i).gt.0. .or. in_aero(i).gt.0.)) then + WETDEP=.true. + WETDEPSPEC(i)=.true. + if (lroot) then + write (*,*) ' In-cloud scavenging: ON' + ! write (*,*) 'In-cloud scavenging coefficients: ',& + ! &ccn_aero(i),in_aero(i),i !,wetc_in(i), wetd_in(i),i + end if + else + if (lroot) write (*,*) ' In-cloud scavenging: OFF' + endif + + if (ohcconst(i).gt.0.) then + OHREA=.true. + if (lroot) write (*,*) ' OHreaction switched on: ',ohcconst(i),i + endif + + if ((reldiff(i).gt.0.).or.(density(i).gt.0.).or.(dryvel(i).gt.0.)) then + DRYDEP=.true. + DRYDEPSPEC(i)=.true. + endif + + deallocate(vsh,fracth,schmih) + end do ! end loop over species + + if (WETDEP.or.DRYDEP) DEP=.true. + + ! Not necessary to read releases when using part_ic.nc + !***************************************************** + if ((ipin.eq.3).or.(ipin.eq.4)) then + maxpointspec_act=1 + return + endif + + ! Read specifications for each release point + !******************************************* + numpoints=numpoint + numpoint=0 + numpartmax=0 + releaserate=0. +101 numpoint=numpoint+1 + + if (numpoint.gt.numpoints) goto 250 + zkind = 1 + mass = 0 + parts = 0 + comment = ' ' + read(unitreleases,release,iostat=ios) + id1=idate1 + it1=itime1 + id2=idate2 + it2=itime2 + xpoint1(numpoint)=lon1 + xpoint2(numpoint)=lon2 + ypoint1(numpoint)=lat1 + ypoint2(numpoint)=lat2 + zpoint1(numpoint)=z1 + zpoint2(numpoint)=z2 + kindz(numpoint)=zkind + do i=1,nspec + xmass(numpoint,i)=mass(i) + end do + npart(numpoint)=parts + compoint(min(1001,numpoint))=comment + +! namelist output + if (nmlout.and.lroot) then + write(unitreleasesout,nml=release) + endif + + ! If a release point contains no particles, stop and issue error message + !*********************************************************************** + + if (npart(numpoint).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 + + ! If FLEXPART is run for backward deposition force zpoint + !********************************************************************* + if (WETBKDEP) then + zpoint1(numpoint)=0. + zpoint2(numpoint)=20000. + kindz(numpoint)=1 + endif + if (DRYBKDEP) then + zpoint1(numpoint)=0. + zpoint2(numpoint)=2.*href + kindz(numpoint)=1 + endif + + + ! Check whether x coordinates of release point are within model domain + !********************************************************************* + + 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) + julm=(jul1+jul2)/2. + 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)).and.(ipin.eq.0)) 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 + if (npart(numpoint).gt.num_min_discrete) then + ireleasestart(numpoint)=int((jul1-bdate)*86400.) + ireleaseend(numpoint)=int((jul2-bdate)*86400.) + else + ireleasestart(numpoint)=int((julm-bdate)*86400.) + ireleaseend(numpoint)=int((julm-bdate)*86400.) + endif + else if (ldirect.eq.-1) then + if (((jul1.lt.edate).or.(jul2.gt.bdate)).and.(ipin.eq.0)) 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 + if (npart(numpoint).gt.num_min_discrete) then + ireleasestart(numpoint)=int((jul1-bdate)*86400.) + ireleaseend(numpoint)=int((jul2-bdate)*86400.) + else + ireleasestart(numpoint)=int((julm-bdate)*86400.) + ireleaseend(numpoint)=int((julm-bdate)*86400.) + endif + endif + endif + + + ! Determine the release rate (particles per second) and total number + ! of particles released during the simulation + !******************************************************************* + + if (ireleasestart(numpoint).ne.ireleaseend(numpoint)) then + releaserate=releaserate+real(npart(numpoint))/ & + real(ireleaseend(numpoint)-ireleasestart(numpoint)) + else + releaserate=99999999 + endif + numpartmax=numpartmax+npart(numpoint) + goto 101 + +250 close(unitreleases) + + if (nmlout.and.lroot) then + close(unitreleasesout) + endif + + !if (lroot) write (*,*) 'Particles allocated (maxpart) : ',maxpart + if (lroot) write (*,*) 'Particles released (numpartmax): ',numpartmax + numpoint=numpoint-1 + + if (ioutputforeachrelease.eq.1) then + maxpointspec_act=numpoint + else + maxpointspec_act=1 + endif + + ! Disable settling if more than 1 species at any release point + ! or if MQUASILAG and more than one species + !************************************************************* + + if (mquasilag.ne.0) then + if (nspec.gt.1) lsettling=.false. + else + do irel=1,numpoint + nsettle=0 + do ispc=1,nspec + if (xmass(irel,ispc).gt.eps2) nsettle=nsettle+1 + end do + if (nsettle.gt.1) lsettling=.false. + end do + end if + + if (lroot) then + if (.not.lsettling) then + write(*,*) 'WARNING: more than 1 species per release point, settling & + &disabled' + end if + end if + + ! Check, whether the total number of particles may exceed totally allowed + ! number of particles at some time during the simulation + !************************************************************************ + + ! if (releaserate.gt. & + ! 0.99*real(maxpart)/real(lage(nageclass))) then + ! if (numpartmax.gt.maxpart.and.lroot) 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 + + + if (lroot) then + write(*,FMT='(A,ES14.7)') ' Total mass released:', sum(xmass(1:numpoint,1:nspec)) + end if + + return + +994 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 + +998 write(*,*) '#####################################################' + write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####' + write(*,*) '#### ####' + write(*,*) '#### FATAL ERROR - FILE "RELEASES" IS ####' + write(*,*) '#### CORRUPT. PLEASE CHECK YOUR INPUTS FOR ####' + write(*,*) '#### MISTAKES OR GET A NEW "RELEASES"- ####' + write(*,*) '#### FILE ... ####' + 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 + +1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "RELEASES" #### ' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(2)(1:length(2)) + stop +end subroutine readreleases diff --git a/src/rea_readspecies.f90 b/src/rea_readspecies.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4657539e0936e3b449617b6ed35557ecf24e9c3c --- /dev/null +++ b/src/rea_readspecies.f90 @@ -0,0 +1,504 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readspecies(id_spec,pos_spec) + + !***************************************************************************** + ! * + ! This routine reads names and physical constants of chemical species/ * + ! radionuclides given in the parameter pos_spec * + ! * + ! Author: A. Stohl * + ! * + ! 11 July 1996 * + ! * + ! Changes: * + ! N. Kristiansen, 31.01.2013: Including parameters for in-cloud scavenging * + ! * + ! HSO, 13 August 2013 + ! added optional namelist input + ! * + !***************************************************************************** + ! * + ! Variables: * + ! decaytime(maxtable) half time for radiological decay * + ! specname(maxtable) names of chemical species, radionuclides * + ! weta_gas, wetb_gas Parameters for below-cloud scavenging of gasses * + ! crain_aero,csnow_aero Parameters for below-cloud scavenging of aerosols * + ! ccn_aero,in_aero Parameters for in-cloud scavenging of aerosols * + ! ohcconst OH reaction rate constant C * + ! ohdconst OH reaction rate constant D * + ! ohnconst OH reaction rate constant n * + ! id_spec SPECIES number as referenced in RELEASE file * + ! id_pos position where SPECIES data shall be stored * + ! ni Number of diameter classes of particles * * + ! Constants: * + ! * + !***************************************************************************** + + implicit none + + integer :: i, pos_spec,j + integer :: idow,ihour,id_spec + character(len=3) :: aspecnumb + logical :: spec_found + + character(len=16) :: pspecies + real :: pdecay, pweta_gas, pwetb_gas, preldiff, phenry, pf0, pdensity, pdquer + real :: pdsigma, pdryvel, pweightmolar, pohcconst, pohdconst, pohnconst + real :: pcrain_aero, pcsnow_aero, pccn_aero, pin_aero + real :: parea_dow(7), parea_hour(24), ppoint_dow(7), ppoint_hour(24) + integer :: pndia + integer :: ios + integer :: pshape,porient + ! Daria Tatsii: species shape properties + real ::pla,pia,psa,f,e,paspectratio + real :: la(maxspec),ia(maxspec),sa(maxspec) ! Axes + + ! declare namelist + namelist /species_params/ & + pspecies, pdecay, pweta_gas, pwetb_gas, & + pcrain_aero, pcsnow_aero, pccn_aero, pin_aero, & + preldiff, phenry, pf0, pdensity, pdquer, & + pdsigma, pndia, pdryvel, pweightmolar, pohcconst, pohdconst, pohnconst, & + parea_dow, parea_hour, ppoint_dow, ppoint_hour, & + pshape, paspectratio, pla, pia, psa, porient + + pspecies="" ! read failure indicator value + pdecay=-999.9 + pweta_gas=-9.9E-09 + pwetb_gas=0.0 + pcrain_aero=-9.9E-09 + pcsnow_aero=-9.9E-09 + pccn_aero=-9.9E-09 + pin_aero=-9.9E-09 + preldiff=-9.9 + phenry=0.0 + pf0=0.0 + pdensity=-9.9E09 + pdquer=0.0 + pdsigma=0.0 + pndia=1 + pdryvel=-9.99 + pohcconst=-9.99 + pohdconst=-9.9E-09 + pohnconst=2.0 + pweightmolar=-999.9 + parea_dow=-999.9 + parea_hour=-999.9 + ppoint_dow=-999.9 + ppoint_hour=-999.9 + pshape=0 ! 0 for sphere, 1 for other shapes + paspectratio=-1. + pla=-1. ! longest axis in micrometer + pia=-1. ! Intermediate axis + psa=-1. ! Smallest axis + porient=0 ! 0 for horizontal, 1 for random + + + do j=1,24 ! initialize everything to no variation + parea_hour(j)=1. + ppoint_hour(j)=1. + area_hour(pos_spec,j)=1. + point_hour(pos_spec,j)=1. + end do + do j=1,7 + parea_dow(j)=1. + ppoint_dow(j)=1. + area_dow(pos_spec,j)=1. + point_dow(pos_spec,j)=1. + end do + + ! Open the SPECIES file and read species names and properties + !************************************************************ + specnum(pos_spec)=id_spec + write(aspecnumb,'(i3.3)') specnum(pos_spec) + open(unitspecies,file=path(1)(1:length(1))//'SPECIES/SPECIES_'//aspecnumb, & + status='old',form='formatted',err=998) + !write(*,*) 'reading SPECIES',specnum(pos_spec) + + ASSSPEC=.FALSE. + + ! try namelist input + read(unitspecies,species_params,iostat=ios) + close(unitspecies) + + if ((len(trim(pspecies)).eq.0).or. ios.ne.0) then ! no namelist found + if (lroot) write(*,*) "SPECIES file not in NAMELIST format, attempting to & + &read as fixed format" + + ios=1 + + open(unitspecies,file=path(1)(1:length(1))//'SPECIES/SPECIES_'//aspecnumb, & + status='old',err=998) + + do i=1,6 + read(unitspecies,*) + end do + + read(unitspecies,'(a10)',end=22) species(pos_spec) + ! write(*,*) species(pos_spec) + read(unitspecies,'(f18.1)',end=22) decay(pos_spec) + ! write(*,*) decay(pos_spec) + read(unitspecies,'(e18.1)',end=22) weta_gas(pos_spec) + ! write(*,*) weta_gas(pos_spec) + read(unitspecies,'(f18.2)',end=22) wetb_gas(pos_spec) + ! write(*,*) wetb_gas(pos_spec) + read(unitspecies,'(e18.1)',end=22) crain_aero(pos_spec) + ! write(*,*) crain_aero(pos_spec) + read(unitspecies,'(f18.2)',end=22) csnow_aero(pos_spec) + ! write(*,*) csnow_aero(pos_spec) + !*** NIK 31.01.2013: including in-cloud scavening parameters + read(unitspecies,'(e18.1)',end=22) ccn_aero(pos_spec) + ! write(*,*) ccn_aero(pos_spec) + read(unitspecies,'(f18.2)',end=22) in_aero(pos_spec) + ! write(*,*) in_aero(pos_spec) + read(unitspecies,'(f18.1)',end=22) reldiff(pos_spec) + ! write(*,*) reldiff(pos_spec) + read(unitspecies,'(e18.1)',end=22) henry(pos_spec) + ! write(*,*) henry(pos_spec) + read(unitspecies,'(f18.1)',end=22) f0(pos_spec) + ! write(*,*) f0(pos_spec) + read(unitspecies,'(e18.1)',end=22) density(pos_spec) + ! write(*,*) density(pos_spec) + read(unitspecies,'(e18.1)',end=22) dquer(pos_spec) + ! write(*,*) 'dquer(pos_spec):', dquer(pos_spec) + read(unitspecies,'(e18.1)',end=22) dsigma(pos_spec) + ! write(*,*) dsigma(pos_spec) + read(unitspecies,'(i16)',end=22) ndia(pos_spec) + ! write(*,*) ndia(pos_spec) + read(unitspecies,'(f18.2)',end=22) dryvel(pos_spec) + ! write(*,*) dryvel(pos_spec) + read(unitspecies,'(f18.2)',end=22) weightmolar(pos_spec) + ! write(*,*) weightmolar(pos_spec) + read(unitspecies,'(e18.2)',end=22) ohcconst(pos_spec) + ! write(*,*) ohcconst(pos_spec) + read(unitspecies,'(f8.2)',end=22) ohdconst(pos_spec) + ! write(*,*) ohdconst(pos_spec) + read(unitspecies,'(f8.2)',end=22) ohnconst(pos_spec) + ! write(*,*) ohnconst(pos_spec) + + ! Read in daily and day-of-week variation of emissions, if available + !******************************************************************* + + read(unitspecies,*,end=22) + do j=1,24 ! 24 hours, starting with 0-1 local time + read(unitspecies,*) ihour,area_hour(pos_spec,j),point_hour(pos_spec,j) + end do + read(unitspecies,*) + do j=1,7 ! 7 days of the week, starting with Monday + read(unitspecies,*) idow,area_dow(pos_spec,j),point_dow(pos_spec,j) + end do + + pspecies=species(pos_spec) + pdecay=decay(pos_spec) + pweta_gas=weta_gas(pos_spec) + pwetb_gas=wetb_gas(pos_spec) + pcrain_aero=crain_aero(pos_spec) + pcsnow_aero=csnow_aero(pos_spec) + pccn_aero=ccn_aero(pos_spec) + pin_aero=in_aero(pos_spec) + preldiff=reldiff(pos_spec) + phenry=henry(pos_spec) + pf0=f0(pos_spec) + pdensity=density(pos_spec) + pdquer=dquer(pos_spec) + pdsigma=dsigma(pos_spec) + pndia=ndia(pos_spec) + pdryvel=dryvel(pos_spec) + pweightmolar=weightmolar(pos_spec) + pohcconst=ohcconst(pos_spec) + pohdconst=ohdconst(pos_spec) + pohnconst=ohnconst(pos_spec) + + + do j=1,24 ! 24 hours, starting with 0-1 local time + parea_hour(j)=area_hour(pos_spec,j) + ppoint_hour(j)=point_hour(pos_spec,j) + end do + do j=1,7 ! 7 days of the week, starting with Monday + parea_dow(j)=area_dow(pos_spec,j) + ppoint_dow(j)=point_dow(pos_spec,j) + end do + + else ! namelist available + + species(pos_spec)=pspecies + decay(pos_spec)=pdecay + weta_gas(pos_spec)=pweta_gas + wetb_gas(pos_spec)=pwetb_gas + crain_aero(pos_spec)=pcrain_aero + csnow_aero(pos_spec)=pcsnow_aero + ccn_aero(pos_spec)=pccn_aero + in_aero(pos_spec)=pin_aero + reldiff(pos_spec)=preldiff + henry(pos_spec)=phenry + f0(pos_spec)=pf0 + density(pos_spec)=pdensity + dquer(pos_spec)=pdquer + dsigma(pos_spec)=pdsigma + ndia(pos_spec)=pndia + dryvel(pos_spec)=pdryvel + weightmolar(pos_spec)=pweightmolar + ohcconst(pos_spec)=pohcconst + ohdconst(pos_spec)=pohdconst + ohnconst(pos_spec)=pohnconst + shape(pos_spec)=pshape + orient(pos_spec)=porient + + + ! Daria Tatsii 2023: compute particle shape dimensions + if (shape(pos_spec).ge.1) then ! Compute shape according to given axes + select case (shape(pos_spec)) + case (1) + write(*,*) "Particle shape USER-DEFINED for particle", id_spec + if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then + write(*,*) "#### ERROR: Shape=1 (user-defined) is chosen, & + &but no valid axes are provided." + write(*,*) "#### SPECIES file requires SA, IA, and LA parameter& + &greater than zero." + stop + endif + write(*,*) "SA,IA,LA:",psa,pia,pla + case (2) ! Cylinders (fibers) ! + if (paspectratio.le.0.0) then + write(*,*) "#### ERROR: Shape=2 cylinder is chosen, but no valid apect ratio is provided." + write(*,*) "#### SPECIES file requires ASPECTRATIO parameter greater than zero." + stop + endif + psa=(((dquer(pos_spec)**3.0)*2.0)/ & + (3.0*paspectratio))**(1.0/3.0) + pia=psa + pla=psa*paspectratio + write(*,*) "Particle shape CYLINDER for particle", id_spec + write(*,*) "SA,IA,LA:",psa,pia,pla + case (3) ! Cubes ! + write(*,*) "Particle shape CUBE for particle", id_spec + psa=((dquer(pos_spec)**3)*pi/6.0)**(1.0/3.0) + pia=(2.0**0.5)*psa + pla=(3.0**0.5)*psa + if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then + write(*,*) "#### ERROR: Shape=3 (user-defined) is chosen, but no valid axes are provided." + write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero." + stop + endif + write(*,*) "SA,IA,LA:",psa,pia,pla + case (4) ! Tetrahedrons ! + write(*,*) "Particle shape TETRAHEDRON for particle", id_spec + pla=((dquer(pos_spec)**3)*pi*2**(0.5))**(1.0/3.0) + pia=pla*((3.0/4.0)**(0.5)) + psa=pla*((2.0/3.0)**(0.5)) + if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then + write(*,*) "#### ERROR: Shape=4 (user-defined) is chosen, but no valid axes are provided." + write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero." + stop + endif + write(*,*) "SA,IA,LA:",psa,pia,pla + case (5) ! Octahedrons ! + write(*,*) "Particle shape OCTAHEDRON for particle", id_spec + psa=dquer(pos_spec)*(pi/(2.0*2.0**(0.5)))**3 + pia=psa + pla=psa*(2.0**(0.5)) + if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then + write(*,*) "#### ERROR: Shape=5 (user-defined) is chosen, but no valid axes are provided." + write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero." + stop + endif + write(*,*) "SA,IA,LA:",psa,pia,pla + case (6) ! Ellipsoids ! + write(*,*) "Particle shape ELLIPSOID for particle", id_spec + psa=dquer(pos_spec)/(2.0**(1.0/3.0)) + pia=psa + pla=2*pia + if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then + write(*,*) "#### ERROR: Shape=6 (user-defined) is chosen, but no valid axes are provided." + write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero." + stop + endif + write(*,*) "SA,IA,LA:",psa,pia,pla + end select + + ! When using the shape option, dquer is the sphere equivalent diameter + f=psa/pia + e=pia/pla + Fn(pos_spec)=f*f*e*((dquer(pos_spec))**3)/(psa*pia*pla) ! Newton's regime + Fs(pos_spec)=f*e**(1.3)*(dquer(pos_spec)**3/(psa*pia*pla)) ! Stokes' regime + else ! Spheres + write(*,*) "Particle shape SPHERE for particle", id_spec + endif + + do j=1,24 ! 24 hours, starting with 0-1 local time + area_hour(pos_spec,j)=parea_hour(j) + point_hour(pos_spec,j)=ppoint_hour(j) + end do + do j=1,7 ! 7 days of the week, starting with Monday + area_dow(pos_spec,j)=parea_dow(j) + point_dow(pos_spec,j)=ppoint_dow(j) + end do + endif + + i=pos_spec + + !NIK 16.02.2015 + ! Check scavenging parameters given in SPECIES file + + if (lroot) then + ! ZHG 2016.04.07 Start of changes + write(*,*) ' ' + if (dquer(pos_spec) .gt.0) write(*,'(a,i3,a,a,a)') ' SPECIES: ', & + id_spec,' ', species(pos_spec),' (AEROSOL) ' + if (dquer(pos_spec) .le.0) write(*,'(a,i3,a,a,a)') ' SPECIES: ', & + id_spec,' ', species(pos_spec),' (GAS) ' + + ! Particles + !********** + if (dquer(pos_spec).gt.0) then + if (ccn_aero(pos_spec) .gt. 0) then + write(*,'(a,f5.2)') ' Particle CCN efficiency (CCNeff):', ccn_aero(pos_spec) + else + write(*,'(a)') ' Particle CCN efficiency (CCNeff): OFF' + endif + if (in_aero(pos_spec) .gt. 0) then + write(*,'(a,f5.2)') ' Particle IN efficiency (INeff) :', in_aero(pos_spec) + else + write(*,'(a)') ' Particle IN efficiency (INeff) : OFF' + endif + if (crain_aero(pos_spec) .gt. 0) then + write(*,'(a,f5.2)') ' Particle Rain efficiency (Crain) :', crain_aero(pos_spec) + else + write(*,'(a)') ' Particle Rain efficiency (Crain) : OFF' + endif + if (csnow_aero(pos_spec) .gt. 0) then + write(*,'(a,f5.2)') ' Particle Snow efficiency (Csnow) :', csnow_aero(pos_spec) + else + write(*,'(a)') ' Particle Snow efficiency (Csnow) : OFF' + end if + if (density(pos_spec) .gt. 0) then + write(*,'(a)') ' Dry deposition is turned : ON' + if (reldiff(pos_spec).gt.0) then + stop 'density>0 (SPECIES is a particle) implies reldiff <=0 ' + endif + else + if (reldiff(pos_spec).le.0) then + stop 'density<=0 (SPECIES is a gas) implies reldiff >0 ' + endif + write(*,'(a)') ' Dry deposition is (density<0) : OFF' + end if + if (crain_aero(pos_spec).gt.10.0 .or. csnow_aero(pos_spec).gt.10.0 .or. & + &ccn_aero(pos_spec).gt.1.0 .or. in_aero(pos_spec).gt.1.0) then + write(*,*) '*******************************************' + write(*,*) ' WARNING: Particle Scavenging parameter likely out of range ' + write(*,*) ' Likely range for Crain 0.0-10' + write(*,*) ' Likely range for Csnow 0.0-10' + write(*,*) ' Physical range for CCNeff 0.0-1' + write(*,*) ' Physical range for INeff 0.0-1' + write(*,*) '*******************************************' + end if + else + ! Gas + !**** + if (weta_gas(pos_spec) .gt. 0 .and. wetb_gas(pos_spec).gt.0) then + write(*,*) ' Wet removal for gases is turned: ON' + write(*,*) ' Gas below-cloud scavenging parameter A ', & + &weta_gas(pos_spec) + write(*,'(a,f5.2)') ' Gas below-cloud scavenging parameter B ', & + &wetb_gas(pos_spec) + else + write(*,*) ' Wet removal for gases is turned: OFF ' + end if + if (reldiff(i).gt.0.) then + write(*,*) ' Dry deposition for gases is turned: ON ' + else + write(*,*) ' Dry deposition for gases is turned: OFF ' + end if + if (weta_gas(pos_spec).gt.0.) then !if wet deposition is turned on + if (weta_gas(pos_spec).gt.1E-04 .or. weta_gas(pos_spec).lt.1E-09 .or. & + &wetb_gas(pos_spec).gt.0.8 .or. wetb_gas(pos_spec).lt.0.4) then + write(*,*) '*******************************************' + write(*,*) ' WARNING: Gas below-cloud scavengig is out of likely range' + write(*,*) ' Likely range for A is 1E-04 to 1E-08' + write(*,*) ' Likely range for B is 0.60 to 0.80 ' + write(*,*) '*******************************************' + end if + endif + + if (((weta_gas(pos_spec).gt.0).or.(wetb_gas(pos_spec).gt.0)).and.& + &(henry(pos_spec).le.0)) then + if (dquer(pos_spec).le.0) goto 996 ! no particle, no henry set + endif + end if + end if + + if (ndia(pos_spec).gt.maxndia) then + write(*,*) 'NDIA in SPECIES file', pos_spec, 'set to', ndia(pos_spec), 'larger than maxndia', & + maxndia, 'set in par_mod.f90' + endif + ! if (dsigma(i).eq.0.) dsigma(i)=1.0001 ! avoid floating exception + if (dquer(i).gt.0 .and. dsigma(i).le.1.) then !dsigma(i)=1.0001 ! avoid floating exception + !write(*,*) '#### FLEXPART MODEL ERROR! ####' + write(*,*) '#### FLEXPART MODEL WARNING ####' + write(*,*) '#### in SPECIES_',aspecnumb, ' ####' + write(*,*) '#### from v10.4 dsigma has to be larger than 1 ####' + write(*,*) '#### to adapt older SPECIES files, ####' + write(*,*) '#### if dsigma was < 1 ####' + write(*,*) '#### use the reciprocal of the old dsigma ####' + if (.not.debug_mode) then + stop + else + write(*,*) 'debug mode: continue' + endif + endif + + if ((reldiff(i).gt.0.).and.(density(i).gt.0.)) then + write(*,*) '#### FLEXPART MODEL ERROR! FILE "SPECIES" ####' + write(*,*) '#### IS CORRUPT. SPECIES CANNOT BE BOTH ####' + write(*,*) '#### PARTICLE AND GAS. ####' + write(*,*) '#### SPECIES NUMBER',aspecnumb + stop + endif +20 continue + + +22 close(unitspecies) + +! namelist output if requested + if (nmlout.and.lroot) then + open(unitspecies,file=path(2)(1:length(2))//'SPECIES_'//aspecnumb//'.namelist',access='append',status='replace',err=1000) + write(unitspecies,nml=species_params) + close(unitspecies) + endif + + return + +996 write(*,*) '#####################################################' + write(*,*) '#### FLEXPART MODEL ERROR! #### ' + write(*,*) '#### WET DEPOSITION SWITCHED ON, BUT NO HENRYS #### ' + write(*,*) '#### CONSTANT IS SET ####' + write(*,*) '#### PLEASE MODIFY SPECIES DESCR. FILE! #### ' + write(*,*) '#####################################################' + stop + + +997 write(*,*) '#####################################################' + write(*,*) '#### FLEXPART MODEL ERROR! #### ' + write(*,*) '#### THE ASSSOCIATED SPECIES HAS TO BE DEFINED #### ' + write(*,*) '#### BEFORE THE ONE WHICH POINTS AT IT #### ' + write(*,*) '#### PLEASE CHANGE ORDER IN RELEASES OR ADD #### ' + write(*,*) '#### THE ASSOCIATED SPECIES IN RELEASES #### ' + write(*,*) '#####################################################' + stop + + +998 write(*,*) '#####################################################' + write(*,*) '#### FLEXPART MODEL ERROR! #### ' + write(*,*) '#### THE SPECIES FILE FOR SPECIES ', id_spec + write(*,*) '#### CANNOT BE FOUND: CREATE FILE' + write(*,*) '#### ',path(1)(1:length(1)),'SPECIES/SPECIES_',aspecnumb + write(*,*) '#####################################################' + stop + +1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "SPECIES_',aspecnumb,'.namelist' + write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' + write(*,'(a)') path(2)(1:length(2)) + stop +end subroutine readspecies diff --git a/src/rea_skplin.f90 b/src/rea_skplin.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4ffd1b4c8b3620b4c7ec5ef1ee4c85c60b8c4144 --- /dev/null +++ b/src/rea_skplin.f90 @@ -0,0 +1,31 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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/readoptions_mod.f90 b/src/readoptions_mod.f90 index e47a71d2878ed5fb902bce20be782b861a444edf..8331d1648fdaa9d0477968ddf2fbe69aeb4f14e9 100644 --- a/src/readoptions_mod.f90 +++ b/src/readoptions_mod.f90 @@ -19,3355 +19,33 @@ module readoptions_mod contains -subroutine readageclasses +#include "rea_readageclasses.f90" - !***************************************************************************** - ! * - ! This routine reads the age classes to be used for the current model * - ! run. * - ! * - ! Author: A. Stohl * - ! 20 March 2000 * - ! HSO, 1 July 2014 * - ! Added optional namelist input * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! Constants: * - ! * - !***************************************************************************** +#include "rea_readavailable.f90" - implicit none - - integer :: i - - ! namelist help variables - integer :: ios - - ! namelist declaration - namelist /ageclass/ & - nageclass, & - lage - - ! If age spectra calculation is switched off, set number of age classes - ! to 1 and maximum age to a large number - !********************************************************************** - - if (lagespectra.ne.1) then - nageclass=1 - lage(nageclass)=999999999 - return - endif - - ! If age spectra claculation is switched on, - ! open the AGECLASSSES file and read user options - !************************************************ - - open(unitageclasses,file=path(1)(1:length(1))//'AGECLASSES', & - form='formatted',status='old',err=999) - -! try to read in as a namelist - nageclass=-1 ! preset to negative value to identify failed namelist input - read(unitageclasses,ageclass,iostat=ios) - close(unitageclasses) - - if (nageclass.lt.0 .or. ios.ne.0) then - open(unitageclasses,file=path(1)(1:length(1))//'AGECLASSES', & - status='old',err=999) - do i=1,13 - read(unitageclasses,*) - end do - read(unitageclasses,*) nageclass - read(unitageclasses,*) lage(1) - if (nageclass.ge.2) then - do i=2,nageclass - read(unitageclasses,*) lage(i) - end do - endif - close(unitageclasses) - endif - - ! write ageclasses file in namelist format to output directory if requested -! if (nmlout.and.lroot) then - if (nmlout) then - open(unitageclasses,file=path(2)(1:length(2))//'AGECLASSES.namelist', & - err=1000) - write(unitageclasses,nml=ageclass) - close(unitageclasses) - endif - - if (nageclass.gt.maxageclass) then - write(*,*) ' #### FLEXPART MODEL ERROR! NUMBER OF AGE #### ' - write(*,*) ' #### CLASSES GREATER THAN MAXIMUM ALLOWED. #### ' - write(*,*) ' #### CHANGE SETTINGS IN FILE AGECLASSES OR #### ' - write(*,*) ' #### RECOMPILE WITH LARGER MAXAGECLASS IN #### ' - write(*,*) ' #### FILE PAR_MOD. #### ' - 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 FILE AGECLASSES. #### ' - stop - endif - - do i=2,nageclass - 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 FILE AGECLASSES. #### ' - stop - endif - end do - - return - -999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "AGECLASSES" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(1)(1:length(1)) - stop - -1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "AGECLASSES" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(2)(1:length(2)) - stop -end subroutine readageclasses - -subroutine readavailable - - !***************************************************************************** - ! * - ! 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 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! bdate beginning date as Julian date * - ! beg beginning date for windfields * - ! endl 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 * - ! * - !***************************************************************************** - - implicit none - - integer :: i,idiff,ldat,ltim,wftime1(maxwf),numbwfn(maxnests),k - integer :: wftime1n(maxnests,maxwf),wftimen(maxnests,maxwf) - logical :: lwarntd=.true. - real(kind=dp) :: jul,beg,endl - character(len=255) :: fname,spec,wfname1(maxwf),wfspec1(maxwf) - character(len=255) :: wfname1n(maxnests,maxwf) - character(len=40) :: wfspec1n(maxnests,maxwf) - - - ! 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._dp - endl=bdate+real(ideltas,kind=dp)/86400._dp+real(idiffmax,kind=dp)/ & - 86400._dp - else ! backward trajectories - beg=bdate+real(ideltas,kind=dp)/86400._dp-real(idiffmax,kind=dp)/ & - 86400._dp - endl=bdate+1._dp - endif - - ! Open the wind field availability file and read available wind fields - ! within the modelling period. - !********************************************************************* - - open(unitavailab,file=path(4)(1:length(4)),status='old', & - err=999) - - do i=1,3 - read(unitavailab,*) - end do - - numbwf=0 -100 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=99) & - ldat,ltim,fname,spec - jul=juldate(ldat,ltim) - if ((jul.ge.beg).and.(jul.le.endl)) 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(1:index(fname,' ')) - wfspec1(numbwf)=spec - wftime1(numbwf)=nint((jul-bdate)*86400._dp) - 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 - !print*,length(numpath+2*(k-1)+1),length(numpath+2*(k-1)+2),length(4),length(3) - !print*,path(numpath+2*(k-1)+2)(1:length(numpath+2*(k-1)+2)) - open(unitavailab,file=path(numpath+2*(k-1)+2) & - (1:length(numpath+2*(k-1)+2)),status='old',err=998) - - do i=1,3 - read(unitavailab,*) - end do - - numbwfn(k)=0 -700 read(unitavailab,'(i8,1x,i6,2(6x,a255))',end=699) ldat, & - ltim,fname,spec - jul=juldate(ldat,ltim) - if ((jul.ge.beg).and.(jul.le.endl)) 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._dp) - endif - goto 700 ! next wind field - -699 continue - - close(unitavailab) - end do - - - ! 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 - end do - - ! 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(*,*) 'FLEXPART 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 - end do - - end do - - - ! For backward trajectories, reverse the order of the windfields - !*************************************************************** - - if (ideltas.ge.0) then - do i=1,numbwf - wfname(i)=wfname1(i) - wfspec(i)=wfspec1(i) - wftime(i)=wftime1(i) - end do - 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) - end do - end do - else - do i=1,numbwf - wfname(numbwf-i+1)=wfname1(i) - wfspec(numbwf-i+1)=wfspec1(i) - wftime(numbwf-i+1)=wftime1(i) - end do - 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) - end do - end do - 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.and.lroot) 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.and.lroot.and.lwarntd) then - write(*,*) 'FLEXPART WARNING: TIME DIFFERENCE BETWEEN TWO' - write(*,*) 'WIND FIELDS IS BIG. THIS MAY CAUSE A DEGRADATION' - write(*,*) 'OF SIMULATION QUALITY.' - lwarntd=.false. ! only issue this warning once - endif - end do - - do k=1,numbnests - if (numbwfn(k).ne.numbwf) then - write(*,*) 'FLEXPART 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(*,*) 'FLEXPART 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 - end do - end do - - ! 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 - end do - - return - -998 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE FILE #### ' - write(*,'(a)') ' '//path(numpath+2*(k-1)+2) & - (1:length(numpath+2*(k-1)+2)) - write(*,*) ' #### CANNOT BE OPENED #### ' - stop - -999 write(*,*) ' #### FLEXPART MODEL ERROR! AVAILABLE FILE #### ' - write(*,'(a)') ' '//path(4)(1:length(4)) - write(*,*) ' #### CANNOT BE OPENED #### ' - stop -end subroutine readavailable - -subroutine readcommand - - !***************************************************************************** - ! * - ! This routine reads the user specifications for the current model run. * - ! * - ! Author: A. Stohl * - ! * - ! 18 May 1996 * - ! HSO, 1 July 2014 * - ! Added optional namelist input * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! bdate beginning date as Julian date * - ! ctl factor by which time step must be smaller than * - ! Lagrangian time scale * - ! 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 * - ! outputforeachrel for forward runs it is possible either to create * - ! one outputfield or several for each releasepoint * - ! 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 restart.bin file, * - ! 2 continue simulaion with dumped particle data, 0 no * - ! 3 use self-defined initial conditions in netcdf * - ! 4 initial run using option 3, restart from restart.bin* - ! ipout 0 no particle dump, 1 every output time, 3 only at end* - ! ipoutfac increase particle dump interval by factor (default 1) * - ! 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 * - ! * - ! Constants: * - ! unitcommand unit connected to file COMMAND * - ! * - !***************************************************************************** - - implicit none - - character(len=50) :: line - logical :: old - integer :: ios - - namelist /command/ & - ldirect, & - ibdate,ibtime, & - iedate,ietime, & - loutstep, & - loutaver, & - loutsample, & - loutrestart, & - lsynctime, & - ctl, & - ifine, & - iout, & - ipout, & - ipoutfac, & - lsubgrid, & - lconvection, & - lagespectra, & - ipin, & - ioutputforeachrelease, & - iflux, & - mdomainfill, & - ind_source, & - ind_receptor, & - mquasilag, & - nested_output, & - linit_cond, & - lnetcdfout, & - surf_only, & - cblflag, & - linversionout, & - ohfields_path, & - d_trop, & - d_strat, & - nxshift - - ! Presetting namelist command - ldirect=0 - ibdate=20000101 - ibtime=0 - iedate=20000102 - ietime=0 - loutstep=10800 - loutaver=10800 - loutsample=900 - loutrestart=999999999 - lsynctime=900 - ctl=-5.0 - ifine=4 - iout=3 - ipout=0 - ipoutfac=1 - lsubgrid=1 - lconvection=1 - lagespectra=0 - ipin=0 - ioutputforeachrelease=1 - iflux=1 - mdomainfill=0 - ind_source=1 - ind_receptor=1 - mquasilag=0 - nested_output=0 - linit_cond=0 - lnetcdfout=0 - surf_only=0 - cblflag=0 ! if using old-style COMMAND file, set to 1 here to use mc cbl routine - linversionout=0 - ohfields_path="../../flexin/" - nxshift=-9999 - - !Af set release-switch - WETBKDEP=.false. - DRYBKDEP=.false. - - ! Open the command file and read user options - ! Namelist input first: try to read as namelist file - !************************************************************************** - open(unitcommand,file=path(1)(1:length(1))//'COMMAND',status='old', & - form='formatted',err=999) - - ! try namelist input (default) - read(unitcommand,command,iostat=ios) - close(unitcommand) - - ! distinguish namelist from fixed text input - if (ios.ne.0 .or. ldirect.eq.0) then ! parse as text file format -! if (lroot) - write(*,*) 'COMMAND either having unrecognised entries, & - &or in old format, please update to namelist format.' - stop - endif ! input format - - ! write command file in namelist format to output directory if requested -! if (nmlout.and.lroot) then - if (nmlout) then - open(unitcommand,file=path(2)(1:length(2))//'COMMAND.namelist',err=1000) - write(unitcommand,nml=command) - close(unitcommand) - endif - - ifine=max(ifine,1) - - ! Determine how Markov chain is formulated (for w or for w/sigw) - !*************************************************************** - if (cblflag.eq.1) then ! added by MC to set parameters for CBL simulations - turbswitch=.true. - if (lsynctime .gt. maxtl) lsynctime=maxtl !maxtl defined in com_mod.f90 - if (ctl.lt.5) then - print *,'WARNING: CBL flag active the ratio of TLu/dt has been set to 5' - ctl=5. - end if - if (ifine*ctl.lt.50) then - ifine=int(50./ctl)+1 - - print *,'WARNING: CBL flag active the ratio of TLW/dt was < 50, & - &ifine has been re-set to', ifine - !pause - endif - print *,'WARNING: CBL flag active the ratio of TLW/dt is ',ctl*ifine - print *,'WARNING: CBL flag active lsynctime is ',lsynctime - else !added by MC - if (ctl.ge.0.1) then - turbswitch=.true. - else - turbswitch=.false. - ifine=1 - endif - endif !added by MC - 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 particles 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 - ! 0 = no receptors - !Af 1 = mass units - !Af 2 = mass mixing ratio units - ! 3 = wet deposition in outputfield - ! 4 = dry deposition in outputfield - - 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 .le. 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 - select case (ind_receptor) - case (1) ! 1 .. concentration at receptor - ind_rel = 1 - case (2) ! 2 .. mixing ratio at receptor - ind_rel = 0 - case (3) ! 3 .. wet deposition in outputfield - ind_rel = 3 - if (lroot) then - write(*,*) ' #### FLEXPART WET DEPOSITION BACKWARD MODE #### ' - write(*,*) ' #### Releaseheight is forced to 0 - 20km #### ' - write(*,*) ' #### Release is performed above ground lev #### ' - end if - WETBKDEP=.true. - !allocate(xscav_frac1(maxpart,maxspec)) - case (4) ! 4 .. dry deposition in outputfield - ind_rel = 4 - if (lroot) then - write(*,*) ' #### FLEXPART DRY DEPOSITION BACKWARD MODE #### ' - write(*,*) ' #### Releaseheight is forced to 0 - 2*href #### ' - write(*,*) ' #### Release is performed above ground lev #### ' - end if - DRYBKDEP=.true. - !allocate(xscav_frac1(maxpart,maxspec)) - end select - endif - - !************************************************************* - ! Check whether valid options have been chosen in file COMMAND - !************************************************************* - - ! Check options for initial condition output: Switch off for forward runs - !************************************************************************ - - if (ldirect.eq.1) linit_cond=0 - if (linit_cond.lt.0 .or. linit_cond.gt.2) then - write(*,*) ' #### FLEXPART MODEL ERROR! INVALID OPTION #### ' - write(*,*) ' #### FOR LINIT_COND IN FILE "COMMAND". #### ' - stop - endif - - ! 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 IN FILE #### ' - write(*,*) ' #### "COMMAND". #### ' - 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 IN FILE #### ' - write(*,*) ' #### "COMMAND". #### ' - stop - endif - endif - -#ifndef USE_NCF - if ((loutrestart.ne.999999999).or.(ipin.ne.0)) then - write(*,*) ' WARNING: restart option set with intervals' - write(*,*) ' LOUTRESTART', loutrestart - write(*,*) ' not possible when using binary gridded output' - write(*,*) ' ==> RESTART FUNCTION SWITCHED OFF!' - endif - if (ipin.ne.0) then - write(*,*) ' ERROR: restart option not possible using binary' - write(*,*) ' output.' - write(*,*) ' Please only use IPIN>0 when compiling and running using' - write(*,*) ' netcdf output. ' - endif -#else - if ((surf_only.eq.1).or.(linversionout.eq.1)) then - write(*,*) ' ERROR: NetCDF output for surface only or for inversions' - write(*,*) ' is not yet implemented. Please compile without NetCDF.' - stop - endif -#endif - - ! Determine kind of dispersion method - !************************************ - - if (ctl.gt.0.) then - method=1 - mintime=minstep - else - method=0 - mintime=lsynctime - endif - - ! Check for netcdf output switch - !******************************* -#ifdef USE_NCF - lnetcdfout = 1 -#endif - if (iout.ge.8) then - lnetcdfout = 1 - iout = iout - 8 -#ifndef USE_NCF - write(*,*) 'ERROR: netcdf output not activated during compile time & - &but used in COMMAND file!' - write(*,*) 'Please recompile with netcdf library (`make [...] ncf=yes`) & - &or use standard output format.' - stop -#endif - endif -#ifndef USE_NCF - if (ipout.ne.0) then - write(*,*) 'ERROR: NETCDF missing! Please recompile with the netcdf' - write(*,*) 'library if you want the particle dump or set IPOUT=0.' - stop - endif -#endif - - ! Check whether a valid option for gridded model output has been chosen - !********************************************************************** - - if (iout.eq.0) then - write(*,*) 'WARNING: IOUT set to zero, no gridded information will be & - &written to file' - else if ((iout.lt.0).or.(iout.gt.5)) then - write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### ' - write(*,*) ' #### IOUT MUST BE 1, 2, 3, 4 OR 5 FOR #### ' - write(*,*) ' #### STANDARD FLEXPART OUTPUT OR 9 - 13 #### ' - write(*,*) ' #### FOR NETCDF OUTPUT #### ' - 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! FILE COMMAND: #### ' - 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! FILE COMMAND: ####' - 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! FILE COMMAND: ####' - 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 - !***************************************************************************** - - if ((ldirect.lt.0).and.(ioutputforeachrelease.eq.0)) then - write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####' - 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! FILE COMMAND: ####' - write(*,*) '#### FOR DOMAIN FILLING RUNS OUTPUT FOR ####' - write(*,*) '#### EACH RELEASE IS FORBIDDEN ! ####' - stop - endif - - ! Inversion output format only for backward runs - !***************************************************************************** - - if ((linversionout.eq.1).and.(ldirect.eq.1)) then - write(*,*) '#### FLEXPART MODEL ERROR! FILE COMMAND: ####' - write(*,*) '#### INVERSION OUTPUT FORMAT ONLY FOR ####' - write(*,*) '#### BACKWARD RUNS ####' - 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! FILE COMMAND: ####' - 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! FILE COMMAND: ####' - 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).and.(ipout.ne.3)) then - write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### ' - write(*,*) ' #### IPOUT MUST BE 0, 1, 2 OR 3! #### ' - stop - endif - - ! Check whether input and output settings don't contradict - !********************************************************* - if (((iout.eq.4).or.(iout.eq.5)).and.((ipin.eq.3).or.(ipin.eq.4))) then - write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### ' - write(*,*) ' #### IOUT CANNOT BE 4 or 5 (plume) WHEN #### ' - write(*,*) ' #### READING FROM part_ic.nc (ipin=4/5) #### ' - stop - endif - - if(lsubgrid.ne.1.and.verbosity.eq.0) then - write(*,*) ' ---------------- ' - write(*,*) ' INFORMATION: SUBGRIDSCALE TERRAIN EFFECT IS' - write(*,*) ' NOT PARAMETERIZED DURING THIS SIMULATION. ' - write(*,*) ' ---------------- ' - endif - - - ! Check whether convection scheme is either turned on or off - !*********************************************************** - - if ((lconvection.ne.0).and.(lconvection.ne.1)) then - write(*,*) ' #### FLEXPART MODEL ERROR! FILE COMMAND: #### ' - write(*,*) ' #### LCONVECTION MUST BE SET TO EITHER 1 OR 0#### ' - 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. #### ' - write(*,*) ' #### MINIMUM HAS TO BE: ', idiffnorm/2 - 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 IN FILE COMMAND. #### ' - 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 IN FILE COMMAND. #### ' - 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 IN FILE COMMAND. #### ' - 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 ((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 - - ! 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(*,*) ' #### FILE "COMMAND" MUST BE EITHER -1 OR 1. #### ' - stop - endif - - return - -999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(1)(1:length(1)) - stop - -1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "COMMAND" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(2)(1:length(2)) - stop -end subroutine readcommand - -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: * - ! * - !***************************************************************************** - - 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))//'sfcdepo.txt', & - 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 - -subroutine readOHfield - - !***************************************************************************** - ! * - ! Reads the OH field into memory * - ! * - ! AUTHOR: R.L. Thompson, Nov 2014 * - ! * - ! UPDATES: * - ! 03/2018 SEC: Converted original netCDF files to binary format * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! path(numpath) contains the path names * - ! lonOH(nxOH) longitude of OH fields * - ! latOH(nyOH) latitude of OH fields * - ! altOH(nzOH) altitude of OH fields * - ! etaOH(nzOH) eta-levels of OH fields * - ! OH_field(nxOH,nyOH,nzOH,m) OH concentration (molecules/cm3) * - ! * - ! * - !***************************************************************************** - - use ohr_mod - - implicit none - - integer :: i,j,k,l,ierr - real, dimension(:), allocatable :: etaOH - - ! real, parameter :: gasct=8.314 ! gas constant - ! real, parameter :: mct=0.02894 ! kg mol-1 - ! real, parameter :: g=9.80665 ! m s-2 - ! real, parameter :: lrate=0.0065 ! K m-1 - real, parameter :: scalehgt=7000. ! scale height in metres - - - open(unitOH,file=trim(ohfields_path) & - //'OH_FIELDS/OH_variables.bin',status='old', & - form='UNFORMATTED', iostat=ierr, convert='little_endian') - - if(ierr.ne.0) then - write(*,*) 'Cannot read binary OH fields in ', & - trim(ohfields_path)//'OH_FIELDS/OH_variables.bin' - stop - endif - - read(unitOH) nxOH - read(unitOH) nyOH - read(unitOH) nzOH - write(*,*) nxOH,nyOH,nzOH - - ! allocate variables - allocate(lonOH(nxOH)) - allocate(latOH(nyOH)) - allocate(etaOH(nzOH)) - allocate(altOH(nzOH)) - allocate(OH_field(nxOH,nyOH,nzOH,12)) - allocate(OH_hourly(nxOH,nyOH,nzOH,2)) - - read(unitOH) (lonjr(i),i=1,360) - read(unitOH) (latjr(i),i=1,180) - read(unitOH) (((jrate_average(i,j,k),i=1,360),j=1,180),k=1,12) - read(unitOH) (lonOH(i),i=1,nxOH) - read(unitOH) (latOH(i),i=1,nyOH) - read(unitOH) (lonOH(i),i=1,nxOH) - - read(unitOH) (altOH(i),i=1,nzOH) - read(unitOH) ((((OH_field(i,j,k,l),i=1,nxOH),j=1,nyOH),k=1,nzOH),l=1,12) - read(unitOH) ((((OH_hourly(i,j,k,l),i=1,nxOH),j=1,nyOH),k=1,nzOH),l=1,2) - -end subroutine readOHfield - -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 drydepo_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', & - form='UNFORMATTED', err=998, convert='little_endian') - 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(unitsfcdata,file=path(1)(1:length(1))//'sfcdata.txt', & - status='old',err=999) - - do i=1,4 - read(unitsfcdata,*) - end do - do i=1,numclass - read(unitsfcdata,'(45x,f15.3)') z0(i) - end do - close(unitsfcdata) - - return - - ! Issue error messages - !********************* - -998 write(*,*) ' #### FLEXPART ERROR! FILE ####' - write(*,*) ' #### ', path(1)(1:length(1))//'IGBP_int1.dat' - write(*,*) " #### (LANDUSE INVENTORY) COULD NOT BE OPENED ####" - stop - -999 write(*,*) ' #### FLEXPART ERROR! FILE ####' - write(*,*) ' #### ', path(1)(1:length(1))//'sfcdata.txt' - write(*,*) ' #### DOES NOT EXIST. Note that ####' - write(*,*) ' #### file was renamed from surfdata.t ####' - write(*,*) ' #### to sfcdata.txt in v11 ####' - stop - -end subroutine readlanduse - -subroutine readoutgrid - - !***************************************************************************** - ! * - ! This routine reads the user specifications for the output grid. * - ! * - ! Author: A. Stohl * - ! * - ! 4 June 1996 * - ! HSO, 1 July 2014 - ! Added optional namelist input - ! * - !***************************************************************************** - ! * - ! Variables: * - ! dxout,dyout grid distance * - ! numxgrid,numygrid,numzgrid grid dimensions * - ! outlon0,outlat0 lower left corner of grid * - ! outheight(maxzgrid) height levels of output grid [m] * - ! * - ! Constants: * - ! unitoutgrid unit connected to file OUTGRID * - ! * - !***************************************************************************** - - use prepoutgrid_mod - - implicit none - - integer :: i,j,stat - real :: outhelp,xr,xr1,yr,yr1 - real,parameter :: eps=1.e-4 - - ! namelist variables - integer, parameter :: maxoutlev=500 - integer :: ios - real,allocatable, dimension (:) :: outheights - - ! declare namelist - namelist /outgrid/ & - outlon0,outlat0, & - numxgrid,numygrid, & - dxout,dyout, & - outheights - - ! allocate large array for reading input - allocate(outheights(maxoutlev),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate outheights' - - - ! Open the OUTGRID file and read output grid specifications - !********************************************************** - - open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID',status='old', & - form='formatted',err=999) - -! try namelist input - dxout=-1. - outheights=-1. -! helps identifying failed namelist input - read (unitoutgrid,outgrid,iostat=ios) - close(unitoutgrid) - - if (dxout.le.0 .or. ios.ne.0) then - - ios=1 - - open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID',status='old',err=999) - - call skplin(5,unitoutgrid) - - ! 1. Read horizontal grid specifications - !**************************************** - - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,f11.4)') outlon0 - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,f11.4)') outlat0 - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,i5)') numxgrid - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,i5)') numygrid - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,f12.5)') dxout - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,f12.5)') dyout - - endif - - ! Check validity of output grid (shall be within model domain) - !************************************************************* - - xr=outlon0+real(numxgrid)*dxout - yr=outlat0+real(numygrid)*dyout - xr1=xlon0+real(nxmin1)*dx - yr1=ylat0+real(nymin1)*dy - if ((outlon0+eps.lt.xlon0).or.(outlat0+eps.lt.ylat0) & - .or.(xr.gt.xr1+eps).or.(yr.gt.yr1+eps)) then - write(*,*) outlon0,outlat0 - write(*,*) xr1,yr1,xlon0,ylat0,xr,yr,dxout,dyout - write(*,*) ' #### FLEXPART MODEL ERROR! PART OF OUTPUT ####' - write(*,*) ' #### GRID IS OUTSIDE MODEL DOMAIN. CHANGE ####' - write(*,*) ' #### FILE OUTGRID IN DIRECTORY ####' - write(*,'(a)') path(1)(1:length(1)) - stop - endif - - ! 2. Count Vertical levels of output grid - !**************************************** - - if (ios.ne.0) then - j=0 -100 j=j+1 - do i=1,3 - read(unitoutgrid,*,end=99) - end do - read(unitoutgrid,'(4x,f7.1)',end=99) outhelp - if (outhelp.eq.0.) goto 99 - goto 100 -99 numzgrid=j-1 - else - do i=1,maxoutlev - if (outheights(i).lt.0) exit - end do - numzgrid=i-1 - end if - - allocate(outheight(numzgrid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate outheight' - allocate(outheighthalf(numzgrid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate outheighthalf' - - ! 2. Vertical levels of output grid - !********************************** - - if (ios.ne.0) then - - rewind(unitoutgrid) - call skplin(29,unitoutgrid) - - do j=1,numzgrid - do i=1,3 - read(unitoutgrid,*) - end do - read(unitoutgrid,'(4x,f7.1)') outhelp - outheight(j)=outhelp - outheights(j)=outhelp - end do - close(unitoutgrid) - - else - - do j=1,numzgrid - outheight(j)=outheights(j) - end do - - endif - - ! write outgrid file in namelist format to output directory if requested - if (nmlout.and.lroot) then - ! reallocate outheights with actually required dimension for namelist writing - deallocate(outheights) - allocate(outheights(numzgrid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate outheights' - - do j=1,numzgrid - outheights(j)=outheight(j) - end do - - open(unitoutgrid,file=path(2)(1:length(2))//'OUTGRID.namelist',err=1000) - write(unitoutgrid,nml=outgrid) - close(unitoutgrid) - endif - - ! 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 FILE OUTGRID. #### ' - endif - end do - - ! 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. - end do - - xoutshift=xlon0-outlon0 - youtshift=ylat0-outlat0 - - allocate(oroout(0:numxgrid-1,0:numygrid-1),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate oroout' - allocate(area(0:numxgrid-1,0:numygrid-1),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate area' - allocate(volume(0:numxgrid-1,0:numygrid-1,numzgrid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate volume' - allocate(areaeast(0:numxgrid-1,0:numygrid-1,numzgrid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate areaeast' - allocate(areanorth(0:numxgrid-1,0:numygrid-1,numzgrid),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate areanorth' - return - -999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(1)(1:length(1)) - stop - -1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(2)(1:length(2)) - stop -end subroutine readoutgrid - -subroutine readoutgrid_nest - - !***************************************************************************** - ! * - ! This routine reads the user specifications for the output nest. * - ! * - ! Author: A. Stohl * - ! * - ! 4 June 1996 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! dxoutn,dyoutn grid distances of output nest * - ! numxgridn,numygridn,numzgrid nest dimensions * - ! outlon0n,outlat0n lower left corner of nest * - ! outheight(maxzgrid) height levels of output grid [m] * - ! * - ! Constants: * - ! unitoutgrid unit connected to file OUTGRID * - ! * - !***************************************************************************** - - use prepoutgrid_mod - - implicit none - - integer :: stat - real :: xr,xr1,yr,yr1 - real,parameter :: eps=1.e-4 - - integer :: ios - - ! declare namelist - namelist /outgridn/ & - outlon0n,outlat0n, & - numxgridn,numygridn, & - dxoutn,dyoutn +#include "rea_readcommand.f90" - ! helps identifying failed namelist input - dxoutn=-1.0 +#include "rea_readdepo.f90" - ! Open the OUTGRID file and read output grid specifications - !********************************************************** +#include "rea_readOHfield.f90" - open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID_NEST',form='formatted',status='old',err=999) +#include "rea_readlanduse.f90" - ! try namelist input - read(unitoutgrid,outgridn,iostat=ios) - close(unitoutgrid) +#include "rea_readoutgrid.f90" - if ((dxoutn.le.0).or. ios.ne.0) then +#include "rea_readoutgrid_nest.f90" - open(unitoutgrid,file=path(1)(1:length(1))//'OUTGRID_NEST',status='old',err=999) - call skplin(5,unitoutgrid) +#include "rea_readpaths.f90" - ! 1. Read horizontal grid specifications - !**************************************** - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,f11.4)') outlon0n - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,f11.4)') outlat0n - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,i5)') numxgridn - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,i5)') numygridn - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,f12.5)') dxoutn - call skplin(3,unitoutgrid) - read(unitoutgrid,'(4x,f12.5)') dyoutn +#include "rea_readreceptors.f90" - close(unitoutgrid) - endif - - ! write outgrid_nest file in namelist format to output directory if requested - if (nmlout.and.lroot) then - open(unitoutgrid,file=path(2)(1:length(2))//'OUTGRID_NEST.namelist',err=1000) - write(unitoutgrid,nml=outgridn) - close(unitoutgrid) - endif - - 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' - - ! Check validity of output grid (shall be within model domain) - !************************************************************* - - xr=outlon0n+real(numxgridn)*dxoutn - yr=outlat0n+real(numygridn)*dyoutn - xr1=xlon0+real(nxmin1)*dx - yr1=ylat0+real(nymin1)*dy - if ((outlon0n+eps.lt.xlon0).or.(outlat0n+eps.lt.ylat0) & - .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(*,*) ' #### FILE OUTGRID IN DIRECTORY ####' - write(*,'(a)') path(1)(1:length(1)) - stop - endif - - xoutshiftn=xlon0-outlon0n - youtshiftn=ylat0-outlat0n - return - -999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(1)(1:length(1)) - stop - -1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "OUTGRID" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(2)(1:length(2)) - stop -end subroutine readoutgrid_nest - -subroutine readpaths - - !***************************************************************************** - ! * - ! 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 * - ! last modified * - ! HS, 7.9.2012 * - ! option to give pathnames file as command line option * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! length(numpath) lengths of the path names * - ! path(numpath) pathnames of input/output files * - ! * - ! Constants: * - ! numpath number of pathnames to be read in * - ! * - !***************************************************************************** - - implicit none - - integer :: i - character(256) :: string_test - character(1) :: character_test - - ! Read the pathname information stored in unitpath - !************************************************* - - open(unitpath,file=trim(pathfile),status='old',err=999) - - do i=1,numpath - read(unitpath,'(a)',err=998) path(i) - length(i)=index(path(i),' ')-1 - - - string_test = path(i) - character_test = string_test(length(i):length(i)) - !print*, 'character_test, string_test ', character_test, string_test - if ((character_test .NE. '/') .AND. (i .LT. 4)) then - print*, 'WARNING: path not ending in /' - print*, path(i) - path(i) = string_test(1:length(i)) // '/' - length(i)=length(i)+1 - print*, 'fix: padded with /' - print*, path(i) - print*, 'length(i) increased 1' - endif - end do - - ! Check whether any nested subdomains are to be used - !*************************************************** - - do i=1,maxnests - ! ESO 2016 Added 'end'/'err' in case user forgot '====' at end of file and - ! maxnests > numbnests - read(unitpath,'(a)', end=30, err=30) path(numpath+2*(i-1)+1) - read(unitpath,'(a)', end=30, err=30) 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 - end do - - - ! Determine number of available nested domains - !********************************************* - -30 numbnests=i-1 - - close(unitpath) - return - -998 write(*,*) ' #### TRAJECTORY MODEL ERROR! ERROR WHILE #### ' - write(*,*) ' #### READING FILE PATHNAMES. #### ' - stop - -999 write(*,*) ' #### TRAJECTORY MODEL ERROR! FILE "pathnames"#### ' - write(*,*) ' #### CANNOT BE OPENED IN THE CURRENT WORKING #### ' - write(*,*) ' #### DIRECTORY. #### ' - stop -end subroutine readpaths - - -subroutine readreceptors - - !***************************************************************************** - ! * - ! This routine reads the user specifications for the receptor points. * - ! * - ! Author: A. Stohl * - ! 1 August 1996 * - ! * - ! HSO, 14 August 2013: Added optional namelist input - ! PS, 2/2015: access= -> position= - ! PS, 6/2015: variable names, simplify code - ! PS, 3/2023: remove position=append, makes no sense for new file * - ! * - !***************************************************************************** - ! * - ! 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 * - ! * - !***************************************************************************** - - implicit none - - integer :: j - real :: x,y,xm,ym - character(len=10) :: receptor - - integer :: ios - real :: xlon,ylat ! for namelist input, xlon/xlat are used instead of x,y - - ! declare namelist -! namelist /nml_receptors/ receptor, xlon, ylat - namelist /receptors/ receptor, xlon, ylat - -!CPS I comment this out - why should we not have receptor output in bwd runs? - ! For backward runs, do not allow receptor output. Thus, set number of - ! receptors to zero - ! if (ldirect.lt.0) then - ! numreceptor=0 - ! return - ! endif - - - ! Open the RECEPTORS file and read output grid specifications - !************************************************************ - - open (unitreceptor,file=trim(path(1))//'RECEPTORS',form='formatted', & - status='old',err=999) - -! try namelist input - xlon = -999. ! we need this to check namelist reading - ylat = -999. - read (unitreceptor,receptors,iostat=ios) -! read (unitreceptor,nml_receptors,iostat=ios) -! write (*,*) 'nml_receptors iostat',ios -! write (*,nml_receptors) - close(unitreceptor) - - ! prepare namelist output if requested - if (nmlout) open(unitreceptorout,file=trim(path(2))// & - 'RECEPTORS.namelist',status='new',err=1000) - - if (ios .gt. 0) then - - goto 991 ! wrong variable name in namelist - - elseif (ios .eq. 0) then ! read as namelist - - if (nint(xlon) .eq. -999 .or. nint(ylat) .eq. -999) goto 993 - -! PS: reopen file otherwise first receptor is skipped! - open (unitreceptor,file=trim(path(1))//'RECEPTORS',status='old',err=999) - - j=0 - do while (ios .eq. 0) - j=j+1 - read(unitreceptor,receptors,iostat=ios) -! read(unitreceptor,nml_receptors,iostat=ios) - if (ios .eq. 0) then - if (j .gt. maxreceptor) then - write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### ' - write(*,*) ' #### POINTS ARE GIVEN. #### ' - write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### ' - write(*,*) ' #### PLEASE MAKE CHANGES IN FILE RECEPTORS #### ' - endif - receptorname(j)=receptor - xreceptor(j)=(xlon-xlon0)/dx ! transform to grid coordinates - yreceptor(j)=(ylat-ylat0)/dy - xm=r_earth*cos(ylat*pi/180.)*dx/180.*pi - ym=r_earth*dy/180.*pi - receptorarea(j)=xm*ym - ! write receptors in namelist format to output directory if requested - if (nmlout) write(unitreceptorout,nml=receptors) -! if (nmlout) write(unitreceptorout,nml=nml_receptors) - elseif (ios .gt. 0) then - write(*,*) ' ### FLEXPART MODEL ERROR! Error in RECEPTORS namelist ###' - stop 'Error in RECEPTORS namelist' - else - write (*,*) 'receptor read in nml format, ios<0', ios - write (*,receptors) -! write (*,nml_receptors) - endif - end do ! end nml receptors reading loop - - numreceptor=j-1 - - else ! ios<0 = EOF, read as conventional input file - - open (unitreceptor,file=trim(path(1))//'RECEPTORS',status='old',err=999) - call skplin(5,unitreceptor) - - ! Read the names and coordinates of the receptors - !************************************************ - - j=1 -100 continue - read(unitreceptor,*,end=99) - read(unitreceptor,*,end=99) - read(unitreceptor,*,end=99) - read(unitreceptor,'(4x,a16)',end=99) receptor - call skplin(3,unitreceptor) - read(unitreceptor,'(4x,f11.4)',end=99) xlon - call skplin(3,unitreceptor) - read(unitreceptor,'(4x,f11.4)',end=99) ylat - if (xlon.eq.0. .and. ylat.eq.0. .and. & - (receptor .eq. ' ')) then - write(*,*) 'WARNING: looks like empty receptor at south pole;'// & - ' will be skipped' - j=j-1 - goto 100 - endif - - if (j .gt. maxreceptor) goto 992 - - receptorname(j)=receptor - xreceptor(j)=(xlon-xlon0)/dx ! transform to grid coordinates - yreceptor(j)=(ylat-ylat0)/dy - xm=r_earth*cos(ylat*pi/180.)*dx/180.*pi - ym=r_earth*dy/180.*pi - receptorarea(j)=xm*ym - ! write receptors file in namelist format to output directory if requested - if (nmlout) write(unitreceptorout,nml=receptors) -! if (nmlout) write(unitreceptorout,nml=nml_receptors) - goto 100 - -99 numreceptor=j-1 - - endif ! end no-nml / nml bloc - - close (unitreceptor) - if (nmlout) close (unitreceptorout) - - return - -991 continue - write(*,*) '#### FLEXPART ERROR: wrong variable names present' - write(*,*) '#### in namelist in file RECEPTORS' - write(*,*) '#### note that in v11+ coordinate names are xlon and ylat' - - stop - -992 continue - write(*,*) ' #### FLEXPART MODEL ERROR! TOO MANY RECEPTOR #### ' - write(*,*) ' #### POINTS ARE GIVEN. #### ' - write(*,*) ' #### MAXIMUM NUMBER IS ',maxreceptor,' #### ' -! write(*,*) ' #### PLEASE MAKE CHANGES IN FILE RECEPTORS #### ' - stop - -993 continue - write(*,*) '#### FLEXPART ERROR: namelist in file RECEPTORS' - write(*,*) '#### first receptor point did not contain xlon and/or ylat' - write(*,*) '#### Check your namelist!' - stop - -999 write(*,*) 'INFORMATION: input file RECEPTORS cannot be opened' - write(*,*) 'in directory '//trim(path(1)) - write(*,*) 'Continuing without RECEPTOR' - - numreceptor=0 - return - -1000 write(*,*) ' #### FLEXPART MODEL ERROR! File "RECEPTORS" #### ' - write(*,*) ' #### cannot be opened in the output directory #### ' - write(*,'(a)') ' #### '//trim(path(2)) - write(*,*) ' #### either write perm missing or old file exists ###' - - stop - -end subroutine readreceptors - -subroutine readreleases - - !***************************************************************************** - ! * - ! This routine reads the release point specifications for the current * - ! model run. Several release points can be used at the same time. * - ! * - ! Author: A. Stohl * - ! * - ! 18 May 1996 * - ! * - ! Update: 29 January 2001 * - ! Release altitude can be either in magl or masl * - ! HSO, 12 August 2013 - ! Added optional namelist input - ! * - !***************************************************************************** - ! * - ! 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 * - ! area * - ! weta_gas, wetb_gas parameters for below-cloud scavenging (gas) * - ! crain_aero, csnow_aero parameters for below-cloud scavenging (aerosol) * - ! ccn_aero, in_aero parameters for in-cloud scavenging (aerosol) * - ! zpoint1,zpoint2 height range, over which release takes place * - ! num_min_discrete if less, release cannot be randomized and happens at * - ! time mid-point of release interval * - ! lroot true if serial version, or if MPI and root process * - ! * - !***************************************************************************** - - use point_mod - use xmass_mod - use drydepo_mod - - implicit none - - integer :: numpartmax,i,j,id1,it1,id2,it2,idum,stat,irel,ispc,nsettle - integer,parameter :: num_min_discrete=100 - real :: releaserate,xdum,cun - real(kind=dp) :: jul1,jul2,julm - real,parameter :: eps2=1.e-9 - character(len=50) :: line - logical :: old - - ! help variables for namelist reading - integer :: numpoints, parts, ios - integer*2 :: zkind - integer :: idate1, itime1, idate2, itime2 - real :: lon1,lon2,lat1,lat2,z1,z2 - character*40 :: comment - integer,parameter :: unitreleasesout=2 - real,allocatable, dimension (:) :: mass - integer,allocatable, dimension (:) :: specnum_rel,specnum_rel2 - real,allocatable,dimension(:) :: vsh,fracth,schmih - - ! declare namelists - namelist /releases_ctrl/ & - nspec, & - specnum_rel - - namelist /release/ & - idate1, itime1, & - idate2, itime2, & - lon1, lon2, & - lat1, lat2, & - z1, z2, & - zkind, & - mass, & - parts, & - comment - - numpoint=0 - - ! allocate with maxspec for first input loop - allocate(mass(maxspec),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate mass' - allocate(specnum_rel(maxspec),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel' - - ! presetting namelist releases_ctrl - nspec = -1 ! use negative value to determine failed namelist input - specnum_rel = 0 - - !sec, read release to find how many releasepoints should be allocated - open(unitreleases,file=path(1)(1:length(1))//'RELEASES',status='old', & - form='formatted',err=999) - - ! check if namelist input provided - read(unitreleases,releases_ctrl,iostat=ios) - - ! prepare namelist output if requested -! if (nmlout.and.lroot) then - if (nmlout) & - open(unitreleasesout,file=path(2)(1:length(2))//'RELEASES.namelist', & - access='append',status='replace',err=1000) - - if (ios.ne.0 .or. nspec.lt.0) then -! if (lroot) write(*,*) 'RELEASE either having unrecognised entries, & -! &or in old format, please update to namelist format.' - write(*,*) 'RELEASE either having unrecognised entries, & - &or in old format, please update to namelist format.' - stop - else - if (ipin.ne.3 .and. ipin.ne.4) then - ! Not necessary to read releases when using part_ic.nc - ios=0 - do while (ios.eq.0) - idate1=-1 - read(unitreleases,release,iostat=ios) - if ((idate1.lt.0).or. ios.ne.0) then - ios=1 - else - numpoint=numpoint+1 - endif - end do - ios=0 - else - numpoint=1 - endif - endif - - rewind(unitreleases) - - if (nspec.gt.maxspec) goto 994 - - ! allocate arrays of matching size for number of species (namelist output) - deallocate(mass) - allocate(mass(nspec),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate mass' - allocate(specnum_rel2(nspec),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel2' - specnum_rel2=specnum_rel(1:nspec) - deallocate(specnum_rel) - ! eso: BUG, crashes here for nspec=12 and maxspec=6, - ! TODO: catch error and exit - allocate(specnum_rel(nspec),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate specnum_rel' - specnum_rel=specnum_rel2 - deallocate(specnum_rel2) - - !allocate memory for numpoint releaspoints - allocate(ireleasestart(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate ireleasestart' - allocate(ireleaseend(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate ireleaseend' - allocate(xpoint1(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate xpoint1' - allocate(xpoint2(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate xpoint2' - allocate(ypoint1(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate ypoint1' - allocate(ypoint2(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate ypoint2' - allocate(zpoint1(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate zpoint1' - allocate(zpoint2(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate zpoint2' - allocate(kindz(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate kindz' - allocate(xmass(numpoint,maxspec),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate xmass' - allocate(rho_rel(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate rho_rel' - allocate(npart(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate npart' - allocate(xmasssave(numpoint),stat=stat) - if (stat.ne.0) write(*,*)'ERROR: could not allocate xmasssave' - - if (lroot) write (*,*) 'Releasepoints : ', numpoint - - do i=1,numpoint - xmasssave(i)=0. - end do - - !now save the information - DEP=.false. - DRYDEP=.false. - WETDEP=.false. - OHREA=.false. - do i=1,maxspec - DRYDEPSPEC(i)=.false. - WETDEPSPEC(i)=.false. - end do - - ! namelist output - if (nmlout.and.lroot) then - write(unitreleasesout,nml=releases_ctrl) - endif - - do i=1,nspec - call readspecies(specnum_rel(i),i) - - - ! Allocate temporary memory necessary for the different diameter bins - !******************************************************************** - allocate(vsh(ndia(i)),fracth(ndia(i)),schmih(ndia(i))) - - ! Molecular weight - !***************** - - 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/decay(i) !conversion half life to decay constant - - - ! Dry deposition of gases - !************************ - - if (reldiff(i).gt.0.) rm(i)=1./(henry(i)/3000.+100.*f0(i)) ! mesophyll resistance - - ! Dry deposition of particles - !**************************** - - vsetaver(i)=0. - cunningham(i)=0. - dquer(i)=dquer(i)*1000000. ! Conversion m to um - if (density(i).gt.0.) then ! Additional parameters - call part0(dquer(i),dsigma(i),density(i),ndia(i),fracth,schmih,cun,vsh) - do j=1,ndia(i) - 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) - end do - if (lroot) write(*,*) 'Average settling velocity: ',i,vsetaver(i) - endif - - ! Dry deposition for constant deposition velocity - !************************************************ - - dryvel(i)=dryvel(i)*0.01 ! conversion to m/s - - ! Check if wet deposition or OH reaction shall be calculated - !*********************************************************** - - ! ESO 04.2016 check for below-cloud scavenging (gas or aerosol) - if ((dquer(i).le.0..and.(weta_gas(i).gt.0. .or. wetb_gas(i).gt.0.)) .or. & - &(dquer(i).gt.0. .and. (crain_aero(i) .gt. 0. .or. csnow_aero(i).gt.0.))) then - WETDEP=.true. - WETDEPSPEC(i)=.true. - if (lroot) then - write (*,*) ' Below-cloud scavenging: ON' - ! write (*,*) 'Below-cloud scavenging coefficients: ',weta(i),i - end if - else - if (lroot) write (*,*) ' Below-cloud scavenging: OFF' - endif - - ! NIK 31.01.2013 + 10.12.2013 + 15.02.2015 - if (dquer(i).gt.0..and.(ccn_aero(i).gt.0. .or. in_aero(i).gt.0.)) then - WETDEP=.true. - WETDEPSPEC(i)=.true. - if (lroot) then - write (*,*) ' In-cloud scavenging: ON' - ! write (*,*) 'In-cloud scavenging coefficients: ',& - ! &ccn_aero(i),in_aero(i),i !,wetc_in(i), wetd_in(i),i - end if - else - if (lroot) write (*,*) ' In-cloud scavenging: OFF' - endif - - if (ohcconst(i).gt.0.) then - OHREA=.true. - if (lroot) write (*,*) ' OHreaction switched on: ',ohcconst(i),i - endif - - if ((reldiff(i).gt.0.).or.(density(i).gt.0.).or.(dryvel(i).gt.0.)) then - DRYDEP=.true. - DRYDEPSPEC(i)=.true. - endif - - deallocate(vsh,fracth,schmih) - end do ! end loop over species - - if (WETDEP.or.DRYDEP) DEP=.true. - - ! Not necessary to read releases when using part_ic.nc - !***************************************************** - if ((ipin.eq.3).or.(ipin.eq.4)) then - maxpointspec_act=1 - return - endif - - ! Read specifications for each release point - !******************************************* - numpoints=numpoint - numpoint=0 - numpartmax=0 - releaserate=0. -101 numpoint=numpoint+1 - - if (numpoint.gt.numpoints) goto 250 - zkind = 1 - mass = 0 - parts = 0 - comment = ' ' - read(unitreleases,release,iostat=ios) - id1=idate1 - it1=itime1 - id2=idate2 - it2=itime2 - xpoint1(numpoint)=lon1 - xpoint2(numpoint)=lon2 - ypoint1(numpoint)=lat1 - ypoint2(numpoint)=lat2 - zpoint1(numpoint)=z1 - zpoint2(numpoint)=z2 - kindz(numpoint)=zkind - do i=1,nspec - xmass(numpoint,i)=mass(i) - end do - npart(numpoint)=parts - compoint(min(1001,numpoint))=comment - -! namelist output - if (nmlout.and.lroot) then - write(unitreleasesout,nml=release) - endif - - ! If a release point contains no particles, stop and issue error message - !*********************************************************************** - - if (npart(numpoint).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 - - ! If FLEXPART is run for backward deposition force zpoint - !********************************************************************* - if (WETBKDEP) then - zpoint1(numpoint)=0. - zpoint2(numpoint)=20000. - kindz(numpoint)=1 - endif - if (DRYBKDEP) then - zpoint1(numpoint)=0. - zpoint2(numpoint)=2.*href - kindz(numpoint)=1 - endif - - - ! Check whether x coordinates of release point are within model domain - !********************************************************************* - - 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) - julm=(jul1+jul2)/2. - 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)).and.(ipin.eq.0)) 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 - if (npart(numpoint).gt.num_min_discrete) then - ireleasestart(numpoint)=int((jul1-bdate)*86400.) - ireleaseend(numpoint)=int((jul2-bdate)*86400.) - else - ireleasestart(numpoint)=int((julm-bdate)*86400.) - ireleaseend(numpoint)=int((julm-bdate)*86400.) - endif - else if (ldirect.eq.-1) then - if (((jul1.lt.edate).or.(jul2.gt.bdate)).and.(ipin.eq.0)) 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 - if (npart(numpoint).gt.num_min_discrete) then - ireleasestart(numpoint)=int((jul1-bdate)*86400.) - ireleaseend(numpoint)=int((jul2-bdate)*86400.) - else - ireleasestart(numpoint)=int((julm-bdate)*86400.) - ireleaseend(numpoint)=int((julm-bdate)*86400.) - endif - endif - endif - - - ! Determine the release rate (particles per second) and total number - ! of particles released during the simulation - !******************************************************************* - - if (ireleasestart(numpoint).ne.ireleaseend(numpoint)) then - releaserate=releaserate+real(npart(numpoint))/ & - real(ireleaseend(numpoint)-ireleasestart(numpoint)) - else - releaserate=99999999 - endif - numpartmax=numpartmax+npart(numpoint) - goto 101 - -250 close(unitreleases) - - if (nmlout.and.lroot) then - close(unitreleasesout) - endif - - !if (lroot) write (*,*) 'Particles allocated (maxpart) : ',maxpart - if (lroot) write (*,*) 'Particles released (numpartmax): ',numpartmax - numpoint=numpoint-1 - - if (ioutputforeachrelease.eq.1) then - maxpointspec_act=numpoint - else - maxpointspec_act=1 - endif - - ! Disable settling if more than 1 species at any release point - ! or if MQUASILAG and more than one species - !************************************************************* - - if (mquasilag.ne.0) then - if (nspec.gt.1) lsettling=.false. - else - do irel=1,numpoint - nsettle=0 - do ispc=1,nspec - if (xmass(irel,ispc).gt.eps2) nsettle=nsettle+1 - end do - if (nsettle.gt.1) lsettling=.false. - end do - end if - - if (lroot) then - if (.not.lsettling) then - write(*,*) 'WARNING: more than 1 species per release point, settling & - &disabled' - end if - end if - - ! Check, whether the total number of particles may exceed totally allowed - ! number of particles at some time during the simulation - !************************************************************************ - - ! if (releaserate.gt. & - ! 0.99*real(maxpart)/real(lage(nageclass))) then - ! if (numpartmax.gt.maxpart.and.lroot) 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 - - - if (lroot) then - write(*,FMT='(A,ES14.7)') ' Total mass released:', sum(xmass(1:numpoint,1:nspec)) - end if - - return - -994 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 - -998 write(*,*) '#####################################################' - write(*,*) '#### FLEXPART MODEL SUBROUTINE READRELEASES: ####' - write(*,*) '#### ####' - write(*,*) '#### FATAL ERROR - FILE "RELEASES" IS ####' - write(*,*) '#### CORRUPT. PLEASE CHECK YOUR INPUTS FOR ####' - write(*,*) '#### MISTAKES OR GET A NEW "RELEASES"- ####' - write(*,*) '#### FILE ... ####' - 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 - -1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "RELEASES" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(2)(1:length(2)) - stop -end subroutine readreleases - -subroutine readspecies(id_spec,pos_spec) - - !***************************************************************************** - ! * - ! This routine reads names and physical constants of chemical species/ * - ! radionuclides given in the parameter pos_spec * - ! * - ! Author: A. Stohl * - ! * - ! 11 July 1996 * - ! * - ! Changes: * - ! N. Kristiansen, 31.01.2013: Including parameters for in-cloud scavenging * - ! * - ! HSO, 13 August 2013 - ! added optional namelist input - ! * - !***************************************************************************** - ! * - ! Variables: * - ! decaytime(maxtable) half time for radiological decay * - ! specname(maxtable) names of chemical species, radionuclides * - ! weta_gas, wetb_gas Parameters for below-cloud scavenging of gasses * - ! crain_aero,csnow_aero Parameters for below-cloud scavenging of aerosols * - ! ccn_aero,in_aero Parameters for in-cloud scavenging of aerosols * - ! ohcconst OH reaction rate constant C * - ! ohdconst OH reaction rate constant D * - ! ohnconst OH reaction rate constant n * - ! id_spec SPECIES number as referenced in RELEASE file * - ! id_pos position where SPECIES data shall be stored * - ! ni Number of diameter classes of particles * * - ! Constants: * - ! * - !***************************************************************************** - - implicit none - - integer :: i, pos_spec,j - integer :: idow,ihour,id_spec - character(len=3) :: aspecnumb - logical :: spec_found - - character(len=16) :: pspecies - real :: pdecay, pweta_gas, pwetb_gas, preldiff, phenry, pf0, pdensity, pdquer - real :: pdsigma, pdryvel, pweightmolar, pohcconst, pohdconst, pohnconst - real :: pcrain_aero, pcsnow_aero, pccn_aero, pin_aero - real :: parea_dow(7), parea_hour(24), ppoint_dow(7), ppoint_hour(24) - integer :: pndia - integer :: ios - integer :: pshape,porient - ! Daria Tatsii: species shape properties - real ::pla,pia,psa,f,e,paspectratio - real :: la(maxspec),ia(maxspec),sa(maxspec) ! Axes - - ! declare namelist - namelist /species_params/ & - pspecies, pdecay, pweta_gas, pwetb_gas, & - pcrain_aero, pcsnow_aero, pccn_aero, pin_aero, & - preldiff, phenry, pf0, pdensity, pdquer, & - pdsigma, pndia, pdryvel, pweightmolar, pohcconst, pohdconst, pohnconst, & - parea_dow, parea_hour, ppoint_dow, ppoint_hour, & - pshape, paspectratio, pla, pia, psa, porient - - pspecies="" ! read failure indicator value - pdecay=-999.9 - pweta_gas=-9.9E-09 - pwetb_gas=0.0 - pcrain_aero=-9.9E-09 - pcsnow_aero=-9.9E-09 - pccn_aero=-9.9E-09 - pin_aero=-9.9E-09 - preldiff=-9.9 - phenry=0.0 - pf0=0.0 - pdensity=-9.9E09 - pdquer=0.0 - pdsigma=0.0 - pndia=1 - pdryvel=-9.99 - pohcconst=-9.99 - pohdconst=-9.9E-09 - pohnconst=2.0 - pweightmolar=-999.9 - parea_dow=-999.9 - parea_hour=-999.9 - ppoint_dow=-999.9 - ppoint_hour=-999.9 - pshape=0 ! 0 for sphere, 1 for other shapes - paspectratio=-1. - pla=-1. ! longest axis in micrometer - pia=-1. ! Intermediate axis - psa=-1. ! Smallest axis - porient=0 ! 0 for horizontal, 1 for random - - - do j=1,24 ! initialize everything to no variation - parea_hour(j)=1. - ppoint_hour(j)=1. - area_hour(pos_spec,j)=1. - point_hour(pos_spec,j)=1. - end do - do j=1,7 - parea_dow(j)=1. - ppoint_dow(j)=1. - area_dow(pos_spec,j)=1. - point_dow(pos_spec,j)=1. - end do - - ! Open the SPECIES file and read species names and properties - !************************************************************ - specnum(pos_spec)=id_spec - write(aspecnumb,'(i3.3)') specnum(pos_spec) - open(unitspecies,file=path(1)(1:length(1))//'SPECIES/SPECIES_'//aspecnumb, & - status='old',form='formatted',err=998) - !write(*,*) 'reading SPECIES',specnum(pos_spec) - - ASSSPEC=.FALSE. - - ! try namelist input - read(unitspecies,species_params,iostat=ios) - close(unitspecies) - - if ((len(trim(pspecies)).eq.0).or. ios.ne.0) then ! no namelist found - if (lroot) write(*,*) "SPECIES file not in NAMELIST format, attempting to & - &read as fixed format" - - ios=1 - - open(unitspecies,file=path(1)(1:length(1))//'SPECIES/SPECIES_'//aspecnumb, & - status='old',err=998) - - do i=1,6 - read(unitspecies,*) - end do - - read(unitspecies,'(a10)',end=22) species(pos_spec) - ! write(*,*) species(pos_spec) - read(unitspecies,'(f18.1)',end=22) decay(pos_spec) - ! write(*,*) decay(pos_spec) - read(unitspecies,'(e18.1)',end=22) weta_gas(pos_spec) - ! write(*,*) weta_gas(pos_spec) - read(unitspecies,'(f18.2)',end=22) wetb_gas(pos_spec) - ! write(*,*) wetb_gas(pos_spec) - read(unitspecies,'(e18.1)',end=22) crain_aero(pos_spec) - ! write(*,*) crain_aero(pos_spec) - read(unitspecies,'(f18.2)',end=22) csnow_aero(pos_spec) - ! write(*,*) csnow_aero(pos_spec) - !*** NIK 31.01.2013: including in-cloud scavening parameters - read(unitspecies,'(e18.1)',end=22) ccn_aero(pos_spec) - ! write(*,*) ccn_aero(pos_spec) - read(unitspecies,'(f18.2)',end=22) in_aero(pos_spec) - ! write(*,*) in_aero(pos_spec) - read(unitspecies,'(f18.1)',end=22) reldiff(pos_spec) - ! write(*,*) reldiff(pos_spec) - read(unitspecies,'(e18.1)',end=22) henry(pos_spec) - ! write(*,*) henry(pos_spec) - read(unitspecies,'(f18.1)',end=22) f0(pos_spec) - ! write(*,*) f0(pos_spec) - read(unitspecies,'(e18.1)',end=22) density(pos_spec) - ! write(*,*) density(pos_spec) - read(unitspecies,'(e18.1)',end=22) dquer(pos_spec) - ! write(*,*) 'dquer(pos_spec):', dquer(pos_spec) - read(unitspecies,'(e18.1)',end=22) dsigma(pos_spec) - ! write(*,*) dsigma(pos_spec) - read(unitspecies,'(i16)',end=22) ndia(pos_spec) - ! write(*,*) ndia(pos_spec) - read(unitspecies,'(f18.2)',end=22) dryvel(pos_spec) - ! write(*,*) dryvel(pos_spec) - read(unitspecies,'(f18.2)',end=22) weightmolar(pos_spec) - ! write(*,*) weightmolar(pos_spec) - read(unitspecies,'(e18.2)',end=22) ohcconst(pos_spec) - ! write(*,*) ohcconst(pos_spec) - read(unitspecies,'(f8.2)',end=22) ohdconst(pos_spec) - ! write(*,*) ohdconst(pos_spec) - read(unitspecies,'(f8.2)',end=22) ohnconst(pos_spec) - ! write(*,*) ohnconst(pos_spec) - - ! Read in daily and day-of-week variation of emissions, if available - !******************************************************************* - - read(unitspecies,*,end=22) - do j=1,24 ! 24 hours, starting with 0-1 local time - read(unitspecies,*) ihour,area_hour(pos_spec,j),point_hour(pos_spec,j) - end do - read(unitspecies,*) - do j=1,7 ! 7 days of the week, starting with Monday - read(unitspecies,*) idow,area_dow(pos_spec,j),point_dow(pos_spec,j) - end do - - pspecies=species(pos_spec) - pdecay=decay(pos_spec) - pweta_gas=weta_gas(pos_spec) - pwetb_gas=wetb_gas(pos_spec) - pcrain_aero=crain_aero(pos_spec) - pcsnow_aero=csnow_aero(pos_spec) - pccn_aero=ccn_aero(pos_spec) - pin_aero=in_aero(pos_spec) - preldiff=reldiff(pos_spec) - phenry=henry(pos_spec) - pf0=f0(pos_spec) - pdensity=density(pos_spec) - pdquer=dquer(pos_spec) - pdsigma=dsigma(pos_spec) - pndia=ndia(pos_spec) - pdryvel=dryvel(pos_spec) - pweightmolar=weightmolar(pos_spec) - pohcconst=ohcconst(pos_spec) - pohdconst=ohdconst(pos_spec) - pohnconst=ohnconst(pos_spec) - - - do j=1,24 ! 24 hours, starting with 0-1 local time - parea_hour(j)=area_hour(pos_spec,j) - ppoint_hour(j)=point_hour(pos_spec,j) - end do - do j=1,7 ! 7 days of the week, starting with Monday - parea_dow(j)=area_dow(pos_spec,j) - ppoint_dow(j)=point_dow(pos_spec,j) - end do - - else ! namelist available - - species(pos_spec)=pspecies - decay(pos_spec)=pdecay - weta_gas(pos_spec)=pweta_gas - wetb_gas(pos_spec)=pwetb_gas - crain_aero(pos_spec)=pcrain_aero - csnow_aero(pos_spec)=pcsnow_aero - ccn_aero(pos_spec)=pccn_aero - in_aero(pos_spec)=pin_aero - reldiff(pos_spec)=preldiff - henry(pos_spec)=phenry - f0(pos_spec)=pf0 - density(pos_spec)=pdensity - dquer(pos_spec)=pdquer - dsigma(pos_spec)=pdsigma - ndia(pos_spec)=pndia - dryvel(pos_spec)=pdryvel - weightmolar(pos_spec)=pweightmolar - ohcconst(pos_spec)=pohcconst - ohdconst(pos_spec)=pohdconst - ohnconst(pos_spec)=pohnconst - shape(pos_spec)=pshape - orient(pos_spec)=porient - - - ! Daria Tatsii 2023: compute particle shape dimensions - if (shape(pos_spec).ge.1) then ! Compute shape according to given axes - select case (shape(pos_spec)) - case (1) - write(*,*) "Particle shape USER-DEFINED for particle", id_spec - if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then - write(*,*) "#### ERROR: Shape=1 (user-defined) is chosen, & - &but no valid axes are provided." - write(*,*) "#### SPECIES file requires SA, IA, and LA parameter& - &greater than zero." - stop - endif - write(*,*) "SA,IA,LA:",psa,pia,pla - case (2) ! Cylinders (fibers) ! - if (paspectratio.le.0.0) then - write(*,*) "#### ERROR: Shape=2 cylinder is chosen, but no valid apect ratio is provided." - write(*,*) "#### SPECIES file requires ASPECTRATIO parameter greater than zero." - stop - endif - psa=(((dquer(pos_spec)**3.0)*2.0)/ & - (3.0*paspectratio))**(1.0/3.0) - pia=psa - pla=psa*paspectratio - write(*,*) "Particle shape CYLINDER for particle", id_spec - write(*,*) "SA,IA,LA:",psa,pia,pla - case (3) ! Cubes ! - write(*,*) "Particle shape CUBE for particle", id_spec - psa=((dquer(pos_spec)**3)*pi/6.0)**(1.0/3.0) - pia=(2.0**0.5)*psa - pla=(3.0**0.5)*psa - if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then - write(*,*) "#### ERROR: Shape=3 (user-defined) is chosen, but no valid axes are provided." - write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero." - stop - endif - write(*,*) "SA,IA,LA:",psa,pia,pla - case (4) ! Tetrahedrons ! - write(*,*) "Particle shape TETRAHEDRON for particle", id_spec - pla=((dquer(pos_spec)**3)*pi*2**(0.5))**(1.0/3.0) - pia=pla*((3.0/4.0)**(0.5)) - psa=pla*((2.0/3.0)**(0.5)) - if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then - write(*,*) "#### ERROR: Shape=4 (user-defined) is chosen, but no valid axes are provided." - write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero." - stop - endif - write(*,*) "SA,IA,LA:",psa,pia,pla - case (5) ! Octahedrons ! - write(*,*) "Particle shape OCTAHEDRON for particle", id_spec - psa=dquer(pos_spec)*(pi/(2.0*2.0**(0.5)))**3 - pia=psa - pla=psa*(2.0**(0.5)) - if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then - write(*,*) "#### ERROR: Shape=5 (user-defined) is chosen, but no valid axes are provided." - write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero." - stop - endif - write(*,*) "SA,IA,LA:",psa,pia,pla - case (6) ! Ellipsoids ! - write(*,*) "Particle shape ELLIPSOID for particle", id_spec - psa=dquer(pos_spec)/(2.0**(1.0/3.0)) - pia=psa - pla=2*pia - if ((psa.le.0.0).or.(pia.le.0.0).or.(pla.le.0.0)) then - write(*,*) "#### ERROR: Shape=6 (user-defined) is chosen, but no valid axes are provided." - write(*,*) "#### SPECIES file requires SA, IA, and LA parameter greater than zero." - stop - endif - write(*,*) "SA,IA,LA:",psa,pia,pla - end select - - ! When using the shape option, dquer is the sphere equivalent diameter - f=psa/pia - e=pia/pla - Fn(pos_spec)=f*f*e*((dquer(pos_spec))**3)/(psa*pia*pla) ! Newton's regime - Fs(pos_spec)=f*e**(1.3)*(dquer(pos_spec)**3/(psa*pia*pla)) ! Stokes' regime - else ! Spheres - write(*,*) "Particle shape SPHERE for particle", id_spec - endif - - do j=1,24 ! 24 hours, starting with 0-1 local time - area_hour(pos_spec,j)=parea_hour(j) - point_hour(pos_spec,j)=ppoint_hour(j) - end do - do j=1,7 ! 7 days of the week, starting with Monday - area_dow(pos_spec,j)=parea_dow(j) - point_dow(pos_spec,j)=ppoint_dow(j) - end do - endif - - i=pos_spec - - !NIK 16.02.2015 - ! Check scavenging parameters given in SPECIES file - - if (lroot) then - ! ZHG 2016.04.07 Start of changes - write(*,*) ' ' - if (dquer(pos_spec) .gt.0) write(*,'(a,i3,a,a,a)') ' SPECIES: ', & - id_spec,' ', species(pos_spec),' (AEROSOL) ' - if (dquer(pos_spec) .le.0) write(*,'(a,i3,a,a,a)') ' SPECIES: ', & - id_spec,' ', species(pos_spec),' (GAS) ' - - ! Particles - !********** - if (dquer(pos_spec).gt.0) then - if (ccn_aero(pos_spec) .gt. 0) then - write(*,'(a,f5.2)') ' Particle CCN efficiency (CCNeff):', ccn_aero(pos_spec) - else - write(*,'(a)') ' Particle CCN efficiency (CCNeff): OFF' - endif - if (in_aero(pos_spec) .gt. 0) then - write(*,'(a,f5.2)') ' Particle IN efficiency (INeff) :', in_aero(pos_spec) - else - write(*,'(a)') ' Particle IN efficiency (INeff) : OFF' - endif - if (crain_aero(pos_spec) .gt. 0) then - write(*,'(a,f5.2)') ' Particle Rain efficiency (Crain) :', crain_aero(pos_spec) - else - write(*,'(a)') ' Particle Rain efficiency (Crain) : OFF' - endif - if (csnow_aero(pos_spec) .gt. 0) then - write(*,'(a,f5.2)') ' Particle Snow efficiency (Csnow) :', csnow_aero(pos_spec) - else - write(*,'(a)') ' Particle Snow efficiency (Csnow) : OFF' - end if - if (density(pos_spec) .gt. 0) then - write(*,'(a)') ' Dry deposition is turned : ON' - if (reldiff(pos_spec).gt.0) then - stop 'density>0 (SPECIES is a particle) implies reldiff <=0 ' - endif - else - if (reldiff(pos_spec).le.0) then - stop 'density<=0 (SPECIES is a gas) implies reldiff >0 ' - endif - write(*,'(a)') ' Dry deposition is (density<0) : OFF' - end if - if (crain_aero(pos_spec).gt.10.0 .or. csnow_aero(pos_spec).gt.10.0 .or. & - &ccn_aero(pos_spec).gt.1.0 .or. in_aero(pos_spec).gt.1.0) then - write(*,*) '*******************************************' - write(*,*) ' WARNING: Particle Scavenging parameter likely out of range ' - write(*,*) ' Likely range for Crain 0.0-10' - write(*,*) ' Likely range for Csnow 0.0-10' - write(*,*) ' Physical range for CCNeff 0.0-1' - write(*,*) ' Physical range for INeff 0.0-1' - write(*,*) '*******************************************' - end if - else - ! Gas - !**** - if (weta_gas(pos_spec) .gt. 0 .and. wetb_gas(pos_spec).gt.0) then - write(*,*) ' Wet removal for gases is turned: ON' - write(*,*) ' Gas below-cloud scavenging parameter A ', & - &weta_gas(pos_spec) - write(*,'(a,f5.2)') ' Gas below-cloud scavenging parameter B ', & - &wetb_gas(pos_spec) - else - write(*,*) ' Wet removal for gases is turned: OFF ' - end if - if (reldiff(i).gt.0.) then - write(*,*) ' Dry deposition for gases is turned: ON ' - else - write(*,*) ' Dry deposition for gases is turned: OFF ' - end if - if (weta_gas(pos_spec).gt.0.) then !if wet deposition is turned on - if (weta_gas(pos_spec).gt.1E-04 .or. weta_gas(pos_spec).lt.1E-09 .or. & - &wetb_gas(pos_spec).gt.0.8 .or. wetb_gas(pos_spec).lt.0.4) then - write(*,*) '*******************************************' - write(*,*) ' WARNING: Gas below-cloud scavengig is out of likely range' - write(*,*) ' Likely range for A is 1E-04 to 1E-08' - write(*,*) ' Likely range for B is 0.60 to 0.80 ' - write(*,*) '*******************************************' - end if - endif - - if (((weta_gas(pos_spec).gt.0).or.(wetb_gas(pos_spec).gt.0)).and.& - &(henry(pos_spec).le.0)) then - if (dquer(pos_spec).le.0) goto 996 ! no particle, no henry set - endif - end if - end if - - if (ndia(pos_spec).gt.maxndia) then - write(*,*) 'NDIA in SPECIES file', pos_spec, 'set to', ndia(pos_spec), 'larger than maxndia', & - maxndia, 'set in par_mod.f90' - endif - ! if (dsigma(i).eq.0.) dsigma(i)=1.0001 ! avoid floating exception - if (dquer(i).gt.0 .and. dsigma(i).le.1.) then !dsigma(i)=1.0001 ! avoid floating exception - !write(*,*) '#### FLEXPART MODEL ERROR! ####' - write(*,*) '#### FLEXPART MODEL WARNING ####' - write(*,*) '#### in SPECIES_',aspecnumb, ' ####' - write(*,*) '#### from v10.4 dsigma has to be larger than 1 ####' - write(*,*) '#### to adapt older SPECIES files, ####' - write(*,*) '#### if dsigma was < 1 ####' - write(*,*) '#### use the reciprocal of the old dsigma ####' - if (.not.debug_mode) then - stop - else - write(*,*) 'debug mode: continue' - endif - endif - - if ((reldiff(i).gt.0.).and.(density(i).gt.0.)) then - write(*,*) '#### FLEXPART MODEL ERROR! FILE "SPECIES" ####' - write(*,*) '#### IS CORRUPT. SPECIES CANNOT BE BOTH ####' - write(*,*) '#### PARTICLE AND GAS. ####' - write(*,*) '#### SPECIES NUMBER',aspecnumb - stop - endif -20 continue - - -22 close(unitspecies) - -! namelist output if requested - if (nmlout.and.lroot) then - open(unitspecies,file=path(2)(1:length(2))//'SPECIES_'//aspecnumb//'.namelist',access='append',status='replace',err=1000) - write(unitspecies,nml=species_params) - close(unitspecies) - endif - - return - -996 write(*,*) '#####################################################' - write(*,*) '#### FLEXPART MODEL ERROR! #### ' - write(*,*) '#### WET DEPOSITION SWITCHED ON, BUT NO HENRYS #### ' - write(*,*) '#### CONSTANT IS SET ####' - write(*,*) '#### PLEASE MODIFY SPECIES DESCR. FILE! #### ' - write(*,*) '#####################################################' - stop - - -997 write(*,*) '#####################################################' - write(*,*) '#### FLEXPART MODEL ERROR! #### ' - write(*,*) '#### THE ASSSOCIATED SPECIES HAS TO BE DEFINED #### ' - write(*,*) '#### BEFORE THE ONE WHICH POINTS AT IT #### ' - write(*,*) '#### PLEASE CHANGE ORDER IN RELEASES OR ADD #### ' - write(*,*) '#### THE ASSOCIATED SPECIES IN RELEASES #### ' - write(*,*) '#####################################################' - stop - - -998 write(*,*) '#####################################################' - write(*,*) '#### FLEXPART MODEL ERROR! #### ' - write(*,*) '#### THE SPECIES FILE FOR SPECIES ', id_spec - write(*,*) '#### CANNOT BE FOUND: CREATE FILE' - write(*,*) '#### ',path(1)(1:length(1)),'SPECIES/SPECIES_',aspecnumb - write(*,*) '#####################################################' - stop - -1000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "SPECIES_',aspecnumb,'.namelist' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(2)(1:length(2)) - stop -end subroutine readspecies - -subroutine readpartoptions - - !***************************************************************************** - ! * - ! This routine reads the age classes to be used for the current model * - ! run. * - ! * - ! Author: A. Stohl * - ! 20 March 2000 * - ! HSO, 1 July 2014 * - ! Added optional namelist input * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! Constants: * - ! * - !***************************************************************************** - - implicit none - - integer :: i,np - - ! namelist help variables - integer :: ios - - logical :: & - longitude=.false., & - longitude_average=.false., & - latitude=.false., & - latitude_average=.false., & - height=.false., & - height_average=.false., & - pv=.false., & - pv_average=.false., & - qv=.false., & - qv_average=.false., & - density=.false., & - density_average=.false., & - temperature=.false., & - temperature_average=.false., & - pressure=.false., & - pressure_average=.false., & - mixingheight=.false., & - mixingheight_average=.false., & - tropopause=.false., & - tropopause_average=.false., & - topography=.false., & - topography_average=.false., & - mass=.false., & - mass_average=.false., & - u=.false., & - u_average=.false., & - v=.false., & - v_average=.false., & - w=.false., & - w_average=.false., & - vsettling=.false., & - vsettling_average=.false., & - wetdeposition=.false., & - drydeposition=.false. - - ! namelist declaration - namelist /partoptions/ & - longitude, & - longitude_average, & - latitude, & - latitude_average, & - height, & - height_average, & - pv, & - pv_average, & - qv, & - qv_average, & - density, & - density_average, & - temperature, & - temperature_average, & - pressure, & - pressure_average, & - mixingheight, & - mixingheight_average, & - tropopause, & - tropopause_average, & - topography, & - topography_average, & - mass, & - mass_average, & - u, & - u_average, & - v, & - v_average, & - w, & - w_average, & - vsettling, & - vsettling_average, & - wetdeposition, & - drydeposition - - ! If age spectra claculation is switched on, - ! open the AGECLASSSES file and read user options - !************************************************ - - open(unitpartoptions,file=path(1)(1:length(1))//'PARTOPTIONS',form='formatted',status='old',err=9999) - - ! try to read in as a namelist - read(unitpartoptions,partoptions,iostat=ios) - close(unitpartoptions) - - if (ios.ne.0) then - write(*,*) 'Namelist error in PARTOPTIONS file', trim(path(1)(1:length(1))//'PARTOPTIONS') - stop - endif - allocate( partopt(num_partopt) ) - ! Save values in particle options derived type - !********************************************* - partopt(1)%long_name='longitude' - partopt(1)%name='LO' - partopt(1)%print=longitude - - partopt(2)%long_name='longitude_average' - partopt(2)%name='lo' - partopt(2)%print=longitude_average - partopt(2)%average=.true. - - partopt(3)%long_name='latitude' - partopt(3)%name='LA' - partopt(3)%print=latitude - - partopt(4)%long_name='latitude_average' - partopt(4)%name='la' - partopt(4)%print=latitude_average - partopt(4)%average=.true. - - partopt(5)%long_name='height' - partopt(5)%name='ZZ' - partopt(5)%print=height - - partopt(6)%long_name='height_average' - partopt(6)%name='zz' - partopt(6)%print=height_average - partopt(6)%average=.true. - - partopt(7)%long_name='pv' - partopt(7)%name='PV' - partopt(7)%print=pv - - partopt(8)%long_name='pv_average' - partopt(8)%name='pv' - partopt(8)%print=pv_average - partopt(8)%average=.true. - - partopt(9)%long_name='qv' - partopt(9)%name='QV' - partopt(9)%print=qv - - partopt(10)%long_name='qv_average' - partopt(10)%name='qv' - partopt(10)%print=qv_average - partopt(10)%average=.true. - - partopt(11)%long_name='density' - partopt(11)%name='RH' - partopt(11)%print=density - - partopt(12)%long_name='density_average' - partopt(12)%name='rh' - partopt(12)%print=density_average - partopt(12)%average=.true. - - partopt(13)%long_name='temperature' - partopt(13)%name='TT' - partopt(13)%print=temperature - - partopt(14)%long_name='temperature_average' - partopt(14)%name='tt' - partopt(14)%print=temperature_average - partopt(14)%average=.true. - - partopt(15)%long_name='pressure' - partopt(15)%name='PR' - partopt(15)%print=pressure - - partopt(16)%long_name='pressure_average' - partopt(16)%name='pr' - partopt(16)%print=pressure_average - partopt(16)%average=.true. - - partopt(17)%long_name='mixingheight' - partopt(17)%name='HM' - partopt(17)%print=mixingheight - - partopt(18)%long_name='mixingheight_average' - partopt(18)%name='hm' - partopt(18)%print=mixingheight_average - partopt(18)%average=.true. - - partopt(19)%long_name='tropopause' - partopt(19)%name='TR' - partopt(19)%print=tropopause - - partopt(20)%long_name='tropopause_average' - partopt(20)%name='tr' - partopt(20)%print=tropopause_average - partopt(20)%average=.true. - - partopt(21)%long_name='topography' - partopt(21)%name='TO' - partopt(21)%print=topography - - partopt(22)%long_name='topography_average' - partopt(22)%name='to' - partopt(22)%print=topography_average - partopt(22)%average=.true. - - partopt(23)%long_name='mass' - partopt(23)%name='MA' - partopt(23)%print=mass - - partopt(24)%long_name='mass_average' - partopt(24)%name='ma' - partopt(24)%print=mass_average - partopt(24)%average=.true. - - partopt(25)%long_name='u' - partopt(25)%name='UU' - partopt(25)%print=u - - partopt(26)%long_name='u_average' - partopt(26)%name='uu' - partopt(26)%print=u_average - partopt(26)%average=.true. - - partopt(27)%long_name='v' - partopt(27)%name='VV' - partopt(27)%print=v - - partopt(28)%long_name='v_average' - partopt(28)%name='vv' - partopt(28)%print=v_average - partopt(28)%average=.true. - - partopt(29)%long_name='w' - partopt(29)%name='WW' - partopt(29)%print=w - - partopt(30)%long_name='w_average' - partopt(30)%name='ww' - partopt(30)%print=w_average - partopt(30)%average=.true. - - partopt(31)%long_name='vsettling' - partopt(31)%name='VS' - partopt(31)%print=vsettling - - partopt(32)%long_name='vsettling_average' - partopt(32)%name='vs' - partopt(32)%print=vsettling_average - partopt(32)%average=.true. - - partopt(33)%long_name='wetdeposition' - partopt(33)%name='WD' - partopt(33)%print=wetdeposition - - partopt(34)%long_name='drydeposition' - partopt(34)%name='DD' - partopt(34)%print=drydeposition - ! Numbers are assigned to the averaged fields for proper - ! allocation and reading in particle_mod and output_mod - !****************************************************** - n_average=0 - do np=1,num_partopt - if (partopt(np)%average .and. partopt(np)%print) then - n_average=n_average+1 - partopt(np)%i_average = n_average - if ((partopt(np)%name.eq.'MA') .or. (partopt(np)%name.eq.'ma')) then - n_average=n_average + (maxspec-1) - endif - endif - end do - - ! write partoptions file in namelist format to output directory if requested - if (nmlout.and.lroot) then - open(unitpartoptions,file=path(2)(1:length(2))//'PARTOPTIONS.namelist',err=10000) - write(unitpartoptions,nml=partoptions) - close(unitpartoptions) - endif - - - ! Restart files, when using in combination with averaged particle output, - ! need to be synchronised to prevent false averages in the first step of - ! the new run - !************************************************************************ - if ((ipout.ne.0).and.(n_average.gt.0).and.(loutrestart.ne.-1)) then - if (mod(loutrestart,ipoutfac*loutstep).ne.0) then - write(*,*) '### FLEXPART MODEL ERROR! FILE COMMAND: ###' - write(*,*) '### LOUTRESTART NEEDS TO BE DIVISABLE BY ###' - write(*,*) '### LOUTSTEP*IPOUTFAC. ###' - stop - endif - endif - - return - -9999 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "PARTOPTIONS" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(1)(1:length(1)) - stop - -10000 write(*,*) ' #### FLEXPART MODEL ERROR! FILE "PARTOPTIONS" #### ' - write(*,*) ' #### CANNOT BE OPENED IN THE DIRECTORY #### ' - write(*,'(a)') path(2)(1:length(2)) - stop -end subroutine readpartoptions - -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 +#include "rea_readreleases.f90" - integer :: i,iunit, nlines +#include "rea_readspecies.f90" - do i=1,nlines - read(iunit,*) - end do +#include "rea_readpartoptions.f90" -end subroutine skplin +#include "rea_skplin.f90" end module readoptions_mod diff --git a/src/set_get_settling.f90 b/src/set_get_settling.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4cfd3f3871ce3773ecd3b09efa4cd0ddaed62391 --- /dev/null +++ b/src/set_get_settling.f90 @@ -0,0 +1,194 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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. * + ! * + ! Changes * + ! Daria Tatsii 2022: implementation of shape factor according to * + ! Bagheri & Bonadonna 2016 * + !***************************************************************************** + ! * + ! Variables: * + ! itime [s] current temporal position * + ! xt,yt,zt coordinates position for which wind data shall be cal- * + ! culated * + ! * + ! Constants: * + ! dfdr fluid density/particle density * + ! Veq [m^3] equivalent volume of a sphere * + ! dcyl [m] diameter of a cylinder (fiber) * + ! f flatness parameters, S/I * + ! e elongation parameters, I/L * + ! Fs Stokes form factor, f e^1.3 * + ! Fn Newton's form factor * + ! Ks Stokes' drag correction * + ! vsp help variable * + ! x aspect ratio of cylinder height to its diameter * + ! * + ! Variables: * + ! c_d drag coefficient * + ! settling [m/s] settling velocity * + !***************************************************************************** + + use par_mod + use com_mod + use windfields_mod + + implicit none + + integer, intent(in) :: itime, nsp + real, intent(in) :: xt, yt, zt + real, intent(out) :: settling + integer :: indz + + ! Auxiliary variables needed for interpolation + real :: dz1,dz2,dz + real :: rho1(2),tt1(2),temperature,airdens,vis_dyn,vis_kin + real :: settling_old,reynolds,c_d + integer :: i,n,nix,njy,indzh + + ! Variables needed for drag coefficient calculation + real :: dfdr,f,e,kn,ks,alpha1,alpha2,beta1,beta2,ks1,ks2,kn1,kn2 + + !***************************************************************************** + ! 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 + !******************************************************* + indz=nz-1 + do i=2,nz + if (height(i).gt.zt) then + indz=i-1 + exit + endif + end do + + ! 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 + + + ! 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 to define settling velocity of a sphere, constant viscosity estimate + + if (shape(nsp).eq.0) then + do i=1,20 ! do a few iterations Why 20??? + + ! 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 + + ! Clift and Guavin 1971 model + + c_d=(24.0/reynolds)*(1+0.15*(reynolds**0.687))+ & + 0.42/(1.0+42500.0/(reynolds**1.16)) + + settling=-1.* & + sqrt(4*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ & + (3.*c_d*airdens)) + + if (abs((settling-settling_old)/settling).lt.0.01) exit ! stop iteration + + reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin + settling_old=settling + end do + + else ! Drag coefficient scheme by Bagheri & Bonadonna, 2016 to define settling velocities of other shapes (by D.Tatsii) + dfdr=density(nsp)/airdens + + ! Orientation of particles + !************************* + if (orient(nsp).eq.0) then + ! Horizontal orientation + alpha2=0.77 ! B&B: eq. 32 + beta2=0.63 + ks=0.5*((Fs(nsp)**0.05)+(Fs(nsp)**(-0.36))) ! B&B Figure 12 k_(s,max) + kn=10.**(alpha2*(-log10(Fn(nsp)))**beta2) + else if (orient(nsp).eq.1) then + ! Random orientation + alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0) + beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0) + ks=(Fs(nsp)**(1./3.) + Fs(nsp)**(-1./3))/2. + kn=10.**(alpha1*(-log10(Fn(nsp)))**beta1) + else + ! The average of random and horizontal orientation + alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0) + beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0) + alpha2=0.77 ! B&B: eq. 32 + beta2=0.63 + ks1=(Fs(nsp)**(1./3.) + Fs(nsp)**(-1./3))/2. + kn1=10.**(alpha1*(-log10(Fn(nsp)))**beta1) + ks2=0.5*((Fs(nsp)**0.05)+(Fs(nsp)**(-0.36))) ! B&B Figure 12 k_(s,max) + kn2=10.**(alpha2*(-log10(Fn(nsp)))**beta2) + ks=(ks1+ks2)/2. + kn=(kn1+kn2)/2. + endif + + do i=1,20 + c_d=(24.*ks/reynolds)*(1.+0.125*((reynolds*kn/ks)**(2./3.)))+ & + (0.46*kn/(1.+5330./(reynolds*kn/ks))) + + settling=-1.* & + sqrt(4.*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ & + (3.*c_d*airdens)) + + if (abs((settling-settling_old)/settling).lt.0.01) exit + + reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin + settling_old=settling + end do + endif +end subroutine get_settling diff --git a/src/set_viscosity.f90 b/src/set_viscosity.f90 new file mode 100644 index 0000000000000000000000000000000000000000..021b1130a99481a10214b3bdfca7c51e329674e6 --- /dev/null +++ b/src/set_viscosity.f90 @@ -0,0 +1,16 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function viscosity(t) + ! Function calculates dynamic viscosity of air (kg/m/s) as function of + ! temperature (K) using Sutherland's formula + 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/settling_mod.f90 b/src/settling_mod.f90 index 910c41bb8b23fd1d99a8705cf26d1ed0b5938f6d..794134bea36ffb338f2fe3288989d9ed9fc1a572 100644 --- a/src/settling_mod.f90 +++ b/src/settling_mod.f90 @@ -1,217 +1,15 @@ ! SPDX-FileCopyrightText: FLEXPART 1998-2019, see flexpart_license.txt ! SPDX-License-Identifier: GPL-3.0-or-later module settling_mod - + implicit none private :: viscosity public :: get_settling contains -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. * - ! * - ! Changes * - ! Daria Tatsii 2022: implementation of shape factor according to * - ! Bagheri & Bonadonna 2016 * - !***************************************************************************** - ! * - ! Variables: * - ! itime [s] current temporal position * - ! xt,yt,zt coordinates position for which wind data shall be cal- * - ! culated * - ! * - ! Constants: * - ! dfdr fluid density/particle density * - ! Veq [m^3] equivalent volume of a sphere * - ! dcyl [m] diameter of a cylinder (fiber) * - ! f flatness parameters, S/I * - ! e elongation parameters, I/L * - ! Fs Stokes form factor, f e^1.3 * - ! Fn Newton's form factor * - ! Ks Stokes' drag correction * - ! vsp help variable * - ! x aspect ratio of cylinder height to its diameter * - ! * - ! Variables: * - ! c_d drag coefficient * - ! settling [m/s] settling velocity * - !***************************************************************************** - - use par_mod - use com_mod - use windfields_mod - - implicit none - - integer, intent(in) :: itime, nsp - real, intent(in) :: xt, yt, zt - real, intent(out) :: settling - integer :: indz - - ! Auxiliary variables needed for interpolation - real :: dz1,dz2,dz - real :: rho1(2),tt1(2),temperature,airdens,vis_dyn,vis_kin - real :: settling_old,reynolds,c_d - integer :: i,n,nix,njy,indzh - - ! Variables needed for drag coefficient calculation - real :: dfdr,f,e,kn,ks,alpha1,alpha2,beta1,beta2,ks1,ks2,kn1,kn2 - - !***************************************************************************** - ! 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 - !******************************************************* - indz=nz-1 - do i=2,nz - if (height(i).gt.zt) then - indz=i-1 - exit - endif - end do - - ! 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 - - - ! 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 to define settling velocity of a sphere, constant viscosity estimate - - if (shape(nsp).eq.0) then - do i=1,20 ! do a few iterations Why 20??? - - ! 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 - - ! Clift and Guavin 1971 model - - c_d=(24.0/reynolds)*(1+0.15*(reynolds**0.687))+ & - 0.42/(1.0+42500.0/(reynolds**1.16)) - - settling=-1.* & - sqrt(4*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ & - (3.*c_d*airdens)) - - if (abs((settling-settling_old)/settling).lt.0.01) exit ! stop iteration - - reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin - settling_old=settling - end do - - else ! Drag coefficient scheme by Bagheri & Bonadonna, 2016 to define settling velocities of other shapes (by D.Tatsii) - dfdr=density(nsp)/airdens - - ! Orientation of particles - !************************* - if (orient(nsp).eq.0) then - ! Horizontal orientation - alpha2=0.77 ! B&B: eq. 32 - beta2=0.63 - ks=0.5*((Fs(nsp)**0.05)+(Fs(nsp)**(-0.36))) ! B&B Figure 12 k_(s,max) - kn=10.**(alpha2*(-log10(Fn(nsp)))**beta2) - else if (orient(nsp).eq.1) then - ! Random orientation - alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0) - beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0) - ks=(Fs(nsp)**(1./3.) + Fs(nsp)**(-1./3))/2. - kn=10.**(alpha1*(-log10(Fn(nsp)))**beta1) - else - ! The average of random and horizontal orientation - alpha1=0.45+10.0/(exp(2.5*log10(dfdr))+30.0) - beta1=1.-37.0/(exp(3.0*log10(dfdr))+100.0) - alpha2=0.77 ! B&B: eq. 32 - beta2=0.63 - ks1=(Fs(nsp)**(1./3.) + Fs(nsp)**(-1./3))/2. - kn1=10.**(alpha1*(-log10(Fn(nsp)))**beta1) - ks2=0.5*((Fs(nsp)**0.05)+(Fs(nsp)**(-0.36))) ! B&B Figure 12 k_(s,max) - kn2=10.**(alpha2*(-log10(Fn(nsp)))**beta2) - ks=(ks1+ks2)/2. - kn=(kn1+kn2)/2. - endif - - do i=1,20 - c_d=(24.*ks/reynolds)*(1.+0.125*((reynolds*kn/ks)**(2./3.)))+ & - (0.46*kn/(1.+5330./(reynolds*kn/ks))) - - settling=-1.* & - sqrt(4.*ga*dquer(nsp)/1.e6*density(nsp)*cunningham(nsp)/ & - (3.*c_d*airdens)) - - if (abs((settling-settling_old)/settling).lt.0.01) exit - - reynolds=dquer(nsp)/1.e6*abs(settling)/vis_kin - settling_old=settling - end do - endif -end subroutine get_settling - -real function viscosity(t) - ! Function calculates dynamic viscosity of air (kg/m/s) as function of - ! temperature (K) using Sutherland's formula - 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 +#include "set_get_settling.f90" -end function viscosity +#include "set_viscosity.f90" end module settling_mod diff --git a/src/tim_timemanager.f90 b/src/tim_timemanager.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c3fa8e6d23708415324a18d106e1bcc686c42767 --- /dev/null +++ b/src/tim_timemanager.f90 @@ -0,0 +1,651 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine timemanager + + !***************************************************************************** + ! * + ! 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 * + ! * + !***************************************************************************** + ! 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 * + ! Changes Stefan Henne, Harald Sodemann, 2013-2014 * + ! added netcdf output code * + ! Changes Espen Sollum 2014 * + ! For compatibility with MPI version, * + ! variables uap,ucp,uzp,us,vs,ws,cbt now in module com_mod * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! Changes L Bakels 2022: - OpenMP parallelisation * + ! - converting input to ETA coordinates * + ! - spawning particles from part_ic.nc * + !***************************************************************************** + ! * + ! 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 * + ! itime [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 * + ! loutrestart [s] time interval for which restart files will be produced * + ! npoint 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 * + ! 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) * + ! * + !***************************************************************************** + ! openmp change + use omp_lib + ! openmp change end + use unc_mod + use point_mod + use xmass_mod + use flux_mod + use prepoutgrid_mod + use ohr_mod + use par_mod + use com_mod + use coord_ec_mod + use particle_mod + use conv_mod + use windfields_mod + use advance_mod, only: advance + use drydepo_mod + use wetdepo_mod + use plume_mod + use initialise_mod + use getfields_mod + use output_mod + use interpol_mod, only: alloc_interpol,dealloc_interpol + + implicit none + real, parameter :: & + e_inv = 1.0/exp(1.0) + integer :: & + j,i, & ! loop variable + ks, & ! loop variable species + kp, & ! loop variable for maxpointspec_act + l, & ! loop variable over nclassunc + n, & ! loop variable over particles + itime=0, & ! time index + nstop1, & ! windfield existence flag + loutnext, & ! following timestep + loutstart,loutend, & ! concentration calculation starting and ending time + ix,jy, & ! gridcell indices + ldeltat, & ! radioactive decay time + itage,nage,inage, & ! related to age classes + idummy, & ! used for the random routines + i_nan=0,ii_nan,total_nan_intl=0, & !added by mc to check instability in CBL scheme + thread ! openmp change (not sure if necessary) + ! logical :: & + ! active_per_rel(maxpoint) ! are there particles active in each release + real :: & + filesize!(maxpoint) ! Keeping track of the size of the particledump output, so it can be splitted + ! real(kind=dp) :: & + ! jul + ! integer :: & + ! jjjjmmdd,ihmmss + real :: & + outnum, & ! concentration calculation sample number + prob_rec(maxspec), & ! dry deposition related + decfact, & ! radioactive decay factor + wetscav, & ! wet scavenging + xmassfract, & ! dry deposition related + grfraction(3) ! wet deposition related + real(dep_prec) :: & + drydeposit(maxspec) ! dry deposition related + real(kind=dp) :: zhier,zetahier + integer :: npart_alive=0,alive_tmp,spawned_tmp,terminated_tmp + + ! First output for time 0 + !************************ + if (itime_init.ne.0) then + loutnext=loutnext_init + outnum=outnum_init + else + loutnext=loutstep/2 + outnum=0. + endif + loutstart=loutnext-loutaver/2 + loutend=loutnext+loutaver/2 + + ! Initialise the nan count for CBL option + !**************************************** + sum_nan_count(:) = 0 + nan_count(:) = 0 + + !********************************************************************** + ! Loop over the whole modelling period in time steps of mintime seconds + !********************************************************************** + + write(*,46) float(itime)/3600,itime,numpart +46 format(' Simulated ',f7.1,' hours (',i13,' s), ',i13, ' particles') + + filesize=0. + ! active_per_rel=.false. + + ! ! Allocate memory for windfields + ! !******************************* + ! call alloc_windf + + do itime=itime_init,ideltas,lsynctime + + ! Computation of wet deposition, OH reaction and mass transfer + ! between two species 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 + !******************************************************************** + + ! Write basic information on the simulation to a file "header" for the + ! first time step and open files that are to be kept open throughout + ! the simulation. + ! In addition, open new particle dump files if required and keep track + ! of the size of these files. + !********************************************************************* + + write(*,*) 'Time: ', itime, 'seconds.' + + if (itime.eq.itime_init) then + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_firstt = real(count_clock)/real(count_rate) + endif + + ! Writing restart file + !********************* + if ((itime.ne.itime_init).and.(mod(itime,loutrestart).eq.0)) call output_restart(itime,loutnext,outnum) + + if (itime.ne.0) write(*,*) part(1)%xlon,part(1)%ylat,part(1)%z,part(1)%zeta + call init_output(itime,filesize) + + ! Get necessary wind fields if not available + !******************************************* + call getfields(itime,nstop1) !OMP on verttransform_ecmwf and readwind_ecmwf, getfields_mod.f90 + if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE' + + ! In case of ETA coordinates being read from file, convert the z positions + !************************************************************************* + if (((ipin.eq.1).or.(ipin.eq.4)).and.(itime.eq.itime_init).and.(wind_coord_type.eq.'ETA')) then + if (numpart.le.0) stop 'Something is going wrong reading the old particle file!' +!$OMP PARALLEL PRIVATE(i) +!$OMP DO + do i=1,numpart + call update_z_to_zeta(itime, i) + end do +!$OMP END DO +!$OMP END PARALLEL + endif + + if ((ipin.eq.3).and.(itime.eq.itime_init).and.(wind_coord_type.eq.'ETA')) then + do i=1,count%allocated + call update_z_to_zeta(itime, i) + end do + endif + + if (WETDEP .and. (itime.ne.0) .and. (numpart.gt.0)) then + call wetdepo(itime,lsynctime,loutnext) !OMP, wetdepo_mod.f90 (needs test) + endif + + if (OHREA .and. (itime.ne.0) .and. (numpart.gt.0)) & + call ohreaction(itime,lsynctime,loutnext) !OMP, ohr_mod.f90 (needs test) + + ! compute convection for backward runs + !************************************* + + if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(itime.lt.0)) then + call convmix(itime) !OMP, conv_mod.f90 + endif + + ! Get hourly OH fields if not available + !**************************************************** + if (OHREA) then + call gethourlyOH(itime) !OMP, ohr_mod.f90 (needs test) + endif + + ! Release particles + !****************** + if (mdomainfill.ge.1) then + if (itime.eq.itime_init) then + call init_domainfill !OMP, initialise_mod.f90 (needs test) + else + call boundcond_domainfill(itime,loutend) !OMP, initialise_mod.f90 (needs test) + endif + else if ((ipin.eq.3).or.(ipin.eq.4)) then + ! If reading from user defined initial conditions, check which particles are + ! to be activated + if (count%allocated.le.0) stop 'Something is going wrong reading the part_ic.nc file!' + + alive_tmp=count%alive + spawned_tmp=count%spawned +!$OMP PARALLEL PRIVATE(i) REDUCTION(+:alive_tmp,spawned_tmp) +!$OMP DO + do i=1,count%allocated + if (.not. part(i)%alive) then + if (ldirect.lt.0) then + if ((part(i)%tstart.le.itime).and.(part(i)%tstart.gt.itime+lsynctime)) then + call spawn_particle(itime,i) + call update_z_to_zeta(itime,i) + alive_tmp=alive_tmp+1 + spawned_tmp=spawned_tmp+1 + endif + else if ((part(i)%tstart.ge.itime).and.(part(i)%tstart.lt.itime+lsynctime)) then + call spawn_particle(itime,i) + call update_z_to_zeta(itime,i) + alive_tmp=alive_tmp+1 + spawned_tmp=spawned_tmp+1 + endif + endif + end do +!$OMP END DO +!$OMP END PARALLEL + count%alive=alive_tmp + count%spawned=spawned_tmp + call get_totalpart_num(numpart) + else + call releaseparticle(itime) + endif + + ! 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)) then + call convmix(itime) !OMP (not the nested part yet), conv_mod.f90 + endif + + ! If middle of averaging period of output fields is reached, accumulated + ! deposited mass radioactively decays + !*********************************************************************** + if (DEP.and.(itime.eq.loutnext).and.(ldirect.gt.0)) call deposit_decay() !OMP, unc_mod.f90 (needs test) + + + ! Is the time within the computation interval, if not, skip + !************************************************************ + if ((ldirect*itime.ge.ldirect*loutstart).and.(ldirect*itime.le.ldirect*loutend)) then + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_temp = (count_clock - count_clock0)/real(count_rate) + ! If it is not time yet to write outputs, skip + !*********************************************** + if ((itime.eq.loutend).and.(outnum.gt.0).and.(itime.ne.0)) then + + if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(itime) + if (iflux.eq.1) call fluxoutput(itime) + if (ipout.ge.1) then + if (mod(itime,ipoutfac*loutstep).eq.0) then + + call output_particle(itime)!,active_per_rel) ! dump particle positions + endif + endif + endif + ! Check whether concentrations are to be calculated and outputted + !**************************************************************** + call output_conc(itime,loutstart,loutend,loutnext,outnum) + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_writepart = s_writepart + ((count_clock - count_clock0)/real(count_rate)-s_temp) + endif + + if (itime.eq.ideltas) exit ! almost finished + + ! Compute interval since radioactive decay of deposited mass was computed + !************************************************************************ + + if (itime.lt.loutnext) then + ldeltat=itime-(loutnext-loutstep) + else ! first half of next interval + ldeltat=itime-loutnext + endif + + + ! Loop over all particles + !************************ + ! Various variables for testing reason of CBL scheme, by mc + well_mixed_vector=0. !erase vector to test well mixed condition: modified by mc + well_mixed_norm=0. !erase normalization to test well mixed condition: modified by mc + avg_ol=0. + avg_wst=0. + avg_h=0. + avg_air_dens=0. !erase vector to obtain air density at particle positions: modified by mc + !----------------------------------------------------------------------------- + + ! openmp change + ! LB, openmp following CTM version, need to be very careful due to big differences + ! between the openmp loop in this and the CTM version +!$OMP PARALLEL PRIVATE(prob_rec,inage,nage,itage,ks,kp,thread,j,xmassfract,drydeposit) + +#if (defined _OPENMP) + thread = OMP_GET_THREAD_NUM() ! Starts with 0 +#else + thread = 0 +#endif + +!$OMP DO +! SCHEDULE(dynamic, max(1,numpart/1000)) +!max(1,int(real(numpart)/numthreads/20.))) + do j=1,numpart + + ! If integration step is due, do it + !********************************** + if (.not. part(j)%alive) cycle + + ! Determine age class of the particle + !************************************ + itage=abs(itime-part(j)%tstart) + nage=1 + do inage=1,nageclass + nage=inage + if (itage.lt.lage(nage)) exit + end do + + ! Initialize newly released particle + !*********************************** + if ((part(j)%tstart.eq.itime).or.(itime.eq.0)) then + call update_zeta_to_z(itime, j) + call init_particle(itime,j) + endif + + ! Memorize particle positions + !**************************** + part(j)%xlon_prev=part(j)%xlon + part(j)%ylat_prev=part(j)%ylat + part(j)%z_prev=part(j)%z + part(j)%zeta_prev=part(j)%zeta + + ! RECEPTOR: dry/wet depovel + !**************************** + ! Before the particle is moved + ! the calculation of the scavenged mass shall only be done once after release + ! xscav_frac1 was initialised with a negative value + + if (DRYBKDEP) then + do ks=1,nspec + if ((xscav_frac1(j,ks).lt.0)) then + call update_zeta_to_z(itime,j) + call get_vdep_prob(itime,real(part(j)%xlon),real(part(j)%ylat), & + real(part(j)%z),prob_rec) + if (DRYDEPSPEC(ks)) then ! dry deposition + xscav_frac1(j,ks)=prob_rec(ks) + else + part(j)%mass(ks)=0. + xscav_frac1(j,ks)=0. + endif + endif + enddo + endif + + ! Integrate Langevin equation for lsynctime seconds + !************************************************* + + call advance(itime,j,thread) + + if (part(j)%nstop.eqv..true.) cycle + if (n_average.gt.0) call partpos_avg(itime,j) + + ! Calculate the gross fluxes across layer interfaces + !*************************************************** + if (iflux.eq.1) call calcfluxes(itime,nage,j,real(part(j)%xlon_prev), & + real(part(j)%ylat_prev),real(part(j)%z_prev),thread+1) + end do +!$OMP END DO +!$OMP END PARALLEL + +#ifdef _OPENMP + call omp_set_num_threads(numthreads_grid) +#endif + + alive_tmp=count%alive + terminated_tmp=count%terminated + +!$OMP PARALLEL PRIVATE(prob_rec,nage,inage,itage,ks,kp,thread,j,xmassfract,drydeposit) & +!$OMP REDUCTION(+:alive_tmp,terminated_tmp) + +!num_threads(numthreads_grid) + +#if (defined _OPENMP) + thread = OMP_GET_THREAD_NUM() ! Starts with 0 +#else + thread = 0 +#endif + +!$OMP DO +! SCHEDULE(dynamic, max(1,numpart/1000)) +!max(1,int(real(numpart)/numthreads/20.))) + do j=1,numpart + + ! If integration step is due, do it + !********************************** + if (.not. part(j)%alive) cycle + + ! Determine age class of the particle + !************************************ + itage=abs(itime-part(j)%tstart) + nage=1 + do inage=1,nageclass + nage=inage + if (itage.lt.lage(nage)) exit + end do + + ! Determine, when next time step is due + ! If trajectory is terminated, mark it + !************************************** + if (part(j)%nstop) then + if (linit_cond.ge.1) call initcond_calc(itime,j,thread+1) + call terminate_particle(j,itime) + alive_tmp=alive_tmp-1 + terminated_tmp=terminated_tmp+1 + else + +! Dry deposition and radioactive decay for each species +! Also check maximum (of all species) of initial mass remaining on the particle; +! if it is below a threshold value, terminate particle +!***************************************************************************** + + xmassfract=0. + do ks=1,nspec + + if (DRYDEPSPEC(ks)) then ! dry deposition (and radioactive decay) + + call drydepo_massloss(j,ks,ldeltat,drydeposit(ks)) + + else if (decay(ks).gt.0.) then ! no dry depo, but radioactive decay + + part(j)%mass(ks) = part(j)%mass(ks) * & + exp( -real(abs(lsynctime)) * decay(ks) ) + + endif + + ! Skip check on mass fraction when npoint represents particle number + if (mdomainfill.eq.0.and.mquasilag.eq.0) then + if (ipin.eq.3 .or. ipin.eq.4) then + if (part(j)%mass_init(ks).gt.0) & + xmassfract = max( xmassfract, & + part(j)%mass(ks) / part(j)%mass_init(ks) ) + else if (xmass(part(j)%npoint,ks).gt.0.) then + xmassfract = max( xmassfract, real( npart(part(j)%npoint) ) * & + part(j)%mass(ks) / xmass(part(j)%npoint,ks) ) + endif + else + xmassfract=1.0 + end if + + end do + + if (xmassfract.le.minmassfrac) then + ! terminate all particles carrying less mass + call terminate_particle(j,itime) + alive_tmp=alive_tmp-1 + terminated_tmp=terminated_tmp+1 + endif + +! Sabine Eckhardt, June 2008 +! don't create depofield for backward runs + if (DRYDEP.AND.(ldirect.eq.1).and.(iout.ne.0)) then + + if (ioutputforeachrelease.eq.1) then + kp=part(j)%npoint + else + kp=1 + endif + + call drydepokernel(part(j)%nclass,drydeposit,real(part(j)%xlon), & + real(part(j)%ylat),nage,kp,thread+1) + if (nested_output.eq.1) call drydepokernel_nest( & + part(j)%nclass,drydeposit,real(part(j)%xlon),real(part(j)%ylat), & + nage,kp,thread+1) + endif + + ! Terminate trajectories that are older than maximum allowed age + !*************************************************************** + + if ((part(j)%alive).and.(abs(itime-part(j)%tstart).ge.lage(nageclass))) then + if (linit_cond.ge.1) call initcond_calc(itime+lsynctime,j,thread+1) + call terminate_particle(j,itime) + alive_tmp=alive_tmp-1 + terminated_tmp=terminated_tmp+1 + endif + endif + + end do !loop over particles + +!$OMP END DO +!$OMP END PARALLEL + + count%alive=alive_tmp + count%terminated=terminated_tmp + +#ifdef _OPENMP + call omp_set_num_threads(numthreads) +#endif + ! OpenMP Reduction for dynamically allocated arrays. This is done manually since this + ! is not yet supported in most OpenMP versions + !************************************************************************************ +#ifdef _OPENMP + if (iflux.eq.1) then + do i=1,numthreads + flux(:,:,:,:,:,:,:)=flux(:,:,:,:,:,:,:)+flux_omp(:,:,:,:,:,:,:,i) + flux_omp(:,:,:,:,:,:,:,i)=0. + end do + endif + if (linit_cond.ge.1) then + do i=1,numthreads_grid + init_cond(:,:,:,:,:)=init_cond(:,:,:,:,:)+init_cond_omp(:,:,:,:,:,i) + init_cond_omp(:,:,:,:,:,i)=0. + end do + endif + if (DRYDEP.AND.(ldirect.eq.1).and.(iout.ne.0)) then + do i=1,numthreads_grid + drygridunc(:,:,:,:,:,:)=drygridunc(:,:,:,:,:,:)+gridunc_omp(:,:,1,:,:,:,:,i) + gridunc_omp(:,:,1,:,:,:,:,i)=0. + end do + if (nested_output.eq.1) then + do i=1,numthreads_grid + drygriduncn(:,:,:,:,:,:)=drygriduncn(:,:,:,:,:,:)+griduncn_omp(:,:,1,:,:,:,:,i) + griduncn_omp(:,:,1,:,:,:,:,i)=0. + end do + endif + endif +#endif + ! write(*,*) 'DRYGRIDUNC:',sum(drygridunc),drygridunc(20,270,1,1,1,1),drygridunc(19,269,1,1,1,1) + ! Counter of "unstable" particle velocity during a time scale of + ! maximumtl=20 minutes (defined in com_mod) + !*************************************************************** + + total_nan_intl=0 + i_nan=i_nan+1 ! added by mc to count nan during a time of maxtl (i.e. maximum tl fixed here to 20 minutes, see com_mod) + do i=1,numthreads + sum_nan_count(i_nan)=sum_nan_count(i_nan)+nan_count(i) + end do + if (i_nan > maxtl/lsynctime) i_nan=1 !lsynctime must be <= maxtl + do ii_nan=1, (maxtl/lsynctime) + total_nan_intl=total_nan_intl+sum_nan_count(ii_nan) + end do + ! Output to keep track of the numerical instabilities in CBL simulation and if + ! they are compromising the final result (or not) + if (cblflag.eq.1) print *,j,itime,'nan_synctime',sum_nan_count(i_nan),'nan_tl',total_nan_intl + + if (itime.eq.itime_init) then + call SYSTEM_CLOCK(count_clock, count_rate, count_max) + s_firstt = real(count_clock)/real(count_rate) - s_firstt + endif + + end do + + ! Complete the calculation of initial conditions for particles not yet terminated + !***************************************************************************** + call finalise_output(itime) + + ! De-allocate memory and end + !*************************** + call dealloc_all_particles + call dealloc_windf + call dealloc_domainfill + call dealloc_drydepo + call dealloc_convect + call dealloc_getfields + call dealloc_interpol + call dealloc_random + if (numbnests.ge.1) call dealloc_windf_nest + if (iflux.eq.1) deallocate(flux) + if (OHREA) deallocate(OH_field,OH_hourly,lonOH,latOH,altOH) + if (ipin.ne.3 .and. ipin.ne.4) & + deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmasssave) + deallocate(xmass) + deallocate(ireleasestart,ireleaseend,npart,kindz) + deallocate(nan_count) + if (ipout.ne.0) deallocate( partopt ) + if (iout.ne.0) then + deallocate(outheight,outheighthalf) + deallocate(oroout, area, volume) + deallocate(gridunc) +#ifdef _OPENMP + deallocate(gridunc_omp) +#endif + if (ldirect.gt.0) then + deallocate(drygridunc,wetgridunc) +#ifdef _OPENMP + deallocate(drygridunc_omp,wetgridunc_omp) +#endif + endif + if (nested_output.eq.1) then + deallocate(orooutn, arean, volumen) + if (ldirect.gt.0) then + deallocate(griduncn,drygriduncn,wetgriduncn) +#ifdef _OPENMP + deallocate(griduncn_omp,drygriduncn_omp,wetgriduncn_omp) +#endif + endif + endif + endif +end subroutine timemanager diff --git a/src/timemanager_mod.f90 b/src/timemanager_mod.f90 index 1c0b2fb8c50c70f72f7c1ccc09cd683f62fa01ed..a921971dac87d21653ec705c1321c6de2165fb6c 100644 --- a/src/timemanager_mod.f90 +++ b/src/timemanager_mod.f90 @@ -13,653 +13,6 @@ implicit none contains -subroutine timemanager - - !***************************************************************************** - ! * - ! 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 * - ! * - !***************************************************************************** - ! 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 * - ! Changes Stefan Henne, Harald Sodemann, 2013-2014 * - ! added netcdf output code * - ! Changes Espen Sollum 2014 * - ! For compatibility with MPI version, * - ! variables uap,ucp,uzp,us,vs,ws,cbt now in module com_mod * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! Changes L Bakels 2022: - OpenMP parallelisation * - ! - converting input to ETA coordinates * - ! - spawning particles from part_ic.nc * - !***************************************************************************** - ! * - ! 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 * - ! itime [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 * - ! loutrestart [s] time interval for which restart files will be produced * - ! npoint 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 * - ! 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) * - ! * - !***************************************************************************** - ! openmp change - use omp_lib - ! openmp change end - use unc_mod - use point_mod - use xmass_mod - use flux_mod - use prepoutgrid_mod - use ohr_mod - use par_mod - use com_mod - use coord_ec_mod - use particle_mod - use conv_mod - use windfields_mod - use advance_mod, only: advance - use drydepo_mod - use wetdepo_mod - use plume_mod - use initialise_mod - use getfields_mod - use output_mod - use interpol_mod, only: alloc_interpol,dealloc_interpol - - implicit none - real, parameter :: & - e_inv = 1.0/exp(1.0) - integer :: & - j,i, & ! loop variable - ks, & ! loop variable species - kp, & ! loop variable for maxpointspec_act - l, & ! loop variable over nclassunc - n, & ! loop variable over particles - itime=0, & ! time index - nstop1, & ! windfield existence flag - loutnext, & ! following timestep - loutstart,loutend, & ! concentration calculation starting and ending time - ix,jy, & ! gridcell indices - ldeltat, & ! radioactive decay time - itage,nage,inage, & ! related to age classes - idummy, & ! used for the random routines - i_nan=0,ii_nan,total_nan_intl=0, & !added by mc to check instability in CBL scheme - thread ! openmp change (not sure if necessary) - ! logical :: & - ! active_per_rel(maxpoint) ! are there particles active in each release - real :: & - filesize!(maxpoint) ! Keeping track of the size of the particledump output, so it can be splitted - ! real(kind=dp) :: & - ! jul - ! integer :: & - ! jjjjmmdd,ihmmss - real :: & - outnum, & ! concentration calculation sample number - prob_rec(maxspec), & ! dry deposition related - decfact, & ! radioactive decay factor - wetscav, & ! wet scavenging - xmassfract, & ! dry deposition related - grfraction(3) ! wet deposition related - real(dep_prec) :: & - drydeposit(maxspec) ! dry deposition related - real(kind=dp) :: zhier,zetahier - integer :: npart_alive=0,alive_tmp,spawned_tmp,terminated_tmp - - ! First output for time 0 - !************************ - if (itime_init.ne.0) then - loutnext=loutnext_init - outnum=outnum_init - else - loutnext=loutstep/2 - outnum=0. - endif - loutstart=loutnext-loutaver/2 - loutend=loutnext+loutaver/2 - - ! Initialise the nan count for CBL option - !**************************************** - sum_nan_count(:) = 0 - nan_count(:) = 0 - - !********************************************************************** - ! Loop over the whole modelling period in time steps of mintime seconds - !********************************************************************** - - write(*,46) float(itime)/3600,itime,numpart -46 format(' Simulated ',f7.1,' hours (',i13,' s), ',i13, ' particles') - - filesize=0. - ! active_per_rel=.false. - - ! ! Allocate memory for windfields - ! !******************************* - ! call alloc_windf - - do itime=itime_init,ideltas,lsynctime - - ! Computation of wet deposition, OH reaction and mass transfer - ! between two species 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 - !******************************************************************** - - ! Write basic information on the simulation to a file "header" for the - ! first time step and open files that are to be kept open throughout - ! the simulation. - ! In addition, open new particle dump files if required and keep track - ! of the size of these files. - !********************************************************************* - - write(*,*) 'Time: ', itime, 'seconds.' - - if (itime.eq.itime_init) then - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_firstt = real(count_clock)/real(count_rate) - endif - - ! Writing restart file - !********************* - if ((itime.ne.itime_init).and.(mod(itime,loutrestart).eq.0)) call output_restart(itime,loutnext,outnum) - - if (itime.ne.0) write(*,*) part(1)%xlon,part(1)%ylat,part(1)%z,part(1)%zeta - call init_output(itime,filesize) - - ! Get necessary wind fields if not available - !******************************************* - call getfields(itime,nstop1) !OMP on verttransform_ecmwf and readwind_ecmwf, getfields_mod.f90 - if (nstop1.gt.1) stop 'NO METEO FIELDS AVAILABLE' - - ! In case of ETA coordinates being read from file, convert the z positions - !************************************************************************* - if (((ipin.eq.1).or.(ipin.eq.4)).and.(itime.eq.itime_init).and.(wind_coord_type.eq.'ETA')) then - if (numpart.le.0) stop 'Something is going wrong reading the old particle file!' -!$OMP PARALLEL PRIVATE(i) -!$OMP DO - do i=1,numpart - call update_z_to_zeta(itime, i) - end do -!$OMP END DO -!$OMP END PARALLEL - endif - - if ((ipin.eq.3).and.(itime.eq.itime_init).and.(wind_coord_type.eq.'ETA')) then - do i=1,count%allocated - call update_z_to_zeta(itime, i) - end do - endif - - if (WETDEP .and. (itime.ne.0) .and. (numpart.gt.0)) then - call wetdepo(itime,lsynctime,loutnext) !OMP, wetdepo_mod.f90 (needs test) - endif - - if (OHREA .and. (itime.ne.0) .and. (numpart.gt.0)) & - call ohreaction(itime,lsynctime,loutnext) !OMP, ohr_mod.f90 (needs test) - - ! compute convection for backward runs - !************************************* - - if ((ldirect.eq.-1).and.(lconvection.eq.1).and.(itime.lt.0)) then - call convmix(itime) !OMP, conv_mod.f90 - endif - - ! Get hourly OH fields if not available - !**************************************************** - if (OHREA) then - call gethourlyOH(itime) !OMP, ohr_mod.f90 (needs test) - endif - - ! Release particles - !****************** - if (mdomainfill.ge.1) then - if (itime.eq.itime_init) then - call init_domainfill !OMP, initialise_mod.f90 (needs test) - else - call boundcond_domainfill(itime,loutend) !OMP, initialise_mod.f90 (needs test) - endif - else if ((ipin.eq.3).or.(ipin.eq.4)) then - ! If reading from user defined initial conditions, check which particles are - ! to be activated - if (count%allocated.le.0) stop 'Something is going wrong reading the part_ic.nc file!' - - alive_tmp=count%alive - spawned_tmp=count%spawned -!$OMP PARALLEL PRIVATE(i) REDUCTION(+:alive_tmp,spawned_tmp) -!$OMP DO - do i=1,count%allocated - if (.not. part(i)%alive) then - if (ldirect.lt.0) then - if ((part(i)%tstart.le.itime).and.(part(i)%tstart.gt.itime+lsynctime)) then - call spawn_particle(itime,i) - call update_z_to_zeta(itime,i) - alive_tmp=alive_tmp+1 - spawned_tmp=spawned_tmp+1 - endif - else if ((part(i)%tstart.ge.itime).and.(part(i)%tstart.lt.itime+lsynctime)) then - call spawn_particle(itime,i) - call update_z_to_zeta(itime,i) - alive_tmp=alive_tmp+1 - spawned_tmp=spawned_tmp+1 - endif - endif - end do -!$OMP END DO -!$OMP END PARALLEL - count%alive=alive_tmp - count%spawned=spawned_tmp - call get_totalpart_num(numpart) - else - call releaseparticle(itime) - endif - - ! 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)) then - call convmix(itime) !OMP (not the nested part yet), conv_mod.f90 - endif - - ! If middle of averaging period of output fields is reached, accumulated - ! deposited mass radioactively decays - !*********************************************************************** - if (DEP.and.(itime.eq.loutnext).and.(ldirect.gt.0)) call deposit_decay() !OMP, unc_mod.f90 (needs test) - - - ! Is the time within the computation interval, if not, skip - !************************************************************ - if ((ldirect*itime.ge.ldirect*loutstart).and.(ldirect*itime.le.ldirect*loutend)) then - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_temp = (count_clock - count_clock0)/real(count_rate) - ! If it is not time yet to write outputs, skip - !*********************************************** - if ((itime.eq.loutend).and.(outnum.gt.0).and.(itime.ne.0)) then - - if ((iout.eq.4).or.(iout.eq.5)) call plumetraj(itime) - if (iflux.eq.1) call fluxoutput(itime) - if (ipout.ge.1) then - if (mod(itime,ipoutfac*loutstep).eq.0) then - - call output_particle(itime)!,active_per_rel) ! dump particle positions - endif - endif - endif - ! Check whether concentrations are to be calculated and outputted - !**************************************************************** - call output_conc(itime,loutstart,loutend,loutnext,outnum) - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_writepart = s_writepart + ((count_clock - count_clock0)/real(count_rate)-s_temp) - endif - - if (itime.eq.ideltas) exit ! almost finished - - ! Compute interval since radioactive decay of deposited mass was computed - !************************************************************************ - - if (itime.lt.loutnext) then - ldeltat=itime-(loutnext-loutstep) - else ! first half of next interval - ldeltat=itime-loutnext - endif - - - ! Loop over all particles - !************************ - ! Various variables for testing reason of CBL scheme, by mc - well_mixed_vector=0. !erase vector to test well mixed condition: modified by mc - well_mixed_norm=0. !erase normalization to test well mixed condition: modified by mc - avg_ol=0. - avg_wst=0. - avg_h=0. - avg_air_dens=0. !erase vector to obtain air density at particle positions: modified by mc - !----------------------------------------------------------------------------- - - ! openmp change - ! LB, openmp following CTM version, need to be very careful due to big differences - ! between the openmp loop in this and the CTM version -!$OMP PARALLEL PRIVATE(prob_rec,inage,nage,itage,ks,kp,thread,j,xmassfract,drydeposit) - -#if (defined _OPENMP) - thread = OMP_GET_THREAD_NUM() ! Starts with 0 -#else - thread = 0 -#endif - -!$OMP DO -! SCHEDULE(dynamic, max(1,numpart/1000)) -!max(1,int(real(numpart)/numthreads/20.))) - do j=1,numpart - - ! If integration step is due, do it - !********************************** - if (.not. part(j)%alive) cycle - - ! Determine age class of the particle - !************************************ - itage=abs(itime-part(j)%tstart) - nage=1 - do inage=1,nageclass - nage=inage - if (itage.lt.lage(nage)) exit - end do - - ! Initialize newly released particle - !*********************************** - if ((part(j)%tstart.eq.itime).or.(itime.eq.0)) then - call update_zeta_to_z(itime, j) - call init_particle(itime,j) - endif - - ! Memorize particle positions - !**************************** - part(j)%xlon_prev=part(j)%xlon - part(j)%ylat_prev=part(j)%ylat - part(j)%z_prev=part(j)%z - part(j)%zeta_prev=part(j)%zeta - - ! RECEPTOR: dry/wet depovel - !**************************** - ! Before the particle is moved - ! the calculation of the scavenged mass shall only be done once after release - ! xscav_frac1 was initialised with a negative value - - if (DRYBKDEP) then - do ks=1,nspec - if ((xscav_frac1(j,ks).lt.0)) then - call update_zeta_to_z(itime,j) - call get_vdep_prob(itime,real(part(j)%xlon),real(part(j)%ylat), & - real(part(j)%z),prob_rec) - if (DRYDEPSPEC(ks)) then ! dry deposition - xscav_frac1(j,ks)=prob_rec(ks) - else - part(j)%mass(ks)=0. - xscav_frac1(j,ks)=0. - endif - endif - enddo - endif - - ! Integrate Langevin equation for lsynctime seconds - !************************************************* - - call advance(itime,j,thread) - - if (part(j)%nstop.eqv..true.) cycle - if (n_average.gt.0) call partpos_avg(itime,j) - - ! Calculate the gross fluxes across layer interfaces - !*************************************************** - if (iflux.eq.1) call calcfluxes(itime,nage,j,real(part(j)%xlon_prev), & - real(part(j)%ylat_prev),real(part(j)%z_prev),thread+1) - end do -!$OMP END DO -!$OMP END PARALLEL - -#ifdef _OPENMP - call omp_set_num_threads(numthreads_grid) -#endif - - alive_tmp=count%alive - terminated_tmp=count%terminated - -!$OMP PARALLEL PRIVATE(prob_rec,nage,inage,itage,ks,kp,thread,j,xmassfract,drydeposit) & -!$OMP REDUCTION(+:alive_tmp,terminated_tmp) - -!num_threads(numthreads_grid) - -#if (defined _OPENMP) - thread = OMP_GET_THREAD_NUM() ! Starts with 0 -#else - thread = 0 -#endif - -!$OMP DO -! SCHEDULE(dynamic, max(1,numpart/1000)) -!max(1,int(real(numpart)/numthreads/20.))) - do j=1,numpart - - ! If integration step is due, do it - !********************************** - if (.not. part(j)%alive) cycle - - ! Determine age class of the particle - !************************************ - itage=abs(itime-part(j)%tstart) - nage=1 - do inage=1,nageclass - nage=inage - if (itage.lt.lage(nage)) exit - end do - - ! Determine, when next time step is due - ! If trajectory is terminated, mark it - !************************************** - if (part(j)%nstop) then - if (linit_cond.ge.1) call initcond_calc(itime,j,thread+1) - call terminate_particle(j,itime) - alive_tmp=alive_tmp-1 - terminated_tmp=terminated_tmp+1 - else - -! Dry deposition and radioactive decay for each species -! Also check maximum (of all species) of initial mass remaining on the particle; -! if it is below a threshold value, terminate particle -!***************************************************************************** - - xmassfract=0. - do ks=1,nspec - - if (DRYDEPSPEC(ks)) then ! dry deposition (and radioactive decay) - - call drydepo_massloss(j,ks,ldeltat,drydeposit(ks)) - - else if (decay(ks).gt.0.) then ! no dry depo, but radioactive decay - - part(j)%mass(ks) = part(j)%mass(ks) * & - exp( -real(abs(lsynctime)) * decay(ks) ) - - endif - - ! Skip check on mass fraction when npoint represents particle number - if (mdomainfill.eq.0.and.mquasilag.eq.0) then - if (ipin.eq.3 .or. ipin.eq.4) then - if (part(j)%mass_init(ks).gt.0) & - xmassfract = max( xmassfract, & - part(j)%mass(ks) / part(j)%mass_init(ks) ) - else if (xmass(part(j)%npoint,ks).gt.0.) then - xmassfract = max( xmassfract, real( npart(part(j)%npoint) ) * & - part(j)%mass(ks) / xmass(part(j)%npoint,ks) ) - endif - else - xmassfract=1.0 - end if - - end do - - if (xmassfract.le.minmassfrac) then - ! terminate all particles carrying less mass - call terminate_particle(j,itime) - alive_tmp=alive_tmp-1 - terminated_tmp=terminated_tmp+1 - endif - -! Sabine Eckhardt, June 2008 -! don't create depofield for backward runs - if (DRYDEP.AND.(ldirect.eq.1).and.(iout.ne.0)) then - - if (ioutputforeachrelease.eq.1) then - kp=part(j)%npoint - else - kp=1 - endif - - call drydepokernel(part(j)%nclass,drydeposit,real(part(j)%xlon), & - real(part(j)%ylat),nage,kp,thread+1) - if (nested_output.eq.1) call drydepokernel_nest( & - part(j)%nclass,drydeposit,real(part(j)%xlon),real(part(j)%ylat), & - nage,kp,thread+1) - endif - - ! Terminate trajectories that are older than maximum allowed age - !*************************************************************** - - if ((part(j)%alive).and.(abs(itime-part(j)%tstart).ge.lage(nageclass))) then - if (linit_cond.ge.1) call initcond_calc(itime+lsynctime,j,thread+1) - call terminate_particle(j,itime) - alive_tmp=alive_tmp-1 - terminated_tmp=terminated_tmp+1 - endif - endif - - end do !loop over particles - -!$OMP END DO -!$OMP END PARALLEL - - count%alive=alive_tmp - count%terminated=terminated_tmp - -#ifdef _OPENMP - call omp_set_num_threads(numthreads) -#endif - ! OpenMP Reduction for dynamically allocated arrays. This is done manually since this - ! is not yet supported in most OpenMP versions - !************************************************************************************ -#ifdef _OPENMP - if (iflux.eq.1) then - do i=1,numthreads - flux(:,:,:,:,:,:,:)=flux(:,:,:,:,:,:,:)+flux_omp(:,:,:,:,:,:,:,i) - flux_omp(:,:,:,:,:,:,:,i)=0. - end do - endif - if (linit_cond.ge.1) then - do i=1,numthreads_grid - init_cond(:,:,:,:,:)=init_cond(:,:,:,:,:)+init_cond_omp(:,:,:,:,:,i) - init_cond_omp(:,:,:,:,:,i)=0. - end do - endif - if (DRYDEP.AND.(ldirect.eq.1).and.(iout.ne.0)) then - do i=1,numthreads_grid - drygridunc(:,:,:,:,:,:)=drygridunc(:,:,:,:,:,:)+gridunc_omp(:,:,1,:,:,:,:,i) - gridunc_omp(:,:,1,:,:,:,:,i)=0. - end do - if (nested_output.eq.1) then - do i=1,numthreads_grid - drygriduncn(:,:,:,:,:,:)=drygriduncn(:,:,:,:,:,:)+griduncn_omp(:,:,1,:,:,:,:,i) - griduncn_omp(:,:,1,:,:,:,:,i)=0. - end do - endif - endif -#endif - ! write(*,*) 'DRYGRIDUNC:',sum(drygridunc),drygridunc(20,270,1,1,1,1),drygridunc(19,269,1,1,1,1) - ! Counter of "unstable" particle velocity during a time scale of - ! maximumtl=20 minutes (defined in com_mod) - !*************************************************************** - - total_nan_intl=0 - i_nan=i_nan+1 ! added by mc to count nan during a time of maxtl (i.e. maximum tl fixed here to 20 minutes, see com_mod) - do i=1,numthreads - sum_nan_count(i_nan)=sum_nan_count(i_nan)+nan_count(i) - end do - if (i_nan > maxtl/lsynctime) i_nan=1 !lsynctime must be <= maxtl - do ii_nan=1, (maxtl/lsynctime) - total_nan_intl=total_nan_intl+sum_nan_count(ii_nan) - end do - ! Output to keep track of the numerical instabilities in CBL simulation and if - ! they are compromising the final result (or not) - if (cblflag.eq.1) print *,j,itime,'nan_synctime',sum_nan_count(i_nan),'nan_tl',total_nan_intl - - if (itime.eq.itime_init) then - call SYSTEM_CLOCK(count_clock, count_rate, count_max) - s_firstt = real(count_clock)/real(count_rate) - s_firstt - endif - - end do - - ! Complete the calculation of initial conditions for particles not yet terminated - !***************************************************************************** - call finalise_output(itime) - - ! De-allocate memory and end - !*************************** - call dealloc_all_particles - call dealloc_windf - call dealloc_domainfill - call dealloc_drydepo - call dealloc_convect - call dealloc_getfields - call dealloc_interpol - call dealloc_random - if (numbnests.ge.1) call dealloc_windf_nest - if (iflux.eq.1) deallocate(flux) - if (OHREA) deallocate(OH_field,OH_hourly,lonOH,latOH,altOH) - if (ipin.ne.3 .and. ipin.ne.4) & - deallocate(xpoint1,xpoint2,ypoint1,ypoint2,zpoint1,zpoint2,xmasssave) - deallocate(xmass) - deallocate(ireleasestart,ireleaseend,npart,kindz) - deallocate(nan_count) - if (ipout.ne.0) deallocate( partopt ) - if (iout.ne.0) then - deallocate(outheight,outheighthalf) - deallocate(oroout, area, volume) - deallocate(gridunc) -#ifdef _OPENMP - deallocate(gridunc_omp) -#endif - if (ldirect.gt.0) then - deallocate(drygridunc,wetgridunc) -#ifdef _OPENMP - deallocate(drygridunc_omp,wetgridunc_omp) -#endif - endif - if (nested_output.eq.1) then - deallocate(orooutn, arean, volumen) - if (ldirect.gt.0) then - deallocate(griduncn,drygriduncn,wetgriduncn) -#ifdef _OPENMP - deallocate(griduncn_omp,drygriduncn_omp,wetgriduncn_omp) -#endif - endif - endif - endif -end subroutine timemanager +#include "tim_timemanager.f90" end module timemanager_mod diff --git a/src/tur_hanna.f90 b/src/tur_hanna.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5deaa30fea4ae95d901f38fa56cc02a3d0154665 --- /dev/null +++ b/src/tur_hanna.f90 @@ -0,0 +1,102 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine hanna(z) + ! 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 * + ! * + !***************************************************************************** + + implicit none + + real :: corr,z + + + !********************** + ! 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/tur_hanna1.f90 b/src/tur_hanna1.f90 new file mode 100644 index 0000000000000000000000000000000000000000..08c48a8b02fcb7901b1553fccb078893a36710de --- /dev/null +++ b/src/tur_hanna1.f90 @@ -0,0 +1,125 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine hanna1(z) + ! 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 * + ! * + !***************************************************************************** + + implicit none + + real :: z,s1,s2 + + + + !********************** + ! 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/tur_hanna_short.f90 b/src/tur_hanna_short.f90 new file mode 100644 index 0000000000000000000000000000000000000000..eeb203de9bdc74dec9d8e9b6fc10dc7a66b94de9 --- /dev/null +++ b/src/tur_hanna_short.f90 @@ -0,0 +1,89 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine hanna_short(z) + ! 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 * + ! * + !***************************************************************************** + + implicit none + + real :: z + + + + !********************** + ! 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/tur_pbl_profile.f90 b/src/tur_pbl_profile.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dd974cb35de7d0d52c14dc9ff60eddadc1dbdbac --- /dev/null +++ b/src/tur_pbl_profile.f90 @@ -0,0 +1,113 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 qvsat_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,e,tv,stress + integer,parameter :: maxiter=10 + real,parameter :: r1=0.74 + + e=ew(td2m,ps) ! 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) exit !! Successive approximation successful + end do + 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/tur_psih.f90 b/src/tur_psih.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a72d6ea562526d4ae1e3078f113457ebde981e48 --- /dev/null +++ b/src/tur_psih.f90 @@ -0,0 +1,56 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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 * + ! * + !***************************************************************************** + + 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/tur_psim.f90 b/src/tur_psim.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c5851af2f23e39d21c76f9971493c979c70cfc39 --- /dev/null +++ b/src/tur_psim.f90 @@ -0,0 +1,30 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +real function psim(z,al) + + !********************************************************************** + ! * + ! DESCRIPTION: CALCULATION OF THE STABILITY CORRECTION FUNCTION FOR * + ! MOMENTUM AS FUNCTION OF HEIGHT Z AND OBUKHOV SCALE * + ! HEIGHT L * + ! * + !********************************************************************** + + 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/tur_turb_mesoscale.f90 b/src/tur_turb_mesoscale.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b4eab23edfafee44f35517e75ba5e542867c6c48 --- /dev/null +++ b/src/tur_turb_mesoscale.f90 @@ -0,0 +1,45 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine turb_mesoscale(nrand,dxsave,dysave,ipart,usig,vsig,wsig,wsigeta,eps_eta) + + implicit none + + integer, intent(inout) :: & + nrand ! random number used for turbulence + integer, intent(in) :: & + ipart ! particle index + real, intent(in) :: & + eps_eta,usig,vsig,wsig,wsigeta + real, intent(inout) :: & + dxsave,dysave ! accumulated displacement in long and lat + real :: & + r,rs, & ! mesoscale related + ux,vy ! random turbulent velocities above PBL + + r=exp(-2.*real(abs(lsynctime))/real(lwindinterv)) + rs=sqrt(1.-r**2) + if (nrand+2.gt.maxrand) nrand=1 + part(ipart)%mesovel%u=r*part(ipart)%mesovel%u+rs*rannumb(nrand)*usig*fturbmeso + part(ipart)%mesovel%v=r*part(ipart)%mesovel%v+rs*rannumb(nrand+1)*vsig*fturbmeso + dxsave=dxsave+part(ipart)%mesovel%u*real(lsynctime) + dysave=dysave+part(ipart)%mesovel%v*real(lsynctime) + + select case (wind_coord_type) + case ('ETA') + part(ipart)%mesovel%w=r*part(ipart)%mesovel%w+rs*rannumb(nrand+2)*wsigeta*fturbmeso + call update_zeta(ipart,part(ipart)%mesovel%w*real(lsynctime)) + if (part(ipart)%zeta.ge.1.) call set_zeta(ipart,1.-(part(ipart)%zeta-1.)) + if (part(ipart)%zeta.eq.1.) call update_zeta(ipart,-eps_eta) + + case ('METER') + part(ipart)%mesovel%w=r*part(ipart)%mesovel%w+rs*rannumb(nrand+2)*wsig*fturbmeso + call update_z(ipart,part(ipart)%mesovel%w*real(lsynctime)) + if (part(ipart)%z.lt.0.) call set_z(ipart,-1.*part(ipart)%z) ! if particle below ground -> refletion + + case default + part(ipart)%mesovel%w=r*part(ipart)%mesovel%w+rs*rannumb(nrand+2)*wsig*fturbmeso + call update_z(ipart,part(ipart)%mesovel%w*real(lsynctime)) + if (part(ipart)%z.lt.0.) call set_z(ipart,-1.*part(ipart)%z) ! if particle below ground -> refletion + end select +end subroutine turb_mesoscale diff --git a/src/tur_turb_pbl.f90 b/src/tur_turb_pbl.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7361e2f9a19d255857dd7174bce519289680e238 --- /dev/null +++ b/src/tur_turb_pbl.f90 @@ -0,0 +1,166 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine turb_pbl(ipart,nrand,dt,zts,rhoa,rhograd,thread) + + use cbl_mod + + implicit none + + integer, intent(in) :: & + ipart, & ! particle index + thread ! number of the omp thread + integer, intent(inout) ::& + nrand ! random number used for turbulence + real,intent(in) :: & + dt, & ! real(ldt) + rhoa, & ! air density, used in CBL + rhograd ! vertical gradient of the air density, used in CBL + real,intent(inout) :: & + zts ! local 'real' copy of the particle position + real :: & + delz, & ! change in vertical position due to turbulence + ru,rv,rw,wp,icbt_r, & ! used for computing turbulence + dtf,rhoaux,dtftlw,ath,bth,& ! CBL related + ptot_lhh,Q_lhh,phi_lhh, & ! CBL related + old_wp_buf,dcas,dcas1, & ! CBL related + del_test ! CBL related + integer :: & + flagrein, & ! flag used in CBL scheme + icbt, & + i ! loop variable + + ! tlw,dsigwdz and dsigw2dz are defined in hanna + if (turbswitch) then + call hanna(zts) + else + call hanna1(zts) + endif + + !***************************************** + ! Determine the new diffusivity velocities + !***************************************** + + ! Horizontal components + !********************** + if (nrand+1.gt.maxrand) nrand=1 + if (dt/tlu.lt..5) then + part(ipart)%turbvel%u=(1.-dt/tlu)*part(ipart)%turbvel%u+rannumb(nrand)*sigu*sqrt(2.*dt/tlu) + else + ru=exp(-dt/tlu) + part(ipart)%turbvel%u=ru*part(ipart)%turbvel%u+rannumb(nrand)*sigu*sqrt(1.-ru**2) + endif + if (dt/tlv.lt..5) then + part(ipart)%turbvel%v=(1.-dt/tlv)*part(ipart)%turbvel%v+rannumb(nrand+1)*sigv*sqrt(2.*dt/tlv) + else + rv=exp(-dt/tlv) + part(ipart)%turbvel%v=rv*part(ipart)%turbvel%v+rannumb(nrand+1)*sigv*sqrt(1.-rv**2) + endif + nrand=nrand+2 + + + if (nrand+ifine.gt.maxrand) nrand=1 + rhoaux=rhograd/rhoa + dtf=dt*fine + + dtftlw=dtf/tlw + + ! Loop over ifine short time steps for vertical component + !******************************************************** + wp=part(ipart)%turbvel%w + icbt=part(ipart)%icbt + do i=1,ifine + icbt_r=real(icbt) + ! Determine the drift velocity and density correction velocity + !************************************************************* + + if (turbswitch) then + if (dtftlw.lt..5) then + !************************************************************* + !************** CBL options added by mc see routine cblf90 *** + ! LB needs to be checked if this works with openmp + if (cblflag.eq.1) then !modified by mc + if (-h/ol.gt.5) then !modified by mc + flagrein=0 + nrand=nrand+1 + old_wp_buf=wp + call cbl(wp,zts,ust,wst,h,rhoa,rhograd,& + sigw,dsigwdz,tlw,ptot_lhh,Q_lhh,phi_lhh,ath,bth,ol,flagrein) !inside the routine for inverse time + wp=(wp+ath*dtf+& + bth*rannumb(nrand)*sqrt(dtf))*icbt_r + delz=wp*dtf + if ((flagrein.eq.1).or.(wp.ne.wp).or.((wp-1.).eq.wp)) then + call reinit_particle(zts,ust,wst,h,sigw,old_wp_buf,nrand,ol) + wp=old_wp_buf + delz=wp*dtf + nan_count(thread+1)=nan_count(thread+1)+1 + end if + else + 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)*icbt_r + delz=wp*dtf + if ((wp.ne.wp).or.((wp-1.).eq.wp)) then ! Catch infinity or NaN + nrand=nrand+1 + wp=sigw*rannumb(nrand) + delz=wp*dtf + nan_count(thread+1)=nan_count(thread+1)+1 + end if + end if + !******************** END CBL option ******************************* + !******************************************************************* + else + wp=((1.-dtftlw)*wp+rannumb(nrand+i)*sqrt(2.*dtftlw) & + +dtf*(dsigwdz+rhoaux*sigw))*icbt_r + 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))*icbt_r + 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))*icbt_r + delz=wp*dtf + endif + + !**************************************************** + ! Compute turbulent vertical displacement of particle + !**************************************************** + + 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.-zts) then ! reflection at ground + icbt=-1 + call set_z(ipart,-zts-delz) + else if (delz.gt.(h-zts)) then ! reflection at h + icbt=-1 + call set_z(ipart,-zts-delz+2.*h) + else ! no reflection + icbt=1 + call set_z(ipart,zts+delz) + endif + + if (i.ne.ifine) then + zeta=zts/h + call hanna_short(zts) + endif + zts=real(part(ipart)%z) + end do + part(ipart)%turbvel%w=wp + part(ipart)%icbt=icbt + if (cblflag.ne.1) nrand=nrand+i +end subroutine turb_pbl diff --git a/src/tur_turb_stratosph.f90 b/src/tur_turb_stratosph.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6f590169f91c75e38b8dc9da452b7d431b9b1645 --- /dev/null +++ b/src/tur_turb_stratosph.f90 @@ -0,0 +1,44 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine turb_stratosph(dt,nrand,ux,vy,wp,tropop,zts) + + implicit none + + integer, intent(inout) :: & + nrand ! random number used for turbulence + real, intent(inout) :: & + ux,vy,wp ! random turbulent velocities above PBL + real, intent(in) :: & + tropop, & ! height of troposphere + zts, & ! height of particle + dt ! real(ldt) + real :: & + uxscale,wpscale, & ! factor used in calculating turbulent perturbations above PBL + weight ! transition above the tropopause + + if (zts.lt.tropop) then ! in the troposphere + uxscale=sqrt(2.*d_trop/dt) + if (nrand+1.gt.maxrand) nrand=1 + ux=rannumb(nrand)*uxscale + vy=rannumb(nrand+1)*uxscale + nrand=nrand+2 + wp=0. + else if (zts.lt.tropop+1000.) then ! just above the tropopause: make transition + weight=(zts-tropop)/1000. + uxscale=sqrt(2.*d_trop/dt*(1.-weight)) + if (nrand+2.gt.maxrand) 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.maxrand) nrand=1 + ux=0. + vy=0. + wpscale=sqrt(2.*d_strat/dt) + wp=rannumb(nrand)*wpscale + nrand=nrand+1 + endif +end subroutine turb_stratosph diff --git a/src/tur_windalign.f90 b/src/tur_windalign.f90 new file mode 100644 index 0000000000000000000000000000000000000000..59989bf4b6956f2bccbd6e3baed2161f12629870 --- /dev/null +++ b/src/tur_windalign.f90 @@ -0,0 +1,55 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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/turbulence_mod.f90 b/src/turbulence_mod.f90 index d347dec2a53bcf43160a206639934484a7851838..15f560c8ac5e48c8b43917cf0503620a2954b07f 100644 --- a/src/turbulence_mod.f90 +++ b/src/turbulence_mod.f90 @@ -20,808 +20,23 @@ module turbulence_mod contains -subroutine turb_pbl(ipart,nrand,dt,zts,rhoa,rhograd,thread) - - use cbl_mod - - implicit none +#include "tur_turb_pbl.f90" - integer, intent(in) :: & - ipart, & ! particle index - thread ! number of the omp thread - integer, intent(inout) ::& - nrand ! random number used for turbulence - real,intent(in) :: & - dt, & ! real(ldt) - rhoa, & ! air density, used in CBL - rhograd ! vertical gradient of the air density, used in CBL - real,intent(inout) :: & - zts ! local 'real' copy of the particle position - real :: & - delz, & ! change in vertical position due to turbulence - ru,rv,rw,wp,icbt_r, & ! used for computing turbulence - dtf,rhoaux,dtftlw,ath,bth,& ! CBL related - ptot_lhh,Q_lhh,phi_lhh, & ! CBL related - old_wp_buf,dcas,dcas1, & ! CBL related - del_test ! CBL related - integer :: & - flagrein, & ! flag used in CBL scheme - icbt, & - i ! loop variable +#include "tur_turb_stratosph.f90" - ! tlw,dsigwdz and dsigw2dz are defined in hanna - if (turbswitch) then - call hanna(zts) - else - call hanna1(zts) - endif +#include "tur_turb_mesoscale.f90" - !***************************************** - ! Determine the new diffusivity velocities - !***************************************** +#include "tur_hanna.f90" - ! Horizontal components - !********************** - if (nrand+1.gt.maxrand) nrand=1 - if (dt/tlu.lt..5) then - part(ipart)%turbvel%u=(1.-dt/tlu)*part(ipart)%turbvel%u+rannumb(nrand)*sigu*sqrt(2.*dt/tlu) - else - ru=exp(-dt/tlu) - part(ipart)%turbvel%u=ru*part(ipart)%turbvel%u+rannumb(nrand)*sigu*sqrt(1.-ru**2) - endif - if (dt/tlv.lt..5) then - part(ipart)%turbvel%v=(1.-dt/tlv)*part(ipart)%turbvel%v+rannumb(nrand+1)*sigv*sqrt(2.*dt/tlv) - else - rv=exp(-dt/tlv) - part(ipart)%turbvel%v=rv*part(ipart)%turbvel%v+rannumb(nrand+1)*sigv*sqrt(1.-rv**2) - endif - nrand=nrand+2 +#include "tur_hanna1.f90" +#include "tur_hanna_short.f90" - if (nrand+ifine.gt.maxrand) nrand=1 - rhoaux=rhograd/rhoa - dtf=dt*fine +#include "tur_windalign.f90" +#include "tur_psih.f90" - dtftlw=dtf/tlw +#include "tur_psim.f90" - ! Loop over ifine short time steps for vertical component - !******************************************************** - wp=part(ipart)%turbvel%w - icbt=part(ipart)%icbt - do i=1,ifine - icbt_r=real(icbt) - ! Determine the drift velocity and density correction velocity - !************************************************************* - - if (turbswitch) then - if (dtftlw.lt..5) then - !************************************************************* - !************** CBL options added by mc see routine cblf90 *** - ! LB needs to be checked if this works with openmp - if (cblflag.eq.1) then !modified by mc - if (-h/ol.gt.5) then !modified by mc - flagrein=0 - nrand=nrand+1 - old_wp_buf=wp - call cbl(wp,zts,ust,wst,h,rhoa,rhograd,& - sigw,dsigwdz,tlw,ptot_lhh,Q_lhh,phi_lhh,ath,bth,ol,flagrein) !inside the routine for inverse time - wp=(wp+ath*dtf+& - bth*rannumb(nrand)*sqrt(dtf))*icbt_r - delz=wp*dtf - if ((flagrein.eq.1).or.(wp.ne.wp).or.((wp-1.).eq.wp)) then - call reinit_particle(zts,ust,wst,h,sigw,old_wp_buf,nrand,ol) - wp=old_wp_buf - delz=wp*dtf - nan_count(thread+1)=nan_count(thread+1)+1 - end if - else - 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)*icbt_r - delz=wp*dtf - if ((wp.ne.wp).or.((wp-1.).eq.wp)) then ! Catch infinity or NaN - nrand=nrand+1 - wp=sigw*rannumb(nrand) - delz=wp*dtf - nan_count(thread+1)=nan_count(thread+1)+1 - end if - end if - !******************** END CBL option ******************************* - !******************************************************************* - else - wp=((1.-dtftlw)*wp+rannumb(nrand+i)*sqrt(2.*dtftlw) & - +dtf*(dsigwdz+rhoaux*sigw))*icbt_r - 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))*icbt_r - 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))*icbt_r - delz=wp*dtf - endif - - !**************************************************** - ! Compute turbulent vertical displacement of particle - !**************************************************** - - 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.-zts) then ! reflection at ground - icbt=-1 - call set_z(ipart,-zts-delz) - else if (delz.gt.(h-zts)) then ! reflection at h - icbt=-1 - call set_z(ipart,-zts-delz+2.*h) - else ! no reflection - icbt=1 - call set_z(ipart,zts+delz) - endif - - if (i.ne.ifine) then - zeta=zts/h - call hanna_short(zts) - endif - zts=real(part(ipart)%z) - end do - part(ipart)%turbvel%w=wp - part(ipart)%icbt=icbt - if (cblflag.ne.1) nrand=nrand+i -end subroutine turb_pbl - -subroutine turb_stratosph(dt,nrand,ux,vy,wp,tropop,zts) - - implicit none - - integer, intent(inout) :: & - nrand ! random number used for turbulence - real, intent(inout) :: & - ux,vy,wp ! random turbulent velocities above PBL - real, intent(in) :: & - tropop, & ! height of troposphere - zts, & ! height of particle - dt ! real(ldt) - real :: & - uxscale,wpscale, & ! factor used in calculating turbulent perturbations above PBL - weight ! transition above the tropopause - - if (zts.lt.tropop) then ! in the troposphere - uxscale=sqrt(2.*d_trop/dt) - if (nrand+1.gt.maxrand) nrand=1 - ux=rannumb(nrand)*uxscale - vy=rannumb(nrand+1)*uxscale - nrand=nrand+2 - wp=0. - else if (zts.lt.tropop+1000.) then ! just above the tropopause: make transition - weight=(zts-tropop)/1000. - uxscale=sqrt(2.*d_trop/dt*(1.-weight)) - if (nrand+2.gt.maxrand) 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.maxrand) nrand=1 - ux=0. - vy=0. - wpscale=sqrt(2.*d_strat/dt) - wp=rannumb(nrand)*wpscale - nrand=nrand+1 - endif -end subroutine turb_stratosph - -subroutine turb_mesoscale(nrand,dxsave,dysave,ipart,usig,vsig,wsig,wsigeta,eps_eta) - - implicit none - - integer, intent(inout) :: & - nrand ! random number used for turbulence - integer, intent(in) :: & - ipart ! particle index - real, intent(in) :: & - eps_eta,usig,vsig,wsig,wsigeta - real, intent(inout) :: & - dxsave,dysave ! accumulated displacement in long and lat - real :: & - r,rs, & ! mesoscale related - ux,vy ! random turbulent velocities above PBL - - r=exp(-2.*real(abs(lsynctime))/real(lwindinterv)) - rs=sqrt(1.-r**2) - if (nrand+2.gt.maxrand) nrand=1 - part(ipart)%mesovel%u=r*part(ipart)%mesovel%u+rs*rannumb(nrand)*usig*fturbmeso - part(ipart)%mesovel%v=r*part(ipart)%mesovel%v+rs*rannumb(nrand+1)*vsig*fturbmeso - dxsave=dxsave+part(ipart)%mesovel%u*real(lsynctime) - dysave=dysave+part(ipart)%mesovel%v*real(lsynctime) - - select case (wind_coord_type) - case ('ETA') - part(ipart)%mesovel%w=r*part(ipart)%mesovel%w+rs*rannumb(nrand+2)*wsigeta*fturbmeso - call update_zeta(ipart,part(ipart)%mesovel%w*real(lsynctime)) - if (part(ipart)%zeta.ge.1.) call set_zeta(ipart,1.-(part(ipart)%zeta-1.)) - if (part(ipart)%zeta.eq.1.) call update_zeta(ipart,-eps_eta) - - case ('METER') - part(ipart)%mesovel%w=r*part(ipart)%mesovel%w+rs*rannumb(nrand+2)*wsig*fturbmeso - call update_z(ipart,part(ipart)%mesovel%w*real(lsynctime)) - if (part(ipart)%z.lt.0.) call set_z(ipart,-1.*part(ipart)%z) ! if particle below ground -> refletion - - case default - part(ipart)%mesovel%w=r*part(ipart)%mesovel%w+rs*rannumb(nrand+2)*wsig*fturbmeso - call update_z(ipart,part(ipart)%mesovel%w*real(lsynctime)) - if (part(ipart)%z.lt.0.) call set_z(ipart,-1.*part(ipart)%z) ! if particle below ground -> refletion - end select -end subroutine turb_mesoscale - -subroutine hanna(z) - ! 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 * - ! * - !***************************************************************************** - - implicit none - - real :: corr,z - - - !********************** - ! 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 - -subroutine hanna1(z) - ! 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 * - ! * - !***************************************************************************** - - implicit none - - real :: z,s1,s2 - - - - !********************** - ! 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 - -subroutine hanna_short(z) - ! 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 * - ! * - !***************************************************************************** - - implicit none - - real :: z - - - - !********************** - ! 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 - -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 -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 * - ! * - !***************************************************************************** - - 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 - -real function psim(z,al) - - !********************************************************************** - ! * - ! DESCRIPTION: CALCULATION OF THE STABILITY CORRECTION FUNCTION FOR * - ! MOMENTUM AS FUNCTION OF HEIGHT Z AND OBUKHOV SCALE * - ! HEIGHT L * - ! * - !********************************************************************** - - 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 - -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 qvsat_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,e,tv,stress - integer,parameter :: maxiter=10 - real,parameter :: r1=0.74 - - e=ew(td2m,ps) ! 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) exit !! Successive approximation successful - end do - 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 +#include "tur_pbl_profile.f90" end module turbulence_mod diff --git a/src/txt_output_mod.f90 b/src/txt_output_mod.f90 index 660513fb6a46b355ec15650854cf4a73ae19e463..440cefd2dacb567c18dd4ae57ee63971ad35c36e 100644 --- a/src/txt_output_mod.f90 +++ b/src/txt_output_mod.f90 @@ -5,167 +5,6 @@ module txt_output_mod contains -subroutine writeheader_txt - - !***************************************************************************** - ! * - ! 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 * - ! modified IP 2013 for text output * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! xlon longitude * - ! xl model x coordinate * - ! ylat latitude * - ! yl model y coordinate * - ! * - !***************************************************************************** - - use point_mod - use prepoutgrid_mod - use par_mod - use com_mod - use date_mod - - implicit none - - ! integer :: jjjjmmdd,ihmmss,i,ix,jy,j - integer :: jjjjmmdd,ihmmss,i,j - real :: xp1,yp1,xp2,yp2 - - - !************************ - ! Open header output file - !************************ - - open(unitheader,file=path(2)(1:length(2))//'header_txt', & - form='formatted',err=998) - open(unitheader_txt,file=path(2)(1:length(2))//'header_txt_releases', & - form='formatted',err=998) - - - ! Write the header information - !***************************** - - write(unitheader,*) '# ibdate,ibtime, iedate, ietime, flexversion' - write(unitheader,*) ibdate, ibtime, iedate, ietime, trim(flexversion) ! 'FLEXPART V9.0' - !if (ldirect.eq.1) then - ! write(unitheader,*) ibdate,ibtime,trim(flexversion) ! 'FLEXPART V9.0' - !else - ! write(unitheader,*) iedate,ietime,trim(flexversion) ! 'FLEXPART V9.0' - !endif - - ! Write info on output interval, averaging time, sampling time - !************************************************************* - - write(unitheader,*) '# interval, averaging time, sampling time' - write(unitheader,*) loutstep,loutaver,loutsample - - ! Write information on output grid setup - !*************************************** - - write(unitheader,*) '# information on grid setup ' - write(unitheader,*) '#outlon0,outlat0,numxgrid,numygrid,dxout,dyout' - write(unitheader,*) outlon0,outlat0,numxgrid,numygrid, & - dxout,dyout - write(unitheader,*) '# numzgrid, outheight(.) ' - write(unitheader,*) numzgrid,(outheight(i),i=1,numzgrid) - - write(unitheader,*) '# jjjjmmdd,ihmmss' - call caldate(bdate,jjjjmmdd,ihmmss) - write(unitheader,*) jjjjmmdd,ihmmss - - ! Write number of species, and name for each species (+extra name for depositions) - ! Indicate the vertical dimension of the fields (i.e., 1 for deposition fields, numzgrid for - ! concentration fields - !***************************************************************************** - - write(unitheader,*) '# information on species' - write(unitheader,*) '# 3*nspec,maxpointspec_act' - write(unitheader,*) 3*nspec,maxpointspec_act - write(unitheader,*) '# for nspec:' - write(unitheader,*) '# 1, WD_ ' - write(unitheader,*) '# 1, DD_ ' - write(unitheader,*) '# numzgrid,species' - 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_txt,*) '# information on release points' - write(unitheader_txt,*) '# numpoint' - write(unitheader_txt,*) numpoint - if ((ipin.ne.3).and.(ipin.ne.4)) then - write(unitheader_txt,*) '# for numpoint:' - do i=1,numpoint - write(unitheader_txt,*) 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_txt,*) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i) - write(unitheader_txt,*) npart(i),1 - if (numpoint.le.1000) then - write(unitheader_txt,*) compoint(i) - else - write(unitheader_txt,*) compoint(1001) - endif - do j=1,nspec - write(unitheader_txt,*) xmass(i,j) - write(unitheader_txt,*) xmass(i,j) - write(unitheader_txt,*) xmass(i,j) - end do - end do - endif - - ! Write information on model switches - !***************************************** - - write(unitheader,*) '# information on model switches' - write(unitheader,*) '# method,lsubgrid,lconvection, ind_source,ind_receptor' - write(unitheader,*) method,lsubgrid,lconvection, & - ind_source,ind_receptor - - ! Write age class information - !**************************** - - write(unitheader,*) '# information on age class ' - write(unitheader,*) nageclass,(lage(i),i=1,nageclass) - - - !Do not write topography to text output file. Keep it on the binary one - !******************************** - - !do ix=0,numxgrid-1 - ! write(unitheader,*) (oroout(ix,jy),jy=0,numygrid-1) - !end do - - close(unitheader) - close(unitheader_txt) - - return - - -998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' - write(*,*) ' #### '//path(2)(1:length(2))//'header_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 writeheader_txt +#include "txt_writeheader_txt.f90" end module txt_output_mod diff --git a/src/txt_writeheader_txt.f90 b/src/txt_writeheader_txt.f90 new file mode 100644 index 0000000000000000000000000000000000000000..4a25781d5b7704077e9bf55317cec441143be5de --- /dev/null +++ b/src/txt_writeheader_txt.f90 @@ -0,0 +1,165 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine writeheader_txt + + !***************************************************************************** + ! * + ! 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 * + ! modified IP 2013 for text output * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! xlon longitude * + ! xl model x coordinate * + ! ylat latitude * + ! yl model y coordinate * + ! * + !***************************************************************************** + + use point_mod + use prepoutgrid_mod + use par_mod + use com_mod + use date_mod + + implicit none + + ! integer :: jjjjmmdd,ihmmss,i,ix,jy,j + integer :: jjjjmmdd,ihmmss,i,j + real :: xp1,yp1,xp2,yp2 + + + !************************ + ! Open header output file + !************************ + + open(unitheader,file=path(2)(1:length(2))//'header_txt', & + form='formatted',err=998) + open(unitheader_txt,file=path(2)(1:length(2))//'header_txt_releases', & + form='formatted',err=998) + + + ! Write the header information + !***************************** + + write(unitheader,*) '# ibdate,ibtime, iedate, ietime, flexversion' + write(unitheader,*) ibdate, ibtime, iedate, ietime, trim(flexversion) ! 'FLEXPART V9.0' + !if (ldirect.eq.1) then + ! write(unitheader,*) ibdate,ibtime,trim(flexversion) ! 'FLEXPART V9.0' + !else + ! write(unitheader,*) iedate,ietime,trim(flexversion) ! 'FLEXPART V9.0' + !endif + + ! Write info on output interval, averaging time, sampling time + !************************************************************* + + write(unitheader,*) '# interval, averaging time, sampling time' + write(unitheader,*) loutstep,loutaver,loutsample + + ! Write information on output grid setup + !*************************************** + + write(unitheader,*) '# information on grid setup ' + write(unitheader,*) '#outlon0,outlat0,numxgrid,numygrid,dxout,dyout' + write(unitheader,*) outlon0,outlat0,numxgrid,numygrid, & + dxout,dyout + write(unitheader,*) '# numzgrid, outheight(.) ' + write(unitheader,*) numzgrid,(outheight(i),i=1,numzgrid) + + write(unitheader,*) '# jjjjmmdd,ihmmss' + call caldate(bdate,jjjjmmdd,ihmmss) + write(unitheader,*) jjjjmmdd,ihmmss + + ! Write number of species, and name for each species (+extra name for depositions) + ! Indicate the vertical dimension of the fields (i.e., 1 for deposition fields, numzgrid for + ! concentration fields + !***************************************************************************** + + write(unitheader,*) '# information on species' + write(unitheader,*) '# 3*nspec,maxpointspec_act' + write(unitheader,*) 3*nspec,maxpointspec_act + write(unitheader,*) '# for nspec:' + write(unitheader,*) '# 1, WD_ ' + write(unitheader,*) '# 1, DD_ ' + write(unitheader,*) '# numzgrid,species' + 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_txt,*) '# information on release points' + write(unitheader_txt,*) '# numpoint' + write(unitheader_txt,*) numpoint + if ((ipin.ne.3).and.(ipin.ne.4)) then + write(unitheader_txt,*) '# for numpoint:' + do i=1,numpoint + write(unitheader_txt,*) 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_txt,*) xp1,yp1,xp2,yp2,zpoint1(i),zpoint2(i) + write(unitheader_txt,*) npart(i),1 + if (numpoint.le.1000) then + write(unitheader_txt,*) compoint(i) + else + write(unitheader_txt,*) compoint(1001) + endif + do j=1,nspec + write(unitheader_txt,*) xmass(i,j) + write(unitheader_txt,*) xmass(i,j) + write(unitheader_txt,*) xmass(i,j) + end do + end do + endif + + ! Write information on model switches + !***************************************** + + write(unitheader,*) '# information on model switches' + write(unitheader,*) '# method,lsubgrid,lconvection, ind_source,ind_receptor' + write(unitheader,*) method,lsubgrid,lconvection, & + ind_source,ind_receptor + + ! Write age class information + !**************************** + + write(unitheader,*) '# information on age class ' + write(unitheader,*) nageclass,(lage(i),i=1,nageclass) + + + !Do not write topography to text output file. Keep it on the binary one + !******************************** + + !do ix=0,numxgrid-1 + ! write(unitheader,*) (oroout(ix,jy),jy=0,numygrid-1) + !end do + + close(unitheader) + close(unitheader_txt) + + return + + +998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(2)(1:length(2))//'header_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 writeheader_txt diff --git a/src/unc_deposit_decay.f90 b/src/unc_deposit_decay.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b9c48d1b55ce572e50e5e6fad06a04a251aa79e3 --- /dev/null +++ b/src/unc_deposit_decay.f90 @@ -0,0 +1,56 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine deposit_decay() + ! Accumulated deposited mass radioactively decays + use com_mod + + implicit none + + integer :: & + j,i, & ! loop variable over grid + ks, & ! loop variable species + kp, & ! loop variable for maxpointspec_act + l, & ! loop variable over nclassunc + nage, & ! loop variable over age classes + n ! loop variable over particles + +!$OMP PARALLEL PRIVATE(ks,kp,nage,l,j,i) +!$OMP DO COLLAPSE(2) + 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 j=0,numygrid-1 + do i=0,numxgrid-1 + wetgridunc(i,j,ks,kp,l,nage)= & + wetgridunc(i,j,ks,kp,l,nage)* & + exp(-1.*outstep*decay(ks)) + drygridunc(i,j,ks,kp,l,nage)= & + drygridunc(i,j,ks,kp,l,nage)* & + exp(-1.*outstep*decay(ks)) + end do + end do + ! Nested output grid + if (nested_output.eq.1) then + do j=0,numygridn-1 + do i=0,numxgridn-1 + wetgriduncn(i,j,ks,kp,l,nage)= & + wetgriduncn(i,j,ks,kp,l,nage)* & + exp(-1.*outstep*decay(ks)) + drygriduncn(i,j,ks,kp,l,nage)= & + drygriduncn(i,j,ks,kp,l,nage)* & + exp(-1.*outstep*decay(ks)) + end do + end do + endif + end do + end do + endif + end do + end do +!$OMP END DO +!$OMP END PARALLEL +end subroutine deposit_decay diff --git a/src/unc_mod.f90 b/src/unc_mod.f90 index e536ef7f9127f6807343bc32121b7e98edcb1deb..e69be2ba7123ba3b76a07f01877602e335f0f149 100644 --- a/src/unc_mod.f90 +++ b/src/unc_mod.f90 @@ -42,58 +42,6 @@ module unc_mod contains -subroutine deposit_decay() - ! Accumulated deposited mass radioactively decays - use com_mod - - implicit none - - integer :: & - j,i, & ! loop variable over grid - ks, & ! loop variable species - kp, & ! loop variable for maxpointspec_act - l, & ! loop variable over nclassunc - nage, & ! loop variable over age classes - n ! loop variable over particles - -!$OMP PARALLEL PRIVATE(ks,kp,nage,l,j,i) -!$OMP DO COLLAPSE(2) - 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 j=0,numygrid-1 - do i=0,numxgrid-1 - wetgridunc(i,j,ks,kp,l,nage)= & - wetgridunc(i,j,ks,kp,l,nage)* & - exp(-1.*outstep*decay(ks)) - drygridunc(i,j,ks,kp,l,nage)= & - drygridunc(i,j,ks,kp,l,nage)* & - exp(-1.*outstep*decay(ks)) - end do - end do - ! Nested output grid - if (nested_output.eq.1) then - do j=0,numygridn-1 - do i=0,numxgridn-1 - wetgriduncn(i,j,ks,kp,l,nage)= & - wetgriduncn(i,j,ks,kp,l,nage)* & - exp(-1.*outstep*decay(ks)) - drygriduncn(i,j,ks,kp,l,nage)= & - drygriduncn(i,j,ks,kp,l,nage)* & - exp(-1.*outstep*decay(ks)) - end do - end do - endif - end do - end do - endif - end do - end do -!$OMP END DO -!$OMP END PARALLEL -end subroutine deposit_decay +#include "unc_deposit_decay.f90" end module unc_mod diff --git a/src/ver_vertransf_init.f90 b/src/ver_vertransf_init.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5ce0a7a1b4e10f7b899d2fb606ea6c6f49933973 --- /dev/null +++ b/src/ver_vertransf_init.f90 @@ -0,0 +1,65 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine vertransf_init(n) + + use par_mod + use com_mod + use qvsat_mod + use initialise_mod + use output_mod + + implicit none + + integer, intent(in) :: n + real :: tvold,pold,pint,tv + integer :: ix,jy,kz,ixm,jym + real,parameter :: const=r_air/ga + + if ((ipin.eq.1).or.(ipin.eq.4)) then + call read_heightlevels(height,nmixz) + return + endif + + loop1: do jy=0,nymin1 + do ix=0,nxmin1 + if (ps(ix,jy,1,n).gt.100000.) then + ixm=ix + jym=jy + exit loop1 + endif + end do + end do loop1 + + tvold=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n),ps(ixm,jym,1,n))/ & + ps(ixm,jym,1,n)) + pold=ps(ixm,jym,1,n) + height(1)=0. + + do kz=2,nuvz + pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n) + tv=tth(ixm,jym,kz,n)*(1.+0.608*qvh(ixm,jym,kz,n)) + + 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 + + tvold=tv + pold=pint + end do + + ! Determine highest levels that can be within PBL + !************************************************ + + do kz=1,nz + if (height(kz).gt.hmixmax) then + nmixz=kz + exit + endif + end do + + call output_heightlevs(height,nmixz) +end subroutine vertransf_init diff --git a/src/ver_verttransf_ec_cloud.f90 b/src/ver_verttransf_ec_cloud.f90 new file mode 100644 index 0000000000000000000000000000000000000000..0ce52f0a72e49a9bca80186baab21096c665935a --- /dev/null +++ b/src/ver_verttransf_ec_cloud.f90 @@ -0,0 +1,168 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine verttransf_ec_cloud(n,lreadclouds,lsumclouds,nxlim,nylim,clouds_tmp,cloudsh_tmp,& + clw_tmp,ctwc_tmp,clwc_tmp,ciwc_tmp,lsprec_tmp,convprec_tmp,rho_tmp,tt_tmp,qv_tmp,uvzlev) + use par_mod + use com_mod + use cmapf_mod, only: cc2gll + use qvsat_mod + + implicit none + + logical,intent(in) :: lreadclouds,lsumclouds + integer, intent(in) :: nxlim,nylim + integer, intent(in) :: n + integer(kind=1),intent(inout) :: clouds_tmp(0:nxlim,0:nylim,nzmax) + integer,intent(inout) :: cloudsh_tmp(0:nxlim,0:nylim) + real,intent(inout) :: clw_tmp(0:nxlim,0:nylim,nzmax) + real,intent(inout) :: ctwc_tmp(0:nxlim,0:nylim) + real,intent(inout) :: clwc_tmp(0:nxlim,0:nylim,nzmax) + real,intent(in) :: ciwc_tmp(0:nxlim,0:nylim,nzmax) + real,intent(in) :: lsprec_tmp(0:nxlim,0:nylim),convprec_tmp(0:nxlim,0:nylim) + real,intent(in),dimension(0:nxlim,0:nylim,nzmax) :: rho_tmp,tt_tmp,qv_tmp + real,intent(out),dimension(0:nxlim,0:nylim,nzmax) :: uvzlev + + integer,dimension(0:nxmax-1,0:nymax-1) :: rain_cloud_above + + integer :: ix,jy,kz,kz_inv + real :: pressure,rh,lsp,convp,cloudh_min,prec + +!******************************************************************************* + if (lreadclouds) then !HG METHOD: +! loops all grids vertically and constructs the 3D matrix for clouds +! Cloud top and cloud bottom gid cells are assigned as well as the total column +! cloud water. For precipitating grids, the type and whether it is in or below +! cloud scavenging are assigned with numbers 2-5 (following the old metod). +! Distinction is done for lsp and convp though they are treated the same in +! regards to scavenging. Also clouds that are not precipitating are defined +! which may be to include future cloud processing by non-precipitating-clouds. +!******************************************************************************* + !write(*,*) 'Global ECMWF fields: using cloud water' + clw_tmp(0:nxlim,0:nylim,:)=0.0 + ! icloud_stats(:,:,:,n)=0.0 + ctwc_tmp(:,:)=0.0 + clouds_tmp(0:nxlim,0:nylim,:)=0 + ! If water/ice are read separately into clwc and ciwc, store sum in clwc + if (.not.lsumclouds) then + clwc_tmp(0:nxlim,0:nylim,:) = clwc_tmp(0:nxlim,0:nylim,:) + ciwc_tmp(:,:,:) + end if + do jy=0,nylim + do ix=0,nxlim + lsp=lsprec_tmp(ix,jy) + convp=convprec_tmp(ix,jy) + prec=lsp+convp + ! tot_cloud_h=0 + ! Find clouds in the vertical + do kz=1, nz-1 !go from top to bottom + if (clwc_tmp(ix,jy,kz).gt.0) then + ! assuming rho is in kg/m3 and hz in m gives: kg/kg * kg/m3 *m3/kg /m = m2/m3 + if (wind_coord_type.eq.'ETA') then + clw_tmp(ix,jy,kz)=(clwc_tmp(ix,jy,kz)*rho_tmp(ix,jy,kz))* & + (uvzlev(ix,jy,kz+1)-uvzlev(ix,jy,kz)) + cloudh_min=min(uvzlev(ix,jy,kz+1),uvzlev(ix,jy,kz)) + else + clw_tmp(ix,jy,kz)= (clwc_tmp(ix,jy,kz)*rho_tmp(ix,jy,kz))* & + (height(kz+1)-height(kz)) + ! icloud_stats(ix,jy,3,n)= min(height(kz+1),height(kz)) + ! Cloud BOT height stats [m] + cloudh_min=min(height(kz+1),height(kz)) + endif + ! tot_cloud_h=tot_cloud_h+(height(kz+1)-height(kz)) + + ! icloud_stats(ix,jy,4,n)= icloud_stats(ix,jy,4,n)+clw(ix,jy,kz,n) + ! Column cloud water [m3/m3] + ctwc_tmp(ix,jy) = ctwc_tmp(ix,jy)+clw_tmp(ix,jy,kz) + + endif + end do + + ! If Precipitation. Define removal type in the vertical + if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation + + do kz=nz,2,-1 !go Bottom up! + if (clw_tmp(ix,jy,kz).gt. 0) then ! is in cloud + if (wind_coord_type.eq.'ETA') then + cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+ & + uvzlev(ix,jy,kz)-uvzlev(ix,jy,kz-1) + else + cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+height(kz)-height(kz-1) + endif + clouds_tmp(ix,jy,kz)=1 ! is a cloud + if (lsp.ge.convp) then + clouds_tmp(ix,jy,kz)=3 ! lsp in-cloud + else + clouds_tmp(ix,jy,kz)=2 ! convp in-cloud + endif ! convective or large scale + elseif (clw_tmp(ix,jy,kz).le.0 .and. cloudh_min.ge.height(kz)) then + ! is below cloud + if (lsp.ge.convp) then + clouds_tmp(ix,jy,kz)=5 ! lsp dominated washout + else + clouds_tmp(ix,jy,kz)=4 ! convp dominated washout + endif ! convective or large scale + endif + + if (height(kz).ge. 19000) then ! set a max height for removal + clouds_tmp(ix,jy,kz)=0 + endif !clw>0 + end do !nz + endif ! precipitation + end do + end do + + ! eso: copy the relevant data to clw4 to reduce amount of communicated data for MPI + ! ctwc(:,:,n) = icloud_stats(:,:,4,n) + + !************************************************************************** + else ! use old definitions + !************************************************************************** + ! create a cloud and rainout/washout field, clouds occur where rh>80% + ! total cloudheight is stored at level 0 + !write(*,*) 'Global fields: using cloud water from Parameterization' + do jy=0,nylim + do ix=0,nxlim + ! OLD METHOD + rain_cloud_above(ix,jy)=0 + lsp=lsprec_tmp(ix,jy) + convp=convprec_tmp(ix,jy) + cloudsh_tmp(ix,jy)=0 + do kz_inv=1,nz-1 + kz=nz-kz_inv+1 + pressure=rho_tmp(ix,jy,kz)*r_air*tt_tmp(ix,jy,kz) + rh=qv_tmp(ix,jy,kz)/f_qvsat(pressure,tt_tmp(ix,jy,kz)) + clouds_tmp(ix,jy,kz)=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(ix,jy)=1 + if (wind_coord_type.eq.'ETA') then + cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+ & + uvzlev(ix,jy,kz)-uvzlev(ix,jy,kz-1) + else + cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+ & + height(kz)-height(kz-1) + endif + if (lsp.ge.convp) then + clouds_tmp(ix,jy,kz)=3 ! lsp dominated rainout + else + clouds_tmp(ix,jy,kz)=2 ! convp dominated rainout + endif + else ! no precipitation + clouds_tmp(ix,jy,kz)=1 ! cloud + endif + else ! no cloud + if (rain_cloud_above(ix,jy).eq.1) then ! scavenging + if (lsp.ge.convp) then + clouds_tmp(ix,jy,kz)=5 ! lsp dominated washout + else + clouds_tmp(ix,jy,kz)=4 ! convp dominated washout + endif + endif + endif + end do + !END OLD METHOD + end do + end do + endif !readclouds + +end subroutine verttransf_ec_cloud diff --git a/src/ver_verttransf_ec_height.f90 b/src/ver_verttransf_ec_height.f90 new file mode 100644 index 0000000000000000000000000000000000000000..554c25ee612db49def32ba3b1aa0341eed6ee906 --- /dev/null +++ b/src/ver_verttransf_ec_height.f90 @@ -0,0 +1,83 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine verttransf_ec_height(nxlim,nylim, & + + tt2_tmp,td2_tmp,ps_tmp,qvh_tmp,tth_tmp,prsh_tmp, & + rhoh_tmp,pinmconv,uvzlev,wzlev) + use par_mod + use com_mod + use qvsat_mod + + implicit none + + integer, intent(in) :: nxlim,nylim + real,intent(in),dimension(0:nxlim,0:nylim) :: tt2_tmp,td2_tmp,ps_tmp + real,intent(in),dimension(0:nxlim,0:nylim,nuvzmax) :: qvh_tmp,tth_tmp + real,intent(out),dimension(0:nxlim,0:nylim,nuvzmax) :: rhoh_tmp,prsh_tmp + real,intent(out),dimension(0:nxlim,0:nylim,nzmax) :: pinmconv + real,intent(out),dimension(0:nxlim,0:nylim,nuvzmax) :: uvzlev,wzlev + real,dimension(0:nxlim,0:nylim) :: tvold,pold,pint,tv + real,parameter :: const=r_air/ga + integer :: ix,jy,kz + integer :: nxm1,nym1 + + ! Loop over the whole grid + !************************* + + do jy=0,nylim + do ix=0,nxlim + tvold(ix,jy)=tt2_tmp(ix,jy)*(1.+0.378*ew(td2_tmp(ix,jy),ps_tmp(ix,jy))/ & + ps_tmp(ix,jy)) + end do + end do + + pold(:,:)=ps_tmp(:,:) + uvzlev(:,:,1)=0. + wzlev(:,:,1)=0. + rhoh_tmp(:,:,1)=pold(:,:)/(r_air*tvold(:,:)) + prsh_tmp(:,:,1)=ps_tmp(:,:) + + ! Compute heights of eta levels + !****************************** + + do kz=2,nuvz + pint(:,:)=akz(kz)+bkz(kz)*ps_tmp(:,:) + prsh_tmp(:,:,kz)=pint(:,:) + tv(:,:)=tth_tmp(:,:,kz)*(1.+0.608*qvh_tmp(:,:,kz)) + rhoh_tmp(:,:,kz)=pint(:,:)/(r_air*tv(:,:)) + + where (abs(tv(:,:)-tvold(:,:)).gt.0.2) + uvzlev(:,:,kz)=uvzlev(:,:,kz-1)+const*& + &log(pold(:,:)/pint(:,:))* & + (tv(:,:)-tvold(:,:))/& + &log(tv(:,:)/tvold(:,:)) + elsewhere + uvzlev(:,:,kz)=uvzlev(:,:,kz-1)+const*& + &log(pold(:,:)/pint(:,:))*tv(:,:) + endwhere + + 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) + + + pinmconv(:,:,1)=(uvzlev(:,:,2))/ & + ((aknew(2)+bknew(2)*ps_tmp(:,:))- & + (aknew(1)+bknew(1)*ps_tmp(:,:))) + do kz=2,nz-1 + pinmconv(:,:,kz)=(uvzlev(:,:,kz+1)-uvzlev(:,:,kz-1))/ & + ((aknew(kz+1)+bknew(kz+1)*ps_tmp(:,:))- & + (aknew(kz-1)+bknew(kz-1)*ps_tmp(:,:))) + end do + pinmconv(:,:,nz)=(uvzlev(:,:,nz)-uvzlev(:,:,nz-1))/ & + ((aknew(nz)+bknew(nz)*ps_tmp(:,:))- & + (aknew(nz-1)+bknew(nz-1)*ps_tmp(:,:))) + +end subroutine verttransf_ec_height diff --git a/src/ver_verttransf_ec_stereo.f90 b/src/ver_verttransf_ec_stereo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..2a26c43fb7f7ff413416f679f010a2118a151c40 --- /dev/null +++ b/src/ver_verttransf_ec_stereo.f90 @@ -0,0 +1,276 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine verttransf_ec_stereo(n) + use par_mod + use com_mod + use cmapf_mod, only: cc2gll + use qvsat_mod + + implicit none + + integer, intent(in) :: n + + integer :: ix,jy,iz + real :: xlon,ylat,xlonr + real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy + + if (nglobal) then + do iz=1,nz + do jy=int(switchnorthg)-2,nymin1 + ylat=ylat0+real(jy)*dy + do ix=0,nxmin1 + xlon=xlon0+real(ix)*dx + 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)) + if (wind_coord_type.eq.'ETA') then + call cc2gll(northpolemap,ylat,xlon,uueta(ix,jy,iz,n), & + vveta(ix,jy,iz,n),uupoleta(ix,jy,iz,n), & + vvpoleta(ix,jy,iz,n)) + endif + end do + end do + end do + + + do iz=1,nz + + ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT + ! + ! AMSnauffer Nov 18 2004 Added check for case vv=0 + ! + 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 if (vv(nx/2-1,nymin1,iz,n).gt.0.) then + ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ & + vv(nx/2-1,nymin1,iz,n))-xlonr + else + ddpol=pi/2-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 ix=0,nxmin1 + uupol(ix,jy,iz,n)=uupolaux + vvpol(ix,jy,iz,n)=vvpolaux + end do + end do + + if (wind_coord_type.eq.'ETA') then + do iz=1,nz + + xlon=xlon0+real(nx/2-1)*dx + xlonr=xlon*pi/180. + ffpol=sqrt(uueta(nx/2-1,nymin1,iz,n)**2+ & + vveta(nx/2-1,nymin1,iz,n)**2) + if (vveta(nx/2-1,nymin1,iz,n).lt.0.) then + ddpol=atan(uueta(nx/2-1,nymin1,iz,n)/ & + vveta(nx/2-1,nymin1,iz,n))-xlonr + else if (vveta(nx/2-1,nymin1,iz,n).gt.0.) then + ddpol=pi+atan(uueta(nx/2-1,nymin1,iz,n)/ & + vveta(nx/2-1,nymin1,iz,n))-xlonr + else + ddpol=pi/2-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 ix=0,nxmin1 + uupoleta(ix,jy,iz,n)=uupolaux + vvpoleta(ix,jy,iz,n)=vvpolaux + end do + end do + endif + + + ! Fix: Set W at pole to the zonally averaged W of the next equator- + ! ward parallel of latitude + + do iz=1,nz + wdummy=0. + jy=ny-2 + do ix=0,nxmin1 + wdummy=wdummy+ww(ix,jy,iz,n) + end do + wdummy=wdummy/real(nx) + jy=nymin1 + do ix=0,nxmin1 + ww(ix,jy,iz,n)=wdummy + end do + end do + + if (wind_coord_type.eq.'ETA') then + do iz=1,nz + wdummy=0. + jy=ny-2 + do ix=0,nxmin1 + wdummy=wdummy+wweta(ix,jy,iz,n) + end do + wdummy=wdummy/real(nx) + jy=nymin1 + do ix=0,nxmin1 + wweta(ix,jy,iz,n)=wdummy + end do + end do + endif + + endif + + + ! If south pole is in the domain, calculate wind velocities in polar + ! stereographic coordinates + !******************************************************************* + + if (sglobal) then + do iz=1,nz + do jy=0,int(switchsouthg)+3 + ylat=ylat0+real(jy)*dy + do ix=0,nxmin1 + xlon=xlon0+real(ix)*dx + 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)) + if (wind_coord_type.eq.'ETA') then + call cc2gll(southpolemap,ylat,xlon,uueta(ix,jy,iz,n), & + vveta(ix,jy,iz,n),uupoleta(ix,jy,iz,n), & + vvpoleta(ix,jy,iz,n)) + endif + end do + end do + end do + + do iz=1,nz + + ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT + ! + ! AMSnauffer Nov 18 2004 Added check for case vv=0 + ! + 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 if (vv(nx/2-1,0,iz,n).gt.0.) then + ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ & + vv(nx/2-1,0,iz,n))+xlonr + else + ddpol=pi/2-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 ix=0,nxmin1 + uupol(ix,jy,iz,n)=uupolaux + vvpol(ix,jy,iz,n)=vvpolaux + end do + end do + + if (wind_coord_type.eq.'ETA') then + do iz=1,nz + ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT + ! + ! AMSnauffer Nov 18 2004 Added check for case vv=0 + ! + xlon=xlon0+real(nx/2-1)*dx + xlonr=xlon*pi/180. + ffpol=sqrt(uueta(nx/2-1,0,iz,n)**2+ & + vveta(nx/2-1,0,iz,n)**2) + if (vveta(nx/2-1,0,iz,n).lt.0.) then + ddpol=atan(uueta(nx/2-1,0,iz,n)/ & + vveta(nx/2-1,0,iz,n))+xlonr + else if (vveta(nx/2-1,0,iz,n).gt.0.) then + ddpol=pi+atan(uueta(nx/2-1,0,iz,n)/ & + vveta(nx/2-1,0,iz,n))+xlonr + else + ddpol=pi/2-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 ix=0,nxmin1 + uupoleta(ix,jy,iz,n)=uupolaux + vvpoleta(ix,jy,iz,n)=vvpolaux + end do + end do + endif + + ! Fix: Set W at pole to the zonally averaged W of the next equator- + ! ward parallel of latitude + + do iz=1,nz + wdummy=0. + jy=1 + do ix=0,nxmin1 + wdummy=wdummy+ww(ix,jy,iz,n) + end do + wdummy=wdummy/real(nx) + jy=0 + do ix=0,nxmin1 + ww(ix,jy,iz,n)=wdummy + end do + end do + + if (wind_coord_type.eq.'ETA') then + do iz=1,nz + wdummy=0. + jy=1 + do ix=0,nxmin1 + wdummy=wdummy+wweta(ix,jy,iz,n) + end do + wdummy=wdummy/real(nx) + jy=0 + do ix=0,nxmin1 + wweta(ix,jy,iz,n)=wdummy + end do + end do + endif + endif +end subroutine verttransf_ec_stereo diff --git a/src/ver_verttransf_ec_windf.f90 b/src/ver_verttransf_ec_windf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..cfc4333e083c5df5ce8c45a590a0844755f9a3c0 --- /dev/null +++ b/src/ver_verttransf_ec_windf.f90 @@ -0,0 +1,297 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine verttransf_ec_windf(n,uuh,vvh,wwh,pvh,rhoh,prsh,pinmconv) + use par_mod + use com_mod + use qvsat_mod + + implicit none + + integer,intent(in) :: n + real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: uuh,vvh,pvh + real,intent(in),dimension(0:nxmax-1,0:nymax-1,nwzmax) :: wwh + real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: rhoh + real,intent(in),dimension(0:nxmax-1,0:nymax-1,nzmax) :: pinmconv + ! RLT added pressure + real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: prsh + + !real,dimension(0:nxmax-1,0:nymax-1) :: dpdeta + + real,dimension(0:nymax-1) :: cosf + + integer,dimension(0:nxmax-1,0:nymax-1) :: idx + + integer :: ix,jy,kz,iz,kmin,ixp,jyp,ix1,jy1 + real :: dz1,dz2,dz,dpdeta + real :: xlon,ylat,xlonr,dzdx,dzdy + real :: dzdx1,dzdx2,dzdy1,dzdy2 + + ! Levels, where u,v,t and q are given + !************************************ +!$OMP PARALLEL PRIVATE(jy,ix,kz,dz1,dz2,dz,ix1,jy1,ixp,jyp,dzdx1,dzdx2,dzdx, & +!$OMP dzdy1,dzdy2,dzdy,dpdeta) + +!$OMP DO + do jy=0,nymin1 + do ix=0,nxmin1 + + uu(ix,jy,1,n)=uuh(ix,jy,1) + uu(ix,jy,nz,n)=uuh(ix,jy,nuvz) + vv(ix,jy,1,n)=vvh(ix,jy,1) + vv(ix,jy,nz,n)=vvh(ix,jy,nuvz) + tt(ix,jy,1,n)=tth(ix,jy,1,n) + tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n) + pv(ix,jy,1,n)=pvh(ix,jy,1) + pv(ix,jy,nz,n)=pvh(ix,jy,nuvz) + if (wind_coord_type.ne.'ETA') then + qv(ix,jy,1,n)=qvh(ix,jy,1,n) + qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n) + !hg adding the cloud water + if (readclouds) then + clwc(ix,jy,1,n)=clwch(ix,jy,1,n) + clwc(ix,jy,nz,n)=clwch(ix,jy,nuvz,n) + if (.not.sumclouds) then + ciwc(ix,jy,1,n)=ciwch(ix,jy,1,n) + ciwc(ix,jy,nz,n)=ciwch(ix,jy,nuvz,n) + endif + end if + !hg + endif + rho(ix,jy,1,n)=rhoh(ix,jy,1) + rho(ix,jy,nz,n)=rhoh(ix,jy,nuvz) + ! RLT add pressure + prs(ix,jy,1,n)=prsh(ix,jy,1) + prs(ix,jy,nz,n)=prsh(ix,jy,nuvz) + ! RLT + + idx(ix,jy)=2 + end do + end do +!$OMP END DO + + do iz=2,nz-1 +!$OMP DO SCHEDULE(dynamic) + do jy=0,nymin1 + do ix=0,nxmin1 + if(height(iz).gt.etauvheight(ix,jy,nuvz,n)) 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) + pv(ix,jy,iz,n)=pv(ix,jy,nz,n) + if (wind_coord_type.ne.'ETA') then + qv(ix,jy,iz,n)=qv(ix,jy,nz,n) + !hg adding the cloud water + if (readclouds) then + clwc(ix,jy,iz,n)=clwc(ix,jy,nz,n) + if (.not.sumclouds) ciwc(ix,jy,iz,n)=ciwc(ix,jy,nz,n) + end if + endif + rho(ix,jy,iz,n)=rho(ix,jy,nz,n) + prs(ix,jy,iz,n)=prs(ix,jy,nz,n) ! RLT + else + innuvz: do kz=idx(ix,jy),nuvz + if ( idx(ix,jy).le.kz .and. & + height(iz).gt.etauvheight(ix,jy,kz-1,n) .and. & + height(iz).le.etauvheight(ix,jy,kz,n) ) then + idx(ix,jy)=kz + exit innuvz + endif + enddo innuvz + endif + + if (height(iz).le.etauvheight(ix,jy,nuvz,n)) then + kz=idx(ix,jy) + dz1=height(iz)-etauvheight(ix,jy,kz-1,n) + dz2=etauvheight(ix,jy,kz,n)-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 + pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz + if (wind_coord_type.ne.'ETA') then + qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2+qvh(ix,jy,kz,n)*dz1)/dz + !hg adding the cloud water + if (readclouds) then + clwc(ix,jy,iz,n)= & + (clwch(ix,jy,kz-1,n)*dz2+clwch(ix,jy,kz,n)*dz1)/dz + if (.not.sumclouds) ciwc(ix,jy,iz,n)= & + (ciwch(ix,jy,kz-1,n)*dz2+ciwch(ix,jy,kz,n)*dz1)/dz + end if + !hg + endif + rho(ix,jy,iz,n)=(rhoh(ix,jy,kz-1)*dz2+rhoh(ix,jy,kz)*dz1)/dz + ! RLT add pressure + prs(ix,jy,iz,n)=(prsh(ix,jy,kz-1)*dz2+prsh(ix,jy,kz)*dz1)/dz + endif + enddo + enddo +!$OMP END DO +!$OMP BARRIER + enddo + ! Levels, where w is given + !************************* + +!$OMP DO + do jy=0,nymin1 + do ix=0,nxmin1 + idx(ix,jy)=2 + ww(ix,jy,1,n)=wwh(ix,jy,1)*pinmconv(ix,jy,1) + ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(ix,jy,nz) + end do + end do +!$OMP END DO + + do iz=2,nz-1 +!$OMP DO SCHEDULE(dynamic) + do jy=0,nymin1 + do ix=0,nxmin1 + + inn: do kz=idx(ix,jy),nwz + if (idx(ix,jy).le.kz .and. height(iz).gt.etawheight(ix,jy,kz-1,n) & + .and. height(iz).le.etawheight(ix,jy,kz,n)) then + idx(ix,jy)=kz + exit inn + endif + enddo inn + + kz=idx(ix,jy) + dz1=height(iz)-etawheight(ix,jy,kz-1,n) + dz2=etawheight(ix,jy,kz,n)-height(iz) + dz=dz1+dz2 + ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(ix,jy,kz-1)*dz2 & + +wwh(ix,jy,kz)*pinmconv(ix,jy,kz)*dz1)/dz + ! Compute density gradients at intermediate levels + !************************************************* + drhodz(ix,jy,iz,n)=(rho(ix,jy,iz+1,n)-rho(ix,jy,iz-1,n))/ & + (height(iz+1)-height(iz-1)) + end do + end do +!$OMP END DO +!$OMP BARRIER + end do + +!$OMP DO + do jy=0,nymin1 + do ix=0,nxmin1 + drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n) + drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/(height(2)-height(1)) + end do + end do +!$OMP END DO NOWAIT + + !**************************************************************** + ! Compute slope of eta levels in windward direction and resulting + ! vertical wind correction + !**************************************************************** + +!$OMP DO + do jy=1,ny-2 + cosf(jy)=1./cos((real(jy)*dy+ylat0)*pi180) + do ix=1,nx-2 + idx(ix,jy)=2 + end do + end do +!$OMP END DO + + do iz=2,nz-1 +!$OMP DO SCHEDULE(dynamic) + do jy=1,ny-2 + do ix=1,nx-2 + ! For gridpoint (ix,jy) and height (iz), this loop finds the first eta + ! level encompassing the height(iz) level and saves it in idx(ix,jy) + inneta: do kz=idx(ix,jy),nz + if (idx(ix,jy) .le. kz .and. height(iz).gt.etauvheight(ix,jy,kz-1,n) & + .and. height(iz).le.etauvheight(ix,jy,kz,n)) then + idx(ix,jy)=kz + exit inneta + endif + enddo inneta + + kz=idx(ix,jy) + dz1=height(iz)-etauvheight(ix,jy,kz-1,n) + dz2=etauvheight(ix,jy,kz,n)-height(iz) + dz=dz1+dz2 + ix1=ix-1 + jy1=jy-1 + ixp=ix+1 + jyp=jy+1 + + dzdx1=(etauvheight(ixp,jy,kz-1,n)-etauvheight(ix1,jy,kz-1,n))/2. + dzdx2=(etauvheight(ixp,jy,kz,n)-etauvheight(ix1,jy,kz,n))/2. + dzdx=(dzdx1*dz2+dzdx2*dz1)/dz + + dzdy1=(etauvheight(ix,jyp,kz-1,n)-etauvheight(ix,jy1,kz-1,n))/2. + dzdy2=(etauvheight(ix,jyp,kz,n)-etauvheight(ix,jy1,kz,n))/2. + dzdy=(dzdy1*dz2+dzdy2*dz1)/dz + + ww(ix,jy,iz,n) = ww(ix,jy,iz,n) + dzdx*uu(ix,jy,iz,n)*dxconst*cosf(jy) & + + dzdy*vv(ix,jy,iz,n)*dyconst + end do + end do +!$OMP END DO +!$OMP BARRIER + end do + + ! Keep original fields if wind_coord_type==ETA + if (wind_coord_type.eq.'ETA') then +!$OMP DO + + do kz=1,nz + do jy=0,nymin1 + do ix=0,nxmin1 + uueta(ix,jy,kz,n) = uuh(ix,jy,kz) + vveta(ix,jy,kz,n) = vvh(ix,jy,kz) + tteta(ix,jy,kz,n) = tth(ix,jy,kz,n) + qv(ix,jy,kz,n) = qvh(ix,jy,kz,n) + pveta(ix,jy,kz,n) = pvh(ix,jy,kz) + rhoeta(ix,jy,kz,n) = rhoh(ix,jy,kz) + prseta(ix,jy,kz,n) = prsh(ix,jy,kz) + ! tvirtual(ix,jy,kz,n)=tteta(ix,jy,kz,n)* & + ! ((qv(ix,jy,kz,n)+0.622)/(0.622*qv(ix,jy,kz,n)+0.622)) + ! eq A11 from Mid-latitude atmospheric dynamics by Jonathan E. Martin + if ((kz.gt.1).and.(kz.lt.nz)) drhodzeta(ix,jy,kz,n)= & + (rhoh(ix,jy,kz+1)-rhoh(ix,jy,kz-1))/ & + (height(kz+1)-height(kz-1)) + ! Note that this is still in SI units and not in eta + if (readclouds) then + clwc(ix,jy,kz,n)=clwch(ix,jy,kz,n) + if (.not. sumclouds) ciwc(ix,jy,kz,n)=ciwch(ix,jy,kz,n) + endif + end do + end do + end do +!$OMP END DO NOWAIT + +!$OMP DO + do jy=0,nymin1 + do ix=0,nxmin1 + drhodzeta(ix,jy,1,n)=(rhoh(ix,jy,2)-rhoh(ix,jy,1))/(height(2)-height(1)) + drhodzeta(ix,jy,nz,n)=drhodzeta(ix,jy,nz-1,n) + ! tvirtual(ix,jy,1,n)=tt2(ix,jy,1,n)* & + ! (1.+0.378*ew(td2(ix,jy,1,n),ps(ix,jy,1,n))/ps(ix,jy,1,n)) + ! Convert w from Pa/s to eta/s, following FLEXTRA + !************************************************ + do kz=1,nuvz-1 + if (kz.eq.1) then + dpdeta=(akm(kz+1)-akm(kz)+(bkm(kz+1)-bkm(kz))*ps(ix,jy,1,n))/ & + (wheight(kz+1)-wheight(kz)) + else if (kz.eq.nuvz-1) then + dpdeta=(akm(kz)-akm(kz-1)+(bkm(kz)-bkm(kz-1))*ps(ix,jy,1,n))/ & + (wheight(kz)-wheight(kz-1)) + else + dpdeta=(akm(kz+1)-akm(kz-1)+(bkm(kz+1)-bkm(kz-1))*ps(ix,jy,1,n))/ & + (wheight(kz+1)-wheight(kz-1)) + endif + wweta(ix,jy,kz,n)=wwh(ix,jy,kz)/dpdeta + end do + wweta(ix,jy,nuvz,n)=wweta(ix,jy,nuvz-1,n) + ! What is the appropriate value for the top level??? + end do + end do +!$OMP END DO + endif +!$OMP END PARALLEL + +end subroutine verttransf_ec_windf diff --git a/src/ver_verttransf_ec_windf_nest.f90 b/src/ver_verttransf_ec_windf_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..33ade8b75e7a276f2b87310b8537244182f67b68 --- /dev/null +++ b/src/ver_verttransf_ec_windf_nest.f90 @@ -0,0 +1,304 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine verttransf_ec_windf_nest(l,n, & + + uuhn,vvhn,wwhn,pvhn,rhohn,prshn,pinmconv) + use par_mod + use com_mod + use qvsat_mod + + implicit none + + integer,intent(in) :: l,n + real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) :: & + uuhn,vvhn,pvhn + real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) :: wwhn + real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax) :: rhohn + real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax) :: prshn + real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nzmax) :: pinmconv + real,dimension(0:nymaxn-1) :: cosf + + integer,dimension(0:nxmaxn-1,0:nymaxn-1) :: rain_cloud_above, idx + + integer :: ix,jy,kz,iz,kmin,kl,klp,ix1,jy1,ixp,jyp,kz_inv + real :: pressure,rh,lsp,convp,cloudh_min,prec + + real :: dz1,dz2,dz,dpdeta + real :: dzdx,dzdy + real :: dzdx1,dzdx2,dzdy1,dzdy2 + real :: tot_cloud_h + integer :: nxm1, nym1 + + nxm1=nxn(l)-1 + nym1=nyn(l)-1 + + ! Levels, where u,v,t and q are given + !************************************ +!$OMP PARALLEL PRIVATE(jy,ix,kz,dz1,dz2,dz,ix1,jy1,ixp,jyp,dzdx1,dzdx2,dzdx, & +!$OMP dzdy1,dzdy2,dzdy,dpdeta) + +!$OMP DO + do jy=0,nym1 + do ix=0,nxm1 + uun(ix,jy,1,n,l)=uuhn(ix,jy,1,l) + vvn(ix,jy,1,n,l)=vvhn(ix,jy,1,l) + ttn(ix,jy,1,n,l)=tthn(ix,jy,1,n,l) + if (wind_coord_type.ne.'ETA') then + qvn(ix,jy,1,n,l)=qvhn(ix,jy,1,n,l) + endif + if (readclouds_nest(l)) then + clwcn(ix,jy,1,n,l)=clwchn(ix,jy,1,n,l) + if (.not.sumclouds_nest(l)) ciwcn(ix,jy,1,n,l)=ciwchn(ix,jy,1,n,l) + end if + pvn(ix,jy,1,n,l)=pvhn(ix,jy,1,l) + rhon(ix,jy,1,n,l)=rhohn(ix,jy,1) + prsn(ix,jy,1,n,l)=prshn(ix,jy,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) + if (wind_coord_type.ne.'ETA') then + qvn(ix,jy,nz,n,l)=qvhn(ix,jy,nuvz,n,l) + if (readclouds_nest(l)) then + clwcn(ix,jy,nz,n,l)=clwchn(ix,jy,nuvz,n,l) + if (.not.sumclouds_nest(l)) ciwcn(ix,jy,nz,n,l)=ciwchn(ix,jy,nuvz,n,l) + endif + endif + pvn(ix,jy,nz,n,l)=pvhn(ix,jy,nuvz,l) + rhon(ix,jy,nz,n,l)=rhohn(ix,jy,nuvz) + prsn(ix,jy,nz,n,l)=prshn(ix,jy,nuvz) + + idx(ix,jy)=2 + end do + end do +!$OMP END DO + + do iz=2,nz-1 +!$OMP DO SCHEDULE(dynamic) + do jy=0,nym1 + do ix=0,nxm1 + if(height(iz).gt.etauvheightn(ix,jy,nuvz,n,l)) 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) + pvn(ix,jy,iz,n,l)=pvn(ix,jy,nz,n,l) + if (wind_coord_type.ne.'ETA') then + qvn(ix,jy,iz,n,l)=qvn(ix,jy,nz,n,l) + !hg adding the cloud water + if (readclouds_nest(l)) then + clwcn(ix,jy,iz,n,l)=clwcn(ix,jy,nz,n,l) + if (.not.sumclouds_nest(l)) & + ciwcn(ix,jy,iz,n,l)=ciwcn(ix,jy,nz,n,l) + endif + endif + rhon(ix,jy,iz,n,l)=rhon(ix,jy,nz,n,l) + prsn(ix,jy,iz,n,l)=prsn(ix,jy,nz,n,l) + else + innuvz: do kz=idx(ix,jy),nuvz + if (idx(ix,jy) .le. kz .and. & + height(iz).gt.etauvheightn(ix,jy,kz-1,n,l) .and. & + height(iz).le.etauvheightn(ix,jy,kz,n,l) ) then + idx(ix,jy)=kz + exit innuvz + endif + enddo innuvz + endif + + if(height(iz).le.etauvheightn(ix,jy,nuvz,n,l)) then + kz=idx(ix,jy) + dz1=height(iz)-etauvheightn(ix,jy,kz-1,n,l) + dz2=etauvheightn(ix,jy,kz,n,l)-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 + pvn(ix,jy,iz,n,l)=(pvhn(ix,jy,kz-1,l)*dz2+pvhn(ix,jy,kz,l)*dz1)/dz + if (wind_coord_type.ne.'ETA') then + qvn(ix,jy,iz,n,l)=(qvhn(ix,jy,kz-1,n,l)*dz2 & + +qvhn(ix,jy,kz,n,l)*dz1)/dz + !hg adding the cloud water + if (readclouds_nest(l)) then + clwcn(ix,jy,iz,n,l)=(clwchn(ix,jy,kz-1,n,l)*dz2 + & + clwchn(ix,jy,kz,n,l)*dz1)/dz + if (.not.sumclouds_nest(l)) ciwcn(ix,jy,iz,n,l)= & + (ciwchn(ix,jy,kz-1,n,l)*dz2+ciwchn(ix,jy,kz,n,l)*dz1)/dz + end if + endif + rhon(ix,jy,iz,n,l)=(rhohn(ix,jy,kz-1)*dz2+rhohn(ix,jy,kz)*dz1)/dz + prsn(ix,jy,iz,n,l)=(prshn(ix,jy,kz-1)*dz2+prshn(ix,jy,kz)*dz1)/dz + endif + enddo + enddo +!$OMP END DO +!$OMP BARRIER + enddo + + ! Levels, where w is given + !************************* + +!$OMP DO + do jy=0,nym1 + do ix=0,nxm1 + idx(ix,jy)=2 + wwn(ix,jy,1,n,l)=wwhn(ix,jy,1,l)*pinmconv(ix,jy,1) + wwn(ix,jy,nz,n,l)=wwhn(ix,jy,nwz,l)*pinmconv(ix,jy,nz) + end do + end do +!$OMP END DO + + do iz=2,nz-1 +!$OMP DO SCHEDULE(dynamic) + do jy=0,nym1 + do ix=0,nxm1 + + inn: do kz=idx(ix,jy),nwz + if (idx(ix,jy).le.kz .and. height(iz).gt.etawheightn(ix,jy,kz-1,n,l) & + .and. height(iz).le.etawheightn(ix,jy,kz, n,l))& + then + idx(ix,jy)=kz + exit inn + endif + enddo inn + + kz=idx(ix,jy) + dz1=height(iz)-etawheightn(ix,jy,kz-1,n,l) + dz2=etawheightn(ix,jy,kz,n,l)-height(iz) + dz=dz1+dz2 + wwn(ix,jy,iz,n,l)=(wwhn(ix,jy,kz-1,l)*pinmconv(ix,jy,kz-1)*dz2 & + +wwhn(ix,jy,kz,l)*pinmconv(ix,jy,kz)*dz1)/dz + drhodzn(ix,jy,iz,n,l)=(rhon(ix,jy,iz+1,n,l)-rhon(ix,jy,iz-1,n,l))/ & + (height(iz+1)-height(iz-1)) + enddo + enddo +!$OMP END DO +!$OMP BARRIER + end do + + ! Compute density gradients at intermediate levels + !************************************************* +!$OMP DO + do jy=0,nym1 + do ix=0,nxm1 + drhodzn(ix,jy,nz,n,l)=drhodzn(ix,jy,nz-1,n,l) + drhodzn(ix,jy,1,n,l)=(rhon(ix,jy,2,n,l)-rhon(ix,jy,1,n,l))/ & + (height(2)-height(1)) + end do + end do +!$OMP END DO NOWAIT + + !**************************************************************** + ! Compute slope of eta levels in windward direction and resulting + ! vertical wind correction + !**************************************************************** + +!$OMP DO + do jy=1,nyn(l)-2 + cosf(jy)=1./cos((real(jy)*dyn(l)+ylat0n(l))*pi180) + do ix=1,nxn(l)-2 + idx(ix,jy)=2 + end do + end do +!$OMP END DO + + do iz=2,nz-1 +!$OMP DO SCHEDULE(dynamic) + do jy=1,nyn(l)-2 + do ix=1,nxn(l)-2 + + inneta: do kz=idx(ix,jy),nz + if (idx(ix,jy) .le. kz .and. & + height(iz).gt.etauvheightn(ix,jy,kz-1,n,l) .and. & + height(iz).le.etauvheightn(ix,jy,kz, n,l)) then + idx(ix,jy)=kz + exit inneta + endif + enddo inneta + + kz=idx(ix,jy) + dz1=height(iz)-etauvheightn(ix,jy,kz-1,n,l) + dz2=etauvheightn(ix,jy,kz,n,l)-height(iz) + dz=dz1+dz2 + ix1=ix-1 + jy1=jy-1 + ixp=ix+1 + jyp=jy+1 + + dzdx1=(etauvheightn(ixp,jy,kz-1,n,l)-etauvheightn(ix1,jy,kz-1,n,l))/2. + dzdx2=(etauvheightn(ixp,jy,kz,n,l)-etauvheightn(ix1,jy,kz,n,l))/2. + dzdx=(dzdx1*dz2+dzdx2*dz1)/dz + + dzdy1=(etauvheightn(ix,jyp,kz-1,n,l)-etauvheightn(ix,jy1,kz-1,n,l))/2. + dzdy2=(etauvheightn(ix,jyp,kz,n,l)-etauvheightn(ix,jy1,kz,n,l))/2. + dzdy=(dzdy1*dz2+dzdy2*dz1)/dz + + wwn(ix,jy,iz,n,l)=wwn(ix,jy,iz,n,l) + & + (dzdx*uun(ix,jy,iz,n,l)*dxconst*xresoln(l)*cosf(jy) + & + dzdy*vvn(ix,jy,iz,n,l)*dyconst*yresoln(l)) + + end do + end do +!$OMP END DO +!$OMP BARRIER + end do + + ! Keep original fields if wind_coord_type==ETA + if (wind_coord_type.eq.'ETA') then +!$OMP DO + + do kz=1,nz + do jy=0,nym1 + do ix=0,nxm1 + uuetan(ix,jy,kz,n,l) = uuhn(ix,jy,kz,l) + vvetan(ix,jy,kz,n,l) = vvhn(ix,jy,kz,l) + ttetan(ix,jy,kz,n,l) = tthn(ix,jy,kz,n,l) + qvn(ix,jy,kz,n,l) = qvhn(ix,jy,kz,n,l) + pvetan(ix,jy,kz,n,l) = pvhn(ix,jy,kz,l) + rhoetan(ix,jy,kz,n,l) = rhohn(ix,jy,kz) + prsetan(ix,jy,kz,n,l) = prshn(ix,jy,kz) + ! tvirtualn(ix,jy,kz,n,l)=ttetan(ix,jy,kz,n,l)* & + ! ((qvn(ix,jy,kz,n,l)+0.622)/(0.622*qvn(ix,jy,kz,n,l)+0.622)) + ! eq A11 from Mid-latitude atmospheric dynamics by Jonathan E. Martin + if ((kz.gt.1).and.(kz.lt.nz)) drhodzetan(ix,jy,kz,n,l)= & + (rhohn(ix,jy,kz+1)-rhohn(ix,jy,kz-1))/(height(kz+1)-height(kz-1)) + if (readclouds) then + clwcn(ix,jy,kz,n,l)=clwchn(ix,jy,kz,n,l) + if (.not.sumclouds_nest(l)) ciwcn(ix,jy,kz,n,l)=ciwchn(ix,jy,kz,n,l) + endif + end do + end do + end do +!$OMP END DO NOWAIT + +!$OMP DO + do jy=0,nym1 + do ix=0,nxm1 + drhodzetan(ix,jy,1,n,l)=(rhoetan(ix,jy,2,n,l)-rhoetan(ix,jy,1,n,l))/ & + (height(2)-height(1)) + drhodzetan(ix,jy,nz,n,l)=drhodzetan(ix,jy,nz-1,n,l) + ! tvirtualn(ix,jy,1,n,l)=tt2n(ix,jy,1,n,l)* & + ! (1.+0.378*ew(td2n(ix,jy,1,n,l),psn(ix,jy,1,n,l))/ps(ix,jy,1,n,l)) + ! Convert w from Pa/s to eta/s, following FLEXTRA + !************************************************ + do kz=1,nuvz-1 + if (kz.eq.1) then + dpdeta=(akm(kz+1)-akm(kz)+(bkm(kz+1)-bkm(kz))*ps(ix,jy,1,n))/ & + (wheight(kz+1)-wheight(kz)) + else if (kz.eq.nuvz-1) then + dpdeta=(akm(kz)-akm(kz-1)+(bkm(kz)-bkm(kz-1))*ps(ix,jy,1,n))/ & + (wheight(kz)-wheight(kz-1)) + else + dpdeta=(akm(kz+1)-akm(kz-1)+(bkm(kz+1)-bkm(kz-1))*ps(ix,jy,1,n))/ & + (wheight(kz+1)-wheight(kz-1)) + endif + wwetan(ix,jy,kz,n,l)=wwhn(ix,jy,kz,l)/dpdeta + end do + wwetan(ix,jy,nuvz,n,l)=wwetan(ix,jy,nuvz-1,n,l) + end do + end do +!$OMP END DO + endif +!$OMP END PARALLEL + +end subroutine verttransf_ec_windf_nest diff --git a/src/ver_verttransform_ecmwf.f90 b/src/ver_verttransform_ecmwf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..08dfad1b2b2ffddfd2d86bbca66c5b2991d082e3 --- /dev/null +++ b/src/ver_verttransform_ecmwf.f90 @@ -0,0 +1,127 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh) + ! 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. * + ! * + ! 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 + ! + ! Sabine Eckhardt, March 2007 + ! added the variable cloud for use with scavenging - descr. in com_mod + ! + ! Unified ECMWF and GFS builds + ! Marian Harustak, 12.5.2017 + ! - Renamed from verttransform to verttransform_ecmwf + ! + ! Date: 2017-05-30 modification of a bug in ew. Don Morton (CTBTO project) * + ! * + ! Lucie Bakels, 2022 * + ! - Separated the code into subroutines * + ! - In case of wind_coord_type='ETA': keep ECMWF vertical winds in eta * + ! coordinates * + ! - OpenMP parallelisation * + !***************************************************************************** + ! * + ! Variables: * + ! nx,ny,nz field dimensions in x,y and z direction * + ! clouds(0:nxmax,0:nymax,0:nzmax,numwfmem) cloud field for wet deposition * + ! uu(0:nxmax,0:nymax,nzmax,numwfmem) wind components in x-direction [m/s]* + ! vv(0:nxmax,0:nymax,nzmax,numwfmem) wind components in y-direction [m/s]* + ! ww(0:nxmax,0:nymax,nzmax,numwfmem) wind components in z-direction * + ! [deltaeta/s] * + ! tt(0:nxmax,0:nymax,nzmax,numwfmem) temperature [K] * + ! pv(0:nxmax,0:nymax,nzmax,numwfmem) potential voriticity (pvu) * + ! ps(0:nxmax,0:nymax,numwfmem) surface pressure [Pa] * + ! * + !***************************************************************************** + + use par_mod + use com_mod + use cmapf_mod, only: cc2gll + use qvsat_mod + + implicit none + + integer, intent(in) :: n + real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: uuh,vvh,pvh + real,intent(in),dimension(0:nxmax-1,0:nymax-1,nwzmax) :: wwh + + real,dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: rhoh + real,dimension(0:nxmax-1,0:nymax-1,nzmax) :: pinmconv + ! RLT added pressure + real,dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: prsh + + logical :: init = .true. + + !************************************************************************* + ! 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. * + !************************************************************************* + + + !eso measure CPU time + ! call mpif_mtime('verttransform',0) + + 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 + !***************************************************************************** + call vertransf_init(n) + + ! Do not repeat initialization of the Cartesian z grid + !***************************************************** + + init=.false. + endif + + + ! Compute heights of eta levels and their respective pressure and density fields + !******************************************************************************* + call verttransf_ec_height(nxmax-1,nymax-1,tt2(:,:,1,n),td2(:,:,1,n), & + ps(:,:,1,n),qvh(:,:,:,n),tth(:,:,:,n),prsh,rhoh,pinmconv, & + etauvheight(:,:,:,n),etawheight(:,:,:,n)) + + ! Transform the wind fields to the internal coordinate system and save the native ETA + ! fields when case wind_coord_type==ETA + !************************************************************* + call verttransf_ec_windf(n,uuh,vvh,wwh,pvh,rhoh,prsh,pinmconv) + + ! If north or south pole is in the domain, calculate wind velocities in polar + ! stereographic coordinates + !******************************************************************* + call verttransf_ec_stereo(n) + + ! Create cloud fields + !********************* + call verttransf_ec_cloud(n,readclouds,sumclouds,nxmin1,nymin1,clouds(:,:,:,n), & + cloudsh(:,:,n),clw(:,:,:,n),ctwc(:,:,n),clwc(:,:,:,n),ciwc(:,:,:,n),lsprec(:,:,1,n), & + convprec(:,:,1,n),rho(:,:,:,n),tt(:,:,:,n),qv(:,:,:,n),etauvheight(:,:,:,n)) +end subroutine verttransform_ecmwf diff --git a/src/ver_verttransform_gfs.f90 b/src/ver_verttransform_gfs.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8cf1eafdc4b49fbe5f9bf7e17604e6e8b68e5f9f --- /dev/null +++ b/src/ver_verttransform_gfs.f90 @@ -0,0 +1,556 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine verttransform_gfs(n,uuh,vvh,wwh,pvh) + ! 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. * + ! * + ! Author: A. Stohl, G. Wotawa * + ! * + ! 12 August 1996 * + ! Update: 16 January 1998 * + ! * + ! Major update: 17 February 1999 * + ! by G. Wotawa * + ! CHANGE 17/11/2005 Caroline Forster, NCEP GFS version * + ! * + ! - 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 + ! + ! Unified ECMWF and GFS builds + ! Marian Harustak, 12.5.2017 + ! - Renamed routine from verttransform to verttransform_gfs + ! + !***************************************************************************** + ! * + ! 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] * + ! clouds(0:nxmax,0:nymax,0:nzmax,2) cloud field for wet deposition * + ! * + !***************************************************************************** + + use par_mod + use com_mod + use cmapf_mod + use qvsat_mod + + implicit none + + integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym + integer :: rain_cloud_above,kz_inv + real :: pressure + real :: rh,lsp,cloudh_min,convp,prec + real :: rhoh(nuvzmax),pinmconv(nzmax) + real :: pint,tv,tvold,pold,dz1,dz2,dz,ui,vi + real :: xlon,ylat,xlonr,dzdx,dzdy + real :: dzdx1,dzdx2,dzdy1,dzdy2,cosf + real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy + 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 :: wzlev(nwzmax),uvwzlev(0:nxmax-1,0:nymax-1,nzmax) + real,parameter :: const=r_air/ga + + ! NCEP version + integer :: llev, i + + logical :: init = .true. + + + !************************************************************************* + ! 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. * + !************************************************************************* + + 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 + !***************************************************************************** + call vertransf_init(n) + + ! Do not repeat initialization of the Cartesian z grid + !***************************************************** + + init=.false. + + endif + + + ! Loop over the whole grid + !************************* + + do jy=0,nymin1 + do ix=0,nxmin1 + + ! NCEP version: find first level above ground + llev = 0 + do i=1,nuvz + if (ps(ix,jy,1,n).lt.akz(i)) llev=i + end do + llev = llev+1 + if (llev.gt.nuvz-2) llev = nuvz-2 + ! if (llev.eq.nuvz-2) write(*,*) 'verttransform + ! +WARNING: LLEV eq NUZV-2' + ! NCEP version + + + ! compute height of pressure levels above ground + !*********************************************** + + tvold=tth(ix,jy,llev,n)*(1.+0.608*qvh(ix,jy,llev,n)) + pold=akz(llev) + wzlev(llev)=0. + uvwzlev(ix,jy,llev)=0. + rhoh(llev)=pold/(r_air*tvold) + + do kz=llev+1,nuvz + pint=akz(kz)+bkz(kz)*ps(ix,jy,1,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 + uvwzlev(ix,jy,kz)=uvwzlev(ix,jy,kz-1)+const*log(pold/pint)* & + (tv-tvold)/log(tv/tvold) + else + uvwzlev(ix,jy,kz)=uvwzlev(ix,jy,kz-1)+const*log(pold/pint)*tv + endif + wzlev(kz)=uvwzlev(ix,jy,kz) + + tvold=tv + pold=pint + end do + + ! pinmconv=(h2-h1)/(p2-p1) + + pinmconv(llev)=(uvwzlev(ix,jy,llev+1)-uvwzlev(ix,jy,llev))/ & + ((aknew(llev+1)+bknew(llev+1)*ps(ix,jy,1,n))- & + (aknew(llev)+bknew(llev)*ps(ix,jy,1,n))) + do kz=llev+1,nz-1 + pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ & + ((aknew(kz+1)+bknew(kz+1)*ps(ix,jy,1,n))- & + (aknew(kz-1)+bknew(kz-1)*ps(ix,jy,1,n))) + end do + pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ & + ((aknew(nz)+bknew(nz)*ps(ix,jy,1,n))- & + (aknew(nz-1)+bknew(nz-1)*ps(ix,jy,1,n))) + + + ! Levels, where u,v,t and q are given + !************************************ + + uu(ix,jy,1,n)=uuh(ix,jy,llev) + vv(ix,jy,1,n)=vvh(ix,jy,llev) + tt(ix,jy,1,n)=tth(ix,jy,llev,n) + qv(ix,jy,1,n)=qvh(ix,jy,llev,n) + ! IP & SEC, 201812 add clouds + if (readclouds) then + clwc(ix,jy,1,n)=clwch(ix,jy,llev,n) + endif + pv(ix,jy,1,n)=pvh(ix,jy,llev) + rho(ix,jy,1,n)=rhoh(llev) + pplev(ix,jy,1,n)=akz(llev) + 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) + ! IP & SEC, 201812 add clouds + if (readclouds) then + clwc(ix,jy,nz,n)=clwch(ix,jy,nuvz,n) + endif + pv(ix,jy,nz,n)=pvh(ix,jy,nuvz) + rho(ix,jy,nz,n)=rhoh(nuvz) + pplev(ix,jy,nz,n)=akz(nuvz) + kmin=llev+1 + do iz=2,nz-1 + do kz=kmin,nuvz + if(height(iz).gt.uvwzlev(ix,jy,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) + ! IP & SEC, 201812 add clouds + if (readclouds) then + clwc(ix,jy,iz,n)=clwc(ix,jy,nz,n) + endif + pv(ix,jy,iz,n)=pv(ix,jy,nz,n) + rho(ix,jy,iz,n)=rho(ix,jy,nz,n) + pplev(ix,jy,iz,n)=pplev(ix,jy,nz,n) + exit + endif + if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. & + (height(iz).le.uvwzlev(ix,jy,kz))) then + dz1=height(iz)-uvwzlev(ix,jy,kz-1) + dz2=uvwzlev(ix,jy,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 + ! IP & SEC, 201812 add clouds + if (readclouds) then + clwc(ix,jy,iz,n)=(clwch(ix,jy,kz-1,n)*dz2 & + +clwch(ix,jy,kz,n)*dz1)/dz + endif + 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 + pplev(ix,jy,iz,n)=(akz(kz-1)*dz2+akz(kz)*dz1)/dz + endif + end do + end do + + + ! Levels, where w is given + !************************* + + ww(ix,jy,1,n)=wwh(ix,jy,llev)*pinmconv(llev) + ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(nz) + kmin=llev+1 + 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)*pinmconv(kz-1)*dz2 & + +wwh(ix,jy,kz)*pinmconv(kz)*dz1)/dz + endif + end do + end do + + + ! 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 + + + !**************************************************************** + ! Compute slope of eta levels in windward direction and resulting + ! vertical wind correction + !**************************************************************** + + do jy=1,ny-2 + cosf=cos((real(jy)*dy+ylat0)*pi180) + do ix=1,nx-2 + + ! NCEP version: find first level above ground + llev = 0 + do i=1,nuvz + if (ps(ix,jy,1,n).lt.akz(i)) llev=i + end do + llev = llev+1 + if (llev.gt.nuvz-2) llev = nuvz-2 + ! if (llev.eq.nuvz-2) write(*,*) 'verttransform + ! +WARNING: LLEV eq NUZV-2' + ! NCEP version + + kmin=llev+1 + do iz=2,nz-1 + + ui=uu(ix,jy,iz,n)*dxconst/cosf + vi=vv(ix,jy,iz,n)*dyconst + + do kz=kmin,nz + if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. & + (height(iz).le.uvwzlev(ix,jy,kz))) then + dz1=height(iz)-uvwzlev(ix,jy,kz-1) + dz2=uvwzlev(ix,jy,kz)-height(iz) + dz=dz1+dz2 + kl=kz-1 + klp=kz + exit + endif + end do + + ix1=ix-1 + jy1=jy-1 + ixp=ix+1 + jyp=jy+1 + + dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2. + dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2. + dzdx=(dzdx1*dz2+dzdx2*dz1)/dz + + dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2. + dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2. + dzdy=(dzdy1*dz2+dzdy2*dz1)/dz + + ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*ui+dzdy*vi) + + end do + + end do + end do + + + ! If north pole is in the domain, calculate wind velocities in polar + ! stereographic coordinates + !******************************************************************* + + if (nglobal) then + do jy=int(switchnorthg)-2,nymin1 + ylat=ylat0+real(jy)*dy + do ix=0,nxmin1 + xlon=xlon0+real(ix)*dx + do iz=1,nz + 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)) + end do + end do + end do + + + do 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 + elseif (vv(nx/2-1,nymin1,iz,n).gt.0.) then + ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ & + vv(nx/2-1,nymin1,iz,n))-xlonr + else + ddpol=pi/2-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 ix=0,nxmin1 + uupol(ix,jy,iz,n)=uupolaux + vvpol(ix,jy,iz,n)=vvpolaux + end do + end do + + + ! Fix: Set W at pole to the zonally averaged W of the next equator- + ! ward parallel of latitude + + do iz=1,nz + wdummy=0. + jy=ny-2 + do ix=0,nxmin1 + wdummy=wdummy+ww(ix,jy,iz,n) + end do + wdummy=wdummy/real(nx) + jy=nymin1 + do ix=0,nxmin1 + ww(ix,jy,iz,n)=wdummy + end do + end do + + endif + + + ! If south pole is in the domain, calculate wind velocities in polar + ! stereographic coordinates + !******************************************************************* + + if (sglobal) then + do jy=0,int(switchsouthg)+3 + ylat=ylat0+real(jy)*dy + do ix=0,nxmin1 + xlon=xlon0+real(ix)*dx + do iz=1,nz + 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)) + end do + end do + end do + + do 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 + elseif (vv(nx/2-1,0,iz,n).gt.0.) then + ddpol=pi+atan(uu(nx/2-1,0,iz,n)/vv(nx/2-1,0,iz,n))-xlonr + else + ddpol=pi/2-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 ix=0,nxmin1 + uupol(ix,jy,iz,n)=uupolaux + vvpol(ix,jy,iz,n)=vvpolaux + end do + end do + + + ! Fix: Set W at pole to the zonally averaged W of the next equator- + ! ward parallel of latitude + + do iz=1,nz + wdummy=0. + jy=1 + do ix=0,nxmin1 + wdummy=wdummy+ww(ix,jy,iz,n) + end do + wdummy=wdummy/real(nx) + jy=0 + do ix=0,nxmin1 + ww(ix,jy,iz,n)=wdummy + end do + end do + endif + + !***************************************************************************** + ! IP & SEC, 201812 GFS clouds read + if (readclouds) then +! loops all grids vertically and constructs the 3D matrix for clouds +! Cloud top and cloud bottom gid cells are assigned as well as the total column +! cloud water. For precipitating grids, the type and whether it is in or below +! cloud scavenging are assigned with numbers 2-5 (following the old metod). +! Distinction is done for lsp and convp though they are treated the same in +! regards to scavenging. Also clouds that are not precipitating are defined +! which may be to include future cloud processing by non-precipitating-clouds. +!***************************************************************************** + write(*,*) 'Global NCEP fields: using cloud water' + clw(:,:,:,n)=0.0 + ctwc(:,:,n)=0.0 + clouds(:,:,:,n)=0 + ! If water/ice are read separately into clwc and ciwc, store sum in clwc + do jy=0,nymin1 + do ix=0,nxmin1 + lsp=lsprec(ix,jy,1,n) + convp=convprec(ix,jy,1,n) + prec=lsp+convp + ! Find clouds in the vertical + do kz=1, nz-1 !go from top to bottom + if (clwc(ix,jy,kz,n).gt.0) then + ! assuming rho is in kg/m3 and hz in m gives: kg/kg * kg/m3 *m3/kg /m = m2/m3 + clw(ix,jy,kz,n)=(clwc(ix,jy,kz,n)*rho(ix,jy,kz,n))* & + (height(kz+1)-height(kz)) + ctwc(ix,jy,n) = ctwc(ix,jy,n)+clw(ix,jy,kz,n) + cloudh_min=min(height(kz+1),height(kz)) + endif + end do + + ! If Precipitation. Define removal type in the vertical + if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation + + do kz=nz,2,-1 !go Bottom up! + if (clw(ix,jy,kz,n).gt. 0) then ! is in cloud + cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+height(kz)-height(kz-1) + clouds(ix,jy,kz,n)=1 ! is a cloud + if (lsp.ge.convp) then + clouds(ix,jy,kz,n)=3 ! lsp in-cloud + else + clouds(ix,jy,kz,n)=2 ! convp in-cloud + endif ! convective or large scale + elseif((clw(ix,jy,kz,n).le.0) .and. (cloudh_min.ge.height(kz))) then + ! is below cloud + 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 ! convective or large scale + endif + + if (height(kz).ge. 19000) then ! set a max height for removal + clouds(ix,jy,kz,n)=0 + endif !clw>0 + end do !nz + endif ! precipitation + end do + end do + else + write(*,*) 'Global NCEP fields: using cloud water from Parameterization' + ! write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz + ! create a cloud and rainout/washout field, clouds occur where rh>80% + ! total cloudheight is stored at level 0 + do jy=0,nymin1 + do ix=0,nxmin1 + rain_cloud_above=0 + lsp=lsprec(ix,jy,1,n) + convp=convprec(ix,jy,1,n) + cloudsh(ix,jy,n)=0 + 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 + endif ! IP & SEC 201812, GFS clouds read + +end subroutine verttransform_gfs diff --git a/src/ver_verttransform_nest.f90 b/src/ver_verttransform_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..dd6a0a2644446d0203589ebe56cc7483e72d7a43 --- /dev/null +++ b/src/ver_verttransform_nest.f90 @@ -0,0 +1,100 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine verttransform_nest(n,uuhn,vvhn,wwhn,pvhn) + ! 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. * + ! 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 + !***************************************************************************** + ! Sabine Eckhardt, March 2007 + ! add the variable cloud for use with scavenging - descr. in com_mod + !***************************************************************************** + ! ESO, 2016 + ! -note that divide-by-zero occurs when nxmaxn,nymaxn etc. are larger than + ! the actual field dimensions + !***************************************************************************** + ! Date: 2017-05-30 modification of a bug in ew. Don Morton (CTBTO project) * + !***************************************************************************** + ! * + ! 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 + use qvsat_mod + + implicit none + + real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) :: uuhn,vvhn,pvhn + real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) :: wwhn + + real,dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax) :: rhohn,uvzlev,wzlev,prshn + real,dimension(0:nxmaxn-1,0:nymaxn-1,nzmax) :: pinmconv + + integer,dimension(0:nxmaxn-1,0:nymaxn-1) :: rain_cloud_above, idx + + integer :: ix,jy,kz,iz,n,l,kmin,kl,klp,ix1,jy1,ixp,jyp,kz_inv + integer :: nxm1, nym1 + + ! real,parameter :: precmin = 0.002 ! minimum prec in mm/h for cloud diagnostics + + ! Loop over all nests + !******************** + + do l=1,numbnests + nxm1=nxn(l)-1 + nym1=nyn(l)-1 + call verttransf_ec_height(nxm1,nym1, tt2n(0:nxm1,0:nym1,1,n,l),& + td2n(0:nxm1,0:nym1,1,n,l),psn(0:nxm1,0:nym1,1,n,l), & + qvhn(0:nxm1,0:nym1,:,n,l),tthn(0:nxm1,0:nym1,:,n,l), & + prshn(0:nxm1,0:nym1,:),rhohn(0:nxm1,0:nym1,:),pinmconv(0:nxm1,0:nym1,:), & + etauvheightn(0:nxm1,0:nym1,:,n,l),etawheightn(0:nxm1,0:nym1,:,n,l)) + + call verttransf_ec_windf_nest(l,n,uuhn,vvhn,wwhn,pvhn,rhohn,prshn,pinmconv) + + ! Create cloud fields + !********************* + + call verttransf_ec_cloud(n,readclouds_nest(l),sumclouds_nest(l),nxm1,nym1,& + cloudsn(0:nxm1,0:nym1,:,n,l),cloudshn(0:nxm1,0:nym1,n,l), & + clwn(0:nxm1,0:nym1,:,n,l), ctwcn(0:nxm1,0:nym1,n,l), & + clwcn(0:nxm1,0:nym1,:,n,l), ciwcn(0:nxm1,0:nym1,:,n,l), & + lsprecn(0:nxm1,0:nym1,1,n,l),convprecn(0:nxm1,0:nym1,1,n,l), & + rhon(0:nxm1,0:nym1,:,n,l),ttn(0:nxm1,0:nym1,:,n,l), & + qvn(0:nxm1,0:nym1,:,n,l), etauvheightn(0:nxm1,0:nym1,:,n,l)) + + end do ! end loop over nests + +end subroutine verttransform_nest diff --git a/src/verttransform_mod.f90 b/src/verttransform_mod.f90 index 9bd5b70a8e04b48c1010f970d9f65b3f916ac3e3..f750eec2a15add9d09dbeb733028698b3c870cd3 100644 --- a/src/verttransform_mod.f90 +++ b/src/verttransform_mod.f90 @@ -17,1962 +17,22 @@ module verttransform_mod contains -subroutine verttransform_ecmwf(n,uuh,vvh,wwh,pvh) - ! 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. * - ! * - ! 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 - ! - ! Sabine Eckhardt, March 2007 - ! added the variable cloud for use with scavenging - descr. in com_mod - ! - ! Unified ECMWF and GFS builds - ! Marian Harustak, 12.5.2017 - ! - Renamed from verttransform to verttransform_ecmwf - ! - ! Date: 2017-05-30 modification of a bug in ew. Don Morton (CTBTO project) * - ! * - ! Lucie Bakels, 2022 * - ! - Separated the code into subroutines * - ! - In case of wind_coord_type='ETA': keep ECMWF vertical winds in eta * - ! coordinates * - ! - OpenMP parallelisation * - !***************************************************************************** - ! * - ! Variables: * - ! nx,ny,nz field dimensions in x,y and z direction * - ! clouds(0:nxmax,0:nymax,0:nzmax,numwfmem) cloud field for wet deposition * - ! uu(0:nxmax,0:nymax,nzmax,numwfmem) wind components in x-direction [m/s]* - ! vv(0:nxmax,0:nymax,nzmax,numwfmem) wind components in y-direction [m/s]* - ! ww(0:nxmax,0:nymax,nzmax,numwfmem) wind components in z-direction * - ! [deltaeta/s] * - ! tt(0:nxmax,0:nymax,nzmax,numwfmem) temperature [K] * - ! pv(0:nxmax,0:nymax,nzmax,numwfmem) potential voriticity (pvu) * - ! ps(0:nxmax,0:nymax,numwfmem) surface pressure [Pa] * - ! * - !***************************************************************************** - - use par_mod - use com_mod - use cmapf_mod, only: cc2gll - use qvsat_mod - - implicit none - - integer, intent(in) :: n - real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: uuh,vvh,pvh - real,intent(in),dimension(0:nxmax-1,0:nymax-1,nwzmax) :: wwh - - real,dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: rhoh - real,dimension(0:nxmax-1,0:nymax-1,nzmax) :: pinmconv - ! RLT added pressure - real,dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: prsh - - logical :: init = .true. - - !************************************************************************* - ! 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. * - !************************************************************************* - - - !eso measure CPU time - ! call mpif_mtime('verttransform',0) - - 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 - !***************************************************************************** - call vertransf_init(n) - - ! Do not repeat initialization of the Cartesian z grid - !***************************************************** - - init=.false. - endif - - - ! Compute heights of eta levels and their respective pressure and density fields - !******************************************************************************* - call verttransf_ec_height(nxmax-1,nymax-1,tt2(:,:,1,n),td2(:,:,1,n), & - ps(:,:,1,n),qvh(:,:,:,n),tth(:,:,:,n),prsh,rhoh,pinmconv, & - etauvheight(:,:,:,n),etawheight(:,:,:,n)) - - ! Transform the wind fields to the internal coordinate system and save the native ETA - ! fields when case wind_coord_type==ETA - !************************************************************* - call verttransf_ec_windf(n,uuh,vvh,wwh,pvh,rhoh,prsh,pinmconv) - - ! If north or south pole is in the domain, calculate wind velocities in polar - ! stereographic coordinates - !******************************************************************* - call verttransf_ec_stereo(n) - - ! Create cloud fields - !********************* - call verttransf_ec_cloud(n,readclouds,sumclouds,nxmin1,nymin1,clouds(:,:,:,n), & - cloudsh(:,:,n),clw(:,:,:,n),ctwc(:,:,n),clwc(:,:,:,n),ciwc(:,:,:,n),lsprec(:,:,1,n), & - convprec(:,:,1,n),rho(:,:,:,n),tt(:,:,:,n),qv(:,:,:,n),etauvheight(:,:,:,n)) -end subroutine verttransform_ecmwf - -subroutine verttransform_nest(n,uuhn,vvhn,wwhn,pvhn) - ! 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. * - ! 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 - !***************************************************************************** - ! Sabine Eckhardt, March 2007 - ! add the variable cloud for use with scavenging - descr. in com_mod - !***************************************************************************** - ! ESO, 2016 - ! -note that divide-by-zero occurs when nxmaxn,nymaxn etc. are larger than - ! the actual field dimensions - !***************************************************************************** - ! Date: 2017-05-30 modification of a bug in ew. Don Morton (CTBTO project) * - !***************************************************************************** - ! * - ! 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 - use qvsat_mod - - implicit none - - real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) :: uuhn,vvhn,pvhn - real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) :: wwhn - - real,dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax) :: rhohn,uvzlev,wzlev,prshn - real,dimension(0:nxmaxn-1,0:nymaxn-1,nzmax) :: pinmconv - - integer,dimension(0:nxmaxn-1,0:nymaxn-1) :: rain_cloud_above, idx - - integer :: ix,jy,kz,iz,n,l,kmin,kl,klp,ix1,jy1,ixp,jyp,kz_inv - integer :: nxm1, nym1 - - ! real,parameter :: precmin = 0.002 ! minimum prec in mm/h for cloud diagnostics - - ! Loop over all nests - !******************** - - do l=1,numbnests - nxm1=nxn(l)-1 - nym1=nyn(l)-1 - call verttransf_ec_height(nxm1,nym1, tt2n(0:nxm1,0:nym1,1,n,l),& - td2n(0:nxm1,0:nym1,1,n,l),psn(0:nxm1,0:nym1,1,n,l), & - qvhn(0:nxm1,0:nym1,:,n,l),tthn(0:nxm1,0:nym1,:,n,l), & - prshn(0:nxm1,0:nym1,:),rhohn(0:nxm1,0:nym1,:),pinmconv(0:nxm1,0:nym1,:), & - etauvheightn(0:nxm1,0:nym1,:,n,l),etawheightn(0:nxm1,0:nym1,:,n,l)) - - call verttransf_ec_windf_nest(l,n,uuhn,vvhn,wwhn,pvhn,rhohn,prshn,pinmconv) - - ! Create cloud fields - !********************* - - call verttransf_ec_cloud(n,readclouds_nest(l),sumclouds_nest(l),nxm1,nym1,& - cloudsn(0:nxm1,0:nym1,:,n,l),cloudshn(0:nxm1,0:nym1,n,l), & - clwn(0:nxm1,0:nym1,:,n,l), ctwcn(0:nxm1,0:nym1,n,l), & - clwcn(0:nxm1,0:nym1,:,n,l), ciwcn(0:nxm1,0:nym1,:,n,l), & - lsprecn(0:nxm1,0:nym1,1,n,l),convprecn(0:nxm1,0:nym1,1,n,l), & - rhon(0:nxm1,0:nym1,:,n,l),ttn(0:nxm1,0:nym1,:,n,l), & - qvn(0:nxm1,0:nym1,:,n,l), etauvheightn(0:nxm1,0:nym1,:,n,l)) - - end do ! end loop over nests - -end subroutine verttransform_nest - -subroutine vertransf_init(n) - - use par_mod - use com_mod - use qvsat_mod - use initialise_mod - use output_mod - - implicit none - - integer, intent(in) :: n - real :: tvold,pold,pint,tv - integer :: ix,jy,kz,ixm,jym - real,parameter :: const=r_air/ga - - if ((ipin.eq.1).or.(ipin.eq.4)) then - call read_heightlevels(height,nmixz) - return - endif - - loop1: do jy=0,nymin1 - do ix=0,nxmin1 - if (ps(ix,jy,1,n).gt.100000.) then - ixm=ix - jym=jy - exit loop1 - endif - end do - end do loop1 - - tvold=tt2(ixm,jym,1,n)*(1.+0.378*ew(td2(ixm,jym,1,n),ps(ixm,jym,1,n))/ & - ps(ixm,jym,1,n)) - pold=ps(ixm,jym,1,n) - height(1)=0. - - do kz=2,nuvz - pint=akz(kz)+bkz(kz)*ps(ixm,jym,1,n) - tv=tth(ixm,jym,kz,n)*(1.+0.608*qvh(ixm,jym,kz,n)) - - 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 - - tvold=tv - pold=pint - end do - - ! Determine highest levels that can be within PBL - !************************************************ - - do kz=1,nz - if (height(kz).gt.hmixmax) then - nmixz=kz - exit - endif - end do - - call output_heightlevs(height,nmixz) -end subroutine vertransf_init - -subroutine verttransf_ec_windf(n,uuh,vvh,wwh,pvh,rhoh,prsh,pinmconv) - use par_mod - use com_mod - use qvsat_mod - - implicit none - - integer,intent(in) :: n - real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: uuh,vvh,pvh - real,intent(in),dimension(0:nxmax-1,0:nymax-1,nwzmax) :: wwh - real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: rhoh - real,intent(in),dimension(0:nxmax-1,0:nymax-1,nzmax) :: pinmconv - ! RLT added pressure - real,intent(in),dimension(0:nxmax-1,0:nymax-1,nuvzmax) :: prsh - - !real,dimension(0:nxmax-1,0:nymax-1) :: dpdeta - - real,dimension(0:nymax-1) :: cosf - - integer,dimension(0:nxmax-1,0:nymax-1) :: idx - - integer :: ix,jy,kz,iz,kmin,ixp,jyp,ix1,jy1 - real :: dz1,dz2,dz,dpdeta - real :: xlon,ylat,xlonr,dzdx,dzdy - real :: dzdx1,dzdx2,dzdy1,dzdy2 - - ! Levels, where u,v,t and q are given - !************************************ -!$OMP PARALLEL PRIVATE(jy,ix,kz,dz1,dz2,dz,ix1,jy1,ixp,jyp,dzdx1,dzdx2,dzdx, & -!$OMP dzdy1,dzdy2,dzdy,dpdeta) - -!$OMP DO - do jy=0,nymin1 - do ix=0,nxmin1 - - uu(ix,jy,1,n)=uuh(ix,jy,1) - uu(ix,jy,nz,n)=uuh(ix,jy,nuvz) - vv(ix,jy,1,n)=vvh(ix,jy,1) - vv(ix,jy,nz,n)=vvh(ix,jy,nuvz) - tt(ix,jy,1,n)=tth(ix,jy,1,n) - tt(ix,jy,nz,n)=tth(ix,jy,nuvz,n) - pv(ix,jy,1,n)=pvh(ix,jy,1) - pv(ix,jy,nz,n)=pvh(ix,jy,nuvz) - if (wind_coord_type.ne.'ETA') then - qv(ix,jy,1,n)=qvh(ix,jy,1,n) - qv(ix,jy,nz,n)=qvh(ix,jy,nuvz,n) - !hg adding the cloud water - if (readclouds) then - clwc(ix,jy,1,n)=clwch(ix,jy,1,n) - clwc(ix,jy,nz,n)=clwch(ix,jy,nuvz,n) - if (.not.sumclouds) then - ciwc(ix,jy,1,n)=ciwch(ix,jy,1,n) - ciwc(ix,jy,nz,n)=ciwch(ix,jy,nuvz,n) - endif - end if - !hg - endif - rho(ix,jy,1,n)=rhoh(ix,jy,1) - rho(ix,jy,nz,n)=rhoh(ix,jy,nuvz) - ! RLT add pressure - prs(ix,jy,1,n)=prsh(ix,jy,1) - prs(ix,jy,nz,n)=prsh(ix,jy,nuvz) - ! RLT - - idx(ix,jy)=2 - end do - end do -!$OMP END DO - - do iz=2,nz-1 -!$OMP DO SCHEDULE(dynamic) - do jy=0,nymin1 - do ix=0,nxmin1 - if(height(iz).gt.etauvheight(ix,jy,nuvz,n)) 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) - pv(ix,jy,iz,n)=pv(ix,jy,nz,n) - if (wind_coord_type.ne.'ETA') then - qv(ix,jy,iz,n)=qv(ix,jy,nz,n) - !hg adding the cloud water - if (readclouds) then - clwc(ix,jy,iz,n)=clwc(ix,jy,nz,n) - if (.not.sumclouds) ciwc(ix,jy,iz,n)=ciwc(ix,jy,nz,n) - end if - endif - rho(ix,jy,iz,n)=rho(ix,jy,nz,n) - prs(ix,jy,iz,n)=prs(ix,jy,nz,n) ! RLT - else - innuvz: do kz=idx(ix,jy),nuvz - if ( idx(ix,jy).le.kz .and. & - height(iz).gt.etauvheight(ix,jy,kz-1,n) .and. & - height(iz).le.etauvheight(ix,jy,kz,n) ) then - idx(ix,jy)=kz - exit innuvz - endif - enddo innuvz - endif - - if (height(iz).le.etauvheight(ix,jy,nuvz,n)) then - kz=idx(ix,jy) - dz1=height(iz)-etauvheight(ix,jy,kz-1,n) - dz2=etauvheight(ix,jy,kz,n)-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 - pv(ix,jy,iz,n)=(pvh(ix,jy,kz-1)*dz2+pvh(ix,jy,kz)*dz1)/dz - if (wind_coord_type.ne.'ETA') then - qv(ix,jy,iz,n)=(qvh(ix,jy,kz-1,n)*dz2+qvh(ix,jy,kz,n)*dz1)/dz - !hg adding the cloud water - if (readclouds) then - clwc(ix,jy,iz,n)= & - (clwch(ix,jy,kz-1,n)*dz2+clwch(ix,jy,kz,n)*dz1)/dz - if (.not.sumclouds) ciwc(ix,jy,iz,n)= & - (ciwch(ix,jy,kz-1,n)*dz2+ciwch(ix,jy,kz,n)*dz1)/dz - end if - !hg - endif - rho(ix,jy,iz,n)=(rhoh(ix,jy,kz-1)*dz2+rhoh(ix,jy,kz)*dz1)/dz - ! RLT add pressure - prs(ix,jy,iz,n)=(prsh(ix,jy,kz-1)*dz2+prsh(ix,jy,kz)*dz1)/dz - endif - enddo - enddo -!$OMP END DO -!$OMP BARRIER - enddo - ! Levels, where w is given - !************************* - -!$OMP DO - do jy=0,nymin1 - do ix=0,nxmin1 - idx(ix,jy)=2 - ww(ix,jy,1,n)=wwh(ix,jy,1)*pinmconv(ix,jy,1) - ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(ix,jy,nz) - end do - end do -!$OMP END DO - - do iz=2,nz-1 -!$OMP DO SCHEDULE(dynamic) - do jy=0,nymin1 - do ix=0,nxmin1 - - inn: do kz=idx(ix,jy),nwz - if (idx(ix,jy).le.kz .and. height(iz).gt.etawheight(ix,jy,kz-1,n) & - .and. height(iz).le.etawheight(ix,jy,kz,n)) then - idx(ix,jy)=kz - exit inn - endif - enddo inn - - kz=idx(ix,jy) - dz1=height(iz)-etawheight(ix,jy,kz-1,n) - dz2=etawheight(ix,jy,kz,n)-height(iz) - dz=dz1+dz2 - ww(ix,jy,iz,n)=(wwh(ix,jy,kz-1)*pinmconv(ix,jy,kz-1)*dz2 & - +wwh(ix,jy,kz)*pinmconv(ix,jy,kz)*dz1)/dz - ! Compute density gradients at intermediate levels - !************************************************* - drhodz(ix,jy,iz,n)=(rho(ix,jy,iz+1,n)-rho(ix,jy,iz-1,n))/ & - (height(iz+1)-height(iz-1)) - end do - end do -!$OMP END DO -!$OMP BARRIER - end do - -!$OMP DO - do jy=0,nymin1 - do ix=0,nxmin1 - drhodz(ix,jy,nz,n)=drhodz(ix,jy,nz-1,n) - drhodz(ix,jy,1,n)=(rho(ix,jy,2,n)-rho(ix,jy,1,n))/(height(2)-height(1)) - end do - end do -!$OMP END DO NOWAIT - - !**************************************************************** - ! Compute slope of eta levels in windward direction and resulting - ! vertical wind correction - !**************************************************************** - -!$OMP DO - do jy=1,ny-2 - cosf(jy)=1./cos((real(jy)*dy+ylat0)*pi180) - do ix=1,nx-2 - idx(ix,jy)=2 - end do - end do -!$OMP END DO - - do iz=2,nz-1 -!$OMP DO SCHEDULE(dynamic) - do jy=1,ny-2 - do ix=1,nx-2 - ! For gridpoint (ix,jy) and height (iz), this loop finds the first eta - ! level encompassing the height(iz) level and saves it in idx(ix,jy) - inneta: do kz=idx(ix,jy),nz - if (idx(ix,jy) .le. kz .and. height(iz).gt.etauvheight(ix,jy,kz-1,n) & - .and. height(iz).le.etauvheight(ix,jy,kz,n)) then - idx(ix,jy)=kz - exit inneta - endif - enddo inneta - - kz=idx(ix,jy) - dz1=height(iz)-etauvheight(ix,jy,kz-1,n) - dz2=etauvheight(ix,jy,kz,n)-height(iz) - dz=dz1+dz2 - ix1=ix-1 - jy1=jy-1 - ixp=ix+1 - jyp=jy+1 - - dzdx1=(etauvheight(ixp,jy,kz-1,n)-etauvheight(ix1,jy,kz-1,n))/2. - dzdx2=(etauvheight(ixp,jy,kz,n)-etauvheight(ix1,jy,kz,n))/2. - dzdx=(dzdx1*dz2+dzdx2*dz1)/dz - - dzdy1=(etauvheight(ix,jyp,kz-1,n)-etauvheight(ix,jy1,kz-1,n))/2. - dzdy2=(etauvheight(ix,jyp,kz,n)-etauvheight(ix,jy1,kz,n))/2. - dzdy=(dzdy1*dz2+dzdy2*dz1)/dz - - ww(ix,jy,iz,n) = ww(ix,jy,iz,n) + dzdx*uu(ix,jy,iz,n)*dxconst*cosf(jy) & - + dzdy*vv(ix,jy,iz,n)*dyconst - end do - end do -!$OMP END DO -!$OMP BARRIER - end do - - ! Keep original fields if wind_coord_type==ETA - if (wind_coord_type.eq.'ETA') then -!$OMP DO - - do kz=1,nz - do jy=0,nymin1 - do ix=0,nxmin1 - uueta(ix,jy,kz,n) = uuh(ix,jy,kz) - vveta(ix,jy,kz,n) = vvh(ix,jy,kz) - tteta(ix,jy,kz,n) = tth(ix,jy,kz,n) - qv(ix,jy,kz,n) = qvh(ix,jy,kz,n) - pveta(ix,jy,kz,n) = pvh(ix,jy,kz) - rhoeta(ix,jy,kz,n) = rhoh(ix,jy,kz) - prseta(ix,jy,kz,n) = prsh(ix,jy,kz) - ! tvirtual(ix,jy,kz,n)=tteta(ix,jy,kz,n)* & - ! ((qv(ix,jy,kz,n)+0.622)/(0.622*qv(ix,jy,kz,n)+0.622)) - ! eq A11 from Mid-latitude atmospheric dynamics by Jonathan E. Martin - if ((kz.gt.1).and.(kz.lt.nz)) drhodzeta(ix,jy,kz,n)= & - (rhoh(ix,jy,kz+1)-rhoh(ix,jy,kz-1))/ & - (height(kz+1)-height(kz-1)) - ! Note that this is still in SI units and not in eta - if (readclouds) then - clwc(ix,jy,kz,n)=clwch(ix,jy,kz,n) - if (.not. sumclouds) ciwc(ix,jy,kz,n)=ciwch(ix,jy,kz,n) - endif - end do - end do - end do -!$OMP END DO NOWAIT - -!$OMP DO - do jy=0,nymin1 - do ix=0,nxmin1 - drhodzeta(ix,jy,1,n)=(rhoh(ix,jy,2)-rhoh(ix,jy,1))/(height(2)-height(1)) - drhodzeta(ix,jy,nz,n)=drhodzeta(ix,jy,nz-1,n) - ! tvirtual(ix,jy,1,n)=tt2(ix,jy,1,n)* & - ! (1.+0.378*ew(td2(ix,jy,1,n),ps(ix,jy,1,n))/ps(ix,jy,1,n)) - ! Convert w from Pa/s to eta/s, following FLEXTRA - !************************************************ - do kz=1,nuvz-1 - if (kz.eq.1) then - dpdeta=(akm(kz+1)-akm(kz)+(bkm(kz+1)-bkm(kz))*ps(ix,jy,1,n))/ & - (wheight(kz+1)-wheight(kz)) - else if (kz.eq.nuvz-1) then - dpdeta=(akm(kz)-akm(kz-1)+(bkm(kz)-bkm(kz-1))*ps(ix,jy,1,n))/ & - (wheight(kz)-wheight(kz-1)) - else - dpdeta=(akm(kz+1)-akm(kz-1)+(bkm(kz+1)-bkm(kz-1))*ps(ix,jy,1,n))/ & - (wheight(kz+1)-wheight(kz-1)) - endif - wweta(ix,jy,kz,n)=wwh(ix,jy,kz)/dpdeta - end do - wweta(ix,jy,nuvz,n)=wweta(ix,jy,nuvz-1,n) - ! What is the appropriate value for the top level??? - end do - end do -!$OMP END DO - endif -!$OMP END PARALLEL - -end subroutine verttransf_ec_windf - -subroutine verttransf_ec_stereo(n) - use par_mod - use com_mod - use cmapf_mod, only: cc2gll - use qvsat_mod - - implicit none - - integer, intent(in) :: n - - integer :: ix,jy,iz - real :: xlon,ylat,xlonr - real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy - - if (nglobal) then - do iz=1,nz - do jy=int(switchnorthg)-2,nymin1 - ylat=ylat0+real(jy)*dy - do ix=0,nxmin1 - xlon=xlon0+real(ix)*dx - 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)) - if (wind_coord_type.eq.'ETA') then - call cc2gll(northpolemap,ylat,xlon,uueta(ix,jy,iz,n), & - vveta(ix,jy,iz,n),uupoleta(ix,jy,iz,n), & - vvpoleta(ix,jy,iz,n)) - endif - end do - end do - end do - - - do iz=1,nz - - ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT - ! - ! AMSnauffer Nov 18 2004 Added check for case vv=0 - ! - 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 if (vv(nx/2-1,nymin1,iz,n).gt.0.) then - ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ & - vv(nx/2-1,nymin1,iz,n))-xlonr - else - ddpol=pi/2-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 ix=0,nxmin1 - uupol(ix,jy,iz,n)=uupolaux - vvpol(ix,jy,iz,n)=vvpolaux - end do - end do - - if (wind_coord_type.eq.'ETA') then - do iz=1,nz - - xlon=xlon0+real(nx/2-1)*dx - xlonr=xlon*pi/180. - ffpol=sqrt(uueta(nx/2-1,nymin1,iz,n)**2+ & - vveta(nx/2-1,nymin1,iz,n)**2) - if (vveta(nx/2-1,nymin1,iz,n).lt.0.) then - ddpol=atan(uueta(nx/2-1,nymin1,iz,n)/ & - vveta(nx/2-1,nymin1,iz,n))-xlonr - else if (vveta(nx/2-1,nymin1,iz,n).gt.0.) then - ddpol=pi+atan(uueta(nx/2-1,nymin1,iz,n)/ & - vveta(nx/2-1,nymin1,iz,n))-xlonr - else - ddpol=pi/2-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 ix=0,nxmin1 - uupoleta(ix,jy,iz,n)=uupolaux - vvpoleta(ix,jy,iz,n)=vvpolaux - end do - end do - endif - - - ! Fix: Set W at pole to the zonally averaged W of the next equator- - ! ward parallel of latitude - - do iz=1,nz - wdummy=0. - jy=ny-2 - do ix=0,nxmin1 - wdummy=wdummy+ww(ix,jy,iz,n) - end do - wdummy=wdummy/real(nx) - jy=nymin1 - do ix=0,nxmin1 - ww(ix,jy,iz,n)=wdummy - end do - end do - - if (wind_coord_type.eq.'ETA') then - do iz=1,nz - wdummy=0. - jy=ny-2 - do ix=0,nxmin1 - wdummy=wdummy+wweta(ix,jy,iz,n) - end do - wdummy=wdummy/real(nx) - jy=nymin1 - do ix=0,nxmin1 - wweta(ix,jy,iz,n)=wdummy - end do - end do - endif - - endif - - - ! If south pole is in the domain, calculate wind velocities in polar - ! stereographic coordinates - !******************************************************************* - - if (sglobal) then - do iz=1,nz - do jy=0,int(switchsouthg)+3 - ylat=ylat0+real(jy)*dy - do ix=0,nxmin1 - xlon=xlon0+real(ix)*dx - 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)) - if (wind_coord_type.eq.'ETA') then - call cc2gll(southpolemap,ylat,xlon,uueta(ix,jy,iz,n), & - vveta(ix,jy,iz,n),uupoleta(ix,jy,iz,n), & - vvpoleta(ix,jy,iz,n)) - endif - end do - end do - end do - - do iz=1,nz - - ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT - ! - ! AMSnauffer Nov 18 2004 Added check for case vv=0 - ! - 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 if (vv(nx/2-1,0,iz,n).gt.0.) then - ddpol=pi+atan(uu(nx/2-1,0,iz,n)/ & - vv(nx/2-1,0,iz,n))+xlonr - else - ddpol=pi/2-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 ix=0,nxmin1 - uupol(ix,jy,iz,n)=uupolaux - vvpol(ix,jy,iz,n)=vvpolaux - end do - end do - - if (wind_coord_type.eq.'ETA') then - do iz=1,nz - ! CALCULATE FFPOL, DDPOL FOR CENTRAL GRID POINT - ! - ! AMSnauffer Nov 18 2004 Added check for case vv=0 - ! - xlon=xlon0+real(nx/2-1)*dx - xlonr=xlon*pi/180. - ffpol=sqrt(uueta(nx/2-1,0,iz,n)**2+ & - vveta(nx/2-1,0,iz,n)**2) - if (vveta(nx/2-1,0,iz,n).lt.0.) then - ddpol=atan(uueta(nx/2-1,0,iz,n)/ & - vveta(nx/2-1,0,iz,n))+xlonr - else if (vveta(nx/2-1,0,iz,n).gt.0.) then - ddpol=pi+atan(uueta(nx/2-1,0,iz,n)/ & - vveta(nx/2-1,0,iz,n))+xlonr - else - ddpol=pi/2-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 ix=0,nxmin1 - uupoleta(ix,jy,iz,n)=uupolaux - vvpoleta(ix,jy,iz,n)=vvpolaux - end do - end do - endif - - ! Fix: Set W at pole to the zonally averaged W of the next equator- - ! ward parallel of latitude - - do iz=1,nz - wdummy=0. - jy=1 - do ix=0,nxmin1 - wdummy=wdummy+ww(ix,jy,iz,n) - end do - wdummy=wdummy/real(nx) - jy=0 - do ix=0,nxmin1 - ww(ix,jy,iz,n)=wdummy - end do - end do - - if (wind_coord_type.eq.'ETA') then - do iz=1,nz - wdummy=0. - jy=1 - do ix=0,nxmin1 - wdummy=wdummy+wweta(ix,jy,iz,n) - end do - wdummy=wdummy/real(nx) - jy=0 - do ix=0,nxmin1 - wweta(ix,jy,iz,n)=wdummy - end do - end do - endif - endif -end subroutine verttransf_ec_stereo - -subroutine verttransf_ec_cloud(n,lreadclouds,lsumclouds,nxlim,nylim,clouds_tmp,cloudsh_tmp,& - clw_tmp,ctwc_tmp,clwc_tmp,ciwc_tmp,lsprec_tmp,convprec_tmp,rho_tmp,tt_tmp,qv_tmp,uvzlev) - use par_mod - use com_mod - use cmapf_mod, only: cc2gll - use qvsat_mod - - implicit none - - logical,intent(in) :: lreadclouds,lsumclouds - integer, intent(in) :: nxlim,nylim - integer, intent(in) :: n - integer(kind=1),intent(inout) :: clouds_tmp(0:nxlim,0:nylim,nzmax) - integer,intent(inout) :: cloudsh_tmp(0:nxlim,0:nylim) - real,intent(inout) :: clw_tmp(0:nxlim,0:nylim,nzmax) - real,intent(inout) :: ctwc_tmp(0:nxlim,0:nylim) - real,intent(inout) :: clwc_tmp(0:nxlim,0:nylim,nzmax) - real,intent(in) :: ciwc_tmp(0:nxlim,0:nylim,nzmax) - real,intent(in) :: lsprec_tmp(0:nxlim,0:nylim),convprec_tmp(0:nxlim,0:nylim) - real,intent(in),dimension(0:nxlim,0:nylim,nzmax) :: rho_tmp,tt_tmp,qv_tmp - real,intent(out),dimension(0:nxlim,0:nylim,nzmax) :: uvzlev - - integer,dimension(0:nxmax-1,0:nymax-1) :: rain_cloud_above - - integer :: ix,jy,kz,kz_inv - real :: pressure,rh,lsp,convp,cloudh_min,prec - -!******************************************************************************* - if (lreadclouds) then !HG METHOD: -! loops all grids vertically and constructs the 3D matrix for clouds -! Cloud top and cloud bottom gid cells are assigned as well as the total column -! cloud water. For precipitating grids, the type and whether it is in or below -! cloud scavenging are assigned with numbers 2-5 (following the old metod). -! Distinction is done for lsp and convp though they are treated the same in -! regards to scavenging. Also clouds that are not precipitating are defined -! which may be to include future cloud processing by non-precipitating-clouds. -!******************************************************************************* - !write(*,*) 'Global ECMWF fields: using cloud water' - clw_tmp(0:nxlim,0:nylim,:)=0.0 - ! icloud_stats(:,:,:,n)=0.0 - ctwc_tmp(:,:)=0.0 - clouds_tmp(0:nxlim,0:nylim,:)=0 - ! If water/ice are read separately into clwc and ciwc, store sum in clwc - if (.not.lsumclouds) then - clwc_tmp(0:nxlim,0:nylim,:) = clwc_tmp(0:nxlim,0:nylim,:) + ciwc_tmp(:,:,:) - end if - do jy=0,nylim - do ix=0,nxlim - lsp=lsprec_tmp(ix,jy) - convp=convprec_tmp(ix,jy) - prec=lsp+convp - ! tot_cloud_h=0 - ! Find clouds in the vertical - do kz=1, nz-1 !go from top to bottom - if (clwc_tmp(ix,jy,kz).gt.0) then - ! assuming rho is in kg/m3 and hz in m gives: kg/kg * kg/m3 *m3/kg /m = m2/m3 - if (wind_coord_type.eq.'ETA') then - clw_tmp(ix,jy,kz)=(clwc_tmp(ix,jy,kz)*rho_tmp(ix,jy,kz))* & - (uvzlev(ix,jy,kz+1)-uvzlev(ix,jy,kz)) - cloudh_min=min(uvzlev(ix,jy,kz+1),uvzlev(ix,jy,kz)) - else - clw_tmp(ix,jy,kz)= (clwc_tmp(ix,jy,kz)*rho_tmp(ix,jy,kz))* & - (height(kz+1)-height(kz)) - ! icloud_stats(ix,jy,3,n)= min(height(kz+1),height(kz)) - ! Cloud BOT height stats [m] - cloudh_min=min(height(kz+1),height(kz)) - endif - ! tot_cloud_h=tot_cloud_h+(height(kz+1)-height(kz)) - - ! icloud_stats(ix,jy,4,n)= icloud_stats(ix,jy,4,n)+clw(ix,jy,kz,n) - ! Column cloud water [m3/m3] - ctwc_tmp(ix,jy) = ctwc_tmp(ix,jy)+clw_tmp(ix,jy,kz) - - endif - end do - - ! If Precipitation. Define removal type in the vertical - if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation - - do kz=nz,2,-1 !go Bottom up! - if (clw_tmp(ix,jy,kz).gt. 0) then ! is in cloud - if (wind_coord_type.eq.'ETA') then - cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+ & - uvzlev(ix,jy,kz)-uvzlev(ix,jy,kz-1) - else - cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+height(kz)-height(kz-1) - endif - clouds_tmp(ix,jy,kz)=1 ! is a cloud - if (lsp.ge.convp) then - clouds_tmp(ix,jy,kz)=3 ! lsp in-cloud - else - clouds_tmp(ix,jy,kz)=2 ! convp in-cloud - endif ! convective or large scale - elseif (clw_tmp(ix,jy,kz).le.0 .and. cloudh_min.ge.height(kz)) then - ! is below cloud - if (lsp.ge.convp) then - clouds_tmp(ix,jy,kz)=5 ! lsp dominated washout - else - clouds_tmp(ix,jy,kz)=4 ! convp dominated washout - endif ! convective or large scale - endif - - if (height(kz).ge. 19000) then ! set a max height for removal - clouds_tmp(ix,jy,kz)=0 - endif !clw>0 - end do !nz - endif ! precipitation - end do - end do - - ! eso: copy the relevant data to clw4 to reduce amount of communicated data for MPI - ! ctwc(:,:,n) = icloud_stats(:,:,4,n) - - !************************************************************************** - else ! use old definitions - !************************************************************************** - ! create a cloud and rainout/washout field, clouds occur where rh>80% - ! total cloudheight is stored at level 0 - !write(*,*) 'Global fields: using cloud water from Parameterization' - do jy=0,nylim - do ix=0,nxlim - ! OLD METHOD - rain_cloud_above(ix,jy)=0 - lsp=lsprec_tmp(ix,jy) - convp=convprec_tmp(ix,jy) - cloudsh_tmp(ix,jy)=0 - do kz_inv=1,nz-1 - kz=nz-kz_inv+1 - pressure=rho_tmp(ix,jy,kz)*r_air*tt_tmp(ix,jy,kz) - rh=qv_tmp(ix,jy,kz)/f_qvsat(pressure,tt_tmp(ix,jy,kz)) - clouds_tmp(ix,jy,kz)=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(ix,jy)=1 - if (wind_coord_type.eq.'ETA') then - cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+ & - uvzlev(ix,jy,kz)-uvzlev(ix,jy,kz-1) - else - cloudsh_tmp(ix,jy)=cloudsh_tmp(ix,jy)+ & - height(kz)-height(kz-1) - endif - if (lsp.ge.convp) then - clouds_tmp(ix,jy,kz)=3 ! lsp dominated rainout - else - clouds_tmp(ix,jy,kz)=2 ! convp dominated rainout - endif - else ! no precipitation - clouds_tmp(ix,jy,kz)=1 ! cloud - endif - else ! no cloud - if (rain_cloud_above(ix,jy).eq.1) then ! scavenging - if (lsp.ge.convp) then - clouds_tmp(ix,jy,kz)=5 ! lsp dominated washout - else - clouds_tmp(ix,jy,kz)=4 ! convp dominated washout - endif - endif - endif - end do - !END OLD METHOD - end do - end do - endif !readclouds - -end subroutine verttransf_ec_cloud - -subroutine verttransform_gfs(n,uuh,vvh,wwh,pvh) - ! 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. * - ! * - ! Author: A. Stohl, G. Wotawa * - ! * - ! 12 August 1996 * - ! Update: 16 January 1998 * - ! * - ! Major update: 17 February 1999 * - ! by G. Wotawa * - ! CHANGE 17/11/2005 Caroline Forster, NCEP GFS version * - ! * - ! - 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 - ! - ! Unified ECMWF and GFS builds - ! Marian Harustak, 12.5.2017 - ! - Renamed routine from verttransform to verttransform_gfs - ! - !***************************************************************************** - ! * - ! 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] * - ! clouds(0:nxmax,0:nymax,0:nzmax,2) cloud field for wet deposition * - ! * - !***************************************************************************** - - use par_mod - use com_mod - use cmapf_mod - use qvsat_mod - - implicit none - - integer :: ix,jy,kz,iz,n,kmin,kl,klp,ix1,jy1,ixp,jyp,ixm,jym - integer :: rain_cloud_above,kz_inv - real :: pressure - real :: rh,lsp,cloudh_min,convp,prec - real :: rhoh(nuvzmax),pinmconv(nzmax) - real :: pint,tv,tvold,pold,dz1,dz2,dz,ui,vi - real :: xlon,ylat,xlonr,dzdx,dzdy - real :: dzdx1,dzdx2,dzdy1,dzdy2,cosf - real :: uuaux,vvaux,uupolaux,vvpolaux,ddpol,ffpol,wdummy - 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 :: wzlev(nwzmax),uvwzlev(0:nxmax-1,0:nymax-1,nzmax) - real,parameter :: const=r_air/ga - - ! NCEP version - integer :: llev, i - - logical :: init = .true. - - - !************************************************************************* - ! 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. * - !************************************************************************* - - 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 - !***************************************************************************** - call vertransf_init(n) - - ! Do not repeat initialization of the Cartesian z grid - !***************************************************** - - init=.false. - - endif - - - ! Loop over the whole grid - !************************* - - do jy=0,nymin1 - do ix=0,nxmin1 - - ! NCEP version: find first level above ground - llev = 0 - do i=1,nuvz - if (ps(ix,jy,1,n).lt.akz(i)) llev=i - end do - llev = llev+1 - if (llev.gt.nuvz-2) llev = nuvz-2 - ! if (llev.eq.nuvz-2) write(*,*) 'verttransform - ! +WARNING: LLEV eq NUZV-2' - ! NCEP version - - - ! compute height of pressure levels above ground - !*********************************************** - - tvold=tth(ix,jy,llev,n)*(1.+0.608*qvh(ix,jy,llev,n)) - pold=akz(llev) - wzlev(llev)=0. - uvwzlev(ix,jy,llev)=0. - rhoh(llev)=pold/(r_air*tvold) - - do kz=llev+1,nuvz - pint=akz(kz)+bkz(kz)*ps(ix,jy,1,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 - uvwzlev(ix,jy,kz)=uvwzlev(ix,jy,kz-1)+const*log(pold/pint)* & - (tv-tvold)/log(tv/tvold) - else - uvwzlev(ix,jy,kz)=uvwzlev(ix,jy,kz-1)+const*log(pold/pint)*tv - endif - wzlev(kz)=uvwzlev(ix,jy,kz) - - tvold=tv - pold=pint - end do - - ! pinmconv=(h2-h1)/(p2-p1) - - pinmconv(llev)=(uvwzlev(ix,jy,llev+1)-uvwzlev(ix,jy,llev))/ & - ((aknew(llev+1)+bknew(llev+1)*ps(ix,jy,1,n))- & - (aknew(llev)+bknew(llev)*ps(ix,jy,1,n))) - do kz=llev+1,nz-1 - pinmconv(kz)=(uvwzlev(ix,jy,kz+1)-uvwzlev(ix,jy,kz-1))/ & - ((aknew(kz+1)+bknew(kz+1)*ps(ix,jy,1,n))- & - (aknew(kz-1)+bknew(kz-1)*ps(ix,jy,1,n))) - end do - pinmconv(nz)=(uvwzlev(ix,jy,nz)-uvwzlev(ix,jy,nz-1))/ & - ((aknew(nz)+bknew(nz)*ps(ix,jy,1,n))- & - (aknew(nz-1)+bknew(nz-1)*ps(ix,jy,1,n))) - - - ! Levels, where u,v,t and q are given - !************************************ - - uu(ix,jy,1,n)=uuh(ix,jy,llev) - vv(ix,jy,1,n)=vvh(ix,jy,llev) - tt(ix,jy,1,n)=tth(ix,jy,llev,n) - qv(ix,jy,1,n)=qvh(ix,jy,llev,n) - ! IP & SEC, 201812 add clouds - if (readclouds) then - clwc(ix,jy,1,n)=clwch(ix,jy,llev,n) - endif - pv(ix,jy,1,n)=pvh(ix,jy,llev) - rho(ix,jy,1,n)=rhoh(llev) - pplev(ix,jy,1,n)=akz(llev) - 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) - ! IP & SEC, 201812 add clouds - if (readclouds) then - clwc(ix,jy,nz,n)=clwch(ix,jy,nuvz,n) - endif - pv(ix,jy,nz,n)=pvh(ix,jy,nuvz) - rho(ix,jy,nz,n)=rhoh(nuvz) - pplev(ix,jy,nz,n)=akz(nuvz) - kmin=llev+1 - do iz=2,nz-1 - do kz=kmin,nuvz - if(height(iz).gt.uvwzlev(ix,jy,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) - ! IP & SEC, 201812 add clouds - if (readclouds) then - clwc(ix,jy,iz,n)=clwc(ix,jy,nz,n) - endif - pv(ix,jy,iz,n)=pv(ix,jy,nz,n) - rho(ix,jy,iz,n)=rho(ix,jy,nz,n) - pplev(ix,jy,iz,n)=pplev(ix,jy,nz,n) - exit - endif - if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. & - (height(iz).le.uvwzlev(ix,jy,kz))) then - dz1=height(iz)-uvwzlev(ix,jy,kz-1) - dz2=uvwzlev(ix,jy,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 - ! IP & SEC, 201812 add clouds - if (readclouds) then - clwc(ix,jy,iz,n)=(clwch(ix,jy,kz-1,n)*dz2 & - +clwch(ix,jy,kz,n)*dz1)/dz - endif - 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 - pplev(ix,jy,iz,n)=(akz(kz-1)*dz2+akz(kz)*dz1)/dz - endif - end do - end do - - - ! Levels, where w is given - !************************* - - ww(ix,jy,1,n)=wwh(ix,jy,llev)*pinmconv(llev) - ww(ix,jy,nz,n)=wwh(ix,jy,nwz)*pinmconv(nz) - kmin=llev+1 - 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)*pinmconv(kz-1)*dz2 & - +wwh(ix,jy,kz)*pinmconv(kz)*dz1)/dz - endif - end do - end do - - - ! 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 - - - !**************************************************************** - ! Compute slope of eta levels in windward direction and resulting - ! vertical wind correction - !**************************************************************** - - do jy=1,ny-2 - cosf=cos((real(jy)*dy+ylat0)*pi180) - do ix=1,nx-2 - - ! NCEP version: find first level above ground - llev = 0 - do i=1,nuvz - if (ps(ix,jy,1,n).lt.akz(i)) llev=i - end do - llev = llev+1 - if (llev.gt.nuvz-2) llev = nuvz-2 - ! if (llev.eq.nuvz-2) write(*,*) 'verttransform - ! +WARNING: LLEV eq NUZV-2' - ! NCEP version - - kmin=llev+1 - do iz=2,nz-1 - - ui=uu(ix,jy,iz,n)*dxconst/cosf - vi=vv(ix,jy,iz,n)*dyconst - - do kz=kmin,nz - if ((height(iz).gt.uvwzlev(ix,jy,kz-1)).and. & - (height(iz).le.uvwzlev(ix,jy,kz))) then - dz1=height(iz)-uvwzlev(ix,jy,kz-1) - dz2=uvwzlev(ix,jy,kz)-height(iz) - dz=dz1+dz2 - kl=kz-1 - klp=kz - exit - endif - end do - - ix1=ix-1 - jy1=jy-1 - ixp=ix+1 - jyp=jy+1 - - dzdx1=(uvwzlev(ixp,jy,kl)-uvwzlev(ix1,jy,kl))/2. - dzdx2=(uvwzlev(ixp,jy,klp)-uvwzlev(ix1,jy,klp))/2. - dzdx=(dzdx1*dz2+dzdx2*dz1)/dz - - dzdy1=(uvwzlev(ix,jyp,kl)-uvwzlev(ix,jy1,kl))/2. - dzdy2=(uvwzlev(ix,jyp,klp)-uvwzlev(ix,jy1,klp))/2. - dzdy=(dzdy1*dz2+dzdy2*dz1)/dz - - ww(ix,jy,iz,n)=ww(ix,jy,iz,n)+(dzdx*ui+dzdy*vi) - - end do - - end do - end do - - - ! If north pole is in the domain, calculate wind velocities in polar - ! stereographic coordinates - !******************************************************************* - - if (nglobal) then - do jy=int(switchnorthg)-2,nymin1 - ylat=ylat0+real(jy)*dy - do ix=0,nxmin1 - xlon=xlon0+real(ix)*dx - do iz=1,nz - 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)) - end do - end do - end do - - - do 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 - elseif (vv(nx/2-1,nymin1,iz,n).gt.0.) then - ddpol=pi+atan(uu(nx/2-1,nymin1,iz,n)/ & - vv(nx/2-1,nymin1,iz,n))-xlonr - else - ddpol=pi/2-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 ix=0,nxmin1 - uupol(ix,jy,iz,n)=uupolaux - vvpol(ix,jy,iz,n)=vvpolaux - end do - end do - - - ! Fix: Set W at pole to the zonally averaged W of the next equator- - ! ward parallel of latitude - - do iz=1,nz - wdummy=0. - jy=ny-2 - do ix=0,nxmin1 - wdummy=wdummy+ww(ix,jy,iz,n) - end do - wdummy=wdummy/real(nx) - jy=nymin1 - do ix=0,nxmin1 - ww(ix,jy,iz,n)=wdummy - end do - end do - - endif - - - ! If south pole is in the domain, calculate wind velocities in polar - ! stereographic coordinates - !******************************************************************* - - if (sglobal) then - do jy=0,int(switchsouthg)+3 - ylat=ylat0+real(jy)*dy - do ix=0,nxmin1 - xlon=xlon0+real(ix)*dx - do iz=1,nz - 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)) - end do - end do - end do - - do 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 - elseif (vv(nx/2-1,0,iz,n).gt.0.) then - ddpol=pi+atan(uu(nx/2-1,0,iz,n)/vv(nx/2-1,0,iz,n))-xlonr - else - ddpol=pi/2-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 ix=0,nxmin1 - uupol(ix,jy,iz,n)=uupolaux - vvpol(ix,jy,iz,n)=vvpolaux - end do - end do - - - ! Fix: Set W at pole to the zonally averaged W of the next equator- - ! ward parallel of latitude - - do iz=1,nz - wdummy=0. - jy=1 - do ix=0,nxmin1 - wdummy=wdummy+ww(ix,jy,iz,n) - end do - wdummy=wdummy/real(nx) - jy=0 - do ix=0,nxmin1 - ww(ix,jy,iz,n)=wdummy - end do - end do - endif - - !***************************************************************************** - ! IP & SEC, 201812 GFS clouds read - if (readclouds) then -! loops all grids vertically and constructs the 3D matrix for clouds -! Cloud top and cloud bottom gid cells are assigned as well as the total column -! cloud water. For precipitating grids, the type and whether it is in or below -! cloud scavenging are assigned with numbers 2-5 (following the old metod). -! Distinction is done for lsp and convp though they are treated the same in -! regards to scavenging. Also clouds that are not precipitating are defined -! which may be to include future cloud processing by non-precipitating-clouds. -!***************************************************************************** - write(*,*) 'Global NCEP fields: using cloud water' - clw(:,:,:,n)=0.0 - ctwc(:,:,n)=0.0 - clouds(:,:,:,n)=0 - ! If water/ice are read separately into clwc and ciwc, store sum in clwc - do jy=0,nymin1 - do ix=0,nxmin1 - lsp=lsprec(ix,jy,1,n) - convp=convprec(ix,jy,1,n) - prec=lsp+convp - ! Find clouds in the vertical - do kz=1, nz-1 !go from top to bottom - if (clwc(ix,jy,kz,n).gt.0) then - ! assuming rho is in kg/m3 and hz in m gives: kg/kg * kg/m3 *m3/kg /m = m2/m3 - clw(ix,jy,kz,n)=(clwc(ix,jy,kz,n)*rho(ix,jy,kz,n))* & - (height(kz+1)-height(kz)) - ctwc(ix,jy,n) = ctwc(ix,jy,n)+clw(ix,jy,kz,n) - cloudh_min=min(height(kz+1),height(kz)) - endif - end do - - ! If Precipitation. Define removal type in the vertical - if ((lsp.gt.0.01).or.(convp.gt.0.01)) then ! cloud and precipitation - - do kz=nz,2,-1 !go Bottom up! - if (clw(ix,jy,kz,n).gt. 0) then ! is in cloud - cloudsh(ix,jy,n)=cloudsh(ix,jy,n)+height(kz)-height(kz-1) - clouds(ix,jy,kz,n)=1 ! is a cloud - if (lsp.ge.convp) then - clouds(ix,jy,kz,n)=3 ! lsp in-cloud - else - clouds(ix,jy,kz,n)=2 ! convp in-cloud - endif ! convective or large scale - elseif((clw(ix,jy,kz,n).le.0) .and. (cloudh_min.ge.height(kz))) then - ! is below cloud - 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 ! convective or large scale - endif - - if (height(kz).ge. 19000) then ! set a max height for removal - clouds(ix,jy,kz,n)=0 - endif !clw>0 - end do !nz - endif ! precipitation - end do - end do - else - write(*,*) 'Global NCEP fields: using cloud water from Parameterization' - ! write (*,*) 'initializing clouds, n:',n,nymin1,nxmin1,nz - ! create a cloud and rainout/washout field, clouds occur where rh>80% - ! total cloudheight is stored at level 0 - do jy=0,nymin1 - do ix=0,nxmin1 - rain_cloud_above=0 - lsp=lsprec(ix,jy,1,n) - convp=convprec(ix,jy,1,n) - cloudsh(ix,jy,n)=0 - 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 - endif ! IP & SEC 201812, GFS clouds read - -end subroutine verttransform_gfs - -subroutine verttransf_ec_height(nxlim,nylim, & - - tt2_tmp,td2_tmp,ps_tmp,qvh_tmp,tth_tmp,prsh_tmp, & - rhoh_tmp,pinmconv,uvzlev,wzlev) - use par_mod - use com_mod - use qvsat_mod - - implicit none - - integer, intent(in) :: nxlim,nylim - real,intent(in),dimension(0:nxlim,0:nylim) :: tt2_tmp,td2_tmp,ps_tmp - real,intent(in),dimension(0:nxlim,0:nylim,nuvzmax) :: qvh_tmp,tth_tmp - real,intent(out),dimension(0:nxlim,0:nylim,nuvzmax) :: rhoh_tmp,prsh_tmp - real,intent(out),dimension(0:nxlim,0:nylim,nzmax) :: pinmconv - real,intent(out),dimension(0:nxlim,0:nylim,nuvzmax) :: uvzlev,wzlev - real,dimension(0:nxlim,0:nylim) :: tvold,pold,pint,tv - real,parameter :: const=r_air/ga - integer :: ix,jy,kz - integer :: nxm1,nym1 - - ! Loop over the whole grid - !************************* - - do jy=0,nylim - do ix=0,nxlim - tvold(ix,jy)=tt2_tmp(ix,jy)*(1.+0.378*ew(td2_tmp(ix,jy),ps_tmp(ix,jy))/ & - ps_tmp(ix,jy)) - end do - end do - - pold(:,:)=ps_tmp(:,:) - uvzlev(:,:,1)=0. - wzlev(:,:,1)=0. - rhoh_tmp(:,:,1)=pold(:,:)/(r_air*tvold(:,:)) - prsh_tmp(:,:,1)=ps_tmp(:,:) - - ! Compute heights of eta levels - !****************************** - - do kz=2,nuvz - pint(:,:)=akz(kz)+bkz(kz)*ps_tmp(:,:) - prsh_tmp(:,:,kz)=pint(:,:) - tv(:,:)=tth_tmp(:,:,kz)*(1.+0.608*qvh_tmp(:,:,kz)) - rhoh_tmp(:,:,kz)=pint(:,:)/(r_air*tv(:,:)) - - where (abs(tv(:,:)-tvold(:,:)).gt.0.2) - uvzlev(:,:,kz)=uvzlev(:,:,kz-1)+const*& - &log(pold(:,:)/pint(:,:))* & - (tv(:,:)-tvold(:,:))/& - &log(tv(:,:)/tvold(:,:)) - elsewhere - uvzlev(:,:,kz)=uvzlev(:,:,kz-1)+const*& - &log(pold(:,:)/pint(:,:))*tv(:,:) - endwhere - - 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) - - - pinmconv(:,:,1)=(uvzlev(:,:,2))/ & - ((aknew(2)+bknew(2)*ps_tmp(:,:))- & - (aknew(1)+bknew(1)*ps_tmp(:,:))) - do kz=2,nz-1 - pinmconv(:,:,kz)=(uvzlev(:,:,kz+1)-uvzlev(:,:,kz-1))/ & - ((aknew(kz+1)+bknew(kz+1)*ps_tmp(:,:))- & - (aknew(kz-1)+bknew(kz-1)*ps_tmp(:,:))) - end do - pinmconv(:,:,nz)=(uvzlev(:,:,nz)-uvzlev(:,:,nz-1))/ & - ((aknew(nz)+bknew(nz)*ps_tmp(:,:))- & - (aknew(nz-1)+bknew(nz-1)*ps_tmp(:,:))) - -end subroutine verttransf_ec_height - -subroutine verttransf_ec_windf_nest(l,n, & - - uuhn,vvhn,wwhn,pvhn,rhohn,prshn,pinmconv) - use par_mod - use com_mod - use qvsat_mod - - implicit none - - integer,intent(in) :: l,n - real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax,maxnests) :: & - uuhn,vvhn,pvhn - real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nwzmax,maxnests) :: wwhn - real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax) :: rhohn - real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nuvzmax) :: prshn - real,intent(in),dimension(0:nxmaxn-1,0:nymaxn-1,nzmax) :: pinmconv - real,dimension(0:nymaxn-1) :: cosf - - integer,dimension(0:nxmaxn-1,0:nymaxn-1) :: rain_cloud_above, idx - - integer :: ix,jy,kz,iz,kmin,kl,klp,ix1,jy1,ixp,jyp,kz_inv - real :: pressure,rh,lsp,convp,cloudh_min,prec - - real :: dz1,dz2,dz,dpdeta - real :: dzdx,dzdy - real :: dzdx1,dzdx2,dzdy1,dzdy2 - real :: tot_cloud_h - integer :: nxm1, nym1 - - nxm1=nxn(l)-1 - nym1=nyn(l)-1 - - ! Levels, where u,v,t and q are given - !************************************ -!$OMP PARALLEL PRIVATE(jy,ix,kz,dz1,dz2,dz,ix1,jy1,ixp,jyp,dzdx1,dzdx2,dzdx, & -!$OMP dzdy1,dzdy2,dzdy,dpdeta) - -!$OMP DO - do jy=0,nym1 - do ix=0,nxm1 - uun(ix,jy,1,n,l)=uuhn(ix,jy,1,l) - vvn(ix,jy,1,n,l)=vvhn(ix,jy,1,l) - ttn(ix,jy,1,n,l)=tthn(ix,jy,1,n,l) - if (wind_coord_type.ne.'ETA') then - qvn(ix,jy,1,n,l)=qvhn(ix,jy,1,n,l) - endif - if (readclouds_nest(l)) then - clwcn(ix,jy,1,n,l)=clwchn(ix,jy,1,n,l) - if (.not.sumclouds_nest(l)) ciwcn(ix,jy,1,n,l)=ciwchn(ix,jy,1,n,l) - end if - pvn(ix,jy,1,n,l)=pvhn(ix,jy,1,l) - rhon(ix,jy,1,n,l)=rhohn(ix,jy,1) - prsn(ix,jy,1,n,l)=prshn(ix,jy,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) - if (wind_coord_type.ne.'ETA') then - qvn(ix,jy,nz,n,l)=qvhn(ix,jy,nuvz,n,l) - if (readclouds_nest(l)) then - clwcn(ix,jy,nz,n,l)=clwchn(ix,jy,nuvz,n,l) - if (.not.sumclouds_nest(l)) ciwcn(ix,jy,nz,n,l)=ciwchn(ix,jy,nuvz,n,l) - endif - endif - pvn(ix,jy,nz,n,l)=pvhn(ix,jy,nuvz,l) - rhon(ix,jy,nz,n,l)=rhohn(ix,jy,nuvz) - prsn(ix,jy,nz,n,l)=prshn(ix,jy,nuvz) - - idx(ix,jy)=2 - end do - end do -!$OMP END DO - - do iz=2,nz-1 -!$OMP DO SCHEDULE(dynamic) - do jy=0,nym1 - do ix=0,nxm1 - if(height(iz).gt.etauvheightn(ix,jy,nuvz,n,l)) 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) - pvn(ix,jy,iz,n,l)=pvn(ix,jy,nz,n,l) - if (wind_coord_type.ne.'ETA') then - qvn(ix,jy,iz,n,l)=qvn(ix,jy,nz,n,l) - !hg adding the cloud water - if (readclouds_nest(l)) then - clwcn(ix,jy,iz,n,l)=clwcn(ix,jy,nz,n,l) - if (.not.sumclouds_nest(l)) & - ciwcn(ix,jy,iz,n,l)=ciwcn(ix,jy,nz,n,l) - endif - endif - rhon(ix,jy,iz,n,l)=rhon(ix,jy,nz,n,l) - prsn(ix,jy,iz,n,l)=prsn(ix,jy,nz,n,l) - else - innuvz: do kz=idx(ix,jy),nuvz - if (idx(ix,jy) .le. kz .and. & - height(iz).gt.etauvheightn(ix,jy,kz-1,n,l) .and. & - height(iz).le.etauvheightn(ix,jy,kz,n,l) ) then - idx(ix,jy)=kz - exit innuvz - endif - enddo innuvz - endif - - if(height(iz).le.etauvheightn(ix,jy,nuvz,n,l)) then - kz=idx(ix,jy) - dz1=height(iz)-etauvheightn(ix,jy,kz-1,n,l) - dz2=etauvheightn(ix,jy,kz,n,l)-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 - pvn(ix,jy,iz,n,l)=(pvhn(ix,jy,kz-1,l)*dz2+pvhn(ix,jy,kz,l)*dz1)/dz - if (wind_coord_type.ne.'ETA') then - qvn(ix,jy,iz,n,l)=(qvhn(ix,jy,kz-1,n,l)*dz2 & - +qvhn(ix,jy,kz,n,l)*dz1)/dz - !hg adding the cloud water - if (readclouds_nest(l)) then - clwcn(ix,jy,iz,n,l)=(clwchn(ix,jy,kz-1,n,l)*dz2 + & - clwchn(ix,jy,kz,n,l)*dz1)/dz - if (.not.sumclouds_nest(l)) ciwcn(ix,jy,iz,n,l)= & - (ciwchn(ix,jy,kz-1,n,l)*dz2+ciwchn(ix,jy,kz,n,l)*dz1)/dz - end if - endif - rhon(ix,jy,iz,n,l)=(rhohn(ix,jy,kz-1)*dz2+rhohn(ix,jy,kz)*dz1)/dz - prsn(ix,jy,iz,n,l)=(prshn(ix,jy,kz-1)*dz2+prshn(ix,jy,kz)*dz1)/dz - endif - enddo - enddo -!$OMP END DO -!$OMP BARRIER - enddo - - ! Levels, where w is given - !************************* - -!$OMP DO - do jy=0,nym1 - do ix=0,nxm1 - idx(ix,jy)=2 - wwn(ix,jy,1,n,l)=wwhn(ix,jy,1,l)*pinmconv(ix,jy,1) - wwn(ix,jy,nz,n,l)=wwhn(ix,jy,nwz,l)*pinmconv(ix,jy,nz) - end do - end do -!$OMP END DO - - do iz=2,nz-1 -!$OMP DO SCHEDULE(dynamic) - do jy=0,nym1 - do ix=0,nxm1 - - inn: do kz=idx(ix,jy),nwz - if (idx(ix,jy).le.kz .and. height(iz).gt.etawheightn(ix,jy,kz-1,n,l) & - .and. height(iz).le.etawheightn(ix,jy,kz, n,l))& - then - idx(ix,jy)=kz - exit inn - endif - enddo inn - - kz=idx(ix,jy) - dz1=height(iz)-etawheightn(ix,jy,kz-1,n,l) - dz2=etawheightn(ix,jy,kz,n,l)-height(iz) - dz=dz1+dz2 - wwn(ix,jy,iz,n,l)=(wwhn(ix,jy,kz-1,l)*pinmconv(ix,jy,kz-1)*dz2 & - +wwhn(ix,jy,kz,l)*pinmconv(ix,jy,kz)*dz1)/dz - drhodzn(ix,jy,iz,n,l)=(rhon(ix,jy,iz+1,n,l)-rhon(ix,jy,iz-1,n,l))/ & - (height(iz+1)-height(iz-1)) - enddo - enddo -!$OMP END DO -!$OMP BARRIER - end do - - ! Compute density gradients at intermediate levels - !************************************************* -!$OMP DO - do jy=0,nym1 - do ix=0,nxm1 - drhodzn(ix,jy,nz,n,l)=drhodzn(ix,jy,nz-1,n,l) - drhodzn(ix,jy,1,n,l)=(rhon(ix,jy,2,n,l)-rhon(ix,jy,1,n,l))/ & - (height(2)-height(1)) - end do - end do -!$OMP END DO NOWAIT - - !**************************************************************** - ! Compute slope of eta levels in windward direction and resulting - ! vertical wind correction - !**************************************************************** - -!$OMP DO - do jy=1,nyn(l)-2 - cosf(jy)=1./cos((real(jy)*dyn(l)+ylat0n(l))*pi180) - do ix=1,nxn(l)-2 - idx(ix,jy)=2 - end do - end do -!$OMP END DO - - do iz=2,nz-1 -!$OMP DO SCHEDULE(dynamic) - do jy=1,nyn(l)-2 - do ix=1,nxn(l)-2 - - inneta: do kz=idx(ix,jy),nz - if (idx(ix,jy) .le. kz .and. & - height(iz).gt.etauvheightn(ix,jy,kz-1,n,l) .and. & - height(iz).le.etauvheightn(ix,jy,kz, n,l)) then - idx(ix,jy)=kz - exit inneta - endif - enddo inneta - - kz=idx(ix,jy) - dz1=height(iz)-etauvheightn(ix,jy,kz-1,n,l) - dz2=etauvheightn(ix,jy,kz,n,l)-height(iz) - dz=dz1+dz2 - ix1=ix-1 - jy1=jy-1 - ixp=ix+1 - jyp=jy+1 +#include "ver_verttransform_ecmwf.f90" - dzdx1=(etauvheightn(ixp,jy,kz-1,n,l)-etauvheightn(ix1,jy,kz-1,n,l))/2. - dzdx2=(etauvheightn(ixp,jy,kz,n,l)-etauvheightn(ix1,jy,kz,n,l))/2. - dzdx=(dzdx1*dz2+dzdx2*dz1)/dz +#include "ver_verttransform_nest.f90" - dzdy1=(etauvheightn(ix,jyp,kz-1,n,l)-etauvheightn(ix,jy1,kz-1,n,l))/2. - dzdy2=(etauvheightn(ix,jyp,kz,n,l)-etauvheightn(ix,jy1,kz,n,l))/2. - dzdy=(dzdy1*dz2+dzdy2*dz1)/dz +#include "ver_vertransf_init.f90" - wwn(ix,jy,iz,n,l)=wwn(ix,jy,iz,n,l) + & - (dzdx*uun(ix,jy,iz,n,l)*dxconst*xresoln(l)*cosf(jy) + & - dzdy*vvn(ix,jy,iz,n,l)*dyconst*yresoln(l)) +#include "ver_verttransf_ec_windf.f90" - end do - end do -!$OMP END DO -!$OMP BARRIER - end do +#include "ver_verttransf_ec_stereo.f90" - ! Keep original fields if wind_coord_type==ETA - if (wind_coord_type.eq.'ETA') then -!$OMP DO +#include "ver_verttransf_ec_cloud.f90" - do kz=1,nz - do jy=0,nym1 - do ix=0,nxm1 - uuetan(ix,jy,kz,n,l) = uuhn(ix,jy,kz,l) - vvetan(ix,jy,kz,n,l) = vvhn(ix,jy,kz,l) - ttetan(ix,jy,kz,n,l) = tthn(ix,jy,kz,n,l) - qvn(ix,jy,kz,n,l) = qvhn(ix,jy,kz,n,l) - pvetan(ix,jy,kz,n,l) = pvhn(ix,jy,kz,l) - rhoetan(ix,jy,kz,n,l) = rhohn(ix,jy,kz) - prsetan(ix,jy,kz,n,l) = prshn(ix,jy,kz) - ! tvirtualn(ix,jy,kz,n,l)=ttetan(ix,jy,kz,n,l)* & - ! ((qvn(ix,jy,kz,n,l)+0.622)/(0.622*qvn(ix,jy,kz,n,l)+0.622)) - ! eq A11 from Mid-latitude atmospheric dynamics by Jonathan E. Martin - if ((kz.gt.1).and.(kz.lt.nz)) drhodzetan(ix,jy,kz,n,l)= & - (rhohn(ix,jy,kz+1)-rhohn(ix,jy,kz-1))/(height(kz+1)-height(kz-1)) - if (readclouds) then - clwcn(ix,jy,kz,n,l)=clwchn(ix,jy,kz,n,l) - if (.not.sumclouds_nest(l)) ciwcn(ix,jy,kz,n,l)=ciwchn(ix,jy,kz,n,l) - endif - end do - end do - end do -!$OMP END DO NOWAIT +#include "ver_verttransform_gfs.f90" -!$OMP DO - do jy=0,nym1 - do ix=0,nxm1 - drhodzetan(ix,jy,1,n,l)=(rhoetan(ix,jy,2,n,l)-rhoetan(ix,jy,1,n,l))/ & - (height(2)-height(1)) - drhodzetan(ix,jy,nz,n,l)=drhodzetan(ix,jy,nz-1,n,l) - ! tvirtualn(ix,jy,1,n,l)=tt2n(ix,jy,1,n,l)* & - ! (1.+0.378*ew(td2n(ix,jy,1,n,l),psn(ix,jy,1,n,l))/ps(ix,jy,1,n,l)) - ! Convert w from Pa/s to eta/s, following FLEXTRA - !************************************************ - do kz=1,nuvz-1 - if (kz.eq.1) then - dpdeta=(akm(kz+1)-akm(kz)+(bkm(kz+1)-bkm(kz))*ps(ix,jy,1,n))/ & - (wheight(kz+1)-wheight(kz)) - else if (kz.eq.nuvz-1) then - dpdeta=(akm(kz)-akm(kz-1)+(bkm(kz)-bkm(kz-1))*ps(ix,jy,1,n))/ & - (wheight(kz)-wheight(kz-1)) - else - dpdeta=(akm(kz+1)-akm(kz-1)+(bkm(kz+1)-bkm(kz-1))*ps(ix,jy,1,n))/ & - (wheight(kz+1)-wheight(kz-1)) - endif - wwetan(ix,jy,kz,n,l)=wwhn(ix,jy,kz,l)/dpdeta - end do - wwetan(ix,jy,nuvz,n,l)=wwetan(ix,jy,nuvz-1,n,l) - end do - end do -!$OMP END DO - endif -!$OMP END PARALLEL +#include "ver_verttransf_ec_height.f90" -end subroutine verttransf_ec_windf_nest +#include "ver_verttransf_ec_windf_nest.f90" end module verttransform_mod diff --git a/src/wet_get_wetscav.f90 b/src/wet_get_wetscav.f90 new file mode 100644 index 0000000000000000000000000000000000000000..82967ef00af89af06e0685e0c96805e6baf72378 --- /dev/null +++ b/src/wet_get_wetscav.f90 @@ -0,0 +1,316 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc_count,wetscav) + ! i i i i i o o o o + !***************************************************************************** + ! * + ! 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! * + ! * + !***************************************************************************** + ! * + ! 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 * + ! 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* + ! wetgrid accumulated deposited mass on output grid * + ! wetscav scavenging coefficient * + ! * + ! Constants: * + ! * + !***************************************************************************** + + use interpol_mod + use windfields_mod + use coord_ec_mod + + implicit none + + integer :: jpart,itime,ltsample,loutnext,i,j + integer :: hz,il,interp_time, n + integer(kind=1) :: clouds_v + integer :: ks, kp + integer(selected_int_kind(16)), dimension(nspec) :: blc_count, inc_count + + ! integer :: n1,n2, icbot,ictop, indcloud !TEST + real :: S_i, act_temp, cl, cle ! in cloud scavenging + real :: clouds_h ! cloud height for the specific grid point + real :: lsp,convp,cc,grfraction(3),prec(3),wetscav,totprec + real :: restmass + real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled + !save lfr,cfr + real :: xts,yts + + real, parameter :: lfr(5) = (/ 0.5,0.65,0.8,0.9,0.95/) + real, parameter :: cfr(5) = (/ 0.4,0.55,0.7,0.8,0.9 /) + + !ZHG aerosol below-cloud scavenging removal polynomial constants for rain and snow + real, parameter :: bclr(6) = (/274.35758, 332839.59273, 226656.57259, 58005.91340, 6588.38582, 0.244984/) !rain (Laakso et al 2003) + real, parameter :: bcls(6) = (/22.7, 0.0, 0.0, 1321.0, 381.0, 0.0/) !now (Kyro et al 2009) + real :: frac_act, liq_frac, ice_frac, dquer_m + + real :: Si_dummy, wetscav_dummy + logical :: readclouds_this_nest + + + wetscav=0. + + ! 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) + + n=memind(2) + if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) & + n=memind(1) + + xts=real(part(jpart)%xlon) + yts=real(part(jpart)%ylat) + + ! Determine which nesting level to be used + !***************************************** + call find_ngrid(xts,yts) + + ! If point at border of grid -> small displacement into grid + !*********************************************************** + if (ngrid.le.0) then + if (xts.ge.real(nx-1)) xts=real(nx-1)-0.00001 + if (yts.ge.real(ny-1)) yts=real(ny-1)-0.00001 + else + if (xts.ge.real(nx-1)) xts=real(nx-1)-0.00001 + if (yts.ge.real(ny-1)) yts=real(ny-1)-0.00001 + endif + + call find_grid_indices(xts,yts) + call find_grid_distances(xts,yts) + + if (ngrid.le.0) then + ! No temporal interpolation to stay consistent with clouds + call hor_interpol(lsprec,lsp,1,n,1) ! large scale total precipitation + call hor_interpol(convprec,convp,1,n,1) ! convective precipitation + call hor_interpol(tcc,cc,1,n,1) ! total cloud cover + else + call hor_interpol_nest(lsprecn,lsp,1,n,1) ! large scale total precipitation + call hor_interpol_nest(convprecn,convp,1,n,1) ! convective precipitation + call hor_interpol_nest(tccn,cc,1,n,1) ! total cloud cover + endif + + ! If total precipitation is less than 0.01 mm/h - no scavenging occurs + if ((lsp.lt.0.01).and.(convp.lt.0.01)) return + + if (wind_coord_type.eq.'ETA') then + call find_z_level_eta_uv(real(part(jpart)%zeta)) + hz=induv + else + call find_z_level_meters(real(part(jpart)%z)) + hz=indz + endif + + if (ngrid.le.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=cloudshn(ix,jy,n,ngrid) + endif + + ! if there is no precipitation or the particle is above the clouds no + ! scavenging is done + + if (clouds_v.le.1) return + + ! 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 + + + !ZHG oct 2014 : Calculated for 1) both 2) lsp 3) convp - 2 and 3 not used removed by SE + ! Tentatively differentiate the grfraction for lsp and convp for treating differently the two forms + ! for now they are treated the same + grfraction(1)=max(0.05,cc*(lsp*lfr(i)+convp*cfr(j))/(lsp+convp)) + + ! 2) Computation of precipitation rate in sub-grid cell + !****************************************************** + prec(1)=(lsp+convp)/grfraction(1) + + ! 3) Computation of scavenging coefficients for all species + ! Computation of wet deposition + !********************************************************** + + if (ngrid.gt.0) then + if (wind_coord_type.eq.'ETA') then + act_temp=ttetan(ix,jy,hz,n,ngrid) + else + act_temp=ttn(ix,jy,hz,n,ngrid) + endif + else + if (wind_coord_type.eq.'ETA') then + act_temp=tteta(ix,jy,hz,n) + else + act_temp=tt(ix,jy,hz,n) + endif + endif + + !*********************** + ! BELOW CLOUD SCAVENGING + !*********************** + if (clouds_v.ge.4) then !below cloud + + ! For gas: if positive below-cloud parameters (A or B), and dquer<=0 + !****************************************************************** + if ((dquer(ks).le.0.).and.(weta_gas(ks).gt.0..or.wetb_gas(ks).gt.0.)) then + blc_count(ks)=blc_count(ks)+1 + wetscav=weta_gas(ks)*prec(1)**wetb_gas(ks) + + ! For aerosols: if positive below-cloud parameters (Crain/Csnow or B), and dquer>0 + !********************************************************************************* + else if ((dquer(ks).gt.0.).and.(crain_aero(ks).gt.0..or.csnow_aero(ks).gt.0.)) then + blc_count(ks)=blc_count(ks)+1 + + !NIK 17.02.2015 + ! For the calculation here particle size needs to be in meter and not um as dquer is + ! changed in readreleases + ! For particles larger than 10 um use the largest size defined in the parameterizations (10um) + dquer_m=min(10.,dquer(ks))/1000000. !conversion from um to m + + ! Rain: + if (act_temp .ge. 273. .and. crain_aero(ks).gt.0.) then + + ! ZHG 2014 : Particle RAIN scavenging coefficient based on Laakso et al 2003, + ! the below-cloud scavenging (rain efficienty) parameter Crain (=crain_aero) from SPECIES file + wetscav=crain_aero(ks)*10**(bclr(1)+(bclr(2)*(log10(dquer_m))**(-4))+ & + & (bclr(3)*(log10(dquer_m))**(-3))+ (bclr(4)*(log10(dquer_m))**(-2))+& + &(bclr(5)*(log10(dquer_m))**(-1))+bclr(6)* (prec(1))**(0.5)) + + ! Snow: + elseif (act_temp .lt. 273. .and. csnow_aero(ks).gt.0.) then + ! ZHG 2014 : Particle SNOW scavenging coefficient based on Kyro et al 2009, + ! the below-cloud scavenging (Snow efficiency) parameter Csnow (=csnow_aero) from SPECIES file + wetscav=csnow_aero(ks)*10**(bcls(1)+(bcls(2)*(log10(dquer_m))**(-4))+& + &(bcls(3)*(log10(dquer_m))**(-3))+ (bcls(4)*(log10(dquer_m))**(-2))+& + &(bcls(5)*(log10(dquer_m))**(-1))+ bcls(6)* (prec(1))**(0.5)) + + endif + + endif ! gas or particle + ! endif ! positive below-cloud scavenging parameters given in Species file + endif !end BELOW + + !******************** + ! IN CLOUD SCAVENGING + !******************** + if (clouds_v.lt.4) then ! In-cloud + ! NIK 13 may 2015: only do incloud if positive in-cloud scavenging parameters are + ! given in species file, or if gas and positive Henry's constant + if ((ccn_aero(ks).gt.0. .or. in_aero(ks).gt.0.).or.(henry(ks).gt.0.and.dquer(ks).le.0)) then + inc_count(ks)=inc_count(ks)+1 + ! if negative coefficients (turned off) set to zero for use in equation + if (ccn_aero(ks).lt.0.) ccn_aero(ks)=0. + if (in_aero(ks).lt.0.) in_aero(ks)=0. + + !ZHG 2015 Cloud liquid & ice water (CLWC+CIWC) from ECMWF + ! nested fields + if (ngrid.gt.0.and.readclouds_this_nest) then + cl=ctwcn(ix,jy,n,ngrid)*(grfraction(1)/cc) + else if (ngrid.eq.0.and.readclouds) then + ! cl=ctwc(ix,jy,n)*(grfraction(1)/cc) + ! A.Plach 2021 cl should not become too small + cl=max(1E6*2E-7*prec(1)**0.36, ctwc(ix,jy,n)*(grfraction(1)/cc)) + else !parameterize cloudwater m2/m3 + !ZHG updated parameterization of cloud water to better reproduce the values coming from ECMWF + ! sec test + ! cl=1E6*1E-7*prec(1)**0.3 !Sec GFS new + cl=1E6*2E-7*prec(1)**0.36 !Sec ECMWF new, is also suitable for GFS + ! cl=2E-7*prec(1)**0.36 !Andreas + ! cl=1.6E-6*prec(1)**0.36 !Henrik + endif + + !ZHG: Calculate the partition between liquid and water phase water. + if (act_temp .le. 253.) then + liq_frac=0 + ice_frac=1 + else if (act_temp .ge. 273.) then + liq_frac=1 + ice_frac=0 + else + ! sec bugfix after FLEXPART paper review, liq_frac was 1-liq_frac + ! IP bugfix v10.4, calculate ice_frac and liq_frac + ice_frac= ((act_temp-273.)/(273.-253.))**2. + !liq_frac = 1-ice_frac !((act_temp-253.)/(273.-253.))**2. + liq_frac=max(0.,1.-ice_frac) + end if + ! ZHG: Calculate the aerosol partition based on cloud phase and Ai and Bi + ! frac_act = liq_frac*ccn_aero(ks) +(1-liq_frac)*in_aero(ks) + ! IP, use ice_frac and liq_frac + frac_act = liq_frac*ccn_aero(ks) + ice_frac*in_aero(ks) + + !ZHG Use the activated fraction and the liqid water to calculate the washout + + ! AEROSOL + !******** + if (dquer(ks).gt.0.) then + S_i= frac_act/cl + ! GAS + !**** + else + cle=(1-cl)/(henry(ks)*(r_air/3500.)*act_temp)+cl + S_i=1/cle + endif ! gas or particle + + ! scavenging coefficient based on Hertel et al 1995 - using the S_i for either gas or aerosol + !SEC wetscav fix, the cloud height is no longer needed, it gives wrong results + wetscav=incloud_ratio*S_i*(prec(1)/3.6E6) + endif ! positive in-cloud scavenging parameters given in Species file + endif !incloud +end subroutine get_wetscav diff --git a/src/wet_wetdepo.f90 b/src/wet_wetdepo.f90 new file mode 100644 index 0000000000000000000000000000000000000000..03d021d75a9ae143f35f39db09b1e155863cbec4 --- /dev/null +++ b/src/wet_wetdepo.f90 @@ -0,0 +1,191 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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! * + ! * + ! 2021 Andreas Plach: - moved backward wet depo. calc. here from timemanager * + ! - bugfix in-cloud scavenging * + !***************************************************************************** + ! * + ! 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 * + ! ltsample [s] interval over which mass is deposited * + ! wetdeposit mass that is wet deposited * + ! wetgrid accumulated deposited mass on output grid * + ! wetscav scavenging coefficient * + ! * + ! Constants: * + ! * + !***************************************************************************** +#ifdef _OPENMP + use omp_lib +#endif + use unc_mod + + implicit none + + integer :: jpart,itime,ltsample,loutnext,ldeltat + integer :: itage,nage,inage,ithread,thread + integer :: ks, kp + integer(selected_int_kind(16)), dimension(nspec) :: blc_count, inc_count + real :: grfraction(3),wetscav + real :: wetdeposit(maxspec),restmass + real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled + + ! 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 + !************************ + blc_count(:)=0 + inc_count(:)=0 + +#ifdef _OPENMP + call omp_set_num_threads(numthreads_grid) +#endif +!$OMP PARALLEL PRIVATE(jpart,itage,nage,inage,ks,kp,thread,wetscav,wetdeposit, & +!$OMP restmass, grfraction) REDUCTION(+:blc_count,inc_count) + +#if (defined _OPENMP) + thread = OMP_GET_THREAD_NUM() ! Starts with 0 +#else + thread = 0 +#endif + +!$OMP DO + do jpart=1,numpart + + ! Check if memory has been deallocated + if (.not. particle_allocated(jpart)) cycle + + ! Check if particle is still allive + if (.not. part(jpart)%alive) cycle + + ! Determine age class of the particle - nage is used for the kernel + !****************************************************************** + itage=abs(itime-part(jpart)%tstart) + nage=1 + do inage=1,nageclass + nage=inage + if (itage.lt.lage(nage)) exit + end do + + do ks=1,nspec ! loop over species + + if (WETDEPSPEC(ks).eqv..false.) cycle + + !************************************************** + ! CALCULATE DEPOSITION + !************************************************** + + call get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc_count,wetscav) ! OMP carefully check + + if (WETBKDEP) then + if ((xscav_frac1(jpart,ks).lt.-0.1)) then ! particle marked as starting particle + if (wetscav.gt.0.) then + xscav_frac1(jpart,ks)=wetscav*(zpoint2(part(jpart)%npoint)-& + zpoint1(part(jpart)%npoint))*grfraction(1) + else + part(jpart)%mass(ks)=0. + xscav_frac1(jpart,ks)=0. + endif + endif + endif + + if (wetscav.gt.0.) then + wetdeposit(ks)=part(jpart)%mass(ks)* & + (1.-exp(-wetscav*abs(ltsample)))*grfraction(1) ! wet deposition + else ! if no scavenging + wetdeposit(ks)=0. + endif + part(jpart)%wetdepo(ks)=part(jpart)%wetdepo(ks)+wetdeposit(ks) + restmass = part(jpart)%mass(ks)-wetdeposit(ks) + if (ioutputforeachrelease.eq.1) then + kp=part(jpart)%npoint + else + kp=1 + endif + if (restmass .gt. smallnum) then + part(jpart)%mass(ks)=restmass + ! depostatistic + ! wetdepo_sum(ks,kp)=wetdepo_sum(ks,kp)+wetdeposit(ks) + ! depostatistic + else + part(jpart)%mass(ks)=0. + endif + ! Correct deposited mass to the last time step when radioactive decay of + ! gridded deposited mass was calculated + if (decay(ks).gt.0.) then + wetdeposit(ks)=wetdeposit(ks)*exp(abs(ldeltat)*decay(ks)) + endif + + ! endif ! no deposition + end do ! loop over species + + ! Sabine Eckhardt, 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).and.(iout.ne.0)) then !OMP reduction necessary for wetgridunc + call wetdepokernel(part(jpart)%nclass,wetdeposit,real(part(jpart)%xlon), & + real(part(jpart)%ylat),nage,kp,thread+1) + if (nested_output.eq.1) call wetdepokernel_nest(part(jpart)%nclass, & + wetdeposit,real(part(jpart)%xlon),real(part(jpart)%ylat),nage,kp,thread+1) + endif + + end do ! all particles + +!$OMP END DO +!$OMP END PARALLEL + +#ifdef _OPENMP + call omp_set_num_threads(numthreads) +#endif + +#ifdef _OPENMP + if ((ldirect.eq.1).and.(iout.ne.0)) then + do ithread=1,numthreads_grid + wetgridunc(:,:,:,:,:,:)=wetgridunc(:,:,:,:,:,:)+gridunc_omp(:,:,1,:,:,:,:,ithread) + gridunc_omp(:,:,1,:,:,:,:,ithread)=0. + end do + if (nested_output.eq.1) then + do ithread=1,numthreads_grid + wetgriduncn(:,:,:,:,:,:)=wetgriduncn(:,:,:,:,:,:)+griduncn_omp(:,:,1,:,:,:,:,ithread) + griduncn_omp(:,:,1,:,:,:,:,ithread)=0. + end do + endif + endif +#endif + !write(*,*) 'WETGRIDUNC:',sum(wetgridunc),wetgridunc(20,270,1,1,1,1),wetgridunc(19,269,1,1,1,1) + ! count the total number of below-cloud and in-cloud occurences: + tot_blc_count(1:nspec)=tot_blc_count(1:nspec)+blc_count(1:nspec) + tot_inc_count(1:nspec)=tot_inc_count(1:nspec)+inc_count(1:nspec) +end subroutine wetdepo diff --git a/src/wet_wetdepokernel.f90 b/src/wet_wetdepokernel.f90 new file mode 100644 index 0000000000000000000000000000000000000000..7a5dbd87e42abd5bb62b0f6c018d9b59a17c6691 --- /dev/null +++ b/src/wet_wetdepokernel.f90 @@ -0,0 +1,133 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine wetdepokernel(nunc,deposit,x,y,nage,kp,thread) + ! 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 * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! nunc uncertainty class of the respective particle * + ! nage age class of the respective particle * + ! deposit amount (kg) to be deposited * + ! * + !***************************************************************************** + ! Changes: + ! eso 10/2016: Added option to disregard kernel + ! + !***************************************************************************** + + use unc_mod + + implicit none + + integer,intent(in) :: thread + real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w + integer :: ix,jy,ixp,jyp,nunc,nage,ks,kp + + xl=(x*dx+xoutshift)/dxout + yl=(y*dy+youtshift)/dyout + ix=int(xl) + jy=int(yl) + 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 + + ! If no kernel is used, direct attribution to grid cell + !****************************************************** + + if (.not.lusekerneloutput) then + do ks=1,nspec + if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. & + (jy.le.numygrid-1)) then +#ifdef _OPENMP + gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks) +#else + wetgridunc(ix,jy,ks,kp,nunc,nage)= & + wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks) +#endif + end if + end do + else ! use kernel + + ! 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 +#ifdef _OPENMP + gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + wetgridunc(ix,jy,ks,kp,nunc,nage)= & + wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w +#endif + 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) +#ifdef _OPENMP + gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + wetgridunc(ixp,jyp,ks,kp,nunc,nage)= & + wetgridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. & + (jy.le.numygrid-1)) then + w=(1.-wx)*wy +#ifdef _OPENMP + gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + wetgridunc(ixp,jy,ks,kp,nunc,nage)= & + wetgridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. & + (jyp.le.numygrid-1)) then + w=wx*(1.-wy) +#ifdef _OPENMP + gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= & + gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + wetgridunc(ix,jyp,ks,kp,nunc,nage)= & + wetgridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + end do + end if +end subroutine wetdepokernel diff --git a/src/wet_wetdepokernel_nest.f90 b/src/wet_wetdepokernel_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6ffc055be4d7aa146a59b253069ba56c3556e628 --- /dev/null +++ b/src/wet_wetdepokernel_nest.f90 @@ -0,0 +1,126 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine wetdepokernel_nest(nunc,deposit,x,y,nage,kp,thread) + ! 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. * + ! * + ! * + !***************************************************************************** + ! * + ! Variables: * + ! * + ! nunc uncertainty class of the respective particle * + ! nage age class of the respective particle * + ! deposit amount (kg) to be deposited * + ! * + !***************************************************************************** + + use unc_mod + + implicit none + + integer,intent(in) :: thread + real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w + integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage + + xl=(x*dx+xoutshiftn)/dxoutn + yl=(y*dy+youtshiftn)/dyoutn + + ! old: + ! ix=int(xl) + ! jy=int(yl) + + ! ESO: for xl,yl in range <-.5,-1> we get ix,jy=0 and thus negative + ! wx,wy as the int function rounds upwards for negative numbers. + ! Either use the floor function, or (perhaps more correctly?) use "(xl.gt.-0.5)" + ! in place of "(ix.ge.0)" and similar for the upper boundary. + + ! new: + ix=floor(xl) + jy=floor(yl) + + 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 +#ifdef _OPENMP + griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & + griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + wetgriduncn(ix,jy,ks,kp,nunc,nage)= & + wetgriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w +#endif + 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) +#ifdef _OPENMP + griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= & + griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + wetgriduncn(ixp,jyp,ks,kp,nunc,nage)= & + wetgriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. & + (jy.le.numygridn-1)) then + w=(1.-wx)*wy +#ifdef _OPENMP + griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= & + griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + wetgriduncn(ixp,jy,ks,kp,nunc,nage)= & + wetgriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. & + (jyp.le.numygridn-1)) then + w=wx*(1.-wy) +#ifdef _OPENMP + griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= & + griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w +#else + wetgriduncn(ix,jyp,ks,kp,nunc,nage)= & + wetgriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w +#endif + endif + + end do +end subroutine wetdepokernel_nest diff --git a/src/wet_writeprecip.f90 b/src/wet_writeprecip.f90 new file mode 100644 index 0000000000000000000000000000000000000000..6d210295be65662de79dd8737db338702d5631d3 --- /dev/null +++ b/src/wet_writeprecip.f90 @@ -0,0 +1,65 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine writeprecip(itime,imem) + + !***************************************************************************** + ! * + ! This routine produces a file containing total precipitation for each * + ! releases point. * + ! * + ! Author: S. Eckhardt * + ! 7 Mai 2017 * + !***************************************************************************** + + use point_mod + use par_mod + use com_mod + use date_mod + use windfields_mod + + implicit none + + integer :: jjjjmmdd,ihmmss,itime,i + real(kind=dp) :: jul + character :: adate*8,atime*6 + + integer :: ix,jy,imem + real :: xp1,yp1 + + + if (itime.eq.0) then + open(unitprecip,file=path(2)(1:length(2))//'wetscav_precip.txt', & + form='formatted',err=998) + else + open(unitprecip,file=path(2)(1:length(2))//'wetscav_precip.txt', & + ACCESS='APPEND',form='formatted',err=998) + endif + + jul=bdate+real(itime,kind=dp)/86400._dp + call caldate(jul,jjjjmmdd,ihmmss) + write(adate,'(i8.8)') jjjjmmdd + write(atime,'(i6.6)') ihmmss + + do i=1,numpoint + xp1=xpoint1(i)*dx+xlon0 !lat, long (real) coord + yp1=ypoint1(i)*dy+ylat0 !lat, long (real) coord + ix=int((xpoint1(i)+xpoint2(i))/2.) + jy=int((ypoint1(i)+ypoint2(i))/2.) + write(unitprecip,*) jjjjmmdd, ihmmss, & + xp1,yp1,lsprec(ix,jy,1,imem),convprec(ix,jy,1,imem) !time is the same as in the ECMWF windfield +! units mm/h, valid for the time given in the windfield + end do + + close(unitprecip) + + return + + +998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' + write(*,*) ' #### '//path(2)(1:length(2))//'header_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 writeprecip diff --git a/src/wetdepo_mod.f90 b/src/wetdepo_mod.f90 index ab1e0fa168a27bd2b61c49ed578888958b1abcbe..071ed64e171976e3b82e436bce153b1c0e66ccea 100644 --- a/src/wetdepo_mod.f90 +++ b/src/wetdepo_mod.f90 @@ -14,825 +14,14 @@ module wetdepo_mod contains -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! * - ! * - ! 2021 Andreas Plach: - moved backward wet depo. calc. here from timemanager * - ! - bugfix in-cloud scavenging * - !***************************************************************************** - ! * - ! 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 * - ! ltsample [s] interval over which mass is deposited * - ! wetdeposit mass that is wet deposited * - ! wetgrid accumulated deposited mass on output grid * - ! wetscav scavenging coefficient * - ! * - ! Constants: * - ! * - !***************************************************************************** -#ifdef _OPENMP - use omp_lib -#endif - use unc_mod - - implicit none - - integer :: jpart,itime,ltsample,loutnext,ldeltat - integer :: itage,nage,inage,ithread,thread - integer :: ks, kp - integer(selected_int_kind(16)), dimension(nspec) :: blc_count, inc_count - real :: grfraction(3),wetscav - real :: wetdeposit(maxspec),restmass - real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled - - ! 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 - !************************ - blc_count(:)=0 - inc_count(:)=0 - -#ifdef _OPENMP - call omp_set_num_threads(numthreads_grid) -#endif -!$OMP PARALLEL PRIVATE(jpart,itage,nage,inage,ks,kp,thread,wetscav,wetdeposit, & -!$OMP restmass, grfraction) REDUCTION(+:blc_count,inc_count) - -#if (defined _OPENMP) - thread = OMP_GET_THREAD_NUM() ! Starts with 0 -#else - thread = 0 -#endif - -!$OMP DO - do jpart=1,numpart - - ! Check if memory has been deallocated - if (.not. particle_allocated(jpart)) cycle - - ! Check if particle is still allive - if (.not. part(jpart)%alive) cycle - - ! Determine age class of the particle - nage is used for the kernel - !****************************************************************** - itage=abs(itime-part(jpart)%tstart) - nage=1 - do inage=1,nageclass - nage=inage - if (itage.lt.lage(nage)) exit - end do - - do ks=1,nspec ! loop over species - - if (WETDEPSPEC(ks).eqv..false.) cycle - - !************************************************** - ! CALCULATE DEPOSITION - !************************************************** - - call get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc_count,wetscav) ! OMP carefully check - - if (WETBKDEP) then - if ((xscav_frac1(jpart,ks).lt.-0.1)) then ! particle marked as starting particle - if (wetscav.gt.0.) then - xscav_frac1(jpart,ks)=wetscav*(zpoint2(part(jpart)%npoint)-& - zpoint1(part(jpart)%npoint))*grfraction(1) - else - part(jpart)%mass(ks)=0. - xscav_frac1(jpart,ks)=0. - endif - endif - endif - - if (wetscav.gt.0.) then - wetdeposit(ks)=part(jpart)%mass(ks)* & - (1.-exp(-wetscav*abs(ltsample)))*grfraction(1) ! wet deposition - else ! if no scavenging - wetdeposit(ks)=0. - endif - part(jpart)%wetdepo(ks)=part(jpart)%wetdepo(ks)+wetdeposit(ks) - restmass = part(jpart)%mass(ks)-wetdeposit(ks) - if (ioutputforeachrelease.eq.1) then - kp=part(jpart)%npoint - else - kp=1 - endif - if (restmass .gt. smallnum) then - part(jpart)%mass(ks)=restmass - ! depostatistic - ! wetdepo_sum(ks,kp)=wetdepo_sum(ks,kp)+wetdeposit(ks) - ! depostatistic - else - part(jpart)%mass(ks)=0. - endif - ! Correct deposited mass to the last time step when radioactive decay of - ! gridded deposited mass was calculated - if (decay(ks).gt.0.) then - wetdeposit(ks)=wetdeposit(ks)*exp(abs(ldeltat)*decay(ks)) - endif - - ! endif ! no deposition - end do ! loop over species - - ! Sabine Eckhardt, 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).and.(iout.ne.0)) then !OMP reduction necessary for wetgridunc - call wetdepokernel(part(jpart)%nclass,wetdeposit,real(part(jpart)%xlon), & - real(part(jpart)%ylat),nage,kp,thread+1) - if (nested_output.eq.1) call wetdepokernel_nest(part(jpart)%nclass, & - wetdeposit,real(part(jpart)%xlon),real(part(jpart)%ylat),nage,kp,thread+1) - endif - - end do ! all particles - -!$OMP END DO -!$OMP END PARALLEL - -#ifdef _OPENMP - call omp_set_num_threads(numthreads) -#endif - -#ifdef _OPENMP - if ((ldirect.eq.1).and.(iout.ne.0)) then - do ithread=1,numthreads_grid - wetgridunc(:,:,:,:,:,:)=wetgridunc(:,:,:,:,:,:)+gridunc_omp(:,:,1,:,:,:,:,ithread) - gridunc_omp(:,:,1,:,:,:,:,ithread)=0. - end do - if (nested_output.eq.1) then - do ithread=1,numthreads_grid - wetgriduncn(:,:,:,:,:,:)=wetgriduncn(:,:,:,:,:,:)+griduncn_omp(:,:,1,:,:,:,:,ithread) - griduncn_omp(:,:,1,:,:,:,:,ithread)=0. - end do - endif - endif -#endif - !write(*,*) 'WETGRIDUNC:',sum(wetgridunc),wetgridunc(20,270,1,1,1,1),wetgridunc(19,269,1,1,1,1) - ! count the total number of below-cloud and in-cloud occurences: - tot_blc_count(1:nspec)=tot_blc_count(1:nspec)+blc_count(1:nspec) - tot_inc_count(1:nspec)=tot_inc_count(1:nspec)+inc_count(1:nspec) -end subroutine wetdepo - -subroutine get_wetscav(itime,ltsample,loutnext,jpart,ks,grfraction,inc_count,blc_count,wetscav) - ! i i i i i o o o o - !***************************************************************************** - ! * - ! 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! * - ! * - !***************************************************************************** - ! * - ! 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 * - ! 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* - ! wetgrid accumulated deposited mass on output grid * - ! wetscav scavenging coefficient * - ! * - ! Constants: * - ! * - !***************************************************************************** - - use interpol_mod - use windfields_mod - use coord_ec_mod - - implicit none - - integer :: jpart,itime,ltsample,loutnext,i,j - integer :: hz,il,interp_time, n - integer(kind=1) :: clouds_v - integer :: ks, kp - integer(selected_int_kind(16)), dimension(nspec) :: blc_count, inc_count - - ! integer :: n1,n2, icbot,ictop, indcloud !TEST - real :: S_i, act_temp, cl, cle ! in cloud scavenging - real :: clouds_h ! cloud height for the specific grid point - real :: lsp,convp,cc,grfraction(3),prec(3),wetscav,totprec - real :: restmass - real,parameter :: smallnum = tiny(0.0) ! smallest number that can be handled - !save lfr,cfr - real :: xts,yts - - real, parameter :: lfr(5) = (/ 0.5,0.65,0.8,0.9,0.95/) - real, parameter :: cfr(5) = (/ 0.4,0.55,0.7,0.8,0.9 /) - - !ZHG aerosol below-cloud scavenging removal polynomial constants for rain and snow - real, parameter :: bclr(6) = (/274.35758, 332839.59273, 226656.57259, 58005.91340, 6588.38582, 0.244984/) !rain (Laakso et al 2003) - real, parameter :: bcls(6) = (/22.7, 0.0, 0.0, 1321.0, 381.0, 0.0/) !now (Kyro et al 2009) - real :: frac_act, liq_frac, ice_frac, dquer_m - - real :: Si_dummy, wetscav_dummy - logical :: readclouds_this_nest - - - wetscav=0. - - ! 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) - - n=memind(2) - if (abs(memtime(1)-interp_time).lt.abs(memtime(2)-interp_time)) & - n=memind(1) - - xts=real(part(jpart)%xlon) - yts=real(part(jpart)%ylat) - - ! Determine which nesting level to be used - !***************************************** - call find_ngrid(xts,yts) - - ! If point at border of grid -> small displacement into grid - !*********************************************************** - if (ngrid.le.0) then - if (xts.ge.real(nx-1)) xts=real(nx-1)-0.00001 - if (yts.ge.real(ny-1)) yts=real(ny-1)-0.00001 - else - if (xts.ge.real(nx-1)) xts=real(nx-1)-0.00001 - if (yts.ge.real(ny-1)) yts=real(ny-1)-0.00001 - endif - - call find_grid_indices(xts,yts) - call find_grid_distances(xts,yts) - - if (ngrid.le.0) then - ! No temporal interpolation to stay consistent with clouds - call hor_interpol(lsprec,lsp,1,n,1) ! large scale total precipitation - call hor_interpol(convprec,convp,1,n,1) ! convective precipitation - call hor_interpol(tcc,cc,1,n,1) ! total cloud cover - else - call hor_interpol_nest(lsprecn,lsp,1,n,1) ! large scale total precipitation - call hor_interpol_nest(convprecn,convp,1,n,1) ! convective precipitation - call hor_interpol_nest(tccn,cc,1,n,1) ! total cloud cover - endif - - ! If total precipitation is less than 0.01 mm/h - no scavenging occurs - if ((lsp.lt.0.01).and.(convp.lt.0.01)) return - - if (wind_coord_type.eq.'ETA') then - call find_z_level_eta_uv(real(part(jpart)%zeta)) - hz=induv - else - call find_z_level_meters(real(part(jpart)%z)) - hz=indz - endif - - if (ngrid.le.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=cloudshn(ix,jy,n,ngrid) - endif - - ! if there is no precipitation or the particle is above the clouds no - ! scavenging is done - - if (clouds_v.le.1) return - - ! 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 - - - !ZHG oct 2014 : Calculated for 1) both 2) lsp 3) convp - 2 and 3 not used removed by SE - ! Tentatively differentiate the grfraction for lsp and convp for treating differently the two forms - ! for now they are treated the same - grfraction(1)=max(0.05,cc*(lsp*lfr(i)+convp*cfr(j))/(lsp+convp)) - - ! 2) Computation of precipitation rate in sub-grid cell - !****************************************************** - prec(1)=(lsp+convp)/grfraction(1) - - ! 3) Computation of scavenging coefficients for all species - ! Computation of wet deposition - !********************************************************** - - if (ngrid.gt.0) then - if (wind_coord_type.eq.'ETA') then - act_temp=ttetan(ix,jy,hz,n,ngrid) - else - act_temp=ttn(ix,jy,hz,n,ngrid) - endif - else - if (wind_coord_type.eq.'ETA') then - act_temp=tteta(ix,jy,hz,n) - else - act_temp=tt(ix,jy,hz,n) - endif - endif - - !*********************** - ! BELOW CLOUD SCAVENGING - !*********************** - if (clouds_v.ge.4) then !below cloud - - ! For gas: if positive below-cloud parameters (A or B), and dquer<=0 - !****************************************************************** - if ((dquer(ks).le.0.).and.(weta_gas(ks).gt.0..or.wetb_gas(ks).gt.0.)) then - blc_count(ks)=blc_count(ks)+1 - wetscav=weta_gas(ks)*prec(1)**wetb_gas(ks) - - ! For aerosols: if positive below-cloud parameters (Crain/Csnow or B), and dquer>0 - !********************************************************************************* - else if ((dquer(ks).gt.0.).and.(crain_aero(ks).gt.0..or.csnow_aero(ks).gt.0.)) then - blc_count(ks)=blc_count(ks)+1 - - !NIK 17.02.2015 - ! For the calculation here particle size needs to be in meter and not um as dquer is - ! changed in readreleases - ! For particles larger than 10 um use the largest size defined in the parameterizations (10um) - dquer_m=min(10.,dquer(ks))/1000000. !conversion from um to m - - ! Rain: - if (act_temp .ge. 273. .and. crain_aero(ks).gt.0.) then - - ! ZHG 2014 : Particle RAIN scavenging coefficient based on Laakso et al 2003, - ! the below-cloud scavenging (rain efficienty) parameter Crain (=crain_aero) from SPECIES file - wetscav=crain_aero(ks)*10**(bclr(1)+(bclr(2)*(log10(dquer_m))**(-4))+ & - & (bclr(3)*(log10(dquer_m))**(-3))+ (bclr(4)*(log10(dquer_m))**(-2))+& - &(bclr(5)*(log10(dquer_m))**(-1))+bclr(6)* (prec(1))**(0.5)) - - ! Snow: - elseif (act_temp .lt. 273. .and. csnow_aero(ks).gt.0.) then - ! ZHG 2014 : Particle SNOW scavenging coefficient based on Kyro et al 2009, - ! the below-cloud scavenging (Snow efficiency) parameter Csnow (=csnow_aero) from SPECIES file - wetscav=csnow_aero(ks)*10**(bcls(1)+(bcls(2)*(log10(dquer_m))**(-4))+& - &(bcls(3)*(log10(dquer_m))**(-3))+ (bcls(4)*(log10(dquer_m))**(-2))+& - &(bcls(5)*(log10(dquer_m))**(-1))+ bcls(6)* (prec(1))**(0.5)) - - endif - - endif ! gas or particle - ! endif ! positive below-cloud scavenging parameters given in Species file - endif !end BELOW - - !******************** - ! IN CLOUD SCAVENGING - !******************** - if (clouds_v.lt.4) then ! In-cloud - ! NIK 13 may 2015: only do incloud if positive in-cloud scavenging parameters are - ! given in species file, or if gas and positive Henry's constant - if ((ccn_aero(ks).gt.0. .or. in_aero(ks).gt.0.).or.(henry(ks).gt.0.and.dquer(ks).le.0)) then - inc_count(ks)=inc_count(ks)+1 - ! if negative coefficients (turned off) set to zero for use in equation - if (ccn_aero(ks).lt.0.) ccn_aero(ks)=0. - if (in_aero(ks).lt.0.) in_aero(ks)=0. - - !ZHG 2015 Cloud liquid & ice water (CLWC+CIWC) from ECMWF - ! nested fields - if (ngrid.gt.0.and.readclouds_this_nest) then - cl=ctwcn(ix,jy,n,ngrid)*(grfraction(1)/cc) - else if (ngrid.eq.0.and.readclouds) then - ! cl=ctwc(ix,jy,n)*(grfraction(1)/cc) - ! A.Plach 2021 cl should not become too small - cl=max(1E6*2E-7*prec(1)**0.36, ctwc(ix,jy,n)*(grfraction(1)/cc)) - else !parameterize cloudwater m2/m3 - !ZHG updated parameterization of cloud water to better reproduce the values coming from ECMWF - ! sec test - ! cl=1E6*1E-7*prec(1)**0.3 !Sec GFS new - cl=1E6*2E-7*prec(1)**0.36 !Sec ECMWF new, is also suitable for GFS - ! cl=2E-7*prec(1)**0.36 !Andreas - ! cl=1.6E-6*prec(1)**0.36 !Henrik - endif - - !ZHG: Calculate the partition between liquid and water phase water. - if (act_temp .le. 253.) then - liq_frac=0 - ice_frac=1 - else if (act_temp .ge. 273.) then - liq_frac=1 - ice_frac=0 - else - ! sec bugfix after FLEXPART paper review, liq_frac was 1-liq_frac - ! IP bugfix v10.4, calculate ice_frac and liq_frac - ice_frac= ((act_temp-273.)/(273.-253.))**2. - !liq_frac = 1-ice_frac !((act_temp-253.)/(273.-253.))**2. - liq_frac=max(0.,1.-ice_frac) - end if - ! ZHG: Calculate the aerosol partition based on cloud phase and Ai and Bi - ! frac_act = liq_frac*ccn_aero(ks) +(1-liq_frac)*in_aero(ks) - ! IP, use ice_frac and liq_frac - frac_act = liq_frac*ccn_aero(ks) + ice_frac*in_aero(ks) - - !ZHG Use the activated fraction and the liqid water to calculate the washout - - ! AEROSOL - !******** - if (dquer(ks).gt.0.) then - S_i= frac_act/cl - ! GAS - !**** - else - cle=(1-cl)/(henry(ks)*(r_air/3500.)*act_temp)+cl - S_i=1/cle - endif ! gas or particle - - ! scavenging coefficient based on Hertel et al 1995 - using the S_i for either gas or aerosol - !SEC wetscav fix, the cloud height is no longer needed, it gives wrong results - wetscav=incloud_ratio*S_i*(prec(1)/3.6E6) - endif ! positive in-cloud scavenging parameters given in Species file - endif !incloud -end subroutine get_wetscav - -subroutine wetdepokernel(nunc,deposit,x,y,nage,kp,thread) - ! 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 * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! nunc uncertainty class of the respective particle * - ! nage age class of the respective particle * - ! deposit amount (kg) to be deposited * - ! * - !***************************************************************************** - ! Changes: - ! eso 10/2016: Added option to disregard kernel - ! - !***************************************************************************** - - use unc_mod - - implicit none - - integer,intent(in) :: thread - real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w - integer :: ix,jy,ixp,jyp,nunc,nage,ks,kp - - xl=(x*dx+xoutshift)/dxout - yl=(y*dy+youtshift)/dyout - ix=int(xl) - jy=int(yl) - 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 - - ! If no kernel is used, direct attribution to grid cell - !****************************************************** - - if (.not.lusekerneloutput) then - do ks=1,nspec - if ((ix.ge.0).and.(jy.ge.0).and.(ix.le.numxgrid-1).and. & - (jy.le.numygrid-1)) then -#ifdef _OPENMP - gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks) -#else - wetgridunc(ix,jy,ks,kp,nunc,nage)= & - wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks) -#endif - end if - end do - else ! use kernel - - ! 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 -#ifdef _OPENMP - gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - wetgridunc(ix,jy,ks,kp,nunc,nage)= & - wetgridunc(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w -#endif - 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) -#ifdef _OPENMP - gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - wetgridunc(ixp,jyp,ks,kp,nunc,nage)= & - wetgridunc(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgrid-1).and. & - (jy.le.numygrid-1)) then - w=(1.-wx)*wy -#ifdef _OPENMP - gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - wetgridunc(ixp,jy,ks,kp,nunc,nage)= & - wetgridunc(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgrid-1).and. & - (jyp.le.numygrid-1)) then - w=wx*(1.-wy) -#ifdef _OPENMP - gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= & - gridunc_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - wetgridunc(ix,jyp,ks,kp,nunc,nage)= & - wetgridunc(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - end do - end if -end subroutine wetdepokernel - -subroutine wetdepokernel_nest(nunc,deposit,x,y,nage,kp,thread) - ! 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. * - ! * - ! * - !***************************************************************************** - ! * - ! Variables: * - ! * - ! nunc uncertainty class of the respective particle * - ! nage age class of the respective particle * - ! deposit amount (kg) to be deposited * - ! * - !***************************************************************************** - - use unc_mod - - implicit none - - integer,intent(in) :: thread - real :: x,y,deposit(maxspec),ddx,ddy,xl,yl,wx,wy,w - integer :: ix,jy,ixp,jyp,ks,kp,nunc,nage - - xl=(x*dx+xoutshiftn)/dxoutn - yl=(y*dy+youtshiftn)/dyoutn - - ! old: - ! ix=int(xl) - ! jy=int(yl) - - ! ESO: for xl,yl in range <-.5,-1> we get ix,jy=0 and thus negative - ! wx,wy as the int function rounds upwards for negative numbers. - ! Either use the floor function, or (perhaps more correctly?) use "(xl.gt.-0.5)" - ! in place of "(ix.ge.0)" and similar for the upper boundary. - - ! new: - ix=floor(xl) - jy=floor(yl) - - 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 -#ifdef _OPENMP - griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)= & - griduncn_omp(ix,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - wetgriduncn(ix,jy,ks,kp,nunc,nage)= & - wetgriduncn(ix,jy,ks,kp,nunc,nage)+deposit(ks)*w -#endif - 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) -#ifdef _OPENMP - griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)= & - griduncn_omp(ixp,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - wetgriduncn(ixp,jyp,ks,kp,nunc,nage)= & - wetgriduncn(ixp,jyp,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - if ((ixp.ge.0).and.(jy.ge.0).and.(ixp.le.numxgridn-1).and. & - (jy.le.numygridn-1)) then - w=(1.-wx)*wy -#ifdef _OPENMP - griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)= & - griduncn_omp(ixp,jy,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - wetgriduncn(ixp,jy,ks,kp,nunc,nage)= & - wetgriduncn(ixp,jy,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - if ((ix.ge.0).and.(jyp.ge.0).and.(ix.le.numxgridn-1).and. & - (jyp.le.numygridn-1)) then - w=wx*(1.-wy) -#ifdef _OPENMP - griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)= & - griduncn_omp(ix,jyp,1,ks,kp,nunc,nage,thread)+deposit(ks)*w -#else - wetgriduncn(ix,jyp,ks,kp,nunc,nage)= & - wetgriduncn(ix,jyp,ks,kp,nunc,nage)+deposit(ks)*w -#endif - endif - - end do -end subroutine wetdepokernel_nest - -subroutine writeprecip(itime,imem) - - !***************************************************************************** - ! * - ! This routine produces a file containing total precipitation for each * - ! releases point. * - ! * - ! Author: S. Eckhardt * - ! 7 Mai 2017 * - !***************************************************************************** - - use point_mod - use par_mod - use com_mod - use date_mod - use windfields_mod - - implicit none - - integer :: jjjjmmdd,ihmmss,itime,i - real(kind=dp) :: jul - character :: adate*8,atime*6 - - integer :: ix,jy,imem - real :: xp1,yp1 - - - if (itime.eq.0) then - open(unitprecip,file=path(2)(1:length(2))//'wetscav_precip.txt', & - form='formatted',err=998) - else - open(unitprecip,file=path(2)(1:length(2))//'wetscav_precip.txt', & - ACCESS='APPEND',form='formatted',err=998) - endif - - jul=bdate+real(itime,kind=dp)/86400._dp - call caldate(jul,jjjjmmdd,ihmmss) - write(adate,'(i8.8)') jjjjmmdd - write(atime,'(i6.6)') ihmmss - - do i=1,numpoint - xp1=xpoint1(i)*dx+xlon0 !lat, long (real) coord - yp1=ypoint1(i)*dy+ylat0 !lat, long (real) coord - ix=int((xpoint1(i)+xpoint2(i))/2.) - jy=int((ypoint1(i)+ypoint2(i))/2.) - write(unitprecip,*) jjjjmmdd, ihmmss, & - xp1,yp1,lsprec(ix,jy,1,imem),convprec(ix,jy,1,imem) !time is the same as in the ECMWF windfield -! units mm/h, valid for the time given in the windfield - end do +#include "wet_wetdepo.f90" - close(unitprecip) +#include "wet_get_wetscav.f90" - return +#include "wet_wetdepokernel.f90" +#include "wet_wetdepokernel_nest.f90" -998 write(*,*) ' #### FLEXPART MODEL ERROR! THE FILE #### ' - write(*,*) ' #### '//path(2)(1:length(2))//'header_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 writeprecip +#include "wet_writeprecip.f90" end module wetdepo_mod diff --git a/src/win_alloc_windf.f90 b/src/win_alloc_windf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e26b6a2bd4d1131c7d5d8b2631ea2a8a03e60555 --- /dev/null +++ b/src/win_alloc_windf.f90 @@ -0,0 +1,82 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine alloc_windf + + ! Eta coordinates + !**************** + allocate(uueta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(vveta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(wweta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(uupoleta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(vvpoleta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(tteta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(pveta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(prseta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(rhoeta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(drhodzeta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + !allocate(tvirtual(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(etauvheight(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) + allocate(etawheight(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) + + ! Intrinsic coordinates + !********************** + allocate(uu(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(vv(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(ww(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(uupol(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(vvpol(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(tt(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(tth(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) + allocate(qv(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(qvh(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) + allocate(rho(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(drhodz(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(pplev(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) + allocate(prs(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(rho_dry(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + + ! Cloud data + !*********** + allocate(clwc(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(ciwc(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(clw(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + allocate(clwch(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) + allocate(ciwch(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) + clwc=0.0 + ciwc=0.0 + clw=0.0 + clwch=0.0 + ciwch=0.0 + allocate(ctwc(0:nxmax-1,0:nymax-1,numwfmem)) + allocate(cloudsh(0:nxmax-1,0:nymax-1,numwfmem)) + allocate(clouds(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + + ! 2d fields + !********** + allocate(ps(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(sd(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(msl(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(tcc(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(u10(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(v10(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(tt2(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(td2(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(lsprec(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(convprec(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(sshf(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(ssr(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(sfcstress(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(ustar(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(wstar(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(hmix(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(tropopause(0:nxmax-1,0:nymax-1,1,numwfmem)) + allocate(oli(0:nxmax-1,0:nymax-1,1,numwfmem)) + + ! Vertical descritisation arrays + !******************************* + allocate(height(nzmax),wheight(nzmax),uvheight(nzmax)) + allocate(akm(nwzmax),bkm(nwzmax),akz(nuvzmax),bkz(nuvzmax), & + aknew(nzmax),bknew(nzmax)) + +end subroutine alloc_windf diff --git a/src/win_alloc_windf_nest.f90 b/src/win_alloc_windf_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..866892dae5180ca6602e1ac8248ff82f24096f8a --- /dev/null +++ b/src/win_alloc_windf_nest.f90 @@ -0,0 +1,96 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine alloc_windf_nest +!**************************************************************************** +! Dynamic allocation of arrays +! +! For nested wind fields. +! +!**************************************************************************** + + allocate(wfnamen(maxnests,maxwf)) + allocate(wfspecn(maxnests,maxwf)) + + allocate(nxn(maxnests)) + allocate(nyn(maxnests)) + allocate(dxn(maxnests)) + allocate(dyn(maxnests)) + allocate(xlon0n(maxnests)) + allocate(ylat0n(maxnests)) + + allocate(oron(0:nxmaxn-1,0:nymaxn-1,maxnests)) + allocate(excessoron(0:nxmaxn-1,0:nymaxn-1,maxnests)) + allocate(lsmn(0:nxmaxn-1,0:nymaxn-1,maxnests)) + + allocate(uun(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(vvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(wwn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(ttn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(qvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(pvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(clwcn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(ciwcn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(clwn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + + ! ETA equivalents + allocate(uuetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(vvetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(wwetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(ttetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(pvetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(prsetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(rhoetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(drhodzetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + ! allocate(tvirtualn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(etauvheightn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) + allocate(etawheightn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) + + allocate(cloudsn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(cloudshn(0:nxmaxn-1,0:nymaxn-1,numwfmem,numbnests)) + allocate(prsn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(rhon(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(drhodzn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) + allocate(tthn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) + allocate(qvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) + allocate(clwchn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) + allocate(ciwchn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) + allocate(ctwcn(0:nxmaxn-1,0:nymaxn-1,numwfmem,numbnests)) + + ! 2d fields + !*********** + allocate(psn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(sdn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(msln(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(tccn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(u10n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(v10n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(tt2n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(td2n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(lsprecn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(convprecn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(sshfn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(ssrn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(sfcstressn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(ustarn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(wstarn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(hmixn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(tropopausen(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(olin(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) + allocate(vdepn(0:nxmaxn-1,0:nymaxn-1,maxspec,numwfmem,maxnests)) + + allocate(xresoln(0:maxnests)) + allocate(yresoln(0:maxnests)) + allocate(xln(maxnests)) + allocate(yln(maxnests)) + allocate(xrn(maxnests)) + allocate(yrn(maxnests)) + + ! Initialise + !************ + clwcn(:,:,:,:,:)=0. + ciwcn(:,:,:,:,:)=0. + clwchn(:,:,:,:,:)=0. + ciwchn(:,:,:,:,:)=0. + +end subroutine alloc_windf_nest diff --git a/src/win_dealloc_windf.f90 b/src/win_dealloc_windf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..8da2638a500762d1d878f5f2d325fdf6b5a7bc82 --- /dev/null +++ b/src/win_dealloc_windf.f90 @@ -0,0 +1,15 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine dealloc_windf + + deallocate(oro,excessoro,lsm) + deallocate(uueta,vveta,wweta,uupoleta,vvpoleta,tteta,pveta, & + prseta,rhoeta,drhodzeta,etauvheight,etawheight) + deallocate(uu,vv,ww,uupol,vvpol,tt,tth,qv,qvh,pv,rho,drhodz,pplev,prs,rho_dry) + deallocate(clwc,ciwc,clw,clwch,ciwch,ctwc,cloudsh,clouds) + deallocate(ps,sd,msl,tcc,u10,v10,tt2,td2,lsprec,convprec,sshf,ssr,sfcstress, & + ustar,wstar,hmix,tropopause,oli) + deallocate(height,wheight,uvheight,akm,bkm,akz,bkz,aknew,bknew) + +end subroutine dealloc_windf diff --git a/src/win_dealloc_windf_nest.f90 b/src/win_dealloc_windf_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..80c89f490ce4da3566d2fec3d798a9ac1466e219 --- /dev/null +++ b/src/win_dealloc_windf_nest.f90 @@ -0,0 +1,17 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine dealloc_windf_nest + + deallocate(wfnamen,wfspecn) + deallocate(nxn,nyn,dxn,dyn,xlon0n,ylat0n) + deallocate(oron,excessoron,lsmn) + deallocate(uun,vvn,wwn,ttn,qvn,pvn,clwcn,ciwcn,clwn,cloudsn, & + cloudshn,rhon,prsn,drhodzn,tthn,qvhn,clwchn,ciwchn,ctwcn) + deallocate(uuetan,vvetan,wwetan,ttetan,pvetan,prsetan,rhoetan, & + drhodzetan,etauvheightn,etawheightn) + deallocate(psn,sdn,msln,tccn,u10n,v10n,tt2n,td2n,lsprecn,convprecn, & + sshfn,ssrn,sfcstressn,ustarn,wstarn,hmixn,tropopausen,olin,vdepn) + deallocate(xresoln,yresoln,xln,yln,xrn,yrn) + +end subroutine dealloc_windf_nest diff --git a/src/win_detectformat.f90 b/src/win_detectformat.f90 new file mode 100644 index 0000000000000000000000000000000000000000..a3ef9d22e994e310d67854778fb9eea2503d6e6e --- /dev/null +++ b/src/win_detectformat.f90 @@ -0,0 +1,47 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine detectformat + + !***************************************************************************** + ! * + ! This routine reads the 1st file with windfields to determine * + ! the format. * + ! * + ! Authors: M. Harustak * + ! * + ! 6 May 2015 * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! - Added routine to FP10 Flexpart distribution * + !***************************************************************************** + ! * + ! Variables: * + ! fname file name of file to check * + ! * + !***************************************************************************** + + use par_mod + use com_mod + use class_gribfile_mod + + + implicit none + + character(len=255) :: filename + character(len=255) :: wfname1(maxwf) + + ! If no file is available + if ( maxwf.le.0 ) then + print*,'No wind file available' + metdata_format = GRIBFILE_CENTRE_UNKNOWN + return + endif + + ! construct filename + filename = path(3)(1:length(3)) // trim(wfname(1)) + + ! get format + metdata_format = gribfile_centre(TRIM(filename)) +end subroutine detectformat diff --git a/src/win_fixedfields_alloc.f90 b/src/win_fixedfields_alloc.f90 new file mode 100644 index 0000000000000000000000000000000000000000..e4d71d2d49baeb5497f182f3d69ed9c3b06ed9f5 --- /dev/null +++ b/src/win_fixedfields_alloc.f90 @@ -0,0 +1,11 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine fixedfields_alloc + + allocate(oro(0:nxmax-1,0:nymax-1)) + allocate(excessoro(0:nxmax-1,0:nymax-1)) + allocate(lsm(0:nxmax-1,0:nymax-1)) + allocate(pv(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) + +end subroutine fixedfields_alloc diff --git a/src/win_gridcheck_ecmwf.f90 b/src/win_gridcheck_ecmwf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..91e20ff1ca8b12f5ce5b157a1b70953aff29a14d --- /dev/null +++ b/src/win_gridcheck_ecmwf.f90 @@ -0,0 +1,568 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine gridcheck_ecmwf + + !********************************************************************** + ! * + ! FLEXPART MODEL SUBROUTINE GRIDCHECK * + ! * + !********************************************************************** + ! * + ! AUTHOR: G. WOTAWA * + ! DATE: 1997-08-06 * + ! LAST UPDATE: 1997-10-10 * + ! * + ! Update: 1999-02-08, global fields allowed, A. Stohl* + ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with * + ! ECMWF grib_api * + ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with * + ! ECMWF grib_api * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! - Renamed from gridcheck to gridcheck_ecmwf * + ! * + !********************************************************************** + ! * + ! DESCRIPTION: * + ! * + ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT * + ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- * + ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE * + ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES * + ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT * + ! ANY CALL. * + ! * + ! XLON0 geographical longitude of lower left gridpoint * + ! YLAT0 geographical latitude of lower left gridpoint * + ! NX number of grid points x-direction * + ! NY number of grid points y-direction * + ! DX grid distance x-direction * + ! DY grid distance y-direction * + ! NUVZ number of grid points for horizontal wind * + ! components in z direction * + ! NWZ number of grid points for vertical wind * + ! component in z direction * + ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid* + ! points of the polar stereographic grid): * + ! used to check the CFL criterion * + ! UVHEIGHT(1)- heights of gridpoints where u and v are * + ! UVHEIGHT(NUVZ) given * + ! WHEIGHT(1)- heights of gridpoints where w is given * + ! WHEIGHT(NWZ) * + ! * + !********************************************************************** + + use grib_api + use cmapf_mod, only: stlmbr,stcm2p + + implicit none + + !HSO parameters for grib_api + integer :: ifile + integer :: iret + integer :: igrib + integer :: gotGrid + real(kind=4) :: xaux1,xaux2,yaux1,yaux2 + real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in + integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl,parId + !HSO end + integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip + real :: sizesouth,sizenorth,xauxa,conversion_factor + + ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING + + ! dimension of isec2 at least (22+n), where n is the number of parallels or + ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid + + ! dimension of zsec2 at least (10+nn), where nn is the number of vertical + ! coordinate parameters + + integer :: isec1(56),isec2(22+nxmax+nymax) + real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp) + character(len=1) :: opt + + !HSO grib api error messages + character(len=24) :: gribErrorMsg = 'Error reading grib file' + character(len=20) :: gribFunction = 'gridcheck' + + + iumax=0 + iwmax=0 + + if(ideltas.gt.0) then + ifn=1 + else + ifn=numbwf + endif + ! + ! OPENING OF DATA FILE (GRIB CODE) + ! +5 call grib_open_file(ifile,path(3)(1:length(3)) & + //trim(wfname(ifn)),'r',iret) + if (iret.ne.GRIB_SUCCESS) then + goto 999 ! ERROR DETECTED + endif + !turn on support for multi fields messages + !call grib_multi_support_on + + gotGrid=0 + ifield=0 + do while(.true.) + ifield=ifield+1 + ! + ! GET NEXT FIELDS + ! + call grib_new_from_file(ifile,igrib,iret) + if (iret.eq.GRIB_END_OF_FILE ) then + exit ! EOF DETECTED + elseif (iret.ne.GRIB_SUCCESS) then + goto 999 ! ERROR DETECTED + endif + + !first see if we read GRIB1 or GRIB2 + call grib_get_int(igrib,'editionNumber',gribVer,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + if (gribVer.eq.1) then ! GRIB Edition 1 + + !print*,'GRiB Edition 1' + !read the grib2 identifiers + call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'level',isec1(8),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + !change code for etadot to code for omega + if (isec1(6).eq.77) then + isec1(6)=135 + endif + + !print*,isec1(6),isec1(8) + + else + + !print*,'GRiB Edition 2' + !read the grib2 identifiers + call grib_get_int(igrib,'discipline',discipl,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterCategory',parCat,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterNumber',parNum,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'level',ivalsfc,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'paramId',parId,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + !print*,discipl,parCat,parNum,sfctyp,ivalsfc + + !convert to grib1 identifiers + isec1(6)=-1 + isec1(7)=-1 + isec1(8)=-1 + isec1(8)=ivalsfc ! level + if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! T + isec1(6)=130 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.105)) then ! U + isec1(6)=131 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.105)) then ! V + isec1(6)=132 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! Q + isec1(6)=133 ! indicatorOfParameter + !ZHG FOR CLOUDS FROM GRIB + elseif ((parCat.eq.1).and.(parNum.eq.83).and.(sfctyp.eq.105)) then ! clwc + isec1(6)=246 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.84).and.(sfctyp.eq.105)) then ! ciwc + isec1(6)=247 ! indicatorOfParameter + !ZHG end + ! ESO qc(=clwc+ciwc) + elseif ((parCat.eq.201).and.(parNum.eq.31).and.(sfctyp.eq.105)) then ! qc + isec1(6)=201031 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then !SP + isec1(6)=134 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot + isec1(6)=135 ! indicatorOfParameter + elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot + isec1(6)=135 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.101)) then !SLP + isec1(6)=151 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! 10U + isec1(6)=165 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! 10V + isec1(6)=166 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! 2T + isec1(6)=167 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.6).and.(sfctyp.eq.103)) then ! 2D + isec1(6)=168 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SD + isec1(6)=141 ! indicatorOfParameter + elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC + isec1(6)=164 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP + isec1(6)=142 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP + isec1(6)=143 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SHF + isec1(6)=146 ! indicatorOfParameter + elseif ((parCat.eq.4).and.(parNum.eq.9).and.(sfctyp.eq.1)) then ! SR + isec1(6)=176 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.17) .or. parId .eq. 180) then ! EWSS + isec1(6)=180 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.18) .or. parId .eq. 181) then ! NSSS + isec1(6)=181 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO + isec1(6)=129 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO + isec1(6)=160 ! indicatorOfParameter + elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. & + (sfctyp.eq.1)) then ! LSM + isec1(6)=172 ! indicatorOfParameter + else + print*,'***ERROR: undefined GRiB2 message found!',discipl, & + parCat,parNum,sfctyp + endif + if(parId .ne. isec1(6) .and. parId .ne. 77) then + write(*,*) 'parId',parId, 'isec1(6)',isec1(6) + ! stop + endif + + endif + + call grib_get_int(igrib,'numberOfPointsAlongAParallel', & + isec2(2),iret) + ! ! nx=isec2(2) + ! ! WRITE(*,*) nx,nxmax + ! if (isec2(2).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 ecmwf_mod.' + ! WRITE(*,*) isec2(2),nxmax + ! ! STOP + ! endif + + !get the size and data of the values array + if (isec1(6).ne.-1) then + call grib_get_real4_array(igrib,'values',zsec4,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + endif + + if (ifield.eq.1) then + + !HSO get the required fields from section 2 in a gribex compatible manner + call grib_get_int(igrib,'numberOfPointsAlongAParallel', & + isec2(2),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & + isec2(3),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & + xaux1in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'numberOfVerticalCoordinateValues', & + isec2(12),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + nxfield=isec2(2) + ny=isec2(3) + nlev_ec=isec2(12)/2-1 + + ! get the size and data of the vertical coordinate array + call grib_get_real4_array(igrib,'pv',zsec2,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + endif + + !HSO get the second part of the grid dimensions only from GRiB1 messages + if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then + call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', & + xaux2in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & + yaux1in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', & + yaux2in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + xaux1=xaux1in + xaux2=xaux2in + yaux1=yaux1in + yaux2=yaux2in + if (xaux1.gt.180.) xaux1=xaux1-360.0 + if (xaux2.gt.180.) xaux2=xaux2-360.0 + if (xaux1.lt.-180.) xaux1=xaux1+360.0 + if (xaux2.lt.-180.) xaux2=xaux2+360.0 + if (xaux2.lt.xaux1) xaux2=xaux2+360.0 + xlon0=xaux1 + ylat0=yaux1 + dx=(xaux2-xaux1)/real(nxfield-1) + dy=(yaux2-yaux1)/real(ny-1) + dxconst=180./(dx*r_earth*pi) + dyconst=180./(dy*r_earth*pi) + gotGrid=1 + ! Check whether fields are global + ! If they contain the poles, specify polar stereographic map + ! projections using the stlmbr- and stcm2p-calls + !*********************************************************** + + xauxa=abs(xaux2+dx-360.-xaux1) + if (xauxa.lt.0.001) then + nx=nxfield+1 ! field is cyclic + xglobal=.true. + if (abs(nxshift).ge.nx) & + stop 'nxshift in file par_mod is too large' + xlon0=xlon0+real(nxshift)*dx + else + nx=nxfield + xglobal=.false. + if (nxshift.ne.0) & + stop 'nxshift (par_mod) must be zero for non-global domain' + endif + nxmin1=nx-1 + nymin1=ny-1 + if (xlon0.gt.180.) xlon0=xlon0-360. + xauxa=abs(yaux1+90.) + if (xglobal.and.xauxa.lt.0.001) then + sglobal=.true. ! field contains south pole + ! Enhance the map scale by factor 3 (*2=6) compared to north-south + ! map scale + sizesouth=6.*(switchsouth+90.)/dy + call stlmbr(southpolemap,-90.,0.) + call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, & + sizesouth,switchsouth,180.) + switchsouthg=(switchsouth-ylat0)/dy + else + sglobal=.false. + switchsouthg=999999. + endif + xauxa=abs(yaux2-90.) + if (xglobal.and.xauxa.lt.0.001) then + nglobal=.true. ! field contains north pole + ! Enhance the map scale by factor 3 (*2=6) compared to north-south + ! map scale + sizenorth=6.*(90.-switchnorth)/dy + call stlmbr(northpolemap,90.,0.) + call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, & + sizenorth,switchnorth,180.) + switchnorthg=(switchnorth-ylat0)/dy + else + nglobal=.false. + switchnorthg=999999. + endif + if (nxshift.lt.0) & + stop 'nxshift (par_mod) must not be negative' + if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large' + endif ! gotGrid + + if (nx.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,nxmax + stop + endif + + if (ny.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,nymax + stop + endif + + k=isec1(8) + if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1) + if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1) + + if (isec1(6) .eq. 167) then + ! ! Assing grid values and allocate memory to read windfields + ! nxmax=nxfield + ! if (xglobal) then + ! nxmax=nxfield+1 + ! endif + ! nymax=ny + ! nwzmax=iwmax+1 + ! nuvzmax=iumax+1 + ! nzmax=nuvzmax + ! nconvlevmax=iumax + ! na=nuvzmax + ! ! Temporary nxmax and nymax + call fixedfields_alloc + endif + + if(isec1(6).eq.129) then + do jy=0,ny-1 + do ix=0,nxfield-1 + oro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)/ga + end do + end do + endif + if(isec1(6).eq.172) then + do jy=0,ny-1 + do ix=0,nxfield-1 + lsm(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1) + end do + end do + endif + if(isec1(6).eq.160) then + do jy=0,ny-1 + do ix=0,nxfield-1 + excessoro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1) + end do + end do + endif + + call grib_release(igrib) + end do !! READ NEXT LEVEL OR PARAMETER + ! + ! CLOSING OF INPUT DATA FILE + ! + call grib_close_file(ifile) + + ! call alloc_windf + + !error message if no fields found with correct first longitude in it + if (gotGrid.eq.0) then + print*,'***ERROR: input file needs to contain GRiB1 formatted'// & + 'messages' + stop + endif + + nuvz=iumax + nwz =iwmax + if(nuvz.eq.nlev_ec) nwz=nlev_ec+1 + + ! 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 + + ! 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 + + ! Output of grid info + !******************** + + if (lroot) then + write(*,'(a,2i7)') ' Vertical levels in ECMWF data: ', & + nuvz+1,nwz + write(*,*) + write(*,'(a)') ' Mother domain:' + write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Longitude range: ', & + xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx + write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Latitude range : ', & + ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy + write(*,*) + end if + + ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL + ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM + + numskip=nlev_ec-nuvz ! number of ecmwf model layers not used + ! by trajectory model + !do 8940 i=1,244 + ! write (*,*) 'zsec2:',i,ifield,zsec2(i),numskip + !940 continue + ! stop + ! SEC SEC SEC + ! for unknown reason zsec 1 to 10 is filled in this version + ! compared to the old one + ! SEC SEC SE + do i=1,nwz + j=numskip+i + k=nlev_ec+1+numskip+i + akm(nwz-i+1)=zsec2(j) + ! write (*,*) 'ifield:',ifield,k,j,zsec2(10+j) + bkm(nwz-i+1)=zsec2(k) + wheight(nwz-i+1)=akm(nwz-i+1)/101325.+bkm(nwz-i+1) ! From FLEXTRA + end do + + ! + ! CALCULATION OF AKZ, BKZ + ! AKZ,BKZ: model discretization parameters at the center of each model + ! layer + ! + ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0, + ! i.e. ground level + !***************************************************************************** + + akz(1)=0. + bkz(1)=1.0 + uvheight(1)=1. + do i=1,nuvz + uvheight(i+1)=0.5*(wheight(i+1)+wheight(i)) ! From FLEXTRA + akz(i+1)=0.5*(akm(i+1)+akm(i)) + bkz(i+1)=0.5*(bkm(i+1)+bkm(i)) + end do + ! exuvheight=wheight + nuvz=nuvz+1 + + ! 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_nest.f + !***************************************************************************** + + nz=nuvz + if (nz.gt.nzmax) stop 'nzmax too small' + do i=1,nuvz + aknew(i)=akz(i) + bknew(i)=bkz(i) + end do + + ! 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 + return + +999 write(*,*) + write(*,*) ' ###########################################'// & + '###### ' + write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:' + write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn) + write(*,*) ' ###########################################'// & + '###### ' + write(*,*) + write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!' + write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!' + write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!' + write(*,'(a)') '!!! THE "X" KEY... !!!' + write(*,*) + read(*,'(a)') opt + if(opt.eq.'X') then + stop + else + goto 5 + endif +end subroutine gridcheck_ecmwf diff --git a/src/win_gridcheck_gfs.f90 b/src/win_gridcheck_gfs.f90 new file mode 100644 index 0000000000000000000000000000000000000000..c8d122aca88425c2f3a939311abfbcfd2fa40a56 --- /dev/null +++ b/src/win_gridcheck_gfs.f90 @@ -0,0 +1,521 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine gridcheck_gfs + + !********************************************************************** + ! * + ! FLEXPART MODEL SUBROUTINE GRIDCHECK * + ! * + !********************************************************************** + ! * + ! AUTHOR: G. WOTAWA * + ! DATE: 1997-08-06 * + ! LAST UPDATE: 1997-10-10 * + ! * + ! Update: 1999-02-08, global fields allowed, A. Stohl* + ! CHANGE: 17/11/2005, Caroline Forster, GFS data * + ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with * + ! ECMWF grib_api * + ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with * + ! ECMWF grib_api * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! - Renamed routine from gridcheck to gridcheck_gfs * + ! * + !********************************************************************** + ! * + ! DESCRIPTION: * + ! * + ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT * + ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- * + ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE * + ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES * + ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT * + ! ANY CALL. * + ! * + ! XLON0 geographical longitude of lower left gridpoint * + ! YLAT0 geographical latitude of lower left gridpoint * + ! NX number of grid points x-direction * + ! NY number of grid points y-direction * + ! DX grid distance x-direction * + ! DY grid distance y-direction * + ! NUVZ number of grid points for horizontal wind * + ! components in z direction * + ! NWZ number of grid points for vertical wind * + ! component in z direction * + ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid* + ! points of the polar stereographic grid): * + ! used to check the CFL criterion * + ! UVHEIGHT(1)- heights of gridpoints where u and v are * + ! UVHEIGHT(NUVZ) given * + ! WHEIGHT(1)- heights of gridpoints where w is given * + ! WHEIGHT(NWZ) * + ! * + !********************************************************************** + + use grib_api + use cmapf_mod, only: stlmbr,stcm2p + + implicit none + + !HSO parameters for grib_api + integer :: ifile + integer :: iret + integer :: igrib + real(kind=4) :: xaux1,xaux2,yaux1,yaux2 + real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in + integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl + !HSO end + integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip + real :: sizesouth,sizenorth,xauxa,pint + real :: akm_usort(nwzmax) + real,parameter :: eps=0.0001 + + ! NCEP GFS + real :: pres(nwzmax), help + + integer :: i179,i180,i181 + + ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING + + integer :: isec1(8),isec2(3) + real(kind=4) :: zsec4(jpunp) + character(len=1) :: opt + + !HSO grib api error messages + character(len=24) :: gribErrorMsg = 'Error reading grib file' + character(len=20) :: gribFunction = 'gridcheckwind_gfs' + ! + if (numbnests.ge.1) then + write(*,*) ' ###########################################' + write(*,*) ' FLEXPART ERROR SUBROUTINE GRIDCHECK:' + write(*,*) ' NO NESTED WINDFIELDAS ALLOWED FOR GFS! ' + write(*,*) ' ###########################################' + stop + endif + + iumax=0 + iwmax=0 + + if(ideltas.gt.0) then + ifn=1 + else + ifn=numbwf + endif + ! + ! OPENING OF DATA FILE (GRIB CODE) + ! +5 call grib_open_file(ifile,path(3)(1:length(3)) & + //trim(wfname(ifn)),'r',iret) + if (iret.ne.GRIB_SUCCESS) then + goto 999 ! ERROR DETECTED + endif + !turn on support for multi fields messages + call grib_multi_support_on + + ifield=0 + do + ifield=ifield+1 + ! + ! GET NEXT FIELDS + ! + call grib_new_from_file(ifile,igrib,iret) + if (iret.eq.GRIB_END_OF_FILE ) then + exit ! EOF DETECTED + elseif (iret.ne.GRIB_SUCCESS) then + goto 999 ! ERROR DETECTED + endif + + !first see if we read GRIB1 or GRIB2 + call grib_get_int(igrib,'editionNumber',gribVer,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + if (gribVer.eq.1) then ! GRIB Edition 1 + + !read the grib1 identifiers + call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'level',isec1(8),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + !get the size and data of the values array + call grib_get_real4_array(igrib,'values',zsec4,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + else ! GRIB Edition 2 + + !read the grib2 identifiers + call grib_get_int(igrib,'discipline',discipl,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterCategory',parCat,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterNumber',parNum,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', & + ivalsfc,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + !convert to grib1 identifiers + isec1(6)=-1 + isec1(7)=-1 + isec1(8)=-1 + if ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.100)) then ! U + isec1(6)=33 ! indicatorOfParameter + isec1(7)=100 ! indicatorOfTypeOfLevel + isec1(8)=ivalsfc/100 ! level, convert to hPa + elseif ((parCat.eq.3).and.(parNum.eq.5).and.(sfctyp.eq.1)) then ! TOPO + isec1(6)=7 ! indicatorOfParameter + isec1(7)=1 ! indicatorOfTypeOfLevel + isec1(8)=0 + elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.1) & + .and.(discipl.eq.2)) then ! LSM + isec1(6)=81 ! indicatorOfParameter + isec1(7)=1 ! indicatorOfTypeOfLevel + isec1(8)=0 + endif + + if (isec1(6).ne.-1) then + ! get the size and data of the values array + call grib_get_real4_array(igrib,'values',zsec4,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + endif + + endif ! gribVer + + if(ifield.eq.1) then + + !get the required fields from section 2 + !store compatible to gribex input + call grib_get_int(igrib,'numberOfPointsAlongAParallel', & + isec2(2),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & + isec2(3),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & + xaux1in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', & + xaux2in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & + yaux1in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', & + yaux2in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + ! Fix for flexpart.eu ticket #48 + if (xaux2in.lt.0) xaux2in = 359.0 + + xaux1=xaux1in + xaux2=xaux2in + yaux1=yaux1in + yaux2=yaux2in + + nxfield=isec2(2) + ny=isec2(3) + if((abs(xaux1).lt.eps).and.(xaux2.ge.359)) then ! NCEP DATA FROM 0 TO + xaux1=-179.0 ! 359 DEG EAST -> + xaux2=-179.0+360.-360./real(nxfield) ! TRANSFORMED TO -179 + endif ! TO 180 DEG EAST + if (xaux1.gt.180) xaux1=xaux1-360.0 + if (xaux2.gt.180) xaux2=xaux2-360.0 + if (xaux1.lt.-180) xaux1=xaux1+360.0 + if (xaux2.lt.-180) xaux2=xaux2+360.0 + if (xaux2.lt.xaux1) xaux2=xaux2+360. + xlon0=xaux1 + ylat0=yaux1 + dx=(xaux2-xaux1)/real(nxfield-1) + dy=(yaux2-yaux1)/real(ny-1) + dxconst=180./(dx*r_earth*pi) + dyconst=180./(dy*r_earth*pi) + !HSO end edits + + + ! Check whether fields are global + ! If they contain the poles, specify polar stereographic map + ! projections using the stlmbr- and stcm2p-calls + !*********************************************************** + + xauxa=abs(xaux2+dx-360.-xaux1) + if (xauxa.lt.0.001) then + nx=nxfield+1 ! field is cyclic + xglobal=.true. + if (abs(nxshift).ge.nx) & + stop 'nxshift in file par_mod is too large' + xlon0=xlon0+real(nxshift)*dx + else + nx=nxfield + xglobal=.false. + if (nxshift.ne.0) & + stop 'nxshift (par_mod) must be zero for non-global domain' + endif + nxmin1=nx-1 + nymin1=ny-1 + if (xlon0.gt.180.) xlon0=xlon0-360. + xauxa=abs(yaux1+90.) + if (xglobal.and.xauxa.lt.0.001) then + sglobal=.true. ! field contains south pole + ! Enhance the map scale by factor 3 (*2=6) compared to north-south + ! map scale + sizesouth=6.*(switchsouth+90.)/dy + call stlmbr(southpolemap,-90.,0.) + call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, & + sizesouth,switchsouth,180.) + switchsouthg=(switchsouth-ylat0)/dy + else + sglobal=.false. + switchsouthg=999999. + endif + xauxa=abs(yaux2-90.) + if (xglobal.and.xauxa.lt.0.001) then + nglobal=.true. ! field contains north pole + ! Enhance the map scale by factor 3 (*2=6) compared to north-south + ! map scale + sizenorth=6.*(90.-switchnorth)/dy + call stlmbr(northpolemap,90.,0.) + call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, & + sizenorth,switchnorth,180.) + switchnorthg=(switchnorth-ylat0)/dy + else + nglobal=.false. + switchnorthg=999999. + endif + endif ! ifield.eq.1 + + if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative' + if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large' + + ! NCEP ISOBARIC LEVELS + !********************* + + if((isec1(6).eq.33).and.(isec1(7).eq.100)) then ! check for U wind + iumax=iumax+1 + pres(iumax)=real(isec1(8))*100.0 + endif + + + i179=nint(179./dx) + if (dx.lt.0.7) then + i180=nint(180./dx)+1 ! 0.5 deg data + else + i180=nint(179./dx)+1 ! 1 deg data + endif + i181=i180+1 + + + ! NCEP TERRAIN + !************* + + if (isec1(6).eq.007 .and. isec1(7).eq.001) then + ! IP 2023-05-09: allocate fields missing for GFS reading + call fixedfields_alloc + do jy=0,ny-1 + do ix=0,nxfield-1 + help=zsec4(nxfield*(ny-jy-1)+ix+1) + if(ix.le.i180) then + oro(i179+ix,jy)=help + excessoro(i179+ix,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED + else + oro(ix-i181,jy)=help + excessoro(ix-i181,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED + endif + end do + end do + endif + + ! NCEP LAND SEA MASK + !******************* + + if((isec1(6).eq.081).and.(isec1(7).eq.001)) then + do jy=0,ny-1 + do ix=0,nxfield-1 + help=zsec4(nxfield*(ny-jy-1)+ix+1) + if(ix.le.i180) then + lsm(i179+ix,jy)=help + else + lsm(ix-i181,jy)=help + endif + end do + end do + endif + + call grib_release(igrib) + + end do !! READ NEXT LEVEL OR PARAMETER + ! + ! CLOSING OF INPUT DATA FILE + ! + + ! HSO + call grib_close_file(ifile) + ! HSO end edits + + nuvz=iumax + nwz =iumax + nlev_ec=iumax + + ! ! Assing grid values and allocate memory to read windfields + ! nxmax=nx + ! nymax=ny + ! nwzmax=nwz + ! nuvzmax=nuvz + ! nzmax=nuvz + ! ! nconvlevmax=nuvzmax-1 + ! ! na=nconvlevmax+1 + + ! call alloc_windf + + if (nx.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,nxmax + stop + endif + + if (ny.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,nymax + stop + endif + + if (nuvz.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,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 + + ! 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 + + ! Output of grid info + !******************** + + if (lroot) then + write(*,*) + write(*,*) + write(*,'(a,2i7)') 'Vertical levels in NCEP data: ', & + nuvz,nwz + write(*,*) + write(*,'(a)') 'Mother domain:' + write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', & + xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx + write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range : ', & + ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy + write(*,*) + end if + + ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL + ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM + + numskip=nlev_ec-nuvz ! number of ecmwf model layers not used + ! by trajectory model + do i=1,nwz + j=numskip+i + k=nlev_ec+1+numskip+i + akm_usort(nwz-i+1)=pres(nwz-i+1) + bkm(nwz-i+1)=0.0 + end do + + !****************************** + ! change Sabine Eckhardt: akm should always be in descending order ... readwind adapted! + !****************************** + do i=1,nwz + if (akm_usort(1).gt.akm_usort(2)) then + akm(i)=akm_usort(i) + else + akm(i)=akm_usort(nwz-i+1) + endif + end do + + ! + ! CALCULATION OF AKZ, BKZ + ! AKZ,BKZ: model discretization parameters at the center of each model + ! layer + ! + ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0, + ! i.e. ground level + !***************************************************************************** + + do i=1,nuvz + akz(i)=akm(i) + bkz(i)=bkm(i) + end do + + ! 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_nest.f + !***************************************************************************** + + nz=nuvz + if (nz.gt.nzmax) stop 'nzmax too small' + do i=1,nuvz + aknew(i)=akz(i) + bknew(i)=bkz(i) + end do + + ! 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 + return + +999 write(*,*) + write(*,*) ' ###########################################'// & + '###### ' + write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:' + write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn) + write(*,*) ' ###########################################'// & + '###### ' + write(*,*) + write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!' + write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!' + write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!' + write(*,'(a)') '!!! THE "X" KEY... !!!' + write(*,*) + read(*,'(a)') opt + if(opt.eq.'X') then + stop + else + goto 5 + endif + +end subroutine gridcheck_gfs diff --git a/src/win_gridcheck_nest.f90 b/src/win_gridcheck_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..9912f236546fd81ff899c7544c4de5ea67701414 --- /dev/null +++ b/src/win_gridcheck_nest.f90 @@ -0,0 +1,449 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine gridcheck_nest + + !***************************************************************************** + ! * + ! This routine checks the grid specification for the nested model * + ! domains. It is similar to subroutine gridcheck, which checks the * + ! mother domain. * + ! * + ! Authors: A. Stohl, G. Wotawa * + ! * + ! 8 February 1999 * + ! * + !***************************************************************************** + ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api * + ! CHANGE: 03/12/2008, Harald Sodemann, change to f90 grib_api * + !***************************************************************************** + + use grib_api + + implicit none + + !HSO parameters for grib_api + integer :: ifile + integer :: iret + integer :: igrib + integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl + integer :: parID !added by mc for making it consistent with new gridcheck.f90 + integer :: gotGrib + !HSO end + integer :: i,j,k,l,ifn,ifield,iumax,iwmax,numskip,nlev_ecn + integer :: nuvzn,nwzn + real :: akmn(nwzmax),bkmn(nwzmax),akzn(nuvzmax),bkzn(nuvzmax) + real(kind=4) :: xaux1,xaux2,yaux1,yaux2 + real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in + real :: conversion_factor !added by mc to make it consistent with new gridchek.f90 + + ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING + + ! dimension of isec2 at least (22+n), where n is the number of parallels or + ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid + + ! dimension of zsec2 at least (10+nn), where nn is the number of vertical + ! coordinate parameters + + integer :: isec1(56),isec2(22+nxmaxn+nymaxn) + real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp) + + !HSO grib api error messages + character(len=24) :: gribErrorMsg = 'Error reading grib file' + character(len=20) :: gribFunction = 'gridcheck_nest' + + xresoln(0)=1. ! resolution enhancement for mother grid + yresoln(0)=1. ! resolution enhancement for mother grid + + ! Loop about all nesting levels + !****************************** + + do l=1,numbnests + + iumax=0 + iwmax=0 + + if(ideltas.gt.0) then + ifn=1 + else + ifn=numbwf + endif + ! + ! OPENING OF DATA FILE (GRIB CODE) + ! + ifile=0 + igrib=0 + iret=0 + +5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) & + (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,ifn)),'r',iret) + if (iret.ne.GRIB_SUCCESS) then + goto 999 ! ERROR DETECTED + endif + !turn on support for multi fields messages + !call grib_multi_support_on + + gotGrib=0 + ifield=0 + do + ifield=ifield+1 + + ! + ! GET NEXT FIELDS + ! + call grib_new_from_file(ifile,igrib,iret) + if (iret.eq.GRIB_END_OF_FILE) then + exit ! EOF DETECTED + elseif (iret.ne.GRIB_SUCCESS) then + goto 999 ! ERROR DETECTED + endif + + !first see if we read GRIB1 or GRIB2 + call grib_get_int(igrib,'editionNumber',gribVer,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + if (gribVer.eq.1) then ! GRIB Edition 1 + + !print*,'GRiB Edition 1' + !read the grib2 identifiers + call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'level',isec1(8),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + !change code for etadot to code for omega + if (isec1(6).eq.77) then + isec1(6)=135 + endif + + !print*,isec1(6),isec1(8) + + else + + !print*,'GRiB Edition 2' + !read the grib2 identifiers + call grib_get_int(igrib,'discipline',discipl,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterCategory',parCat,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterNumber',parNum,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'level',ivalsfc,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'paramId',parId,iret) !added by mc to make it consisitent with new grid_check.f90 + call grib_check(iret,gribFunction,gribErrorMsg) !added by mc to make it consisitent with new grid_check.f90 + + !print*,discipl,parCat,parNum,sfctyp,ivalsfc + + !convert to grib1 identifiers + isec1(6)=-1 + isec1(7)=-1 + isec1(8)=-1 + isec1(8)=ivalsfc ! level + if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! T + isec1(6)=130 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.105)) then ! U + isec1(6)=131 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.105)) then ! V + isec1(6)=132 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! Q + isec1(6)=133 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.83).and.(sfctyp.eq.105)) then ! clwc + isec1(6)=246 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.84).and.(sfctyp.eq.105)) then ! ciwc + isec1(6)=247 ! indicatorOfParameter + !ZHG end + ! ESO qc(=clwc+ciwc) + elseif ((parCat.eq.201).and.(parNum.eq.31).and.(sfctyp.eq.105)) then ! qc + isec1(6)=201031 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then !SP + isec1(6)=134 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot + isec1(6)=135 ! indicatorOfParameter + elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot !added bymc to make it consistent with new gridcheck.f90 + isec1(6)=135 ! indicatorOfParameter ! + elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.101)) then !SLP + isec1(6)=151 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! 10U + isec1(6)=165 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! 10V + isec1(6)=166 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! 2T + isec1(6)=167 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.6).and.(sfctyp.eq.103)) then ! 2D + isec1(6)=168 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SD + isec1(6)=141 ! indicatorOfParameter + elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC !added by mc to make it consistent with new gridchek.f90 + isec1(6)=164 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP !added by mc to make it consistent with new gridchek.f90 + isec1(6)=142 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP + isec1(6)=143 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SHF + isec1(6)=146 ! indicatorOfParameter + elseif ((parCat.eq.4).and.(parNum.eq.9).and.(sfctyp.eq.1)) then ! SR + isec1(6)=176 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.17) .or. parId .eq. 180) then ! EWSS !added by mc to make it consistent with new gridchek.f90 + isec1(6)=180 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.18) .or. parId .eq. 181) then ! NSSS !added by mc to make it consistent with new gridchek.f90 + isec1(6)=181 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO + isec1(6)=129 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO !added by mc to make it consistent with new gridchek.f90 + isec1(6)=160 ! indicatorOfParameter + elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. & + (sfctyp.eq.1)) then ! LSM + isec1(6)=172 ! indicatorOfParameter + else + print*,'***ERROR: undefined GRiB2 message found!',discipl, & + parCat,parNum,sfctyp + endif + if(parId .ne. isec1(6) .and. parId .ne. 77) then !added by mc to make it consistent with new gridchek.f90 + write(*,*) 'parId',parId, 'isec1(6)',isec1(6) + ! stop + endif + + endif + + !get the size and data of the values array + if (isec1(6).ne.-1) then + call grib_get_real4_array(igrib,'values',zsec4,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + endif + + !HSO get the required fields from section 2 in a gribex compatible manner + if (ifield.eq.1) then + call grib_get_int(igrib,'numberOfPointsAlongAParallel', & + isec2(2),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & + isec2(3),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'numberOfVerticalCoordinateValues', & + isec2(12),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + !HSO get the size and data of the vertical coordinate array + call grib_get_real4_array(igrib,'pv',zsec2,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + nxn(l)=isec2(2) + nyn(l)=isec2(3) + nlev_ecn=isec2(12)/2-1 + endif ! ifield + + if (nxn(l).gt.nxmaxn) then + write(*,*) 'FLEXPART error: Too many grid points in x direction.' + write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)' + write(*,*) 'for nesting level ',l + write(*,*) 'Or change parameter settings in file par_mod.' + write(*,*) nxn(l),nxmaxn + stop + endif + + if (nyn(l).gt.nymaxn) then + write(*,*) 'FLEXPART error: Too many grid points in y direction.' + write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)' + write(*,*) 'for nesting level ',l + write(*,*) 'Or change parameter settings in file par_mod.' + write(*,*) nyn(l),nymaxn + stop + endif + + !HSO get the second part of the grid dimensions only from GRiB1 messages + if (isec1(6) .eq. 167 .and. (gotGrib.eq.0)) then !added by mc to make it consistent with new gridchek.f90 note that gotGrid must be changed in gotGrib!! + call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & !comment by mc: note that this was in the (if (ifield.eq.1) ..end above in gridchek.f90 see line 257 + xaux1in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', & + xaux2in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & + yaux1in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', & + yaux2in,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + xaux1=xaux1in + xaux2=xaux2in + yaux1=yaux1in + yaux2=yaux2in + if(xaux1.gt.180.) xaux1=xaux1-360.0 + if(xaux2.gt.180.) xaux2=xaux2-360.0 + if(xaux1.lt.-180.) xaux1=xaux1+360.0 + if(xaux2.lt.-180.) xaux2=xaux2+360.0 + if (xaux2.lt.xaux1) xaux2=xaux2+360.0 + xlon0n(l)=xaux1 + ylat0n(l)=yaux1 + dxn(l)=(xaux2-xaux1)/real(nxn(l)-1) + dyn(l)=(yaux2-yaux1)/real(nyn(l)-1) + gotGrib=1 !commetn by mc note tahthere gotGRIB is used instead of gotGrid!!! + endif ! ifield.eq.1 + + k=isec1(8) + if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1) + if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1) + + if(isec1(6).eq.129) then + do j=0,nyn(l)-1 + do i=0,nxn(l)-1 + oron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga + end do + end do + endif + if(isec1(6).eq.172) then + do j=0,nyn(l)-1 + do i=0,nxn(l)-1 + lsmn(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga + end do + end do + endif + if(isec1(6).eq.160) then + do j=0,nyn(l)-1 + do i=0,nxn(l)-1 + excessoron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga + end do + end do + endif + + call grib_release(igrib) + end do !! READ NEXT LEVEL OR PARAMETER + ! + ! CLOSING OF INPUT DATA FILE + ! + + call grib_close_file(ifile) + + !error message if no fields found with correct first longitude in it + if (gotGrib.eq.0) then + print*,'***ERROR: input file needs to contain GRiB1 formatted'// & + 'messages' + stop + endif + + nuvzn=iumax + nwzn=iwmax + if(nuvzn.eq.nlev_ec) nwzn=nlev_ecn+1 + + if ((nuvzn.gt.nuvzmax).or.(nwzn.gt.nwzmax)) then + write(*,*) 'FLEXPART error: Nested wind fields have too many'// & + 'vertical levels.' + write(*,*) 'Problem was encountered for nesting level ',l + stop + endif + + + ! Output of grid info + !******************** + + write(*,'(a,i2,a)') ' Nested domain ',l,':' + write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Longitude range: ', & + xlon0n(l),' to ',xlon0n(l)+(nxn(l)-1)*dxn(l), & + ' Grid distance: ',dxn(l) + write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Latitude range : ', & + ylat0n(l),' to ',ylat0n(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=xlon0n(l) + xaux2=xlon0n(l)+real(nxn(l)-1)*dxn(l) + yaux1=ylat0n(l) + yaux2=ylat0n(l)+real(nyn(l)-1)*dyn(l) + + xln(l)=(xaux1-xlon0)/dx + xrn(l)=(xaux2-xlon0)/dx + yln(l)=(yaux1-ylat0)/dy + yrn(l)=(yaux2-ylat0)/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(*,*) 'Nested domain does not fit into mother domain' + write(*,*) 'For global mother domain fields, you can shift' + write(*,*) 'shift the mother domain into x-direction' + write(*,*) 'by setting nxshift (file par_mod) to a' + write(*,*) 'positive value. Execution is terminated.' + stop + endif + + + ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL + ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM + + numskip=nlev_ecn-nuvzn ! number of ecmwf model layers not used by FLEXPART + do i=1,nwzn + j=numskip+i + k=nlev_ecn+1+numskip+i + akmn(nwzn-i+1)=zsec2(j) + bkmn(nwzn-i+1)=zsec2(k) + end do + + ! + ! CALCULATION OF AKZ, BKZ + ! AKZ,BKZ: model discretization parameters at the center of each model + ! layer + ! + ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0, + ! i.e. ground level + !***************************************************************************** + + akzn(1)=0. + bkzn(1)=1.0 + do i=1,nuvzn + akzn(i+1)=0.5*(akmn(i+1)+akmn(i)) + bkzn(i+1)=0.5*(bkmn(i+1)+bkmn(i)) + end do + nuvzn=nuvzn+1 + + ! 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. + !************************************************************* + + do i=1,nuvz + if ((akzn(i).ne.akz(i)).or.(bkzn(i).ne.bkz(i))) then + write(*,*) 'FLEXPART error: The wind fields of nesting level',l + write(*,*) 'are not consistent with the mother domain:' + write(*,*) 'Differences in vertical levels detected.' + stop + endif + end do + + do i=1,nwz + if ((akmn(i).ne.akm(i)).or.(bkmn(i).ne.bkm(i))) then + write(*,*) 'FLEXPART error: The wind fields of nesting level',l + write(*,*) 'are not consistent with the mother domain:' + write(*,*) 'Differences in vertical levels detected.' + stop + endif + end do + + end do + + return + +999 write(*,*) + write(*,*) ' ###########################################'// & + '###### ' + write(*,*) ' FLEXPART SUBROUTINE GRIDCHECK:' + write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfnamen(l,ifn) + write(*,*) ' FOR NESTING LEVEL ',k + write(*,*) ' ###########################################'// & + '###### ' + stop + +end subroutine gridcheck_nest diff --git a/src/win_readwind_ecmwf.f90 b/src/win_readwind_ecmwf.f90 new file mode 100644 index 0000000000000000000000000000000000000000..3a8f521cc523e2df08afe15672dc51d5425f429b --- /dev/null +++ b/src/win_readwind_ecmwf.f90 @@ -0,0 +1,683 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh) + + !********************************************************************** + ! * + ! TRAJECTORY MODEL SUBROUTINE READWIND * + ! * + !********************************************************************** + ! * + ! AUTHOR: G. WOTAWA * + ! DATE: 1997-08-05 * + ! LAST UPDATE: 2000-10-17, Andreas Stohl * + ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with * + ! ECMWF grib_api * + ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with * + ! ECMWF grib_api * + ! * + !********************************************************************** + ! Changes, Bernd C. Krueger, Feb. 2001: + ! Variables tth and qvh (on eta coordinates) in common block + ! + ! Unified ECMWF and GFS builds + ! Marian Harustak, 12.5.2017 + ! - Renamed from readwind to readwind_ecmwf + ! + ! L. Bakels, 2021: OpenMP parallelisation (following CTM 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 vertical levels ecmwf model * + ! uu,vv,ww wind fields * + ! tt,qv temperature and specific humidity * + ! ps surface pressure * + ! * + !********************************************************************** + + use grib_api + + implicit none + + ! include 'grib_api.h' + + !HSO parameters for grib_api + integer :: ifile + integer :: iret + integer, dimension(:), allocatable :: igrib + integer :: nfield, ii, arsize + integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl,parId + integer :: gotGrid + ! HSO end + + 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) + integer :: indj,i,j,k,n,levdiff2,iumax,iwmax!,ifield + integer :: kz + + ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING + + ! dimension of isec2 at least (22+n), where n is the number of parallels or + ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid + + ! dimension of zsec2 at least (10+nn), where nn is the number of vertical + ! coordinate parameters + + integer :: isec1(56),isec2(22+nxmax+nymax) + real(kind=4), allocatable, dimension(:) :: zsec4 + ! real(kind=4) :: zsec4(jpunp) + real(kind=4) :: xaux,yaux,xaux0,yaux0 + real(kind=8) :: xauxin,yauxin + real,parameter :: eps=1.e-4 + real(kind=4) :: nsss(0:nxmax-1,0:nymax-1),ewss(0:nxmax-1,0:nymax-1) + real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1,conversion_factor + integer :: stat + + logical :: hflswitch,strswitch!,readcloud + + !HSO grib api error messages + character(len=24) :: gribErrorMsg = 'Error reading grib file' + character(len=20) :: gribFunction = 'readwind' + + hflswitch=.false. + strswitch=.false. + !ZHG test the grib fields that have lcwc without using them + ! readcloud=.false. + + levdiff2=nlev_ec-nwz+1 + iumax=0 + iwmax=0 + + ! + ! OPENING OF DATA FILE (GRIB CODE) + ! + call grib_open_file(ifile,path(3)(1:length(3)) & + //trim(wfname(indj)),'r',iret) + if (iret.ne.GRIB_SUCCESS) then + goto 888 ! ERROR DETECTED + endif + + call grib_count_in_file(ifile,nfield) + + ! allocate memory for grib handles + allocate(igrib(nfield), stat=stat) + if (stat.ne.0) stop "Could not allocate igrib" + ! initialise + igrib(:) = -1 + + do ii = 1,nfield + call grib_new_from_file(ifile, igrib(ii), iret) + end do + + call grib_close_file(ifile) + + !turn on support for multi fields messages */ + !call grib_multi_support_on + + gotGrid=0 + +!$OMP PARALLEL DEFAULT(none) & +!$OMP SHARED (nfield, igrib, gribFunction, nxfield, ny, nlev_ec, dx, xlon0, ylat0, & +!$OMP n, tth, uuh, vvh, iumax, qvh, ps, wwh, iwmax, sd, msl, tcc, u10, v10, tt2, & +!$OMP td2, lsprec, convprec, sshf, hflswitch, ssr, ewss, nsss, strswitch, oro, & +!$OMP excessoro, lsm, nymin1,ciwch,clwch,readclouds,sumclouds, nxshift) & +!$OMP PRIVATE(ii, gribVer, iret, isec1, discipl, parCat, parNum, parId,sfctyp, ivalsfc, & +!$OMP zsec4, isec2, gribErrorMsg, xauxin, yauxin, xaux, yaux, xaux0, & +!$OMP yaux0, k, arsize, stat, conversion_factor) & +!$OMP REDUCTION(+:gotGrid) + ! + ! GET NEXT FIELDS + ! + ! allocate memory for reading from grib + allocate(zsec4(nxfield*ny), stat=stat) + if (stat.ne.0) stop "Could not allocate zsec4" + +!$OMP DO SCHEDULE(static) + + fieldloop : do ii=1,nfield + + !first see if we read GRIB1 or GRIB2 + call grib_get_int(igrib(ii),'editionNumber',gribVer,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + if (gribVer.eq.1) then ! GRIB Edition 1 + + !print*,'GRiB Edition 1' + !read the grib2 identifiers + call grib_get_int(igrib(ii),'indicatorOfParameter',isec1(6),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib(ii),'level',isec1(8),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + !change code for etadot to code for omega + if (isec1(6).eq.77) then + isec1(6)=135 + endif + + conversion_factor=1. + + else + + !print*,'GRiB Edition 2' + !read the grib2 identifiers + call grib_get_int(igrib(ii),'discipline',discipl,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib(ii),'parameterCategory',parCat,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib(ii),'parameterNumber',parNum,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib(ii),'typeOfFirstFixedSurface',sfctyp,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib(ii),'level',ivalsfc,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib(ii),'paramId',parId,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + !print*,discipl,parCat,parNum,sfctyp,ivalsfc + + !convert to grib1 identifiers + isec1(6)=-1 + isec1(7)=-1 + isec1(8)=-1 + isec1(8)=ivalsfc ! level + conversion_factor=1. + if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! T + isec1(6)=130 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.105)) then ! U + isec1(6)=131 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.105)) then ! V + isec1(6)=132 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! Q + isec1(6)=133 ! indicatorOfParameter + ! ESO Cloud water is in a) fields CLWC and CIWC, *or* b) field QC + elseif ((parCat.eq.1).and.(parNum.eq.83).and.(sfctyp.eq.105)) then ! clwc + isec1(6)=246 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.84).and.(sfctyp.eq.105)) then ! ciwc + isec1(6)=247 ! indicatorOfParameter + ! ESO qc(=clwc+ciwc): + elseif ((parCat.eq.201).and.(parNum.eq.31).and.(sfctyp.eq.105)) then ! qc + isec1(6)=201031 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then !SP + isec1(6)=134 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot + isec1(6)=135 ! indicatorOfParameter + elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot + isec1(6)=135 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.101)) then !SLP + isec1(6)=151 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! 10U + isec1(6)=165 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! 10V + isec1(6)=166 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! 2T + isec1(6)=167 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.6).and.(sfctyp.eq.103)) then ! 2D + isec1(6)=168 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SD + isec1(6)=141 ! indicatorOfParameter + conversion_factor=1000. + elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC + isec1(6)=164 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP + isec1(6)=142 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP + isec1(6)=143 ! indicatorOfParameter + conversion_factor=1000. + elseif ((parCat.eq.0).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SHF + isec1(6)=146 ! indicatorOfParameter + elseif ((parCat.eq.4).and.(parNum.eq.9).and.(sfctyp.eq.1)) then ! SR + isec1(6)=176 ! indicatorOfParameter + ! elseif ((parCat.eq.2).and.(parNum.eq.17) .or. parId .eq. 180) then ! EWSS --wrong + elseif ((parCat.eq.2).and.(parNum.eq.38) .or. parId .eq. 180) then ! EWSS --correct + isec1(6)=180 ! indicatorOfParameter + ! elseif ((parCat.eq.2).and.(parNum.eq.18) .or. parId .eq. 181) then ! NSSS --wrong + elseif ((parCat.eq.2).and.(parNum.eq.37) .or. parId .eq. 181) then ! NSSS --correct + isec1(6)=181 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO + isec1(6)=129 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO + isec1(6)=160 ! indicatorOfParameter + elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. & + (sfctyp.eq.1)) then ! LSM + isec1(6)=172 ! indicatorOfParameter + elseif (parNum.eq.152) then + isec1(6)=152 ! avoid warning for lnsp + else + print*,'***WARNING: undefined GRiB2 message found!',discipl, & + parCat,parNum,sfctyp + endif + if(parId .ne. isec1(6) .and. parId .ne. 77) then + write(*,*) 'parId',parId, 'isec1(6)',isec1(6) + ! stop + endif + + endif + + !HSO get the size and data of the values array + if (isec1(6).ne.-1) then + call grib_get_real4_array(igrib(ii),'values',zsec4,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + endif + + !HSO get the required fields from section 2 in a gribex compatible manner + if (ii.eq.1) then + call grib_get_int(igrib(ii),'numberOfPointsAlongAParallel',isec2(2),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib(ii),'numberOfPointsAlongAMeridian',isec2(3),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib(ii),'numberOfVerticalCoordinateValues',isec2(12)) + call grib_check(iret,gribFunction,gribErrorMsg) + ! CHECK GRID SPECIFICATIONS + if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT' + if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT' + if(isec2(12)/2-1.ne.nlev_ec) & + stop 'READWIND: VERTICAL DISCRETIZATION NOT CONSISTENT' + endif ! ifield + +!$OMP CRITICAL + !HSO get the second part of the grid dimensions only from GRiB1 messages + if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then + call grib_get_real8(igrib(ii),'longitudeOfFirstGridPointInDegrees', & + xauxin,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib(ii),'latitudeOfLastGridPointInDegrees', & + yauxin,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + if (xauxin.gt.180.) xauxin=xauxin-360.0 + if (xauxin.lt.-180.) xauxin=xauxin+360.0 + + xaux=xauxin+real(nxshift)*dx + yaux=yauxin + if (xaux.gt.180.) xaux=xaux-360.0 + if(abs(xaux-xlon0).gt.eps) & + stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT' + if(abs(yaux-ylat0).gt.eps) & + stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT' + gotGrid=1 + endif ! gotGrid +!$OMP END CRITICAL + + k=isec1(8) + select case(isec1(6)) + !! TEMPERATURE + case(130) + do j=0,nymin1 + do i=0,nxfield-1 + tth(i,j,nlev_ec-k+2,n) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! U VELOCITY + case(131) + do j=0,nymin1 + do i=0,nxfield-1 + uuh(i,j,nlev_ec-k+2) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do +!$OMP CRITICAL + iumax=max(iumax,nlev_ec-k+1) +!$OMP END CRITICAL + !! V VELOCITY + case(132) + do j=0,nymin1 + do i=0,nxfield-1 + vvh(i,j,nlev_ec-k+2) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! SPEC. HUMIDITY + case(133) + do j=0,nymin1 + do i=0,nxfield-1 + qvh(i,j,nlev_ec-k+2,n) = zsec4(nxfield*(ny-j-1)+i+1) + if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) & + qvh(i,j,nlev_ec-k+2,n) = 0. + ! this is necessary because the gridded data may contain + ! spurious negative values + end do + end do + !! SURF. PRESS. + case(134) + do j=0,nymin1 + do i=0,nxfield-1 + ps(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! W VELOCITY + case(135) + do j=0,nymin1 + do i=0,nxfield-1 + wwh(i,j,nlev_ec-k+1) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do +!$OMP CRITICAL + iwmax=max(iwmax,nlev_ec-k+1) +!$OMP END CRITICAL + !! SNOW DEPTH + case(141) + do j=0,nymin1 + do i=0,nxfield-1 + sd(i,j,1,n)= zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor + end do + end do + !! SEA LEVEL PRESS. + case(151) + do j=0,nymin1 + do i=0,nxfield-1 + msl(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! CLOUD COVER + case(164) + do j=0,nymin1 + do i=0,nxfield-1 + tcc(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! 10 M U VELOCITY + case(165) + do j=0,nymin1 + do i=0,nxfield-1 + u10(i,j,1,n)= zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! 10 M V VELOCITY + case(166) + do j=0,nymin1 + do i=0,nxfield-1 + v10(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! 2 M TEMPERATURE + case(167) + do j=0,nymin1 + do i=0,nxfield-1 + tt2(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! 2 M DEW POINT + case(168) + do j=0,nymin1 + do i=0,nxfield-1 + td2(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! LARGE SCALE PREC. + case(142) + do j=0,nymin1 + do i=0,nxfield-1 + lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1) + if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0. + end do + end do + !! CONVECTIVE PREC. + case(143) + do j=0,nymin1 + do i=0,nxfield-1 + convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor + if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0. + end do + end do + !! SENS. HEAT FLUX + case(146) + do j=0,nymin1 + do i=0,nxfield-1 + sshf(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) +!$OMP CRITICAL + if(zsec4(nxfield*(ny-j-1)+i+1).ne.0.) & + hflswitch=.true. ! Heat flux available +!$OMP END CRITICAL + end do + end do + !! SOLAR RADIATION + case(176) + do j=0,nymin1 + do i=0,nxfield-1 + ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1) + if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0. + end do + end do + !! EW SURFACE STRESS + case(180) + do j=0,nymin1 + do i=0,nxfield-1 + ewss(i,j) = zsec4(nxfield*(ny-j-1)+i+1) +!$OMP CRITICAL + if (zsec4(nxfield*(ny-j-1)+i+1).ne.0.) strswitch=.true. ! stress available +!$OMP END CRITICAL + end do + end do + !! NS SURFACE STRESS + case(181) + do j=0,nymin1 + do i=0,nxfield-1 + nsss(i,j) = zsec4(nxfield*(ny-j-1)+i+1) +!$OMP CRITICAL + if (zsec4(nxfield*(ny-j-1)+i+1).ne.0.) strswitch=.true. ! stress available +!$OMP END CRITICAL + end do + end do + !! ECMWF OROGRAPHY + case(129) + do j=0,nymin1 + do i=0,nxfield-1 + oro(i,j) = zsec4(nxfield*(ny-j-1)+i+1)/ga + end do + end do + !! STANDARD DEVIATION OF OROGRAPHY + case(160) + do j=0,nymin1 + do i=0,nxfield-1 + excessoro(i,j) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! ECMWF LAND SEA MASK + case(172) + do j=0,nymin1 + do i=0,nxfield-1 + lsm(i,j) = zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !! CLWC Cloud liquid water content [kg/kg] + case(246) + do j=0,nymin1 + do i=0,nxfield-1 + clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1) + end do + end do +!$OMP CRITICAL + readclouds=.true. + sumclouds=.false. +!$OMP END CRITICAL + !! CIWC Cloud ice water content + case(247) + do j=0,nymin1 + do i=0,nxfield-1 + ciwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1) + end do + end do + !ZHG end + !ESO read qc (=clwc+ciwc) + !! QC Cloud liquid water content [kg/kg] + case(201031) + do j=0,nymin1 + do i=0,nxfield-1 + clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1) + end do + end do +!$OMP CRITICAL + readclouds=.true. + sumclouds=.false. +!$OMP END CRITICAL + + end select + + call grib_release(igrib(ii)) + + end do fieldloop +!$OMP END DO + deallocate(zsec4) +!$OMP END PARALLEL + + deallocate(igrib) + ! + ! CLOSING OF INPUT DATA FILE + ! + + ! 50 call grib_close_file(ifile) + + !error message if no fields found with correct first longitude in it + if (gotGrid.eq.0) then + print*,'***ERROR: input file needs to contain GRiB1 formatted'// & + 'messages' + stop + endif + + if(levdiff2.eq.0) then + iwmax=nlev_ec+1 + do i=0,nxmin1 + do j=0,nymin1 + wwh(i,j,nlev_ec+1)=0. + end do + end do + endif + + ! For global fields, assign the leftmost data column also to the rightmost + ! data column; if required, shift whole grid by nxshift grid points + !************************************************************************* + + 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) + !ZHG + call shift_field(clwch,nxfield,ny,nuvzmax,nuvz,2,n) + if (.not.sumclouds) call shift_field(ciwch,nxfield,ny,nuvzmax,nuvz,2,n) + !ZHG end + + endif + + do i=0,nxmin1 + do j=0,nymin1 + if ((ewss(i,j).eq.0.).and.(nsss(i,j).eq.0.)) then + if ((i.ne.0).and.(j.ne.0).and.(i.ne.nxmin1).and.(j.ne.nymin1)) then + ewss(i,j)=(ewss(i-1,j-1)+ewss(i+1,j+1)+ewss(i+1,j)+ewss(i-1,j)+ & + ewss(i,j+1)+ewss(i,j-1)+ewss(i-1,j+1)+ewss(i+1,j-1))/8. + nsss(i,j)=(nsss(i-1,j-1)+nsss(i+1,j+1)+nsss(i+1,j)+nsss(i-1,j)+ & + nsss(i,j+1)+nsss(i,j-1)+nsss(i-1,j+1)+nsss(i+1,j-1))/8. + else if ((i.eq.0).and.(j.eq.0)) then + ewss(i,j)=(ewss(i+1,j+1)+ewss(i+1,j)+ewss(i,j+1))/3. + nsss(i,j)=(nsss(i+1,j+1)+nsss(i+1,j)+nsss(i,j+1))/3. + else if ((i.eq.nxmin1).and.(j.eq.nymin1)) then + ewss(i,j)=(ewss(i-1,j-1)+ewss(i-1,j)+ewss(i,j-1))/3. + nsss(i,j)=(nsss(i-1,j-1)+nsss(i-1,j)+nsss(i,j-1))/3. + else if ((i.eq.0).and.(j.eq.nymin1)) then + ewss(i,j)=(ewss(i+1,j-1)+ewss(i+1,j)+ewss(i,j-1))/3. + nsss(i,j)=(nsss(i+1,j-1)+nsss(i+1,j)+nsss(i,j-1))/3. + else if ((i.eq.nxmin1).and.(j.eq.0)) then + ewss(i,j)=(ewss(i-1,j+1)+ewss(i-1,j)+ewss(i,j+1))/3. + nsss(i,j)=(nsss(i-1,j+1)+nsss(i-1,j)+nsss(i,j+1))/3. + else if (i.eq.0) then + ewss(i,j)=(ewss(i+1,j+1)+ewss(i+1,j)+ewss(i,j+1)+ewss(i,j-1)+ewss(i+1,j-1))/5. + nsss(i,j)=(nsss(i+1,j+1)+nsss(i+1,j)+nsss(i,j+1)+nsss(i,j-1)+nsss(i+1,j-1))/5. + else if (i.eq.nxmin1) then + ewss(i,j)=(ewss(i-1,j+1)+ewss(i-1,j)+ewss(i,j+1)+ewss(i,j-1)+ewss(i-1,j-1))/5. + nsss(i,j)=(nsss(i-1,j+1)+nsss(i-1,j)+nsss(i,j+1)+nsss(i,j-1)+nsss(i-1,j-1))/5. + else if (j.eq.0) then + ewss(i,j)=(ewss(i+1,j+1)+ewss(i+1,j)+ewss(i-1,j)+ewss(i,j+1)+ewss(i-1,j+1))/5. + nsss(i,j)=(nsss(i+1,j+1)+nsss(i+1,j)+nsss(i-1,j)+nsss(i,j+1)+nsss(i-1,j+1))/5. + else if (j.eq.nymin1) then + ewss(i,j)=(ewss(i+1,j-1)+ewss(i+1,j)+ewss(i-1,j)+ewss(i,j-1)+ewss(i-1,j-1))/5. + nsss(i,j)=(nsss(i+1,j-1)+nsss(i+1,j)+nsss(i-1,j)+nsss(i,j-1)+nsss(i-1,j-1))/5. + endif + endif + sfcstress(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2) + end do + end do + + if ((.not.hflswitch).or.(.not.strswitch)) then + write(*,*) 'WARNING: No flux data contained in GRIB 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 + !*************************************************************************** + + do i=0,nxmin1 + do j=0,nymin1 + plev1=akz(3)+bkz(3)*ps(i,j,1,n) + pmean=0.5*(ps(i,j,1,n)+plev1) + tv=tth(i,j,3,n)*(1.+0.61*qvh(i,j,3,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,3)**2+vvh(i,j,3)**2) + call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, & + tt2(i,j,1,n),tth(i,j,3,n),ff10m,fflev1, & + sfcstress(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. + end do + end do + 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 + !************************************************************************** + + do i=0,nxmin1 + do j=0,nymin1 + uuh(i,j,1)=u10(i,j,1,n) + vvh(i,j,1)=v10(i,j,1,n) + qvh(i,j,1,n)=qvh(i,j,2,n) + tth(i,j,1,n)=tt2(i,j,1,n) + end do + end do + + if(iumax.ne.nuvz-1) stop 'READWIND: NUVZ NOT CONSISTENT' + if(iwmax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT' + + return + +888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' + write(*,*) ' #### ',wfname(indj),' #### ' + write(*,*) ' #### IS NOT GRIB FORMAT !!! #### ' + stop 'Execution terminated' + +end subroutine readwind_ecmwf diff --git a/src/win_readwind_gfs.f90 b/src/win_readwind_gfs.f90 new file mode 100644 index 0000000000000000000000000000000000000000..d5811d2db02fc01281af617e97da7d78c9a65124 --- /dev/null +++ b/src/win_readwind_gfs.f90 @@ -0,0 +1,734 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readwind_gfs(indj,n,uuh,vvh,wwh) + + !*********************************************************************** + !* * + !* TRAJECTORY MODEL SUBROUTINE READWIND * + !* * + !*********************************************************************** + !* * + !* AUTHOR: G. WOTAWA * + !* DATE: 1997-08-05 * + !* LAST UPDATE: 2000-10-17, Andreas Stohl * + !* CHANGE: 01/02/2001, Bernd C. Krueger, Variables tth and * + !* qvh (on eta coordinates) in common block * + !* CHANGE: 16/11/2005, Caroline Forster, GFS data * + !* CHANGE: 11/01/2008, Harald Sodemann, Input of GRIB1/2 * + !* data with the ECMWF grib_api library * + !* CHANGE: 03/12/2008, Harald Sodemann, update to f90 with * + !* ECMWF grib_api * + ! * + ! Unified ECMWF and GFS builds * + ! Marian Harustak, 12.5.2017 * + ! - Renamed routine from readwind to readwind_gfs * + !* * + !*********************************************************************** + !* * + !* 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 vertical levels ecmwf model * + !* uu,vv,ww wind fields * + !* tt,qv temperature and specific humidity * + !* ps surface pressure * + !* * + !*********************************************************************** + + use grib_api + use qvsat_mod + + implicit none + + !HSO new parameters for grib_api + integer :: ifile + integer :: iret + integer :: igrib + integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl + !HSO end edits + real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax) + real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax) + real :: wwh(0:nxmax-1,0:nymax-1,nwzmax) + integer :: ii,indj,i,j,k,n,levdiff2,ifield,iumax,iwmax + + ! NCEP + integer :: numpt,numpu,numpv,numpw,numprh,numpclwch + real :: help, temp + real :: elev + real :: ulev1(0:nxmax-1,0:nymax-1),vlev1(0:nxmax-1,0:nymax-1) + real :: tlev1(0:nxmax-1,0:nymax-1) + real :: qvh2(0:nxmax-1,0:nymax-1) + + integer :: i179,i180,i181 + + ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING + !HSO kept isec1, isec2 and zsec4 for consistency with gribex GRIB input + + integer :: isec1(8),isec2(3) + real(kind=4) :: zsec4(jpunp) + real(kind=4) :: xaux,yaux,xaux0,yaux0 + real(kind=8) :: xauxin,yauxin + real,parameter :: eps=1.e-4 + real(kind=4) :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1) + real :: plev1,hlev1,ff10m,fflev1 + + logical :: hflswitch,strswitch + + !HSO for grib api error messages + character(len=24) :: gribErrorMsg = 'Error reading grib file' + character(len=20) :: gribFunction = 'readwind_gfs' + character(len=20) :: shortname + + + hflswitch=.false. + strswitch=.false. + levdiff2=nlev_ec-nwz+1 + iumax=0 + iwmax=0 + + + ! OPENING OF DATA FILE (GRIB CODE) + + !HSO + call grib_open_file(ifile,path(3)(1:length(3)) & + //trim(wfname(indj)),'r',iret) + if (iret.ne.GRIB_SUCCESS) then + goto 888 ! ERROR DETECTED + endif + !turn on support for multi fields messages + call grib_multi_support_on + + numpt=0 + numpu=0 + numpv=0 + numpw=0 + numprh=0 + numpclwch=0 + ifield=0 + do + ifield=ifield+1 + ! + ! GET NEXT FIELDS + ! + call grib_new_from_file(ifile,igrib,iret) + if (iret.eq.GRIB_END_OF_FILE) then + exit ! EOF DETECTED + elseif (iret.ne.GRIB_SUCCESS) then + goto 888 ! ERROR DETECTED + endif + + !first see if we read GRIB1 or GRIB2 + call grib_get_int(igrib,'editionNumber',gribVer,iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + + if (gribVer.eq.1) then ! GRIB Edition 1 + + !read the grib1 identifiers + call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'level',isec1(8),iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + + else ! GRIB Edition 2 + + !read the grib2 identifiers + call grib_get_string(igrib,'shortName',shortname,iret) + + call grib_get_int(igrib,'discipline',discipl,iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterCategory',parCat,iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterNumber',parNum,iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', & + ivalsfc,iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + + ! write(*,*) 'Field: ',ifield,parCat,parNum,sfctyp,shortname + !convert to grib1 identifiers + isec1(6)=-1 + isec1(7)=-1 + isec1(8)=-1 + if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.100)) then ! T + isec1(6)=11 ! indicatorOfParameter + isec1(7)=100 ! indicatorOfTypeOfLevel + isec1(8)=ivalsfc/100 ! level, convert to hPa + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.100)) then ! U + isec1(6)=33 ! indicatorOfParameter + isec1(7)=100 ! indicatorOfTypeOfLevel + isec1(8)=ivalsfc/100 ! level, convert to hPa + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.100)) then ! V + isec1(6)=34 ! indicatorOfParameter + isec1(7)=100 ! indicatorOfTypeOfLevel + isec1(8)=ivalsfc/100 ! level, convert to hPa + elseif ((parCat.eq.2).and.(parNum.eq.8).and.(sfctyp.eq.100)) then ! W + isec1(6)=39 ! indicatorOfParameter + isec1(7)=100 ! indicatorOfTypeOfLevel + isec1(8)=ivalsfc/100 ! level, convert to hPa + elseif ((parCat.eq.1).and.(parNum.eq.1).and.(sfctyp.eq.100)) then ! RH + isec1(6)=52 ! indicatorOfParameter + isec1(7)=100 ! indicatorOfTypeOfLevel + isec1(8)=ivalsfc/100 ! level, convert to hPa + elseif ((parCat.eq.1).and.(parNum.eq.1).and.(sfctyp.eq.103)) then ! RH2 + isec1(6)=52 ! indicatorOfParameter + isec1(7)=105 ! indicatorOfTypeOfLevel + isec1(8)=2 + elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! T2 + isec1(6)=11 ! indicatorOfParameter + isec1(7)=105 ! indicatorOfTypeOfLevel + isec1(8)=2 + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! U10 + isec1(6)=33 ! indicatorOfParameter + isec1(7)=105 ! indicatorOfTypeOfLevel + isec1(8)=10 + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! V10 + isec1(6)=34 ! indicatorOfParameter + isec1(7)=105 ! indicatorOfTypeOfLevel + isec1(8)=10 + elseif ((parCat.eq.1).and.(parNum.eq.22).and.(sfctyp.eq.100)) then ! CLWMR Cloud Mixing Ratio [kg/kg]: + isec1(6)=153 ! indicatorOfParameter + isec1(7)=100 ! indicatorOfTypeOfLevel + isec1(8)=ivalsfc/100 ! level, convert to hPa + elseif ((parCat.eq.3).and.(parNum.eq.1).and.(sfctyp.eq.101)) then ! SLP + isec1(6)=2 ! indicatorOfParameter + isec1(7)=102 ! indicatorOfTypeOfLevel + isec1(8)=0 + elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then ! SP + isec1(6)=1 ! indicatorOfParameter + isec1(7)=1 ! indicatorOfTypeOfLevel + isec1(8)=0 + elseif ((parCat.eq.1).and.(parNum.eq.13).and.(sfctyp.eq.1)) then ! SNOW + isec1(6)=66 ! indicatorOfParameter + isec1(7)=1 ! indicatorOfTypeOfLevel + isec1(8)=0 + elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.104)) then ! T sigma 0 + isec1(6)=11 ! indicatorOfParameter + isec1(7)=107 ! indicatorOfTypeOfLevel + isec1(8)=0.995 ! lowest sigma level + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.104)) then ! U sigma 0 + isec1(6)=33 ! indicatorOfParameter + isec1(7)=107 ! indicatorOfTypeOfLevel + isec1(8)=0.995 ! lowest sigma level + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.104)) then ! V sigma 0 + isec1(6)=34 ! indicatorOfParameter + isec1(7)=107 ! indicatorOfTypeOfLevel + isec1(8)=0.995 ! lowest sigma level + elseif ((parCat.eq.3).and.(parNum.eq.5).and.(sfctyp.eq.1)) then ! TOPO + isec1(6)=7 ! indicatorOfParameter + isec1(7)=1 ! indicatorOfTypeOfLevel + isec1(8)=0 + elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.1) & + .and.(discipl.eq.2)) then ! LSM + isec1(6)=81 ! indicatorOfParameter + isec1(7)=1 ! indicatorOfTypeOfLevel + isec1(8)=0 + elseif ((parCat.eq.3).and.(parNum.eq.196).and.(sfctyp.eq.1)) then ! BLH + isec1(6)=221 ! indicatorOfParameter + isec1(7)=1 ! indicatorOfTypeOfLevel + isec1(8)=0 + elseif ((parCat.eq.1).and.(parNum.eq.7).and.(sfctyp.eq.1)) then ! LSP/TP + isec1(6)=62 ! indicatorOfParameter + isec1(7)=1 ! indicatorOfTypeOfLevel + isec1(8)=0 + elseif ((parCat.eq.1).and.(parNum.eq.196).and.(sfctyp.eq.1)) then ! CP + isec1(6)=63 ! indicatorOfParameter + isec1(7)=1 ! indicatorOfTypeOfLevel + isec1(8)=0 + endif + + endif ! gribVer + + if (isec1(6).ne.-1) then + ! get the size and data of the values array + call grib_get_real4_array(igrib,'values',zsec4,iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + endif + + if(ifield.eq.1) then + + !get the required fields from section 2 + !store compatible to gribex input + call grib_get_int(igrib,'numberOfPointsAlongAParallel', & + isec2(2),iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & + isec2(3),iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & + xauxin,iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & + yauxin,iret) + ! call grib_check(iret,gribFunction,gribErrorMsg) + xaux=xauxin+real(nxshift)*dx + yaux=yauxin + + ! CHECK GRID SPECIFICATIONS + + if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT' + if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT' + if(xaux.eq.0.) xaux=-179.0 ! NCEP DATA + xaux0=xlon0 + yaux0=ylat0 + if(xaux.lt.0.) xaux=xaux+360. + if(yaux.lt.0.) yaux=yaux+360. + if(xaux0.lt.0.) xaux0=xaux0+360. + if(yaux0.lt.0.) yaux0=yaux0+360. + if(abs(xaux-xaux0).gt.eps) & + stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT' + if(abs(yaux-yaux0).gt.eps) & + stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT' + endif + !HSO end of edits + + i179=nint(179./dx) + if (dx.lt.0.7) then + i180=nint(180./dx)+1 ! 0.5 deg data + else + i180=nint(179./dx)+1 ! 1 deg data + endif + i181=i180+1 + + if (isec1(6).ne.-1) then + + do j=0,nymin1 + do i=0,nxfield-1 + if((isec1(6).eq.011).and.(isec1(7).eq.100)) then + ! TEMPERATURE + if((i.eq.0).and.(j.eq.0)) then + do ii=1,nuvz + if ((isec1(8)*100.0).eq.akz(ii)) numpt=ii + end do + endif + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + tth(i179+i,j,numpt,n)=help + else + tth(i-i181,j,numpt,n)=help + endif + endif + if((isec1(6).eq.033).and.(isec1(7).eq.100)) then + ! U VELOCITY + if((i.eq.0).and.(j.eq.0)) then + do ii=1,nuvz + if ((isec1(8)*100.0).eq.akz(ii)) numpu=ii + end do + endif + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + uuh(i179+i,j,numpu)=help + else + uuh(i-i181,j,numpu)=help + endif + endif + if((isec1(6).eq.034).and.(isec1(7).eq.100)) then + ! V VELOCITY + if((i.eq.0).and.(j.eq.0)) then + do ii=1,nuvz + if ((isec1(8)*100.0).eq.akz(ii)) numpv=ii + end do + endif + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + vvh(i179+i,j,numpv)=help + else + vvh(i-i181,j,numpv)=help + endif + endif + if((isec1(6).eq.052).and.(isec1(7).eq.100)) then + ! RELATIVE HUMIDITY -> CONVERT TO SPECIFIC HUMIDITY LATER + if((i.eq.0).and.(j.eq.0)) then + do ii=1,nuvz + if ((isec1(8)*100.0).eq.akz(ii)) numprh=ii + end do + endif + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + qvh(i179+i,j,numprh,n)=help + else + qvh(i-i181,j,numprh,n)=help + endif + endif + if((isec1(6).eq.001).and.(isec1(7).eq.001)) then + ! SURFACE PRESSURE + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + ps(i179+i,j,1,n)=help + else + ps(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.039).and.(isec1(7).eq.100)) then + ! W VELOCITY + if((i.eq.0).and.(j.eq.0)) then + do ii=1,nuvz + if ((isec1(8)*100.0).eq.akz(ii)) numpw=ii + end do + endif + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + wwh(i179+i,j,numpw)=help + else + wwh(i-i181,j,numpw)=help + endif + endif + if((isec1(6).eq.066).and.(isec1(7).eq.001)) then + ! SNOW DEPTH + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + sd(i179+i,j,1,n)=help + else + sd(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.002).and.(isec1(7).eq.102)) then + ! MEAN SEA LEVEL PRESSURE + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + msl(i179+i,j,1,n)=help + else + msl(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.071).and.(isec1(7).eq.244)) then + ! TOTAL CLOUD COVER + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + tcc(i179+i,j,1,n)=help + else + tcc(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.033).and.(isec1(7).eq.105).and. & + (isec1(8).eq.10)) then + ! 10 M U VELOCITY + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + u10(i179+i,j,1,n)=help + else + u10(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.034).and.(isec1(7).eq.105).and. & + (isec1(8).eq.10)) then + ! 10 M V VELOCITY + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + v10(i179+i,j,1,n)=help + else + v10(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.011).and.(isec1(7).eq.105).and. & + (isec1(8).eq.02)) then + ! 2 M TEMPERATURE + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + tt2(i179+i,j,1,n)=help + else + tt2(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.017).and.(isec1(7).eq.105).and. & + (isec1(8).eq.02)) then + ! 2 M DEW POINT TEMPERATURE + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + td2(i179+i,j,1,n)=help + else + td2(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.062).and.(isec1(7).eq.001)) then + ! LARGE SCALE PREC. + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + lsprec(i179+i,j,1,n)=help + else + lsprec(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.063).and.(isec1(7).eq.001)) then + ! CONVECTIVE PREC. + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + convprec(i179+i,j,1,n)=help + else + convprec(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.007).and.(isec1(7).eq.001)) then + ! TOPOGRAPHY + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + oro(i179+i,j)=help + excessoro(i179+i,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED + else + oro(i-i181,j)=help + excessoro(i-i181,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED + endif + endif + if((isec1(6).eq.081).and.(isec1(7).eq.001)) then + ! LAND SEA MASK + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + lsm(i179+i,j)=help + else + lsm(i-i181,j)=help + endif + endif + if((isec1(6).eq.221).and.(isec1(7).eq.001)) then + ! MIXING HEIGHT + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + hmix(i179+i,j,1,n)=help + else + hmix(i-i181,j,1,n)=help + endif + endif + if((isec1(6).eq.052).and.(isec1(7).eq.105).and. & + (isec1(8).eq.02)) then + ! 2 M RELATIVE HUMIDITY + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + qvh2(i179+i,j)=help + else + qvh2(i-i181,j)=help + endif + endif + if((isec1(6).eq.011).and.(isec1(7).eq.107)) then + ! TEMPERATURE LOWEST SIGMA LEVEL + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + tlev1(i179+i,j)=help + else + tlev1(i-i181,j)=help + endif + endif + if((isec1(6).eq.033).and.(isec1(7).eq.107)) then + ! U VELOCITY LOWEST SIGMA LEVEL + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + ulev1(i179+i,j)=help + else + ulev1(i-i181,j)=help + endif + endif + if((isec1(6).eq.034).and.(isec1(7).eq.107)) then + ! V VELOCITY LOWEST SIGMA LEVEL + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + vlev1(i179+i,j)=help + else + vlev1(i-i181,j)=help + endif + endif + ! SEC & IP 12/2018 read GFS clouds + if((isec1(6).eq.153).and.(isec1(7).eq.100)) then !! CLWCR Cloud liquid water content [kg/kg] + if((i.eq.0).and.(j.eq.0)) then + do ii=1,nuvz + if ((isec1(8)*100.0).eq.akz(ii)) numpclwch=ii + end do + endif + help=zsec4(nxfield*(ny-j-1)+i+1) + if(i.le.i180) then + clwch(i179+i,j,numpclwch,n)=help + else + clwch(i-i181,j,numpclwch,n)=help + endif + readclouds=.true. + sumclouds=.true. + ! readclouds=.false. + ! sumclouds=.false. + endif + + + end do + end do + + endif + + if((isec1(6).eq.33).and.(isec1(7).eq.100)) then + ! NCEP ISOBARIC LEVELS + iumax=iumax+1 + endif + + call grib_release(igrib) + end do !! READ NEXT LEVEL OR PARAMETER + ! + ! CLOSING OF INPUT DATA FILE + ! + + !HSO close grib file + call grib_close_file(ifile) + + ! SENS. HEAT FLUX + sshf(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files + hflswitch=.false. ! Heat flux not available + ! SOLAR RADIATIVE FLUXES + ssr(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files + ! EW SURFACE STRESS + ewss=0.0 ! not available from gfs.tccz.pgrbfxx files + ! NS SURFACE STRESS + nsss=0.0 ! not available from gfs.tccz.pgrbfxx files + strswitch=.false. ! stress not available + + ! CONVERT TP TO LSP (GRIB2 only) + if (gribVer.eq.2) then + do j=0,nymin1 + do i=0,nxfield-1 + if(i.le.i180) then + if (convprec(i179+i,j,1,n).lt.lsprec(i179+i,j,1,n)) then ! neg precip would occur + lsprec(i179+i,j,1,n)= & + lsprec(i179+i,j,1,n)-convprec(i179+i,j,1,n) + else + lsprec(i179+i,j,1,n)=0 + endif + else + if (convprec(i-i181,j,1,n).lt.lsprec(i-i181,j,1,n)) then + lsprec(i-i181,j,1,n)= & + lsprec(i-i181,j,1,n)-convprec(i-i181,j,1,n) + else + lsprec(i-i181,j,1,n)=0 + endif + endif + enddo + enddo + endif + !HSO end edits + + + ! TRANSFORM RH TO SPECIFIC HUMIDITY + + do j=0,ny-1 + do i=0,nxfield-1 + do k=1,nuvz + help=qvh(i,j,k,n) + temp=tth(i,j,k,n) + plev1=akm(k)+bkm(k)*ps(i,j,1,n) + elev=ew(temp,plev1)*help/100.0 + qvh(i,j,k,n)=xmwml*(elev/(plev1-((1.0-xmwml)*elev))) + end do + end do + end do + + ! CALCULATE 2 M DEW POINT FROM 2 M RELATIVE HUMIDITY + ! USING BOLTON'S (1980) FORMULA + ! BECAUSE td2 IS NOT AVAILABLE FROM NCEP GFS DATA + + do j=0,ny-1 + do i=0,nxfield-1 + help=qvh2(i,j) + temp=tt2(i,j,1,n) + plev1=akm(k)+bkm(k)*ps(i,j,1,n) + elev=ew(temp,plev1)/100.*help/100. !vapour pressure in hPa + td2(i,j,1,n)=243.5/(17.67/log(elev/6.112)-1)+273. + if (help.le.0.) td2(i,j,1,n)=tt2(i,j,1,n) + end do + end do + + if(levdiff2.eq.0) then + iwmax=nlev_ec+1 + do i=0,nxmin1 + do j=0,nymin1 + wwh(i,j,nlev_ec+1)=0. + end do + end do + endif + + + ! For global fields, assign the leftmost data column also to the rightmost + ! data column; if required, shift whole grid by nxshift grid points + !************************************************************************* + + 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_0(ulev1,nxfield,ny) + call shift_field_0(vlev1,nxfield,ny) + call shift_field_0(tlev1,nxfield,ny) + call shift_field_0(qvh2,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(hmix,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) + ! IP & SEC adding GFS Clouds 20181205 + call shift_field(clwch,nxfield,ny,nuvzmax,nuvz,2,n) + endif + + do i=0,nxmin1 + do j=0,nymin1 + ! Convert precip. from mm/s -> mm/hour + convprec(i,j,1,n)=convprec(i,j,1,n)*3600. + lsprec(i,j,1,n)=lsprec(i,j,1,n)*3600. + sfcstress(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2) + end do + end do + + if ((.not.hflswitch).or.(.not.strswitch)) then + ! write(*,*) 'WARNING: No flux data contained in GRIB file ', + ! + wfname(indj) + + ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD + !*************************************************************************** + + do i=0,nxmin1 + do j=0,nymin1 + hlev1=30.0 ! HEIGHT OF FIRST MODEL SIGMA LAYER + ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2) + fflev1=sqrt(ulev1(i,j)**2+vlev1(i,j)**2) + call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, & + tt2(i,j,1,n),tlev1(i,j),ff10m,fflev1, & + sfcstress(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. + end do + end do + endif + + if(iumax.ne.nuvz) stop 'READWIND: NUVZ NOT CONSISTENT' + if(iumax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT' + + return +888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' + write(*,*) ' #### ',wfname(indj),' #### ' + write(*,*) ' #### IS NOT GRIB FORMAT !!! #### ' + stop 'Execution terminated' +999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' + write(*,*) ' #### ',wfname(indj),' #### ' + write(*,*) ' #### CANNOT BE OPENED !!! #### ' + stop 'Execution terminated' + +end subroutine readwind_gfs diff --git a/src/win_readwind_nest.f90 b/src/win_readwind_nest.f90 new file mode 100644 index 0000000000000000000000000000000000000000..99628e11938234f9805d6b932b4221d7caa6f0e1 --- /dev/null +++ b/src/win_readwind_nest.f90 @@ -0,0 +1,443 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +subroutine readwind_nest(indj,n,uuhn,vvhn,wwhn) + ! i i o o o + !***************************************************************************** + ! * + ! 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 * + ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api * + ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with ECMWF grib_api * + !***************************************************************************** + + use grib_api + + implicit none + + !HSO parameters for grib_api + integer :: ifile + integer :: iret + integer :: igrib + integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl + integer :: parId !!added by mc for making it consistent with new readwind.f90 + integer :: gotGrid + !HSO end + + 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) + integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax,l + + ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING + + ! dimension of isec2 at least (22+n), where n is the number of parallels or + ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid + + ! dimension of zsec2 at least (10+nn), where nn is the number of vertical + ! coordinate parameters + + integer :: isec1(56),isec2(22+nxmaxn+nymaxn) + real(kind=4) :: zsec4(jpunp) + real(kind=4) :: xaux,yaux + real(kind=8) :: xauxin,yauxin + real,parameter :: eps=1.e-4 + real :: ewss(0:nxmaxn-1,0:nymaxn-1),nsss(0:nxmaxn-1,0:nymaxn-1) + real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1 + real :: conversion_factor !added by mc to make it consistent with new gridchek.f90 + + logical :: hflswitch,strswitch + + !HSO grib api error messages + character(len=24) :: gribErrorMsg = 'Error reading grib file' + character(len=20) :: gribFunction = 'readwind_nest' + + do l=1,numbnests + hflswitch=.false. + strswitch=.false. + levdiff2=nlev_ec-nwz+1 + iumax=0 + iwmax=0 + + ifile=0 + igrib=0 + iret=0 + + ! + ! OPENING OF DATA FILE (GRIB CODE) + ! + +5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) & + (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,indj)),'r') + if (iret.ne.GRIB_SUCCESS) then + goto 888 ! ERROR DETECTED + endif + !turn on support for multi fields messages */ + !call grib_multi_support_on + + gotGrid=0 + ifield=0 + do + ifield=ifield+1 + ! + ! GET NEXT FIELDS + ! + call grib_new_from_file(ifile,igrib,iret) + if (iret.eq.GRIB_END_OF_FILE) then + exit ! EOF DETECTED + elseif (iret.ne.GRIB_SUCCESS) then + goto 888 ! ERROR DETECTED + endif + + !first see if we read GRIB1 or GRIB2 + call grib_get_int(igrib,'editionNumber',gribVer,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + if (gribVer.eq.1) then ! GRIB Edition 1 + + !print*,'GRiB Edition 1' + !read the grib2 identifiers + call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'level',isec1(8),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + + !change code for etadot to code for omega + if (isec1(6).eq.77) then + isec1(6)=135 + endif + + conversion_factor=1. + + + else + + !print*,'GRiB Edition 2' + !read the grib2 identifiers + call grib_get_int(igrib,'discipline',discipl,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterCategory',parCat,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'parameterNumber',parNum,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'level',ivalsfc,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'paramId',parId,iret) !added by mc to make it consisitent with new readwind.f90 + call grib_check(iret,gribFunction,gribErrorMsg) !added by mc to make it consisitent with new readwind.f90 + + !print*,discipl,parCat,parNum,sfctyp,ivalsfc + + !convert to grib1 identifiers + isec1(6)=-1 + isec1(7)=-1 + isec1(8)=-1 + isec1(8)=ivalsfc ! level + conversion_factor=1. + if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! T + isec1(6)=130 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.105)) then ! U + isec1(6)=131 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.105)) then ! V + isec1(6)=132 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! Q + isec1(6)=133 ! indicatorOfParameter + ! ESO Cloud water is in a) fields CLWC and CIWC, *or* b) field QC + elseif ((parCat.eq.1).and.(parNum.eq.83).and.(sfctyp.eq.105)) then ! clwc + isec1(6)=246 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.84).and.(sfctyp.eq.105)) then ! ciwc + isec1(6)=247 ! indicatorOfParameter + ! ESO qc(=clwc+ciwc): + elseif ((parCat.eq.201).and.(parNum.eq.31).and.(sfctyp.eq.105)) then ! qc + isec1(6)=201031 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then !SP + isec1(6)=134 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot ! + isec1(6)=135 ! indicatorOfParameter + elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot !added by mc to make it consisitent with new readwind.f90 + isec1(6)=135 ! indicatorOfParameter !added by mc to make it consisitent with new readwind.f90 + elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.101)) then !SLP + isec1(6)=151 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! 10U + isec1(6)=165 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! 10V + isec1(6)=166 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! 2T + isec1(6)=167 ! indicatorOfParameter + elseif ((parCat.eq.0).and.(parNum.eq.6).and.(sfctyp.eq.103)) then ! 2D + isec1(6)=168 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SD + isec1(6)=141 ! indicatorOfParameter + conversion_factor=1000. !added by mc to make it consisitent with new readwind.f90 + elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC !added by mc to make it consisitent with new readwind.f90 + isec1(6)=164 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP !added by mc to make it consisitent with new readwind.f90 + isec1(6)=142 ! indicatorOfParameter + elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP + isec1(6)=143 ! indicatorOfParameter + conversion_factor=1000. !added by mc to make it consisitent with new readwind.f90 + elseif ((parCat.eq.0).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SHF + isec1(6)=146 ! indicatorOfParameter + elseif ((parCat.eq.4).and.(parNum.eq.9).and.(sfctyp.eq.1)) then ! SR + isec1(6)=176 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.38) .or. parId .eq. 180) then ! EWSS !added by mc to make it consisitent with new readwind.f90 + isec1(6)=180 ! indicatorOfParameter + elseif ((parCat.eq.2).and.(parNum.eq.37) .or. parId .eq. 181) then ! NSSS !added by mc to make it consisitent with new readwind.f90 + isec1(6)=181 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO + isec1(6)=129 ! indicatorOfParameter + elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO !added by mc to make it consisitent with new readwind.f90 + isec1(6)=160 ! indicatorOfParameter + elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. & + (sfctyp.eq.1)) then ! LSM + isec1(6)=172 ! indicatorOfParameter + elseif (parNum.eq.152) then + isec1(6)=152 ! avoid warning for lnsp + else + print*,'***WARNING: undefined GRiB2 message found!',discipl, & + parCat,parNum,sfctyp + endif + if(parId .ne. isec1(6) .and. parId .ne. 77) then !added by mc to make it consisitent with new readwind.f90 + write(*,*) 'parId',parId, 'isec1(6)',isec1(6) ! + ! stop + endif + + endif + + !HSO get the size and data of the values array + if (isec1(6).ne.-1) then + call grib_get_real4_array(igrib,'values',zsec4,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + endif + + !HSO get the required fields from section 2 in a gribex compatible manner + if(ifield.eq.1) then + call grib_get_int(igrib,'numberOfPointsAlongAParallel', & + isec2(2),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & + isec2(3),iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_int(igrib,'numberOfVerticalCoordinateValues', & + isec2(12)) + call grib_check(iret,gribFunction,gribErrorMsg) + ! CHECK GRID SPECIFICATIONS + if(isec2(2).ne.nxn(l)) stop & + 'READWIND: NX NOT CONSISTENT FOR A NESTING LEVEL' + if(isec2(3).ne.nyn(l)) stop & + 'READWIND: NY NOT CONSISTENT FOR A NESTING LEVEL' + if(isec2(12)/2-1.ne.nlev_ec) stop 'READWIND: VERTICAL DISCRET& + &IZATION NOT CONSISTENT FOR A NESTING LEVEL' + endif ! ifield + + !HSO get the second part of the grid dimensions only from GRiB1 messages + if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then ! !added by mc to make it consisitent with new readwind.f90 + call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & + xauxin,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & + yauxin,iret) + call grib_check(iret,gribFunction,gribErrorMsg) + if (xauxin.gt.180.) xauxin=xauxin-360.0 + if (xauxin.lt.-180.) xauxin=xauxin+360.0 + + xaux=xauxin + yaux=yauxin + if (abs(xaux-xlon0n(l)).gt.eps) & + stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT FOR A NESTING LEVEL' + if (abs(yaux-ylat0n(l)).gt.eps) & + stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT FOR A NESTING LEVEL' + gotGrid=1 + endif + + do j=0,nyn(l)-1 + do i=0,nxn(l)-1 + k=isec1(8) + if(isec1(6).eq.130) tthn(i,j,nlev_ec-k+2,n,l)= &!! TEMPERATURE + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.131) uuhn(i,j,nlev_ec-k+2,l)= &!! U VELOCITY + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.132) vvhn(i,j,nlev_ec-k+2,l)= &!! V VELOCITY + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.133) then !! SPEC. HUMIDITY + qvhn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if (qvhn(i,j,nlev_ec-k+2,n,l) .lt. 0.) & + qvhn(i,j,nlev_ec-k+2,n,l) = 0. + ! this is necessary because the gridded data may contain + ! spurious negative values + endif + if(isec1(6).eq.134) psn(i,j,1,n,l)= &!! SURF. PRESS. + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.135) wwhn(i,j,nlev_ec-k+1,l)= &!! W VELOCITY + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.141) sdn(i,j,1,n,l)= &!! SNOW DEPTH + zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/conversion_factor !added by mc to make it consisitent with new readwind.f90! + if(isec1(6).eq.151) msln(i,j,1,n,l)= &!! SEA LEVEL PRESS. + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.164) tccn(i,j,1,n,l)= &!! CLOUD COVER + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.165) u10n(i,j,1,n,l)= &!! 10 M U VELOCITY + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.166) v10n(i,j,1,n,l)= &!! 10 M V VELOCITY + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.167) tt2n(i,j,1,n,l)= &!! 2 M TEMPERATURE + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.168) td2n(i,j,1,n,l)= &!! 2 M DEW POINT + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.142) then !! LARGE SCALE PREC. + lsprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if (lsprecn(i,j,1,n,l).lt.0.) lsprecn(i,j,1,n,l)=0. + endif + if(isec1(6).eq.143) then !! CONVECTIVE PREC. + convprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/conversion_factor !added by mc to make it consisitent with new readwind.f90 + if (convprecn(i,j,1,n,l).lt.0.) convprecn(i,j,1,n,l)=0. + endif + if(isec1(6).eq.146) sshfn(i,j,1,n,l)= &!! SENS. HEAT FLUX + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if((isec1(6).eq.146).and. & + (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) hflswitch=.true. ! Heat flux available + if(isec1(6).eq.176) then !! SOLAR RADIATION + ssrn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if (ssrn(i,j,1,n,l).lt.0.) ssrn(i,j,1,n,l)=0. + endif + if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. & + (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available + if(isec1(6).eq.129) oron(i,j,l)= &!! ECMWF OROGRAPHY + zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga + if(isec1(6).eq.160) excessoron(i,j,l)= &!! STANDARD DEVIATION OF OROGRAPHY + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.172) lsmn(i,j,l)= &!! ECMWF LAND SEA MASK + zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1) + if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1) + + ! ESO TODO: + ! -add check for if one of clwc/ciwc missing (error), + ! also if all 3 cw fields present, use qc and disregard the others + if(isec1(6).eq.246) then !! CLWC Cloud liquid water content [kg/kg] + clwchn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + readclouds_nest(l)=.true. + sumclouds_nest(l)=.false. + endif + if(isec1(6).eq.247) then !! CIWC Cloud ice water content + ciwchn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + endif + !ZHG end + !ESO read qc (=clwc+ciwc) + if(isec1(6).eq.201031) then !! QC Cloud liquid water content [kg/kg] + clwchn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) + readclouds_nest(l)=.true. + sumclouds_nest(l)=.true. + endif + + + end do + end do + + call grib_release(igrib) + end do !! READ NEXT LEVEL OR PARAMETER + ! + ! CLOSING OF INPUT DATA FILE + ! + call grib_close_file(ifile) + + !error message if no fields found with correct first longitude in it + if (gotGrid.eq.0) then + print*,'***ERROR: input file needs to contain GRiB1 formatted'// & + 'messages' + stop + endif + + if(levdiff2.eq.0) then + iwmax=nlev_ec+1 + do i=0,nxn(l)-1 + do j=0,nyn(l)-1 + wwhn(i,j,nlev_ec+1,l)=0. + end do + end do + endif + + do i=0,nxn(l)-1 + do j=0,nyn(l)-1 + sfcstressn(i,j,1,n,l)=sqrt(ewss(i,j)**2+nsss(i,j)**2) + end do + end do + + if ((.not.hflswitch).or.(.not.strswitch)) then + write(*,*) 'WARNING: No flux data contained in GRIB file ', & + wfnamen(l,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 + !*************************************************************************** + + do i=0,nxn(l)-1 + do j=0,nyn(l)-1 + plev1=akz(3)+bkz(3)*psn(i,j,1,n,l) + pmean=0.5*(psn(i,j,1,n,l)+plev1) + tv=tthn(i,j,3,n,l)*(1.+0.61*qvhn(i,j,3,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,3,l)**2+vvhn(i,j,3,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,3,n,l),ff10m,fflev1, & + sfcstressn(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. + end do + end do + 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 + !************************************************************************** + + do i=0,nxn(l)-1 + do j=0,nyn(l)-1 + uuhn(i,j,1,l)=u10n(i,j,1,n,l) + vvhn(i,j,1,l)=v10n(i,j,1,n,l) + qvhn(i,j,1,n,l)=qvhn(i,j,2,n,l) + tthn(i,j,1,n,l)=tt2n(i,j,1,n,l) + end do + end do + + if(iumax.ne.nuvz-1) stop & + 'READWIND: NUVZ NOT CONSISTENT FOR A NESTING LEVEL' + if(iwmax.ne.nwz) stop & + 'READWIND: NWZ NOT CONSISTENT FOR A NESTING LEVEL' + + end do + + return +888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' + write(*,*) ' #### ',wfnamen(l,indj),' FOR NESTING LEVEL #### ' + write(*,*) ' #### ',l,' IS NOT GRIB FORMAT !!! #### ' + stop 'Execution terminated' + + +999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' + write(*,*) ' #### ',wfnamen(l,indj),' #### ' + write(*,*) ' #### CANNOT BE OPENED FOR NESTING LEVEL ',l,'####' + +end subroutine readwind_nest diff --git a/src/win_shift_field.f90 b/src/win_shift_field.f90 new file mode 100644 index 0000000000000000000000000000000000000000..5deec058a9dec47ec694f7499b7394d641da8f93 --- /dev/null +++ b/src/win_shift_field.f90 @@ -0,0 +1,58 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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: * + ! * + !***************************************************************************** + + 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/win_shift_field_0.f90 b/src/win_shift_field_0.f90 new file mode 100644 index 0000000000000000000000000000000000000000..b3410811961f071b3f596b64219c914668348348 --- /dev/null +++ b/src/win_shift_field_0.f90 @@ -0,0 +1,58 @@ +! SPDX-FileCopyrightText: FLEXPART 1998-2023, see flexpart_license.txt +! SPDX-License-Identifier: GPL-3.0-or-later + +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: * + ! * + !***************************************************************************** + + 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/windfields_mod.f90 b/src/windfields_mod.f90 index 840fba6067f87889e59a8c7884d937b7a84df5e4..2674b3402b61d5426c6396ecb2131822706e394b 100644 --- a/src/windfields_mod.f90 +++ b/src/windfields_mod.f90 @@ -114,7 +114,7 @@ module windfields_mod pvn, & ! potential vorticity rhon, & ! air density [kg/m3] prsn, & ! air pressure RLT - drhodzn ! vertical air density gradient [kg/m2] + drhodzn ! vertical air density gradient [kg/m2] ! ETA equivalents real,allocatable,dimension(:,:,:,:,:) :: & @@ -241,3758 +241,32 @@ module windfields_mod contains -subroutine detectformat +#include "win_detectformat.f90" - !***************************************************************************** - ! * - ! This routine reads the 1st file with windfields to determine * - ! the format. * - ! * - ! Authors: M. Harustak * - ! * - ! 6 May 2015 * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! - Added routine to FP10 Flexpart distribution * - !***************************************************************************** - ! * - ! Variables: * - ! fname file name of file to check * - ! * - !***************************************************************************** - - use par_mod - use com_mod - use class_gribfile_mod - - - implicit none - - character(len=255) :: filename - character(len=255) :: wfname1(maxwf) - - ! If no file is available - if ( maxwf.le.0 ) then - print*,'No wind file available' - metdata_format = GRIBFILE_CENTRE_UNKNOWN - return - endif - - ! construct filename - filename = path(3)(1:length(3)) // trim(wfname(1)) - - ! get format - metdata_format = gribfile_centre(TRIM(filename)) -end subroutine detectformat - -subroutine gridcheck_ecmwf - - !********************************************************************** - ! * - ! FLEXPART MODEL SUBROUTINE GRIDCHECK * - ! * - !********************************************************************** - ! * - ! AUTHOR: G. WOTAWA * - ! DATE: 1997-08-06 * - ! LAST UPDATE: 1997-10-10 * - ! * - ! Update: 1999-02-08, global fields allowed, A. Stohl* - ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with * - ! ECMWF grib_api * - ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with * - ! ECMWF grib_api * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! - Renamed from gridcheck to gridcheck_ecmwf * - ! * - !********************************************************************** - ! * - ! DESCRIPTION: * - ! * - ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT * - ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- * - ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE * - ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES * - ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT * - ! ANY CALL. * - ! * - ! XLON0 geographical longitude of lower left gridpoint * - ! YLAT0 geographical latitude of lower left gridpoint * - ! NX number of grid points x-direction * - ! NY number of grid points y-direction * - ! DX grid distance x-direction * - ! DY grid distance y-direction * - ! NUVZ number of grid points for horizontal wind * - ! components in z direction * - ! NWZ number of grid points for vertical wind * - ! component in z direction * - ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid* - ! points of the polar stereographic grid): * - ! used to check the CFL criterion * - ! UVHEIGHT(1)- heights of gridpoints where u and v are * - ! UVHEIGHT(NUVZ) given * - ! WHEIGHT(1)- heights of gridpoints where w is given * - ! WHEIGHT(NWZ) * - ! * - !********************************************************************** - - use grib_api - use cmapf_mod, only: stlmbr,stcm2p - - implicit none - - !HSO parameters for grib_api - integer :: ifile - integer :: iret - integer :: igrib - integer :: gotGrid - real(kind=4) :: xaux1,xaux2,yaux1,yaux2 - real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in - integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl,parId - !HSO end - integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip - real :: sizesouth,sizenorth,xauxa,conversion_factor - - ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING - - ! dimension of isec2 at least (22+n), where n is the number of parallels or - ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid - - ! dimension of zsec2 at least (10+nn), where nn is the number of vertical - ! coordinate parameters - - integer :: isec1(56),isec2(22+nxmax+nymax) - real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp) - character(len=1) :: opt - - !HSO grib api error messages - character(len=24) :: gribErrorMsg = 'Error reading grib file' - character(len=20) :: gribFunction = 'gridcheck' - - - iumax=0 - iwmax=0 - - if(ideltas.gt.0) then - ifn=1 - else - ifn=numbwf - endif - ! - ! OPENING OF DATA FILE (GRIB CODE) - ! -5 call grib_open_file(ifile,path(3)(1:length(3)) & - //trim(wfname(ifn)),'r',iret) - if (iret.ne.GRIB_SUCCESS) then - goto 999 ! ERROR DETECTED - endif - !turn on support for multi fields messages - !call grib_multi_support_on - - gotGrid=0 - ifield=0 - do while(.true.) - ifield=ifield+1 - ! - ! GET NEXT FIELDS - ! - call grib_new_from_file(ifile,igrib,iret) - if (iret.eq.GRIB_END_OF_FILE ) then - exit ! EOF DETECTED - elseif (iret.ne.GRIB_SUCCESS) then - goto 999 ! ERROR DETECTED - endif - - !first see if we read GRIB1 or GRIB2 - call grib_get_int(igrib,'editionNumber',gribVer,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - if (gribVer.eq.1) then ! GRIB Edition 1 - - !print*,'GRiB Edition 1' - !read the grib2 identifiers - call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'level',isec1(8),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - !change code for etadot to code for omega - if (isec1(6).eq.77) then - isec1(6)=135 - endif - - !print*,isec1(6),isec1(8) - - else - - !print*,'GRiB Edition 2' - !read the grib2 identifiers - call grib_get_int(igrib,'discipline',discipl,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterCategory',parCat,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterNumber',parNum,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'level',ivalsfc,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'paramId',parId,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - !print*,discipl,parCat,parNum,sfctyp,ivalsfc - - !convert to grib1 identifiers - isec1(6)=-1 - isec1(7)=-1 - isec1(8)=-1 - isec1(8)=ivalsfc ! level - if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! T - isec1(6)=130 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.105)) then ! U - isec1(6)=131 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.105)) then ! V - isec1(6)=132 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! Q - isec1(6)=133 ! indicatorOfParameter - !ZHG FOR CLOUDS FROM GRIB - elseif ((parCat.eq.1).and.(parNum.eq.83).and.(sfctyp.eq.105)) then ! clwc - isec1(6)=246 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.84).and.(sfctyp.eq.105)) then ! ciwc - isec1(6)=247 ! indicatorOfParameter - !ZHG end - ! ESO qc(=clwc+ciwc) - elseif ((parCat.eq.201).and.(parNum.eq.31).and.(sfctyp.eq.105)) then ! qc - isec1(6)=201031 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then !SP - isec1(6)=134 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot - isec1(6)=135 ! indicatorOfParameter - elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot - isec1(6)=135 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.101)) then !SLP - isec1(6)=151 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! 10U - isec1(6)=165 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! 10V - isec1(6)=166 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! 2T - isec1(6)=167 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.6).and.(sfctyp.eq.103)) then ! 2D - isec1(6)=168 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SD - isec1(6)=141 ! indicatorOfParameter - elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC - isec1(6)=164 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP - isec1(6)=142 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP - isec1(6)=143 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SHF - isec1(6)=146 ! indicatorOfParameter - elseif ((parCat.eq.4).and.(parNum.eq.9).and.(sfctyp.eq.1)) then ! SR - isec1(6)=176 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.17) .or. parId .eq. 180) then ! EWSS - isec1(6)=180 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.18) .or. parId .eq. 181) then ! NSSS - isec1(6)=181 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO - isec1(6)=129 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO - isec1(6)=160 ! indicatorOfParameter - elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. & - (sfctyp.eq.1)) then ! LSM - isec1(6)=172 ! indicatorOfParameter - else - print*,'***ERROR: undefined GRiB2 message found!',discipl, & - parCat,parNum,sfctyp - endif - if(parId .ne. isec1(6) .and. parId .ne. 77) then - write(*,*) 'parId',parId, 'isec1(6)',isec1(6) - ! stop - endif - - endif - - call grib_get_int(igrib,'numberOfPointsAlongAParallel', & - isec2(2),iret) - ! ! nx=isec2(2) - ! ! WRITE(*,*) nx,nxmax - ! if (isec2(2).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 ecmwf_mod.' - ! WRITE(*,*) isec2(2),nxmax - ! ! STOP - ! endif - - !get the size and data of the values array - if (isec1(6).ne.-1) then - call grib_get_real4_array(igrib,'values',zsec4,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - endif - - if (ifield.eq.1) then - - !HSO get the required fields from section 2 in a gribex compatible manner - call grib_get_int(igrib,'numberOfPointsAlongAParallel', & - isec2(2),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & - isec2(3),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & - xaux1in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'numberOfVerticalCoordinateValues', & - isec2(12),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - nxfield=isec2(2) - ny=isec2(3) - nlev_ec=isec2(12)/2-1 - - ! get the size and data of the vertical coordinate array - call grib_get_real4_array(igrib,'pv',zsec2,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - endif - - !HSO get the second part of the grid dimensions only from GRiB1 messages - if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then - call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', & - xaux2in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & - yaux1in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', & - yaux2in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - xaux1=xaux1in - xaux2=xaux2in - yaux1=yaux1in - yaux2=yaux2in - if (xaux1.gt.180.) xaux1=xaux1-360.0 - if (xaux2.gt.180.) xaux2=xaux2-360.0 - if (xaux1.lt.-180.) xaux1=xaux1+360.0 - if (xaux2.lt.-180.) xaux2=xaux2+360.0 - if (xaux2.lt.xaux1) xaux2=xaux2+360.0 - xlon0=xaux1 - ylat0=yaux1 - dx=(xaux2-xaux1)/real(nxfield-1) - dy=(yaux2-yaux1)/real(ny-1) - dxconst=180./(dx*r_earth*pi) - dyconst=180./(dy*r_earth*pi) - gotGrid=1 - ! Check whether fields are global - ! If they contain the poles, specify polar stereographic map - ! projections using the stlmbr- and stcm2p-calls - !*********************************************************** - - xauxa=abs(xaux2+dx-360.-xaux1) - if (xauxa.lt.0.001) then - nx=nxfield+1 ! field is cyclic - xglobal=.true. - if (abs(nxshift).ge.nx) & - stop 'nxshift in file par_mod is too large' - xlon0=xlon0+real(nxshift)*dx - else - nx=nxfield - xglobal=.false. - if (nxshift.ne.0) & - stop 'nxshift (par_mod) must be zero for non-global domain' - endif - nxmin1=nx-1 - nymin1=ny-1 - if (xlon0.gt.180.) xlon0=xlon0-360. - xauxa=abs(yaux1+90.) - if (xglobal.and.xauxa.lt.0.001) then - sglobal=.true. ! field contains south pole - ! Enhance the map scale by factor 3 (*2=6) compared to north-south - ! map scale - sizesouth=6.*(switchsouth+90.)/dy - call stlmbr(southpolemap,-90.,0.) - call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, & - sizesouth,switchsouth,180.) - switchsouthg=(switchsouth-ylat0)/dy - else - sglobal=.false. - switchsouthg=999999. - endif - xauxa=abs(yaux2-90.) - if (xglobal.and.xauxa.lt.0.001) then - nglobal=.true. ! field contains north pole - ! Enhance the map scale by factor 3 (*2=6) compared to north-south - ! map scale - sizenorth=6.*(90.-switchnorth)/dy - call stlmbr(northpolemap,90.,0.) - call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, & - sizenorth,switchnorth,180.) - switchnorthg=(switchnorth-ylat0)/dy - else - nglobal=.false. - switchnorthg=999999. - endif - if (nxshift.lt.0) & - stop 'nxshift (par_mod) must not be negative' - if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large' - endif ! gotGrid - - if (nx.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,nxmax - stop - endif - - if (ny.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,nymax - stop - endif - - k=isec1(8) - if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1) - if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1) - - if (isec1(6) .eq. 167) then - ! ! Assing grid values and allocate memory to read windfields - ! nxmax=nxfield - ! if (xglobal) then - ! nxmax=nxfield+1 - ! endif - ! nymax=ny - ! nwzmax=iwmax+1 - ! nuvzmax=iumax+1 - ! nzmax=nuvzmax - ! nconvlevmax=iumax - ! na=nuvzmax - ! ! Temporary nxmax and nymax - call fixedfields_alloc - endif - - if(isec1(6).eq.129) then - do jy=0,ny-1 - do ix=0,nxfield-1 - oro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1)/ga - end do - end do - endif - if(isec1(6).eq.172) then - do jy=0,ny-1 - do ix=0,nxfield-1 - lsm(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1) - end do - end do - endif - if(isec1(6).eq.160) then - do jy=0,ny-1 - do ix=0,nxfield-1 - excessoro(ix,jy)=zsec4(nxfield*(ny-jy-1)+ix+1) - end do - end do - endif - - call grib_release(igrib) - end do !! READ NEXT LEVEL OR PARAMETER - ! - ! CLOSING OF INPUT DATA FILE - ! - call grib_close_file(ifile) - - ! call alloc_windf - - !error message if no fields found with correct first longitude in it - if (gotGrid.eq.0) then - print*,'***ERROR: input file needs to contain GRiB1 formatted'// & - 'messages' - stop - endif - - nuvz=iumax - nwz =iwmax - if(nuvz.eq.nlev_ec) nwz=nlev_ec+1 - - ! 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 - - ! 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 - - ! Output of grid info - !******************** - - if (lroot) then - write(*,'(a,2i7)') ' Vertical levels in ECMWF data: ', & - nuvz+1,nwz - write(*,*) - write(*,'(a)') ' Mother domain:' - write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Longitude range: ', & - xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx - write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Latitude range : ', & - ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy - write(*,*) - end if - - ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL - ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM - - numskip=nlev_ec-nuvz ! number of ecmwf model layers not used - ! by trajectory model - !do 8940 i=1,244 - ! write (*,*) 'zsec2:',i,ifield,zsec2(i),numskip - !940 continue - ! stop - ! SEC SEC SEC - ! for unknown reason zsec 1 to 10 is filled in this version - ! compared to the old one - ! SEC SEC SE - do i=1,nwz - j=numskip+i - k=nlev_ec+1+numskip+i - akm(nwz-i+1)=zsec2(j) - ! write (*,*) 'ifield:',ifield,k,j,zsec2(10+j) - bkm(nwz-i+1)=zsec2(k) - wheight(nwz-i+1)=akm(nwz-i+1)/101325.+bkm(nwz-i+1) ! From FLEXTRA - end do - - ! - ! CALCULATION OF AKZ, BKZ - ! AKZ,BKZ: model discretization parameters at the center of each model - ! layer - ! - ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0, - ! i.e. ground level - !***************************************************************************** - - akz(1)=0. - bkz(1)=1.0 - uvheight(1)=1. - do i=1,nuvz - uvheight(i+1)=0.5*(wheight(i+1)+wheight(i)) ! From FLEXTRA - akz(i+1)=0.5*(akm(i+1)+akm(i)) - bkz(i+1)=0.5*(bkm(i+1)+bkm(i)) - end do - ! exuvheight=wheight - nuvz=nuvz+1 - - ! 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_nest.f - !***************************************************************************** - - nz=nuvz - if (nz.gt.nzmax) stop 'nzmax too small' - do i=1,nuvz - aknew(i)=akz(i) - bknew(i)=bkz(i) - end do - - ! 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 - return - -999 write(*,*) - write(*,*) ' ###########################################'// & - '###### ' - write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:' - write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn) - write(*,*) ' ###########################################'// & - '###### ' - write(*,*) - write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!' - write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!' - write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!' - write(*,'(a)') '!!! THE "X" KEY... !!!' - write(*,*) - read(*,'(a)') opt - if(opt.eq.'X') then - stop - else - goto 5 - endif -end subroutine gridcheck_ecmwf - -subroutine gridcheck_gfs - - !********************************************************************** - ! * - ! FLEXPART MODEL SUBROUTINE GRIDCHECK * - ! * - !********************************************************************** - ! * - ! AUTHOR: G. WOTAWA * - ! DATE: 1997-08-06 * - ! LAST UPDATE: 1997-10-10 * - ! * - ! Update: 1999-02-08, global fields allowed, A. Stohl* - ! CHANGE: 17/11/2005, Caroline Forster, GFS data * - ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with * - ! ECMWF grib_api * - ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with * - ! ECMWF grib_api * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! - Renamed routine from gridcheck to gridcheck_gfs * - ! * - !********************************************************************** - ! * - ! DESCRIPTION: * - ! * - ! THIS SUBROUTINE DETERMINES THE GRID SPECIFICATIONS (LOWER LEFT * - ! LONGITUDE, LOWER LEFT LATITUDE, NUMBER OF GRID POINTS, GRID DIST- * - ! ANCE AND VERTICAL DISCRETIZATION OF THE ECMWF MODEL) FROM THE * - ! GRIB HEADER OF THE FIRST INPUT FILE. THE CONSISTANCY (NO CHANGES * - ! WITHIN ONE FLEXPART RUN) IS CHECKED IN THE ROUTINE "READWIND" AT * - ! ANY CALL. * - ! * - ! XLON0 geographical longitude of lower left gridpoint * - ! YLAT0 geographical latitude of lower left gridpoint * - ! NX number of grid points x-direction * - ! NY number of grid points y-direction * - ! DX grid distance x-direction * - ! DY grid distance y-direction * - ! NUVZ number of grid points for horizontal wind * - ! components in z direction * - ! NWZ number of grid points for vertical wind * - ! component in z direction * - ! sizesouth, sizenorth give the map scale (i.e. number of virtual grid* - ! points of the polar stereographic grid): * - ! used to check the CFL criterion * - ! UVHEIGHT(1)- heights of gridpoints where u and v are * - ! UVHEIGHT(NUVZ) given * - ! WHEIGHT(1)- heights of gridpoints where w is given * - ! WHEIGHT(NWZ) * - ! * - !********************************************************************** - - use grib_api - use cmapf_mod, only: stlmbr,stcm2p - - implicit none - - !HSO parameters for grib_api - integer :: ifile - integer :: iret - integer :: igrib - real(kind=4) :: xaux1,xaux2,yaux1,yaux2 - real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in - integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl - !HSO end - integer :: ix,jy,i,ifn,ifield,j,k,iumax,iwmax,numskip - real :: sizesouth,sizenorth,xauxa,pint - real :: akm_usort(nwzmax) - real,parameter :: eps=0.0001 - - ! NCEP GFS - real :: pres(nwzmax), help - - integer :: i179,i180,i181 - - ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING - - integer :: isec1(8),isec2(3) - real(kind=4) :: zsec4(jpunp) - character(len=1) :: opt - - !HSO grib api error messages - character(len=24) :: gribErrorMsg = 'Error reading grib file' - character(len=20) :: gribFunction = 'gridcheckwind_gfs' - ! - if (numbnests.ge.1) then - write(*,*) ' ###########################################' - write(*,*) ' FLEXPART ERROR SUBROUTINE GRIDCHECK:' - write(*,*) ' NO NESTED WINDFIELDAS ALLOWED FOR GFS! ' - write(*,*) ' ###########################################' - stop - endif - - iumax=0 - iwmax=0 - - if(ideltas.gt.0) then - ifn=1 - else - ifn=numbwf - endif - ! - ! OPENING OF DATA FILE (GRIB CODE) - ! -5 call grib_open_file(ifile,path(3)(1:length(3)) & - //trim(wfname(ifn)),'r',iret) - if (iret.ne.GRIB_SUCCESS) then - goto 999 ! ERROR DETECTED - endif - !turn on support for multi fields messages - call grib_multi_support_on - - ifield=0 - do - ifield=ifield+1 - ! - ! GET NEXT FIELDS - ! - call grib_new_from_file(ifile,igrib,iret) - if (iret.eq.GRIB_END_OF_FILE ) then - exit ! EOF DETECTED - elseif (iret.ne.GRIB_SUCCESS) then - goto 999 ! ERROR DETECTED - endif - - !first see if we read GRIB1 or GRIB2 - call grib_get_int(igrib,'editionNumber',gribVer,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - if (gribVer.eq.1) then ! GRIB Edition 1 - - !read the grib1 identifiers - call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'level',isec1(8),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - !get the size and data of the values array - call grib_get_real4_array(igrib,'values',zsec4,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - else ! GRIB Edition 2 - - !read the grib2 identifiers - call grib_get_int(igrib,'discipline',discipl,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterCategory',parCat,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterNumber',parNum,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', & - ivalsfc,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - !convert to grib1 identifiers - isec1(6)=-1 - isec1(7)=-1 - isec1(8)=-1 - if ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.100)) then ! U - isec1(6)=33 ! indicatorOfParameter - isec1(7)=100 ! indicatorOfTypeOfLevel - isec1(8)=ivalsfc/100 ! level, convert to hPa - elseif ((parCat.eq.3).and.(parNum.eq.5).and.(sfctyp.eq.1)) then ! TOPO - isec1(6)=7 ! indicatorOfParameter - isec1(7)=1 ! indicatorOfTypeOfLevel - isec1(8)=0 - elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.1) & - .and.(discipl.eq.2)) then ! LSM - isec1(6)=81 ! indicatorOfParameter - isec1(7)=1 ! indicatorOfTypeOfLevel - isec1(8)=0 - endif - - if (isec1(6).ne.-1) then - ! get the size and data of the values array - call grib_get_real4_array(igrib,'values',zsec4,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - endif - - endif ! gribVer - - if(ifield.eq.1) then - - !get the required fields from section 2 - !store compatible to gribex input - call grib_get_int(igrib,'numberOfPointsAlongAParallel', & - isec2(2),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & - isec2(3),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & - xaux1in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', & - xaux2in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & - yaux1in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', & - yaux2in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - ! Fix for flexpart.eu ticket #48 - if (xaux2in.lt.0) xaux2in = 359.0 - - xaux1=xaux1in - xaux2=xaux2in - yaux1=yaux1in - yaux2=yaux2in - - nxfield=isec2(2) - ny=isec2(3) - if((abs(xaux1).lt.eps).and.(xaux2.ge.359)) then ! NCEP DATA FROM 0 TO - xaux1=-179.0 ! 359 DEG EAST -> - xaux2=-179.0+360.-360./real(nxfield) ! TRANSFORMED TO -179 - endif ! TO 180 DEG EAST - if (xaux1.gt.180) xaux1=xaux1-360.0 - if (xaux2.gt.180) xaux2=xaux2-360.0 - if (xaux1.lt.-180) xaux1=xaux1+360.0 - if (xaux2.lt.-180) xaux2=xaux2+360.0 - if (xaux2.lt.xaux1) xaux2=xaux2+360. - xlon0=xaux1 - ylat0=yaux1 - dx=(xaux2-xaux1)/real(nxfield-1) - dy=(yaux2-yaux1)/real(ny-1) - dxconst=180./(dx*r_earth*pi) - dyconst=180./(dy*r_earth*pi) - !HSO end edits - - - ! Check whether fields are global - ! If they contain the poles, specify polar stereographic map - ! projections using the stlmbr- and stcm2p-calls - !*********************************************************** - - xauxa=abs(xaux2+dx-360.-xaux1) - if (xauxa.lt.0.001) then - nx=nxfield+1 ! field is cyclic - xglobal=.true. - if (abs(nxshift).ge.nx) & - stop 'nxshift in file par_mod is too large' - xlon0=xlon0+real(nxshift)*dx - else - nx=nxfield - xglobal=.false. - if (nxshift.ne.0) & - stop 'nxshift (par_mod) must be zero for non-global domain' - endif - nxmin1=nx-1 - nymin1=ny-1 - if (xlon0.gt.180.) xlon0=xlon0-360. - xauxa=abs(yaux1+90.) - if (xglobal.and.xauxa.lt.0.001) then - sglobal=.true. ! field contains south pole - ! Enhance the map scale by factor 3 (*2=6) compared to north-south - ! map scale - sizesouth=6.*(switchsouth+90.)/dy - call stlmbr(southpolemap,-90.,0.) - call stcm2p(southpolemap,0.,0.,switchsouth,0.,sizesouth, & - sizesouth,switchsouth,180.) - switchsouthg=(switchsouth-ylat0)/dy - else - sglobal=.false. - switchsouthg=999999. - endif - xauxa=abs(yaux2-90.) - if (xglobal.and.xauxa.lt.0.001) then - nglobal=.true. ! field contains north pole - ! Enhance the map scale by factor 3 (*2=6) compared to north-south - ! map scale - sizenorth=6.*(90.-switchnorth)/dy - call stlmbr(northpolemap,90.,0.) - call stcm2p(northpolemap,0.,0.,switchnorth,0.,sizenorth, & - sizenorth,switchnorth,180.) - switchnorthg=(switchnorth-ylat0)/dy - else - nglobal=.false. - switchnorthg=999999. - endif - endif ! ifield.eq.1 - - if (nxshift.lt.0) stop 'nxshift (par_mod) must not be negative' - if (nxshift.ge.nxfield) stop 'nxshift (par_mod) too large' - - ! NCEP ISOBARIC LEVELS - !********************* - - if((isec1(6).eq.33).and.(isec1(7).eq.100)) then ! check for U wind - iumax=iumax+1 - pres(iumax)=real(isec1(8))*100.0 - endif - - - i179=nint(179./dx) - if (dx.lt.0.7) then - i180=nint(180./dx)+1 ! 0.5 deg data - else - i180=nint(179./dx)+1 ! 1 deg data - endif - i181=i180+1 - - - ! NCEP TERRAIN - !************* - - if (isec1(6).eq.007 .and. isec1(7).eq.001) then - ! IP 2023-05-09: allocate fields missing for GFS reading - call fixedfields_alloc - do jy=0,ny-1 - do ix=0,nxfield-1 - help=zsec4(nxfield*(ny-jy-1)+ix+1) - if(ix.le.i180) then - oro(i179+ix,jy)=help - excessoro(i179+ix,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED - else - oro(ix-i181,jy)=help - excessoro(ix-i181,jy)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED - endif - end do - end do - endif - - ! NCEP LAND SEA MASK - !******************* - - if((isec1(6).eq.081).and.(isec1(7).eq.001)) then - do jy=0,ny-1 - do ix=0,nxfield-1 - help=zsec4(nxfield*(ny-jy-1)+ix+1) - if(ix.le.i180) then - lsm(i179+ix,jy)=help - else - lsm(ix-i181,jy)=help - endif - end do - end do - endif - - call grib_release(igrib) - - end do !! READ NEXT LEVEL OR PARAMETER - ! - ! CLOSING OF INPUT DATA FILE - ! - - ! HSO - call grib_close_file(ifile) - ! HSO end edits - - nuvz=iumax - nwz =iumax - nlev_ec=iumax - - ! ! Assing grid values and allocate memory to read windfields - ! nxmax=nx - ! nymax=ny - ! nwzmax=nwz - ! nuvzmax=nuvz - ! nzmax=nuvz - ! ! nconvlevmax=nuvzmax-1 - ! ! na=nconvlevmax+1 - - ! call alloc_windf - - if (nx.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,nxmax - stop - endif - - if (ny.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,nymax - stop - endif - - if (nuvz.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,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 - - ! 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 - - ! Output of grid info - !******************** - - if (lroot) then - write(*,*) - write(*,*) - write(*,'(a,2i7)') 'Vertical levels in NCEP data: ', & - nuvz,nwz - write(*,*) - write(*,'(a)') 'Mother domain:' - write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Longitude range: ', & - xlon0,' to ',xlon0+(nx-1)*dx,' Grid distance: ',dx - write(*,'(a,f10.2,a1,f10.2,a,f10.2)') ' Latitude range : ', & - ylat0,' to ',ylat0+(ny-1)*dy,' Grid distance: ',dy - write(*,*) - end if - - ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL - ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM - - numskip=nlev_ec-nuvz ! number of ecmwf model layers not used - ! by trajectory model - do i=1,nwz - j=numskip+i - k=nlev_ec+1+numskip+i - akm_usort(nwz-i+1)=pres(nwz-i+1) - bkm(nwz-i+1)=0.0 - end do - - !****************************** - ! change Sabine Eckhardt: akm should always be in descending order ... readwind adapted! - !****************************** - do i=1,nwz - if (akm_usort(1).gt.akm_usort(2)) then - akm(i)=akm_usort(i) - else - akm(i)=akm_usort(nwz-i+1) - endif - end do - - ! - ! CALCULATION OF AKZ, BKZ - ! AKZ,BKZ: model discretization parameters at the center of each model - ! layer - ! - ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0, - ! i.e. ground level - !***************************************************************************** - - do i=1,nuvz - akz(i)=akm(i) - bkz(i)=bkm(i) - end do - - ! 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_nest.f - !***************************************************************************** - - nz=nuvz - if (nz.gt.nzmax) stop 'nzmax too small' - do i=1,nuvz - aknew(i)=akz(i) - bknew(i)=bkz(i) - end do - - ! 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 - return - -999 write(*,*) - write(*,*) ' ###########################################'// & - '###### ' - write(*,*) ' TRAJECTORY MODEL SUBROUTINE GRIDCHECK:' - write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfname(ifn) - write(*,*) ' ###########################################'// & - '###### ' - write(*,*) - write(*,'(a)') '!!! PLEASE INSERT A NEW CD-ROM AND !!!' - write(*,'(a)') '!!! PRESS ANY KEY TO CONTINUE... !!!' - write(*,'(a)') '!!! ...OR TERMINATE FLEXPART PRESSING!!!' - write(*,'(a)') '!!! THE "X" KEY... !!!' - write(*,*) - read(*,'(a)') opt - if(opt.eq.'X') then - stop - else - goto 5 - endif - -end subroutine gridcheck_gfs - -subroutine gridcheck_nest - - !***************************************************************************** - ! * - ! This routine checks the grid specification for the nested model * - ! domains. It is similar to subroutine gridcheck, which checks the * - ! mother domain. * - ! * - ! Authors: A. Stohl, G. Wotawa * - ! * - ! 8 February 1999 * - ! * - !***************************************************************************** - ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api * - ! CHANGE: 03/12/2008, Harald Sodemann, change to f90 grib_api * - !***************************************************************************** - - use grib_api - - implicit none - - !HSO parameters for grib_api - integer :: ifile - integer :: iret - integer :: igrib - integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl - integer :: parID !added by mc for making it consistent with new gridcheck.f90 - integer :: gotGrib - !HSO end - integer :: i,j,k,l,ifn,ifield,iumax,iwmax,numskip,nlev_ecn - integer :: nuvzn,nwzn - real :: akmn(nwzmax),bkmn(nwzmax),akzn(nuvzmax),bkzn(nuvzmax) - real(kind=4) :: xaux1,xaux2,yaux1,yaux2 - real(kind=8) :: xaux1in,xaux2in,yaux1in,yaux2in - real :: conversion_factor !added by mc to make it consistent with new gridchek.f90 - - ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING - - ! dimension of isec2 at least (22+n), where n is the number of parallels or - ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid - - ! dimension of zsec2 at least (10+nn), where nn is the number of vertical - ! coordinate parameters - - integer :: isec1(56),isec2(22+nxmaxn+nymaxn) - real(kind=4) :: zsec2(60+2*nuvzmax),zsec4(jpunp) - - !HSO grib api error messages - character(len=24) :: gribErrorMsg = 'Error reading grib file' - character(len=20) :: gribFunction = 'gridcheck_nest' - - xresoln(0)=1. ! resolution enhancement for mother grid - yresoln(0)=1. ! resolution enhancement for mother grid - - ! Loop about all nesting levels - !****************************** - - do l=1,numbnests - - iumax=0 - iwmax=0 - - if(ideltas.gt.0) then - ifn=1 - else - ifn=numbwf - endif - ! - ! OPENING OF DATA FILE (GRIB CODE) - ! - ifile=0 - igrib=0 - iret=0 - -5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) & - (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,ifn)),'r',iret) - if (iret.ne.GRIB_SUCCESS) then - goto 999 ! ERROR DETECTED - endif - !turn on support for multi fields messages - !call grib_multi_support_on - - gotGrib=0 - ifield=0 - do - ifield=ifield+1 - - ! - ! GET NEXT FIELDS - ! - call grib_new_from_file(ifile,igrib,iret) - if (iret.eq.GRIB_END_OF_FILE) then - exit ! EOF DETECTED - elseif (iret.ne.GRIB_SUCCESS) then - goto 999 ! ERROR DETECTED - endif - - !first see if we read GRIB1 or GRIB2 - call grib_get_int(igrib,'editionNumber',gribVer,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - if (gribVer.eq.1) then ! GRIB Edition 1 - - !print*,'GRiB Edition 1' - !read the grib2 identifiers - call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'level',isec1(8),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - !change code for etadot to code for omega - if (isec1(6).eq.77) then - isec1(6)=135 - endif - - !print*,isec1(6),isec1(8) - - else - - !print*,'GRiB Edition 2' - !read the grib2 identifiers - call grib_get_int(igrib,'discipline',discipl,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterCategory',parCat,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterNumber',parNum,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'level',ivalsfc,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'paramId',parId,iret) !added by mc to make it consisitent with new grid_check.f90 - call grib_check(iret,gribFunction,gribErrorMsg) !added by mc to make it consisitent with new grid_check.f90 - - !print*,discipl,parCat,parNum,sfctyp,ivalsfc - - !convert to grib1 identifiers - isec1(6)=-1 - isec1(7)=-1 - isec1(8)=-1 - isec1(8)=ivalsfc ! level - if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! T - isec1(6)=130 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.105)) then ! U - isec1(6)=131 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.105)) then ! V - isec1(6)=132 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! Q - isec1(6)=133 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.83).and.(sfctyp.eq.105)) then ! clwc - isec1(6)=246 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.84).and.(sfctyp.eq.105)) then ! ciwc - isec1(6)=247 ! indicatorOfParameter - !ZHG end - ! ESO qc(=clwc+ciwc) - elseif ((parCat.eq.201).and.(parNum.eq.31).and.(sfctyp.eq.105)) then ! qc - isec1(6)=201031 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then !SP - isec1(6)=134 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot - isec1(6)=135 ! indicatorOfParameter - elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot !added bymc to make it consistent with new gridcheck.f90 - isec1(6)=135 ! indicatorOfParameter ! - elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.101)) then !SLP - isec1(6)=151 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! 10U - isec1(6)=165 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! 10V - isec1(6)=166 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! 2T - isec1(6)=167 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.6).and.(sfctyp.eq.103)) then ! 2D - isec1(6)=168 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SD - isec1(6)=141 ! indicatorOfParameter - elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC !added by mc to make it consistent with new gridchek.f90 - isec1(6)=164 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP !added by mc to make it consistent with new gridchek.f90 - isec1(6)=142 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP - isec1(6)=143 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SHF - isec1(6)=146 ! indicatorOfParameter - elseif ((parCat.eq.4).and.(parNum.eq.9).and.(sfctyp.eq.1)) then ! SR - isec1(6)=176 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.17) .or. parId .eq. 180) then ! EWSS !added by mc to make it consistent with new gridchek.f90 - isec1(6)=180 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.18) .or. parId .eq. 181) then ! NSSS !added by mc to make it consistent with new gridchek.f90 - isec1(6)=181 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO - isec1(6)=129 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO !added by mc to make it consistent with new gridchek.f90 - isec1(6)=160 ! indicatorOfParameter - elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. & - (sfctyp.eq.1)) then ! LSM - isec1(6)=172 ! indicatorOfParameter - else - print*,'***ERROR: undefined GRiB2 message found!',discipl, & - parCat,parNum,sfctyp - endif - if(parId .ne. isec1(6) .and. parId .ne. 77) then !added by mc to make it consistent with new gridchek.f90 - write(*,*) 'parId',parId, 'isec1(6)',isec1(6) - ! stop - endif - - endif - - !get the size and data of the values array - if (isec1(6).ne.-1) then - call grib_get_real4_array(igrib,'values',zsec4,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - endif - - !HSO get the required fields from section 2 in a gribex compatible manner - if (ifield.eq.1) then - call grib_get_int(igrib,'numberOfPointsAlongAParallel', & - isec2(2),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & - isec2(3),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'numberOfVerticalCoordinateValues', & - isec2(12),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - !HSO get the size and data of the vertical coordinate array - call grib_get_real4_array(igrib,'pv',zsec2,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - nxn(l)=isec2(2) - nyn(l)=isec2(3) - nlev_ecn=isec2(12)/2-1 - endif ! ifield - - if (nxn(l).gt.nxmaxn) then - write(*,*) 'FLEXPART error: Too many grid points in x direction.' - write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)' - write(*,*) 'for nesting level ',l - write(*,*) 'Or change parameter settings in file par_mod.' - write(*,*) nxn(l),nxmaxn - stop - endif - - if (nyn(l).gt.nymaxn) then - write(*,*) 'FLEXPART error: Too many grid points in y direction.' - write(*,*) 'Reduce resolution of wind fields (file GRIDSPEC)' - write(*,*) 'for nesting level ',l - write(*,*) 'Or change parameter settings in file par_mod.' - write(*,*) nyn(l),nymaxn - stop - endif - - !HSO get the second part of the grid dimensions only from GRiB1 messages - if (isec1(6) .eq. 167 .and. (gotGrib.eq.0)) then !added by mc to make it consistent with new gridchek.f90 note that gotGrid must be changed in gotGrib!! - call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & !comment by mc: note that this was in the (if (ifield.eq.1) ..end above in gridchek.f90 see line 257 - xaux1in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'longitudeOfLastGridPointInDegrees', & - xaux2in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & - yaux1in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'latitudeOfFirstGridPointInDegrees', & - yaux2in,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - xaux1=xaux1in - xaux2=xaux2in - yaux1=yaux1in - yaux2=yaux2in - if(xaux1.gt.180.) xaux1=xaux1-360.0 - if(xaux2.gt.180.) xaux2=xaux2-360.0 - if(xaux1.lt.-180.) xaux1=xaux1+360.0 - if(xaux2.lt.-180.) xaux2=xaux2+360.0 - if (xaux2.lt.xaux1) xaux2=xaux2+360.0 - xlon0n(l)=xaux1 - ylat0n(l)=yaux1 - dxn(l)=(xaux2-xaux1)/real(nxn(l)-1) - dyn(l)=(yaux2-yaux1)/real(nyn(l)-1) - gotGrib=1 !commetn by mc note tahthere gotGRIB is used instead of gotGrid!!! - endif ! ifield.eq.1 - - k=isec1(8) - if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1) - if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1) - - if(isec1(6).eq.129) then - do j=0,nyn(l)-1 - do i=0,nxn(l)-1 - oron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga - end do - end do - endif - if(isec1(6).eq.172) then - do j=0,nyn(l)-1 - do i=0,nxn(l)-1 - lsmn(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga - end do - end do - endif - if(isec1(6).eq.160) then - do j=0,nyn(l)-1 - do i=0,nxn(l)-1 - excessoron(i,j,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga - end do - end do - endif - - call grib_release(igrib) - end do !! READ NEXT LEVEL OR PARAMETER - ! - ! CLOSING OF INPUT DATA FILE - ! - - call grib_close_file(ifile) - - !error message if no fields found with correct first longitude in it - if (gotGrib.eq.0) then - print*,'***ERROR: input file needs to contain GRiB1 formatted'// & - 'messages' - stop - endif - - nuvzn=iumax - nwzn=iwmax - if(nuvzn.eq.nlev_ec) nwzn=nlev_ecn+1 - - if ((nuvzn.gt.nuvzmax).or.(nwzn.gt.nwzmax)) then - write(*,*) 'FLEXPART error: Nested wind fields have too many'// & - 'vertical levels.' - write(*,*) 'Problem was encountered for nesting level ',l - stop - endif - - - ! Output of grid info - !******************** - - write(*,'(a,i2,a)') ' Nested domain ',l,':' - write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Longitude range: ', & - xlon0n(l),' to ',xlon0n(l)+(nxn(l)-1)*dxn(l), & - ' Grid distance: ',dxn(l) - write(*,'(a,f10.5,a,f10.5,a,f10.5)') ' Latitude range : ', & - ylat0n(l),' to ',ylat0n(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=xlon0n(l) - xaux2=xlon0n(l)+real(nxn(l)-1)*dxn(l) - yaux1=ylat0n(l) - yaux2=ylat0n(l)+real(nyn(l)-1)*dyn(l) - - xln(l)=(xaux1-xlon0)/dx - xrn(l)=(xaux2-xlon0)/dx - yln(l)=(yaux1-ylat0)/dy - yrn(l)=(yaux2-ylat0)/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(*,*) 'Nested domain does not fit into mother domain' - write(*,*) 'For global mother domain fields, you can shift' - write(*,*) 'shift the mother domain into x-direction' - write(*,*) 'by setting nxshift (file par_mod) to a' - write(*,*) 'positive value. Execution is terminated.' - stop - endif - - - ! CALCULATE VERTICAL DISCRETIZATION OF ECMWF MODEL - ! PARAMETER akm,bkm DESCRIBE THE HYBRID "ETA" COORDINATE SYSTEM - - numskip=nlev_ecn-nuvzn ! number of ecmwf model layers not used by FLEXPART - do i=1,nwzn - j=numskip+i - k=nlev_ecn+1+numskip+i - akmn(nwzn-i+1)=zsec2(j) - bkmn(nwzn-i+1)=zsec2(k) - end do - - ! - ! CALCULATION OF AKZ, BKZ - ! AKZ,BKZ: model discretization parameters at the center of each model - ! layer - ! - ! Assign the 10 m winds to an artificial model level with akz=0 and bkz=1.0, - ! i.e. ground level - !***************************************************************************** - - akzn(1)=0. - bkzn(1)=1.0 - do i=1,nuvzn - akzn(i+1)=0.5*(akmn(i+1)+akmn(i)) - bkzn(i+1)=0.5*(bkmn(i+1)+bkmn(i)) - end do - nuvzn=nuvzn+1 - - ! 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. - !************************************************************* - - do i=1,nuvz - if ((akzn(i).ne.akz(i)).or.(bkzn(i).ne.bkz(i))) then - write(*,*) 'FLEXPART error: The wind fields of nesting level',l - write(*,*) 'are not consistent with the mother domain:' - write(*,*) 'Differences in vertical levels detected.' - stop - endif - end do - - do i=1,nwz - if ((akmn(i).ne.akm(i)).or.(bkmn(i).ne.bkm(i))) then - write(*,*) 'FLEXPART error: The wind fields of nesting level',l - write(*,*) 'are not consistent with the mother domain:' - write(*,*) 'Differences in vertical levels detected.' - stop - endif - end do - - end do - - return - -999 write(*,*) - write(*,*) ' ###########################################'// & - '###### ' - write(*,*) ' FLEXPART SUBROUTINE GRIDCHECK:' - write(*,*) ' CAN NOT OPEN INPUT DATA FILE '//wfnamen(l,ifn) - write(*,*) ' FOR NESTING LEVEL ',k - write(*,*) ' ###########################################'// & - '###### ' - stop - -end subroutine gridcheck_nest - -subroutine readwind_ecmwf(indj,n,uuh,vvh,wwh) - - !********************************************************************** - ! * - ! TRAJECTORY MODEL SUBROUTINE READWIND * - ! * - !********************************************************************** - ! * - ! AUTHOR: G. WOTAWA * - ! DATE: 1997-08-05 * - ! LAST UPDATE: 2000-10-17, Andreas Stohl * - ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with * - ! ECMWF grib_api * - ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with * - ! ECMWF grib_api * - ! * - !********************************************************************** - ! Changes, Bernd C. Krueger, Feb. 2001: - ! Variables tth and qvh (on eta coordinates) in common block - ! - ! Unified ECMWF and GFS builds - ! Marian Harustak, 12.5.2017 - ! - Renamed from readwind to readwind_ecmwf - ! - ! L. Bakels, 2021: OpenMP parallelisation (following CTM 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 vertical levels ecmwf model * - ! uu,vv,ww wind fields * - ! tt,qv temperature and specific humidity * - ! ps surface pressure * - ! * - !********************************************************************** - - use grib_api - - implicit none - - ! include 'grib_api.h' - - !HSO parameters for grib_api - integer :: ifile - integer :: iret - integer, dimension(:), allocatable :: igrib - integer :: nfield, ii, arsize - integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl,parId - integer :: gotGrid - ! HSO end - - 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) - integer :: indj,i,j,k,n,levdiff2,iumax,iwmax!,ifield - integer :: kz - - ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING - - ! dimension of isec2 at least (22+n), where n is the number of parallels or - ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid +#include "win_gridcheck_ecmwf.f90" - ! dimension of zsec2 at least (10+nn), where nn is the number of vertical - ! coordinate parameters +#include "win_gridcheck_gfs.f90" - integer :: isec1(56),isec2(22+nxmax+nymax) - real(kind=4), allocatable, dimension(:) :: zsec4 - ! real(kind=4) :: zsec4(jpunp) - real(kind=4) :: xaux,yaux,xaux0,yaux0 - real(kind=8) :: xauxin,yauxin - real,parameter :: eps=1.e-4 - real(kind=4) :: nsss(0:nxmax-1,0:nymax-1),ewss(0:nxmax-1,0:nymax-1) - real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1,conversion_factor - integer :: stat +#include "win_gridcheck_nest.f90" - logical :: hflswitch,strswitch!,readcloud +#include "win_readwind_ecmwf.f90" - !HSO grib api error messages - character(len=24) :: gribErrorMsg = 'Error reading grib file' - character(len=20) :: gribFunction = 'readwind' - - hflswitch=.false. - strswitch=.false. - !ZHG test the grib fields that have lcwc without using them - ! readcloud=.false. - - levdiff2=nlev_ec-nwz+1 - iumax=0 - iwmax=0 - - ! - ! OPENING OF DATA FILE (GRIB CODE) - ! - call grib_open_file(ifile,path(3)(1:length(3)) & - //trim(wfname(indj)),'r',iret) - if (iret.ne.GRIB_SUCCESS) then - goto 888 ! ERROR DETECTED - endif - - call grib_count_in_file(ifile,nfield) - - ! allocate memory for grib handles - allocate(igrib(nfield), stat=stat) - if (stat.ne.0) stop "Could not allocate igrib" - ! initialise - igrib(:) = -1 - - do ii = 1,nfield - call grib_new_from_file(ifile, igrib(ii), iret) - end do - - call grib_close_file(ifile) - - !turn on support for multi fields messages */ - !call grib_multi_support_on - - gotGrid=0 - -!$OMP PARALLEL DEFAULT(none) & -!$OMP SHARED (nfield, igrib, gribFunction, nxfield, ny, nlev_ec, dx, xlon0, ylat0, & -!$OMP n, tth, uuh, vvh, iumax, qvh, ps, wwh, iwmax, sd, msl, tcc, u10, v10, tt2, & -!$OMP td2, lsprec, convprec, sshf, hflswitch, ssr, ewss, nsss, strswitch, oro, & -!$OMP excessoro, lsm, nymin1,ciwch,clwch,readclouds,sumclouds, nxshift) & -!$OMP PRIVATE(ii, gribVer, iret, isec1, discipl, parCat, parNum, parId,sfctyp, ivalsfc, & -!$OMP zsec4, isec2, gribErrorMsg, xauxin, yauxin, xaux, yaux, xaux0, & -!$OMP yaux0, k, arsize, stat, conversion_factor) & -!$OMP REDUCTION(+:gotGrid) - ! - ! GET NEXT FIELDS - ! - ! allocate memory for reading from grib - allocate(zsec4(nxfield*ny), stat=stat) - if (stat.ne.0) stop "Could not allocate zsec4" - -!$OMP DO SCHEDULE(static) - - fieldloop : do ii=1,nfield - - !first see if we read GRIB1 or GRIB2 - call grib_get_int(igrib(ii),'editionNumber',gribVer,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - if (gribVer.eq.1) then ! GRIB Edition 1 - - !print*,'GRiB Edition 1' - !read the grib2 identifiers - call grib_get_int(igrib(ii),'indicatorOfParameter',isec1(6),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib(ii),'level',isec1(8),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - !change code for etadot to code for omega - if (isec1(6).eq.77) then - isec1(6)=135 - endif - - conversion_factor=1. - - else - - !print*,'GRiB Edition 2' - !read the grib2 identifiers - call grib_get_int(igrib(ii),'discipline',discipl,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib(ii),'parameterCategory',parCat,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib(ii),'parameterNumber',parNum,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib(ii),'typeOfFirstFixedSurface',sfctyp,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib(ii),'level',ivalsfc,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib(ii),'paramId',parId,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - !print*,discipl,parCat,parNum,sfctyp,ivalsfc - - !convert to grib1 identifiers - isec1(6)=-1 - isec1(7)=-1 - isec1(8)=-1 - isec1(8)=ivalsfc ! level - conversion_factor=1. - if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! T - isec1(6)=130 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.105)) then ! U - isec1(6)=131 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.105)) then ! V - isec1(6)=132 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! Q - isec1(6)=133 ! indicatorOfParameter - ! ESO Cloud water is in a) fields CLWC and CIWC, *or* b) field QC - elseif ((parCat.eq.1).and.(parNum.eq.83).and.(sfctyp.eq.105)) then ! clwc - isec1(6)=246 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.84).and.(sfctyp.eq.105)) then ! ciwc - isec1(6)=247 ! indicatorOfParameter - ! ESO qc(=clwc+ciwc): - elseif ((parCat.eq.201).and.(parNum.eq.31).and.(sfctyp.eq.105)) then ! qc - isec1(6)=201031 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then !SP - isec1(6)=134 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot - isec1(6)=135 ! indicatorOfParameter - elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot - isec1(6)=135 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.101)) then !SLP - isec1(6)=151 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! 10U - isec1(6)=165 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! 10V - isec1(6)=166 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! 2T - isec1(6)=167 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.6).and.(sfctyp.eq.103)) then ! 2D - isec1(6)=168 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SD - isec1(6)=141 ! indicatorOfParameter - conversion_factor=1000. - elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC - isec1(6)=164 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP - isec1(6)=142 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP - isec1(6)=143 ! indicatorOfParameter - conversion_factor=1000. - elseif ((parCat.eq.0).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SHF - isec1(6)=146 ! indicatorOfParameter - elseif ((parCat.eq.4).and.(parNum.eq.9).and.(sfctyp.eq.1)) then ! SR - isec1(6)=176 ! indicatorOfParameter - ! elseif ((parCat.eq.2).and.(parNum.eq.17) .or. parId .eq. 180) then ! EWSS --wrong - elseif ((parCat.eq.2).and.(parNum.eq.38) .or. parId .eq. 180) then ! EWSS --correct - isec1(6)=180 ! indicatorOfParameter - ! elseif ((parCat.eq.2).and.(parNum.eq.18) .or. parId .eq. 181) then ! NSSS --wrong - elseif ((parCat.eq.2).and.(parNum.eq.37) .or. parId .eq. 181) then ! NSSS --correct - isec1(6)=181 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO - isec1(6)=129 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO - isec1(6)=160 ! indicatorOfParameter - elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. & - (sfctyp.eq.1)) then ! LSM - isec1(6)=172 ! indicatorOfParameter - elseif (parNum.eq.152) then - isec1(6)=152 ! avoid warning for lnsp - else - print*,'***WARNING: undefined GRiB2 message found!',discipl, & - parCat,parNum,sfctyp - endif - if(parId .ne. isec1(6) .and. parId .ne. 77) then - write(*,*) 'parId',parId, 'isec1(6)',isec1(6) - ! stop - endif - - endif - - !HSO get the size and data of the values array - if (isec1(6).ne.-1) then - call grib_get_real4_array(igrib(ii),'values',zsec4,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - endif - - !HSO get the required fields from section 2 in a gribex compatible manner - if (ii.eq.1) then - call grib_get_int(igrib(ii),'numberOfPointsAlongAParallel',isec2(2),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib(ii),'numberOfPointsAlongAMeridian',isec2(3),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib(ii),'numberOfVerticalCoordinateValues',isec2(12)) - call grib_check(iret,gribFunction,gribErrorMsg) - ! CHECK GRID SPECIFICATIONS - if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT' - if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT' - if(isec2(12)/2-1.ne.nlev_ec) & - stop 'READWIND: VERTICAL DISCRETIZATION NOT CONSISTENT' - endif ! ifield - -!$OMP CRITICAL - !HSO get the second part of the grid dimensions only from GRiB1 messages - if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then - call grib_get_real8(igrib(ii),'longitudeOfFirstGridPointInDegrees', & - xauxin,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib(ii),'latitudeOfLastGridPointInDegrees', & - yauxin,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - if (xauxin.gt.180.) xauxin=xauxin-360.0 - if (xauxin.lt.-180.) xauxin=xauxin+360.0 - - xaux=xauxin+real(nxshift)*dx - yaux=yauxin - if (xaux.gt.180.) xaux=xaux-360.0 - if(abs(xaux-xlon0).gt.eps) & - stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT' - if(abs(yaux-ylat0).gt.eps) & - stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT' - gotGrid=1 - endif ! gotGrid -!$OMP END CRITICAL - - k=isec1(8) - select case(isec1(6)) - !! TEMPERATURE - case(130) - do j=0,nymin1 - do i=0,nxfield-1 - tth(i,j,nlev_ec-k+2,n) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! U VELOCITY - case(131) - do j=0,nymin1 - do i=0,nxfield-1 - uuh(i,j,nlev_ec-k+2) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do -!$OMP CRITICAL - iumax=max(iumax,nlev_ec-k+1) -!$OMP END CRITICAL - !! V VELOCITY - case(132) - do j=0,nymin1 - do i=0,nxfield-1 - vvh(i,j,nlev_ec-k+2) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! SPEC. HUMIDITY - case(133) - do j=0,nymin1 - do i=0,nxfield-1 - qvh(i,j,nlev_ec-k+2,n) = zsec4(nxfield*(ny-j-1)+i+1) - if (qvh(i,j,nlev_ec-k+2,n) .lt. 0.) & - qvh(i,j,nlev_ec-k+2,n) = 0. - ! this is necessary because the gridded data may contain - ! spurious negative values - end do - end do - !! SURF. PRESS. - case(134) - do j=0,nymin1 - do i=0,nxfield-1 - ps(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! W VELOCITY - case(135) - do j=0,nymin1 - do i=0,nxfield-1 - wwh(i,j,nlev_ec-k+1) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do -!$OMP CRITICAL - iwmax=max(iwmax,nlev_ec-k+1) -!$OMP END CRITICAL - !! SNOW DEPTH - case(141) - do j=0,nymin1 - do i=0,nxfield-1 - sd(i,j,1,n)= zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor - end do - end do - !! SEA LEVEL PRESS. - case(151) - do j=0,nymin1 - do i=0,nxfield-1 - msl(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! CLOUD COVER - case(164) - do j=0,nymin1 - do i=0,nxfield-1 - tcc(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! 10 M U VELOCITY - case(165) - do j=0,nymin1 - do i=0,nxfield-1 - u10(i,j,1,n)= zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! 10 M V VELOCITY - case(166) - do j=0,nymin1 - do i=0,nxfield-1 - v10(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! 2 M TEMPERATURE - case(167) - do j=0,nymin1 - do i=0,nxfield-1 - tt2(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! 2 M DEW POINT - case(168) - do j=0,nymin1 - do i=0,nxfield-1 - td2(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! LARGE SCALE PREC. - case(142) - do j=0,nymin1 - do i=0,nxfield-1 - lsprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1) - if (lsprec(i,j,1,n).lt.0.) lsprec(i,j,1,n)=0. - end do - end do - !! CONVECTIVE PREC. - case(143) - do j=0,nymin1 - do i=0,nxfield-1 - convprec(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1)/conversion_factor - if (convprec(i,j,1,n).lt.0.) convprec(i,j,1,n)=0. - end do - end do - !! SENS. HEAT FLUX - case(146) - do j=0,nymin1 - do i=0,nxfield-1 - sshf(i,j,1,n) = zsec4(nxfield*(ny-j-1)+i+1) -!$OMP CRITICAL - if(zsec4(nxfield*(ny-j-1)+i+1).ne.0.) & - hflswitch=.true. ! Heat flux available -!$OMP END CRITICAL - end do - end do - !! SOLAR RADIATION - case(176) - do j=0,nymin1 - do i=0,nxfield-1 - ssr(i,j,1,n)=zsec4(nxfield*(ny-j-1)+i+1) - if (ssr(i,j,1,n).lt.0.) ssr(i,j,1,n)=0. - end do - end do - !! EW SURFACE STRESS - case(180) - do j=0,nymin1 - do i=0,nxfield-1 - ewss(i,j) = zsec4(nxfield*(ny-j-1)+i+1) -!$OMP CRITICAL - if (zsec4(nxfield*(ny-j-1)+i+1).ne.0.) strswitch=.true. ! stress available -!$OMP END CRITICAL - end do - end do - !! NS SURFACE STRESS - case(181) - do j=0,nymin1 - do i=0,nxfield-1 - nsss(i,j) = zsec4(nxfield*(ny-j-1)+i+1) -!$OMP CRITICAL - if (zsec4(nxfield*(ny-j-1)+i+1).ne.0.) strswitch=.true. ! stress available -!$OMP END CRITICAL - end do - end do - !! ECMWF OROGRAPHY - case(129) - do j=0,nymin1 - do i=0,nxfield-1 - oro(i,j) = zsec4(nxfield*(ny-j-1)+i+1)/ga - end do - end do - !! STANDARD DEVIATION OF OROGRAPHY - case(160) - do j=0,nymin1 - do i=0,nxfield-1 - excessoro(i,j) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! ECMWF LAND SEA MASK - case(172) - do j=0,nymin1 - do i=0,nxfield-1 - lsm(i,j) = zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !! CLWC Cloud liquid water content [kg/kg] - case(246) - do j=0,nymin1 - do i=0,nxfield-1 - clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1) - end do - end do -!$OMP CRITICAL - readclouds=.true. - sumclouds=.false. -!$OMP END CRITICAL - !! CIWC Cloud ice water content - case(247) - do j=0,nymin1 - do i=0,nxfield-1 - ciwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1) - end do - end do - !ZHG end - !ESO read qc (=clwc+ciwc) - !! QC Cloud liquid water content [kg/kg] - case(201031) - do j=0,nymin1 - do i=0,nxfield-1 - clwch(i,j,nlev_ec-k+2,n)=zsec4(nxfield*(ny-j-1)+i+1) - end do - end do -!$OMP CRITICAL - readclouds=.true. - sumclouds=.false. -!$OMP END CRITICAL - - end select - - call grib_release(igrib(ii)) - - end do fieldloop -!$OMP END DO - deallocate(zsec4) -!$OMP END PARALLEL - - deallocate(igrib) - ! - ! CLOSING OF INPUT DATA FILE - ! - - ! 50 call grib_close_file(ifile) - - !error message if no fields found with correct first longitude in it - if (gotGrid.eq.0) then - print*,'***ERROR: input file needs to contain GRiB1 formatted'// & - 'messages' - stop - endif - - if(levdiff2.eq.0) then - iwmax=nlev_ec+1 - do i=0,nxmin1 - do j=0,nymin1 - wwh(i,j,nlev_ec+1)=0. - end do - end do - endif - - ! For global fields, assign the leftmost data column also to the rightmost - ! data column; if required, shift whole grid by nxshift grid points - !************************************************************************* - - 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) - !ZHG - call shift_field(clwch,nxfield,ny,nuvzmax,nuvz,2,n) - if (.not.sumclouds) call shift_field(ciwch,nxfield,ny,nuvzmax,nuvz,2,n) - !ZHG end - - endif - - do i=0,nxmin1 - do j=0,nymin1 - if ((ewss(i,j).eq.0.).and.(nsss(i,j).eq.0.)) then - if ((i.ne.0).and.(j.ne.0).and.(i.ne.nxmin1).and.(j.ne.nymin1)) then - ewss(i,j)=(ewss(i-1,j-1)+ewss(i+1,j+1)+ewss(i+1,j)+ewss(i-1,j)+ & - ewss(i,j+1)+ewss(i,j-1)+ewss(i-1,j+1)+ewss(i+1,j-1))/8. - nsss(i,j)=(nsss(i-1,j-1)+nsss(i+1,j+1)+nsss(i+1,j)+nsss(i-1,j)+ & - nsss(i,j+1)+nsss(i,j-1)+nsss(i-1,j+1)+nsss(i+1,j-1))/8. - else if ((i.eq.0).and.(j.eq.0)) then - ewss(i,j)=(ewss(i+1,j+1)+ewss(i+1,j)+ewss(i,j+1))/3. - nsss(i,j)=(nsss(i+1,j+1)+nsss(i+1,j)+nsss(i,j+1))/3. - else if ((i.eq.nxmin1).and.(j.eq.nymin1)) then - ewss(i,j)=(ewss(i-1,j-1)+ewss(i-1,j)+ewss(i,j-1))/3. - nsss(i,j)=(nsss(i-1,j-1)+nsss(i-1,j)+nsss(i,j-1))/3. - else if ((i.eq.0).and.(j.eq.nymin1)) then - ewss(i,j)=(ewss(i+1,j-1)+ewss(i+1,j)+ewss(i,j-1))/3. - nsss(i,j)=(nsss(i+1,j-1)+nsss(i+1,j)+nsss(i,j-1))/3. - else if ((i.eq.nxmin1).and.(j.eq.0)) then - ewss(i,j)=(ewss(i-1,j+1)+ewss(i-1,j)+ewss(i,j+1))/3. - nsss(i,j)=(nsss(i-1,j+1)+nsss(i-1,j)+nsss(i,j+1))/3. - else if (i.eq.0) then - ewss(i,j)=(ewss(i+1,j+1)+ewss(i+1,j)+ewss(i,j+1)+ewss(i,j-1)+ewss(i+1,j-1))/5. - nsss(i,j)=(nsss(i+1,j+1)+nsss(i+1,j)+nsss(i,j+1)+nsss(i,j-1)+nsss(i+1,j-1))/5. - else if (i.eq.nxmin1) then - ewss(i,j)=(ewss(i-1,j+1)+ewss(i-1,j)+ewss(i,j+1)+ewss(i,j-1)+ewss(i-1,j-1))/5. - nsss(i,j)=(nsss(i-1,j+1)+nsss(i-1,j)+nsss(i,j+1)+nsss(i,j-1)+nsss(i-1,j-1))/5. - else if (j.eq.0) then - ewss(i,j)=(ewss(i+1,j+1)+ewss(i+1,j)+ewss(i-1,j)+ewss(i,j+1)+ewss(i-1,j+1))/5. - nsss(i,j)=(nsss(i+1,j+1)+nsss(i+1,j)+nsss(i-1,j)+nsss(i,j+1)+nsss(i-1,j+1))/5. - else if (j.eq.nymin1) then - ewss(i,j)=(ewss(i+1,j-1)+ewss(i+1,j)+ewss(i-1,j)+ewss(i,j-1)+ewss(i-1,j-1))/5. - nsss(i,j)=(nsss(i+1,j-1)+nsss(i+1,j)+nsss(i-1,j)+nsss(i,j-1)+nsss(i-1,j-1))/5. - endif - endif - sfcstress(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2) - end do - end do - - if ((.not.hflswitch).or.(.not.strswitch)) then - write(*,*) 'WARNING: No flux data contained in GRIB 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 - !*************************************************************************** - - do i=0,nxmin1 - do j=0,nymin1 - plev1=akz(3)+bkz(3)*ps(i,j,1,n) - pmean=0.5*(ps(i,j,1,n)+plev1) - tv=tth(i,j,3,n)*(1.+0.61*qvh(i,j,3,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,3)**2+vvh(i,j,3)**2) - call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, & - tt2(i,j,1,n),tth(i,j,3,n),ff10m,fflev1, & - sfcstress(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. - end do - end do - 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 - !************************************************************************** - - do i=0,nxmin1 - do j=0,nymin1 - uuh(i,j,1)=u10(i,j,1,n) - vvh(i,j,1)=v10(i,j,1,n) - qvh(i,j,1,n)=qvh(i,j,2,n) - tth(i,j,1,n)=tt2(i,j,1,n) - end do - end do - - if(iumax.ne.nuvz-1) stop 'READWIND: NUVZ NOT CONSISTENT' - if(iwmax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT' - - return - -888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' - write(*,*) ' #### ',wfname(indj),' #### ' - write(*,*) ' #### IS NOT GRIB FORMAT !!! #### ' - stop 'Execution terminated' - -end subroutine readwind_ecmwf - -subroutine readwind_gfs(indj,n,uuh,vvh,wwh) - - !*********************************************************************** - !* * - !* TRAJECTORY MODEL SUBROUTINE READWIND * - !* * - !*********************************************************************** - !* * - !* AUTHOR: G. WOTAWA * - !* DATE: 1997-08-05 * - !* LAST UPDATE: 2000-10-17, Andreas Stohl * - !* CHANGE: 01/02/2001, Bernd C. Krueger, Variables tth and * - !* qvh (on eta coordinates) in common block * - !* CHANGE: 16/11/2005, Caroline Forster, GFS data * - !* CHANGE: 11/01/2008, Harald Sodemann, Input of GRIB1/2 * - !* data with the ECMWF grib_api library * - !* CHANGE: 03/12/2008, Harald Sodemann, update to f90 with * - !* ECMWF grib_api * - ! * - ! Unified ECMWF and GFS builds * - ! Marian Harustak, 12.5.2017 * - ! - Renamed routine from readwind to readwind_gfs * - !* * - !*********************************************************************** - !* * - !* 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 vertical levels ecmwf model * - !* uu,vv,ww wind fields * - !* tt,qv temperature and specific humidity * - !* ps surface pressure * - !* * - !*********************************************************************** - - use grib_api - use qvsat_mod - - implicit none - - !HSO new parameters for grib_api - integer :: ifile - integer :: iret - integer :: igrib - integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl - !HSO end edits - real :: uuh(0:nxmax-1,0:nymax-1,nuvzmax) - real :: vvh(0:nxmax-1,0:nymax-1,nuvzmax) - real :: wwh(0:nxmax-1,0:nymax-1,nwzmax) - integer :: ii,indj,i,j,k,n,levdiff2,ifield,iumax,iwmax - - ! NCEP - integer :: numpt,numpu,numpv,numpw,numprh,numpclwch - real :: help, temp - real :: elev - real :: ulev1(0:nxmax-1,0:nymax-1),vlev1(0:nxmax-1,0:nymax-1) - real :: tlev1(0:nxmax-1,0:nymax-1) - real :: qvh2(0:nxmax-1,0:nymax-1) - - integer :: i179,i180,i181 - - ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING - !HSO kept isec1, isec2 and zsec4 for consistency with gribex GRIB input - - integer :: isec1(8),isec2(3) - real(kind=4) :: zsec4(jpunp) - real(kind=4) :: xaux,yaux,xaux0,yaux0 - real(kind=8) :: xauxin,yauxin - real,parameter :: eps=1.e-4 - real(kind=4) :: ewss(0:nxmax-1,0:nymax-1),nsss(0:nxmax-1,0:nymax-1) - real :: plev1,hlev1,ff10m,fflev1 - - logical :: hflswitch,strswitch - - !HSO for grib api error messages - character(len=24) :: gribErrorMsg = 'Error reading grib file' - character(len=20) :: gribFunction = 'readwind_gfs' - character(len=20) :: shortname - - - hflswitch=.false. - strswitch=.false. - levdiff2=nlev_ec-nwz+1 - iumax=0 - iwmax=0 - - - ! OPENING OF DATA FILE (GRIB CODE) - - !HSO - call grib_open_file(ifile,path(3)(1:length(3)) & - //trim(wfname(indj)),'r',iret) - if (iret.ne.GRIB_SUCCESS) then - goto 888 ! ERROR DETECTED - endif - !turn on support for multi fields messages - call grib_multi_support_on - - numpt=0 - numpu=0 - numpv=0 - numpw=0 - numprh=0 - numpclwch=0 - ifield=0 - do - ifield=ifield+1 - ! - ! GET NEXT FIELDS - ! - call grib_new_from_file(ifile,igrib,iret) - if (iret.eq.GRIB_END_OF_FILE) then - exit ! EOF DETECTED - elseif (iret.ne.GRIB_SUCCESS) then - goto 888 ! ERROR DETECTED - endif - - !first see if we read GRIB1 or GRIB2 - call grib_get_int(igrib,'editionNumber',gribVer,iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - - if (gribVer.eq.1) then ! GRIB Edition 1 - - !read the grib1 identifiers - call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'indicatorOfTypeOfLevel',isec1(7),iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'level',isec1(8),iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - - else ! GRIB Edition 2 - - !read the grib2 identifiers - call grib_get_string(igrib,'shortName',shortname,iret) - - call grib_get_int(igrib,'discipline',discipl,iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterCategory',parCat,iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterNumber',parNum,iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'scaledValueOfFirstFixedSurface', & - ivalsfc,iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - - ! write(*,*) 'Field: ',ifield,parCat,parNum,sfctyp,shortname - !convert to grib1 identifiers - isec1(6)=-1 - isec1(7)=-1 - isec1(8)=-1 - if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.100)) then ! T - isec1(6)=11 ! indicatorOfParameter - isec1(7)=100 ! indicatorOfTypeOfLevel - isec1(8)=ivalsfc/100 ! level, convert to hPa - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.100)) then ! U - isec1(6)=33 ! indicatorOfParameter - isec1(7)=100 ! indicatorOfTypeOfLevel - isec1(8)=ivalsfc/100 ! level, convert to hPa - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.100)) then ! V - isec1(6)=34 ! indicatorOfParameter - isec1(7)=100 ! indicatorOfTypeOfLevel - isec1(8)=ivalsfc/100 ! level, convert to hPa - elseif ((parCat.eq.2).and.(parNum.eq.8).and.(sfctyp.eq.100)) then ! W - isec1(6)=39 ! indicatorOfParameter - isec1(7)=100 ! indicatorOfTypeOfLevel - isec1(8)=ivalsfc/100 ! level, convert to hPa - elseif ((parCat.eq.1).and.(parNum.eq.1).and.(sfctyp.eq.100)) then ! RH - isec1(6)=52 ! indicatorOfParameter - isec1(7)=100 ! indicatorOfTypeOfLevel - isec1(8)=ivalsfc/100 ! level, convert to hPa - elseif ((parCat.eq.1).and.(parNum.eq.1).and.(sfctyp.eq.103)) then ! RH2 - isec1(6)=52 ! indicatorOfParameter - isec1(7)=105 ! indicatorOfTypeOfLevel - isec1(8)=2 - elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! T2 - isec1(6)=11 ! indicatorOfParameter - isec1(7)=105 ! indicatorOfTypeOfLevel - isec1(8)=2 - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! U10 - isec1(6)=33 ! indicatorOfParameter - isec1(7)=105 ! indicatorOfTypeOfLevel - isec1(8)=10 - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! V10 - isec1(6)=34 ! indicatorOfParameter - isec1(7)=105 ! indicatorOfTypeOfLevel - isec1(8)=10 - elseif ((parCat.eq.1).and.(parNum.eq.22).and.(sfctyp.eq.100)) then ! CLWMR Cloud Mixing Ratio [kg/kg]: - isec1(6)=153 ! indicatorOfParameter - isec1(7)=100 ! indicatorOfTypeOfLevel - isec1(8)=ivalsfc/100 ! level, convert to hPa - elseif ((parCat.eq.3).and.(parNum.eq.1).and.(sfctyp.eq.101)) then ! SLP - isec1(6)=2 ! indicatorOfParameter - isec1(7)=102 ! indicatorOfTypeOfLevel - isec1(8)=0 - elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then ! SP - isec1(6)=1 ! indicatorOfParameter - isec1(7)=1 ! indicatorOfTypeOfLevel - isec1(8)=0 - elseif ((parCat.eq.1).and.(parNum.eq.13).and.(sfctyp.eq.1)) then ! SNOW - isec1(6)=66 ! indicatorOfParameter - isec1(7)=1 ! indicatorOfTypeOfLevel - isec1(8)=0 - elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.104)) then ! T sigma 0 - isec1(6)=11 ! indicatorOfParameter - isec1(7)=107 ! indicatorOfTypeOfLevel - isec1(8)=0.995 ! lowest sigma level - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.104)) then ! U sigma 0 - isec1(6)=33 ! indicatorOfParameter - isec1(7)=107 ! indicatorOfTypeOfLevel - isec1(8)=0.995 ! lowest sigma level - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.104)) then ! V sigma 0 - isec1(6)=34 ! indicatorOfParameter - isec1(7)=107 ! indicatorOfTypeOfLevel - isec1(8)=0.995 ! lowest sigma level - elseif ((parCat.eq.3).and.(parNum.eq.5).and.(sfctyp.eq.1)) then ! TOPO - isec1(6)=7 ! indicatorOfParameter - isec1(7)=1 ! indicatorOfTypeOfLevel - isec1(8)=0 - elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.1) & - .and.(discipl.eq.2)) then ! LSM - isec1(6)=81 ! indicatorOfParameter - isec1(7)=1 ! indicatorOfTypeOfLevel - isec1(8)=0 - elseif ((parCat.eq.3).and.(parNum.eq.196).and.(sfctyp.eq.1)) then ! BLH - isec1(6)=221 ! indicatorOfParameter - isec1(7)=1 ! indicatorOfTypeOfLevel - isec1(8)=0 - elseif ((parCat.eq.1).and.(parNum.eq.7).and.(sfctyp.eq.1)) then ! LSP/TP - isec1(6)=62 ! indicatorOfParameter - isec1(7)=1 ! indicatorOfTypeOfLevel - isec1(8)=0 - elseif ((parCat.eq.1).and.(parNum.eq.196).and.(sfctyp.eq.1)) then ! CP - isec1(6)=63 ! indicatorOfParameter - isec1(7)=1 ! indicatorOfTypeOfLevel - isec1(8)=0 - endif - - endif ! gribVer - - if (isec1(6).ne.-1) then - ! get the size and data of the values array - call grib_get_real4_array(igrib,'values',zsec4,iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - endif - - if(ifield.eq.1) then - - !get the required fields from section 2 - !store compatible to gribex input - call grib_get_int(igrib,'numberOfPointsAlongAParallel', & - isec2(2),iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & - isec2(3),iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & - xauxin,iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & - yauxin,iret) - ! call grib_check(iret,gribFunction,gribErrorMsg) - xaux=xauxin+real(nxshift)*dx - yaux=yauxin - - ! CHECK GRID SPECIFICATIONS - - if(isec2(2).ne.nxfield) stop 'READWIND: NX NOT CONSISTENT' - if(isec2(3).ne.ny) stop 'READWIND: NY NOT CONSISTENT' - if(xaux.eq.0.) xaux=-179.0 ! NCEP DATA - xaux0=xlon0 - yaux0=ylat0 - if(xaux.lt.0.) xaux=xaux+360. - if(yaux.lt.0.) yaux=yaux+360. - if(xaux0.lt.0.) xaux0=xaux0+360. - if(yaux0.lt.0.) yaux0=yaux0+360. - if(abs(xaux-xaux0).gt.eps) & - stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT' - if(abs(yaux-yaux0).gt.eps) & - stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT' - endif - !HSO end of edits - - i179=nint(179./dx) - if (dx.lt.0.7) then - i180=nint(180./dx)+1 ! 0.5 deg data - else - i180=nint(179./dx)+1 ! 1 deg data - endif - i181=i180+1 - - if (isec1(6).ne.-1) then - - do j=0,nymin1 - do i=0,nxfield-1 - if((isec1(6).eq.011).and.(isec1(7).eq.100)) then - ! TEMPERATURE - if((i.eq.0).and.(j.eq.0)) then - do ii=1,nuvz - if ((isec1(8)*100.0).eq.akz(ii)) numpt=ii - end do - endif - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - tth(i179+i,j,numpt,n)=help - else - tth(i-i181,j,numpt,n)=help - endif - endif - if((isec1(6).eq.033).and.(isec1(7).eq.100)) then - ! U VELOCITY - if((i.eq.0).and.(j.eq.0)) then - do ii=1,nuvz - if ((isec1(8)*100.0).eq.akz(ii)) numpu=ii - end do - endif - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - uuh(i179+i,j,numpu)=help - else - uuh(i-i181,j,numpu)=help - endif - endif - if((isec1(6).eq.034).and.(isec1(7).eq.100)) then - ! V VELOCITY - if((i.eq.0).and.(j.eq.0)) then - do ii=1,nuvz - if ((isec1(8)*100.0).eq.akz(ii)) numpv=ii - end do - endif - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - vvh(i179+i,j,numpv)=help - else - vvh(i-i181,j,numpv)=help - endif - endif - if((isec1(6).eq.052).and.(isec1(7).eq.100)) then - ! RELATIVE HUMIDITY -> CONVERT TO SPECIFIC HUMIDITY LATER - if((i.eq.0).and.(j.eq.0)) then - do ii=1,nuvz - if ((isec1(8)*100.0).eq.akz(ii)) numprh=ii - end do - endif - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - qvh(i179+i,j,numprh,n)=help - else - qvh(i-i181,j,numprh,n)=help - endif - endif - if((isec1(6).eq.001).and.(isec1(7).eq.001)) then - ! SURFACE PRESSURE - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - ps(i179+i,j,1,n)=help - else - ps(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.039).and.(isec1(7).eq.100)) then - ! W VELOCITY - if((i.eq.0).and.(j.eq.0)) then - do ii=1,nuvz - if ((isec1(8)*100.0).eq.akz(ii)) numpw=ii - end do - endif - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - wwh(i179+i,j,numpw)=help - else - wwh(i-i181,j,numpw)=help - endif - endif - if((isec1(6).eq.066).and.(isec1(7).eq.001)) then - ! SNOW DEPTH - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - sd(i179+i,j,1,n)=help - else - sd(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.002).and.(isec1(7).eq.102)) then - ! MEAN SEA LEVEL PRESSURE - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - msl(i179+i,j,1,n)=help - else - msl(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.071).and.(isec1(7).eq.244)) then - ! TOTAL CLOUD COVER - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - tcc(i179+i,j,1,n)=help - else - tcc(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.033).and.(isec1(7).eq.105).and. & - (isec1(8).eq.10)) then - ! 10 M U VELOCITY - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - u10(i179+i,j,1,n)=help - else - u10(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.034).and.(isec1(7).eq.105).and. & - (isec1(8).eq.10)) then - ! 10 M V VELOCITY - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - v10(i179+i,j,1,n)=help - else - v10(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.011).and.(isec1(7).eq.105).and. & - (isec1(8).eq.02)) then - ! 2 M TEMPERATURE - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - tt2(i179+i,j,1,n)=help - else - tt2(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.017).and.(isec1(7).eq.105).and. & - (isec1(8).eq.02)) then - ! 2 M DEW POINT TEMPERATURE - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - td2(i179+i,j,1,n)=help - else - td2(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.062).and.(isec1(7).eq.001)) then - ! LARGE SCALE PREC. - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - lsprec(i179+i,j,1,n)=help - else - lsprec(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.063).and.(isec1(7).eq.001)) then - ! CONVECTIVE PREC. - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - convprec(i179+i,j,1,n)=help - else - convprec(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.007).and.(isec1(7).eq.001)) then - ! TOPOGRAPHY - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - oro(i179+i,j)=help - excessoro(i179+i,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED - else - oro(i-i181,j)=help - excessoro(i-i181,j)=0.0 ! ISOBARIC SURFACES: SUBGRID TERRAIN DISREGARDED - endif - endif - if((isec1(6).eq.081).and.(isec1(7).eq.001)) then - ! LAND SEA MASK - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - lsm(i179+i,j)=help - else - lsm(i-i181,j)=help - endif - endif - if((isec1(6).eq.221).and.(isec1(7).eq.001)) then - ! MIXING HEIGHT - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - hmix(i179+i,j,1,n)=help - else - hmix(i-i181,j,1,n)=help - endif - endif - if((isec1(6).eq.052).and.(isec1(7).eq.105).and. & - (isec1(8).eq.02)) then - ! 2 M RELATIVE HUMIDITY - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - qvh2(i179+i,j)=help - else - qvh2(i-i181,j)=help - endif - endif - if((isec1(6).eq.011).and.(isec1(7).eq.107)) then - ! TEMPERATURE LOWEST SIGMA LEVEL - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - tlev1(i179+i,j)=help - else - tlev1(i-i181,j)=help - endif - endif - if((isec1(6).eq.033).and.(isec1(7).eq.107)) then - ! U VELOCITY LOWEST SIGMA LEVEL - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - ulev1(i179+i,j)=help - else - ulev1(i-i181,j)=help - endif - endif - if((isec1(6).eq.034).and.(isec1(7).eq.107)) then - ! V VELOCITY LOWEST SIGMA LEVEL - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - vlev1(i179+i,j)=help - else - vlev1(i-i181,j)=help - endif - endif - ! SEC & IP 12/2018 read GFS clouds - if((isec1(6).eq.153).and.(isec1(7).eq.100)) then !! CLWCR Cloud liquid water content [kg/kg] - if((i.eq.0).and.(j.eq.0)) then - do ii=1,nuvz - if ((isec1(8)*100.0).eq.akz(ii)) numpclwch=ii - end do - endif - help=zsec4(nxfield*(ny-j-1)+i+1) - if(i.le.i180) then - clwch(i179+i,j,numpclwch,n)=help - else - clwch(i-i181,j,numpclwch,n)=help - endif - readclouds=.true. - sumclouds=.true. - ! readclouds=.false. - ! sumclouds=.false. - endif - - - end do - end do - - endif - - if((isec1(6).eq.33).and.(isec1(7).eq.100)) then - ! NCEP ISOBARIC LEVELS - iumax=iumax+1 - endif - - call grib_release(igrib) - end do !! READ NEXT LEVEL OR PARAMETER - ! - ! CLOSING OF INPUT DATA FILE - ! - - !HSO close grib file - call grib_close_file(ifile) - - ! SENS. HEAT FLUX - sshf(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files - hflswitch=.false. ! Heat flux not available - ! SOLAR RADIATIVE FLUXES - ssr(:,:,1,n)=0.0 ! not available from gfs.tccz.pgrbfxx files - ! EW SURFACE STRESS - ewss=0.0 ! not available from gfs.tccz.pgrbfxx files - ! NS SURFACE STRESS - nsss=0.0 ! not available from gfs.tccz.pgrbfxx files - strswitch=.false. ! stress not available - - ! CONVERT TP TO LSP (GRIB2 only) - if (gribVer.eq.2) then - do j=0,nymin1 - do i=0,nxfield-1 - if(i.le.i180) then - if (convprec(i179+i,j,1,n).lt.lsprec(i179+i,j,1,n)) then ! neg precip would occur - lsprec(i179+i,j,1,n)= & - lsprec(i179+i,j,1,n)-convprec(i179+i,j,1,n) - else - lsprec(i179+i,j,1,n)=0 - endif - else - if (convprec(i-i181,j,1,n).lt.lsprec(i-i181,j,1,n)) then - lsprec(i-i181,j,1,n)= & - lsprec(i-i181,j,1,n)-convprec(i-i181,j,1,n) - else - lsprec(i-i181,j,1,n)=0 - endif - endif - enddo - enddo - endif - !HSO end edits - - - ! TRANSFORM RH TO SPECIFIC HUMIDITY - - do j=0,ny-1 - do i=0,nxfield-1 - do k=1,nuvz - help=qvh(i,j,k,n) - temp=tth(i,j,k,n) - plev1=akm(k)+bkm(k)*ps(i,j,1,n) - elev=ew(temp,plev1)*help/100.0 - qvh(i,j,k,n)=xmwml*(elev/(plev1-((1.0-xmwml)*elev))) - end do - end do - end do - - ! CALCULATE 2 M DEW POINT FROM 2 M RELATIVE HUMIDITY - ! USING BOLTON'S (1980) FORMULA - ! BECAUSE td2 IS NOT AVAILABLE FROM NCEP GFS DATA - - do j=0,ny-1 - do i=0,nxfield-1 - help=qvh2(i,j) - temp=tt2(i,j,1,n) - plev1=akm(k)+bkm(k)*ps(i,j,1,n) - elev=ew(temp,plev1)/100.*help/100. !vapour pressure in hPa - td2(i,j,1,n)=243.5/(17.67/log(elev/6.112)-1)+273. - if (help.le.0.) td2(i,j,1,n)=tt2(i,j,1,n) - end do - end do - - if(levdiff2.eq.0) then - iwmax=nlev_ec+1 - do i=0,nxmin1 - do j=0,nymin1 - wwh(i,j,nlev_ec+1)=0. - end do - end do - endif - - - ! For global fields, assign the leftmost data column also to the rightmost - ! data column; if required, shift whole grid by nxshift grid points - !************************************************************************* - - 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_0(ulev1,nxfield,ny) - call shift_field_0(vlev1,nxfield,ny) - call shift_field_0(tlev1,nxfield,ny) - call shift_field_0(qvh2,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(hmix,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) - ! IP & SEC adding GFS Clouds 20181205 - call shift_field(clwch,nxfield,ny,nuvzmax,nuvz,2,n) - endif - - do i=0,nxmin1 - do j=0,nymin1 - ! Convert precip. from mm/s -> mm/hour - convprec(i,j,1,n)=convprec(i,j,1,n)*3600. - lsprec(i,j,1,n)=lsprec(i,j,1,n)*3600. - sfcstress(i,j,1,n)=sqrt(ewss(i,j)**2+nsss(i,j)**2) - end do - end do - - if ((.not.hflswitch).or.(.not.strswitch)) then - ! write(*,*) 'WARNING: No flux data contained in GRIB file ', - ! + wfname(indj) - - ! CALCULATE USTAR AND SSHF USING THE PROFILE METHOD - !*************************************************************************** - - do i=0,nxmin1 - do j=0,nymin1 - hlev1=30.0 ! HEIGHT OF FIRST MODEL SIGMA LAYER - ff10m= sqrt(u10(i,j,1,n)**2+v10(i,j,1,n)**2) - fflev1=sqrt(ulev1(i,j)**2+vlev1(i,j)**2) - call pbl_profile(ps(i,j,1,n),td2(i,j,1,n),hlev1, & - tt2(i,j,1,n),tlev1(i,j),ff10m,fflev1, & - sfcstress(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. - end do - end do - endif - - if(iumax.ne.nuvz) stop 'READWIND: NUVZ NOT CONSISTENT' - if(iumax.ne.nwz) stop 'READWIND: NWZ NOT CONSISTENT' - - return -888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' - write(*,*) ' #### ',wfname(indj),' #### ' - write(*,*) ' #### IS NOT GRIB FORMAT !!! #### ' - stop 'Execution terminated' -999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' - write(*,*) ' #### ',wfname(indj),' #### ' - write(*,*) ' #### CANNOT BE OPENED !!! #### ' - stop 'Execution terminated' - -end subroutine readwind_gfs - -subroutine readwind_nest(indj,n,uuhn,vvhn,wwhn) - ! i i o o o - !***************************************************************************** - ! * - ! 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 * - ! CHANGE: 11/01/2008, Harald Sodemann, GRIB1/2 input with ECMWF grib_api * - ! CHANGE: 03/12/2008, Harald Sodemann, update to f90 with ECMWF grib_api * - !***************************************************************************** - - use grib_api - - implicit none - - !HSO parameters for grib_api - integer :: ifile - integer :: iret - integer :: igrib - integer :: gribVer,parCat,parNum,sfctyp,ivalsfc,discipl - integer :: parId !!added by mc for making it consistent with new readwind.f90 - integer :: gotGrid - !HSO end - - 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) - integer :: indj,i,j,k,n,levdiff2,ifield,iumax,iwmax,l - - ! VARIABLES AND ARRAYS NEEDED FOR GRIB DECODING - - ! dimension of isec2 at least (22+n), where n is the number of parallels or - ! meridians in a quasi-regular (reduced) Gaussian or lat/long grid - - ! dimension of zsec2 at least (10+nn), where nn is the number of vertical - ! coordinate parameters - - integer :: isec1(56),isec2(22+nxmaxn+nymaxn) - real(kind=4) :: zsec4(jpunp) - real(kind=4) :: xaux,yaux - real(kind=8) :: xauxin,yauxin - real,parameter :: eps=1.e-4 - real :: ewss(0:nxmaxn-1,0:nymaxn-1),nsss(0:nxmaxn-1,0:nymaxn-1) - real :: plev1,pmean,tv,fu,hlev1,ff10m,fflev1 - real :: conversion_factor !added by mc to make it consistent with new gridchek.f90 - - logical :: hflswitch,strswitch - - !HSO grib api error messages - character(len=24) :: gribErrorMsg = 'Error reading grib file' - character(len=20) :: gribFunction = 'readwind_nest' - - do l=1,numbnests - hflswitch=.false. - strswitch=.false. - levdiff2=nlev_ec-nwz+1 - iumax=0 - iwmax=0 - - ifile=0 - igrib=0 - iret=0 - - ! - ! OPENING OF DATA FILE (GRIB CODE) - ! - -5 call grib_open_file(ifile,path(numpath+2*(l-1)+1) & - (1:length(numpath+2*(l-1)+1))//trim(wfnamen(l,indj)),'r') - if (iret.ne.GRIB_SUCCESS) then - goto 888 ! ERROR DETECTED - endif - !turn on support for multi fields messages */ - !call grib_multi_support_on - - gotGrid=0 - ifield=0 - do - ifield=ifield+1 - ! - ! GET NEXT FIELDS - ! - call grib_new_from_file(ifile,igrib,iret) - if (iret.eq.GRIB_END_OF_FILE) then - exit ! EOF DETECTED - elseif (iret.ne.GRIB_SUCCESS) then - goto 888 ! ERROR DETECTED - endif - - !first see if we read GRIB1 or GRIB2 - call grib_get_int(igrib,'editionNumber',gribVer,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - if (gribVer.eq.1) then ! GRIB Edition 1 - - !print*,'GRiB Edition 1' - !read the grib2 identifiers - call grib_get_int(igrib,'indicatorOfParameter',isec1(6),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'level',isec1(8),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - - !change code for etadot to code for omega - if (isec1(6).eq.77) then - isec1(6)=135 - endif - - conversion_factor=1. - - - else - - !print*,'GRiB Edition 2' - !read the grib2 identifiers - call grib_get_int(igrib,'discipline',discipl,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterCategory',parCat,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'parameterNumber',parNum,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'typeOfFirstFixedSurface',sfctyp,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'level',ivalsfc,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'paramId',parId,iret) !added by mc to make it consisitent with new readwind.f90 - call grib_check(iret,gribFunction,gribErrorMsg) !added by mc to make it consisitent with new readwind.f90 - - !print*,discipl,parCat,parNum,sfctyp,ivalsfc - - !convert to grib1 identifiers - isec1(6)=-1 - isec1(7)=-1 - isec1(8)=-1 - isec1(8)=ivalsfc ! level - conversion_factor=1. - if ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! T - isec1(6)=130 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.105)) then ! U - isec1(6)=131 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.105)) then ! V - isec1(6)=132 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.0).and.(sfctyp.eq.105)) then ! Q - isec1(6)=133 ! indicatorOfParameter - ! ESO Cloud water is in a) fields CLWC and CIWC, *or* b) field QC - elseif ((parCat.eq.1).and.(parNum.eq.83).and.(sfctyp.eq.105)) then ! clwc - isec1(6)=246 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.84).and.(sfctyp.eq.105)) then ! ciwc - isec1(6)=247 ! indicatorOfParameter - ! ESO qc(=clwc+ciwc): - elseif ((parCat.eq.201).and.(parNum.eq.31).and.(sfctyp.eq.105)) then ! qc - isec1(6)=201031 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.1)) then !SP - isec1(6)=134 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.32)) then ! W, actually eta dot ! - isec1(6)=135 ! indicatorOfParameter - elseif ((parCat.eq.128).and.(parNum.eq.77)) then ! W, actually eta dot !added by mc to make it consisitent with new readwind.f90 - isec1(6)=135 ! indicatorOfParameter !added by mc to make it consisitent with new readwind.f90 - elseif ((parCat.eq.3).and.(parNum.eq.0).and.(sfctyp.eq.101)) then !SLP - isec1(6)=151 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.2).and.(sfctyp.eq.103)) then ! 10U - isec1(6)=165 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.3).and.(sfctyp.eq.103)) then ! 10V - isec1(6)=166 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.0).and.(sfctyp.eq.103)) then ! 2T - isec1(6)=167 ! indicatorOfParameter - elseif ((parCat.eq.0).and.(parNum.eq.6).and.(sfctyp.eq.103)) then ! 2D - isec1(6)=168 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SD - isec1(6)=141 ! indicatorOfParameter - conversion_factor=1000. !added by mc to make it consisitent with new readwind.f90 - elseif ((parCat.eq.6).and.(parNum.eq.1) .or. parId .eq. 164) then ! CC !added by mc to make it consisitent with new readwind.f90 - isec1(6)=164 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.9) .or. parId .eq. 142) then ! LSP !added by mc to make it consisitent with new readwind.f90 - isec1(6)=142 ! indicatorOfParameter - elseif ((parCat.eq.1).and.(parNum.eq.10)) then ! CP - isec1(6)=143 ! indicatorOfParameter - conversion_factor=1000. !added by mc to make it consisitent with new readwind.f90 - elseif ((parCat.eq.0).and.(parNum.eq.11).and.(sfctyp.eq.1)) then ! SHF - isec1(6)=146 ! indicatorOfParameter - elseif ((parCat.eq.4).and.(parNum.eq.9).and.(sfctyp.eq.1)) then ! SR - isec1(6)=176 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.38) .or. parId .eq. 180) then ! EWSS !added by mc to make it consisitent with new readwind.f90 - isec1(6)=180 ! indicatorOfParameter - elseif ((parCat.eq.2).and.(parNum.eq.37) .or. parId .eq. 181) then ! NSSS !added by mc to make it consisitent with new readwind.f90 - isec1(6)=181 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.4)) then ! ORO - isec1(6)=129 ! indicatorOfParameter - elseif ((parCat.eq.3).and.(parNum.eq.7) .or. parId .eq. 160) then ! SDO !added by mc to make it consisitent with new readwind.f90 - isec1(6)=160 ! indicatorOfParameter - elseif ((discipl.eq.2).and.(parCat.eq.0).and.(parNum.eq.0).and. & - (sfctyp.eq.1)) then ! LSM - isec1(6)=172 ! indicatorOfParameter - elseif (parNum.eq.152) then - isec1(6)=152 ! avoid warning for lnsp - else - print*,'***WARNING: undefined GRiB2 message found!',discipl, & - parCat,parNum,sfctyp - endif - if(parId .ne. isec1(6) .and. parId .ne. 77) then !added by mc to make it consisitent with new readwind.f90 - write(*,*) 'parId',parId, 'isec1(6)',isec1(6) ! - ! stop - endif - - endif - - !HSO get the size and data of the values array - if (isec1(6).ne.-1) then - call grib_get_real4_array(igrib,'values',zsec4,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - endif - - !HSO get the required fields from section 2 in a gribex compatible manner - if(ifield.eq.1) then - call grib_get_int(igrib,'numberOfPointsAlongAParallel', & - isec2(2),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'numberOfPointsAlongAMeridian', & - isec2(3),iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_int(igrib,'numberOfVerticalCoordinateValues', & - isec2(12)) - call grib_check(iret,gribFunction,gribErrorMsg) - ! CHECK GRID SPECIFICATIONS - if(isec2(2).ne.nxn(l)) stop & - 'READWIND: NX NOT CONSISTENT FOR A NESTING LEVEL' - if(isec2(3).ne.nyn(l)) stop & - 'READWIND: NY NOT CONSISTENT FOR A NESTING LEVEL' - if(isec2(12)/2-1.ne.nlev_ec) stop 'READWIND: VERTICAL DISCRET& - &IZATION NOT CONSISTENT FOR A NESTING LEVEL' - endif ! ifield - - !HSO get the second part of the grid dimensions only from GRiB1 messages - if (isec1(6) .eq. 167 .and. (gotGrid.eq.0)) then ! !added by mc to make it consisitent with new readwind.f90 - call grib_get_real8(igrib,'longitudeOfFirstGridPointInDegrees', & - xauxin,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - call grib_get_real8(igrib,'latitudeOfLastGridPointInDegrees', & - yauxin,iret) - call grib_check(iret,gribFunction,gribErrorMsg) - if (xauxin.gt.180.) xauxin=xauxin-360.0 - if (xauxin.lt.-180.) xauxin=xauxin+360.0 - - xaux=xauxin - yaux=yauxin - if (abs(xaux-xlon0n(l)).gt.eps) & - stop 'READWIND: LOWER LEFT LONGITUDE NOT CONSISTENT FOR A NESTING LEVEL' - if (abs(yaux-ylat0n(l)).gt.eps) & - stop 'READWIND: LOWER LEFT LATITUDE NOT CONSISTENT FOR A NESTING LEVEL' - gotGrid=1 - endif - - do j=0,nyn(l)-1 - do i=0,nxn(l)-1 - k=isec1(8) - if(isec1(6).eq.130) tthn(i,j,nlev_ec-k+2,n,l)= &!! TEMPERATURE - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.131) uuhn(i,j,nlev_ec-k+2,l)= &!! U VELOCITY - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.132) vvhn(i,j,nlev_ec-k+2,l)= &!! V VELOCITY - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.133) then !! SPEC. HUMIDITY - qvhn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if (qvhn(i,j,nlev_ec-k+2,n,l) .lt. 0.) & - qvhn(i,j,nlev_ec-k+2,n,l) = 0. - ! this is necessary because the gridded data may contain - ! spurious negative values - endif - if(isec1(6).eq.134) psn(i,j,1,n,l)= &!! SURF. PRESS. - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.135) wwhn(i,j,nlev_ec-k+1,l)= &!! W VELOCITY - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.141) sdn(i,j,1,n,l)= &!! SNOW DEPTH - zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/conversion_factor !added by mc to make it consisitent with new readwind.f90! - if(isec1(6).eq.151) msln(i,j,1,n,l)= &!! SEA LEVEL PRESS. - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.164) tccn(i,j,1,n,l)= &!! CLOUD COVER - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.165) u10n(i,j,1,n,l)= &!! 10 M U VELOCITY - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.166) v10n(i,j,1,n,l)= &!! 10 M V VELOCITY - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.167) tt2n(i,j,1,n,l)= &!! 2 M TEMPERATURE - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.168) td2n(i,j,1,n,l)= &!! 2 M DEW POINT - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.142) then !! LARGE SCALE PREC. - lsprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if (lsprecn(i,j,1,n,l).lt.0.) lsprecn(i,j,1,n,l)=0. - endif - if(isec1(6).eq.143) then !! CONVECTIVE PREC. - convprecn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/conversion_factor !added by mc to make it consisitent with new readwind.f90 - if (convprecn(i,j,1,n,l).lt.0.) convprecn(i,j,1,n,l)=0. - endif - if(isec1(6).eq.146) sshfn(i,j,1,n,l)= &!! SENS. HEAT FLUX - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if((isec1(6).eq.146).and. & - (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) hflswitch=.true. ! Heat flux available - if(isec1(6).eq.176) then !! SOLAR RADIATION - ssrn(i,j,1,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if (ssrn(i,j,1,n,l).lt.0.) ssrn(i,j,1,n,l)=0. - endif - if(isec1(6).eq.180) ewss(i,j)= &!! EW SURFACE STRESS - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.181) nsss(i,j)= &!! NS SURFACE STRESS - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(((isec1(6).eq.180).or.(isec1(6).eq.181)).and. & - (zsec4(nxn(l)*(nyn(l)-j-1)+i+1).ne.0.)) strswitch=.true. ! stress available - if(isec1(6).eq.129) oron(i,j,l)= &!! ECMWF OROGRAPHY - zsec4(nxn(l)*(nyn(l)-j-1)+i+1)/ga - if(isec1(6).eq.160) excessoron(i,j,l)= &!! STANDARD DEVIATION OF OROGRAPHY - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.172) lsmn(i,j,l)= &!! ECMWF LAND SEA MASK - zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - if(isec1(6).eq.131) iumax=max(iumax,nlev_ec-k+1) - if(isec1(6).eq.135) iwmax=max(iwmax,nlev_ec-k+1) - - ! ESO TODO: - ! -add check for if one of clwc/ciwc missing (error), - ! also if all 3 cw fields present, use qc and disregard the others - if(isec1(6).eq.246) then !! CLWC Cloud liquid water content [kg/kg] - clwchn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - readclouds_nest(l)=.true. - sumclouds_nest(l)=.false. - endif - if(isec1(6).eq.247) then !! CIWC Cloud ice water content - ciwchn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - endif - !ZHG end - !ESO read qc (=clwc+ciwc) - if(isec1(6).eq.201031) then !! QC Cloud liquid water content [kg/kg] - clwchn(i,j,nlev_ec-k+2,n,l)=zsec4(nxn(l)*(nyn(l)-j-1)+i+1) - readclouds_nest(l)=.true. - sumclouds_nest(l)=.true. - endif - - - end do - end do - - call grib_release(igrib) - end do !! READ NEXT LEVEL OR PARAMETER - ! - ! CLOSING OF INPUT DATA FILE - ! - call grib_close_file(ifile) - - !error message if no fields found with correct first longitude in it - if (gotGrid.eq.0) then - print*,'***ERROR: input file needs to contain GRiB1 formatted'// & - 'messages' - stop - endif - - if(levdiff2.eq.0) then - iwmax=nlev_ec+1 - do i=0,nxn(l)-1 - do j=0,nyn(l)-1 - wwhn(i,j,nlev_ec+1,l)=0. - end do - end do - endif - - do i=0,nxn(l)-1 - do j=0,nyn(l)-1 - sfcstressn(i,j,1,n,l)=sqrt(ewss(i,j)**2+nsss(i,j)**2) - end do - end do - - if ((.not.hflswitch).or.(.not.strswitch)) then - write(*,*) 'WARNING: No flux data contained in GRIB file ', & - wfnamen(l,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 - !*************************************************************************** - - do i=0,nxn(l)-1 - do j=0,nyn(l)-1 - plev1=akz(3)+bkz(3)*psn(i,j,1,n,l) - pmean=0.5*(psn(i,j,1,n,l)+plev1) - tv=tthn(i,j,3,n,l)*(1.+0.61*qvhn(i,j,3,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,3,l)**2+vvhn(i,j,3,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,3,n,l),ff10m,fflev1, & - sfcstressn(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. - end do - end do - 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 - !************************************************************************** - - do i=0,nxn(l)-1 - do j=0,nyn(l)-1 - uuhn(i,j,1,l)=u10n(i,j,1,n,l) - vvhn(i,j,1,l)=v10n(i,j,1,n,l) - qvhn(i,j,1,n,l)=qvhn(i,j,2,n,l) - tthn(i,j,1,n,l)=tt2n(i,j,1,n,l) - end do - end do - - if(iumax.ne.nuvz-1) stop & - 'READWIND: NUVZ NOT CONSISTENT FOR A NESTING LEVEL' - if(iwmax.ne.nwz) stop & - 'READWIND: NWZ NOT CONSISTENT FOR A NESTING LEVEL' - - end do - - return -888 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' - write(*,*) ' #### ',wfnamen(l,indj),' FOR NESTING LEVEL #### ' - write(*,*) ' #### ',l,' IS NOT GRIB FORMAT !!! #### ' - stop 'Execution terminated' - - -999 write(*,*) ' #### FLEXPART MODEL ERROR! WINDFIELD #### ' - write(*,*) ' #### ',wfnamen(l,indj),' #### ' - write(*,*) ' #### CANNOT BE OPENED FOR NESTING LEVEL ',l,'####' - -end subroutine readwind_nest - -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: * - ! * - !***************************************************************************** - - 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 - -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: * - ! * - !***************************************************************************** - - 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 - -subroutine fixedfields_alloc - - allocate(oro(0:nxmax-1,0:nymax-1)) - allocate(excessoro(0:nxmax-1,0:nymax-1)) - allocate(lsm(0:nxmax-1,0:nymax-1)) - allocate(pv(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - -end subroutine fixedfields_alloc - -subroutine alloc_windf - - ! Eta coordinates - !**************** - allocate(uueta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(vveta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(wweta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(uupoleta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(vvpoleta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(tteta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(pveta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(prseta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(rhoeta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(drhodzeta(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - !allocate(tvirtual(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(etauvheight(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) - allocate(etawheight(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) - - ! Intrinsic coordinates - !********************** - allocate(uu(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(vv(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(ww(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(uupol(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(vvpol(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(tt(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(tth(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) - allocate(qv(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(qvh(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) - allocate(rho(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(drhodz(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(pplev(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) - allocate(prs(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(rho_dry(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - - ! Cloud data - !*********** - allocate(clwc(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(ciwc(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(clw(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - allocate(clwch(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) - allocate(ciwch(0:nxmax-1,0:nymax-1,nuvzmax,numwfmem)) - clwc=0.0 - ciwc=0.0 - clw=0.0 - clwch=0.0 - ciwch=0.0 - allocate(ctwc(0:nxmax-1,0:nymax-1,numwfmem)) - allocate(cloudsh(0:nxmax-1,0:nymax-1,numwfmem)) - allocate(clouds(0:nxmax-1,0:nymax-1,nzmax,numwfmem)) - - ! 2d fields - !********** - allocate(ps(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(sd(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(msl(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(tcc(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(u10(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(v10(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(tt2(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(td2(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(lsprec(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(convprec(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(sshf(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(ssr(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(sfcstress(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(ustar(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(wstar(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(hmix(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(tropopause(0:nxmax-1,0:nymax-1,1,numwfmem)) - allocate(oli(0:nxmax-1,0:nymax-1,1,numwfmem)) - - ! Vertical descritisation arrays - !******************************* - allocate(height(nzmax),wheight(nzmax),uvheight(nzmax)) - allocate(akm(nwzmax),bkm(nwzmax),akz(nuvzmax),bkz(nuvzmax), & - aknew(nzmax),bknew(nzmax)) - -end subroutine alloc_windf - -subroutine alloc_windf_nest -!**************************************************************************** -! Dynamic allocation of arrays -! -! For nested wind fields. -! -!**************************************************************************** - - allocate(wfnamen(maxnests,maxwf)) - allocate(wfspecn(maxnests,maxwf)) - - allocate(nxn(maxnests)) - allocate(nyn(maxnests)) - allocate(dxn(maxnests)) - allocate(dyn(maxnests)) - allocate(xlon0n(maxnests)) - allocate(ylat0n(maxnests)) - - allocate(oron(0:nxmaxn-1,0:nymaxn-1,maxnests)) - allocate(excessoron(0:nxmaxn-1,0:nymaxn-1,maxnests)) - allocate(lsmn(0:nxmaxn-1,0:nymaxn-1,maxnests)) - - allocate(uun(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(vvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(wwn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(ttn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(qvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(pvn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(clwcn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(ciwcn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(clwn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - - ! ETA equivalents - allocate(uuetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(vvetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(wwetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(ttetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(pvetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(prsetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(rhoetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(drhodzetan(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - ! allocate(tvirtualn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(etauvheightn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) - allocate(etawheightn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) - - allocate(cloudsn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(cloudshn(0:nxmaxn-1,0:nymaxn-1,numwfmem,numbnests)) - allocate(prsn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(rhon(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(drhodzn(0:nxmaxn-1,0:nymaxn-1,nzmax,numwfmem,numbnests)) - allocate(tthn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) - allocate(qvhn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) - allocate(clwchn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) - allocate(ciwchn(0:nxmaxn-1,0:nymaxn-1,nuvzmax,numwfmem,numbnests)) - allocate(ctwcn(0:nxmaxn-1,0:nymaxn-1,numwfmem,numbnests)) - - ! 2d fields - !*********** - allocate(psn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(sdn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(msln(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(tccn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(u10n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(v10n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(tt2n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(td2n(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(lsprecn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(convprecn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(sshfn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(ssrn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(sfcstressn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(ustarn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(wstarn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(hmixn(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(tropopausen(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(olin(0:nxmaxn-1,0:nymaxn-1,1,numwfmem,maxnests)) - allocate(vdepn(0:nxmaxn-1,0:nymaxn-1,maxspec,numwfmem,maxnests)) +#include "win_readwind_gfs.f90" - allocate(xresoln(0:maxnests)) - allocate(yresoln(0:maxnests)) - allocate(xln(maxnests)) - allocate(yln(maxnests)) - allocate(xrn(maxnests)) - allocate(yrn(maxnests)) +#include "win_readwind_nest.f90" - ! Initialise - !************ - clwcn(:,:,:,:,:)=0. - ciwcn(:,:,:,:,:)=0. - clwchn(:,:,:,:,:)=0. - ciwchn(:,:,:,:,:)=0. +#include "win_shift_field_0.f90" -end subroutine alloc_windf_nest +#include "win_shift_field.f90" -subroutine dealloc_windf_nest - - deallocate(wfnamen,wfspecn) - deallocate(nxn,nyn,dxn,dyn,xlon0n,ylat0n) - deallocate(oron,excessoron,lsmn) - deallocate(uun,vvn,wwn,ttn,qvn,pvn,clwcn,ciwcn,clwn,cloudsn, & - cloudshn,rhon,prsn,drhodzn,tthn,qvhn,clwchn,ciwchn,ctwcn) - deallocate(uuetan,vvetan,wwetan,ttetan,pvetan,prsetan,rhoetan, & - drhodzetan,etauvheightn,etawheightn) - deallocate(psn,sdn,msln,tccn,u10n,v10n,tt2n,td2n,lsprecn,convprecn, & - sshfn,ssrn,sfcstressn,ustarn,wstarn,hmixn,tropopausen,olin,vdepn) - deallocate(xresoln,yresoln,xln,yln,xrn,yrn) +#include "win_fixedfields_alloc.f90" -end subroutine dealloc_windf_nest +#include "win_alloc_windf.f90" -subroutine dealloc_windf +#include "win_alloc_windf_nest.f90" - deallocate(oro,excessoro,lsm) - deallocate(uueta,vveta,wweta,uupoleta,vvpoleta,tteta,pveta, & - prseta,rhoeta,drhodzeta,etauvheight,etawheight) - deallocate(uu,vv,ww,uupol,vvpol,tt,tth,qv,qvh,pv,rho,drhodz,pplev,prs,rho_dry) - deallocate(clwc,ciwc,clw,clwch,ciwch,ctwc,cloudsh,clouds) - deallocate(ps,sd,msl,tcc,u10,v10,tt2,td2,lsprec,convprec,sshf,ssr,sfcstress, & - ustar,wstar,hmix,tropopause,oli) - deallocate(height,wheight,uvheight,akm,bkm,akz,bkz,aknew,bknew) +#include "win_dealloc_windf_nest.f90" -end subroutine dealloc_windf +#include "win_dealloc_windf.f90" end module windfields_mod diff --git a/src/xmass_mod.f90 b/src/xmass_mod.f90 index 7af9a0c1db7d26a508d40fe2f72db54c200cd443..0be8d88a826d5123487a591294bc5ea354bc6b8d 100644 --- a/src/xmass_mod.f90 +++ b/src/xmass_mod.f90 @@ -2,9 +2,9 @@ ! SPDX-License-Identifier: GPL-3.0-or-later module xmass_mod - + implicit none - + real,allocatable, dimension (:) :: xmasssave - + end module xmass_mod