subroutine sum1grd(numcols,numrows,numlays, & nspmod,nsptrac,igroup,igrd,idx,emssum, & emsgrd,emsbas,emsoth,emslft,emstot,lemit) use grid use chmstry use tracer c c c Copyright 1996 - 2018 c Ramboll c c c----CAMx v7Beta6 190902 c c SUM1GRD sums up the area emission of one species for a given group c in a given grid c c 07/19/02 --gwilson-- Added seperate source area map for each grids. c 10/28/09 --gwilson-- Changed dimension of variables to accomodate c the dynamic memory allocation c 03/01/16 --gwilson-- Added partial source area map c c Input argument: c numcols number of columns in any grid c numrows number of columns in any grid c numlays number of columns in any grid c nspmod number of model species c nsptrac number of tracer species c igroup group ID c igrd grid ID c idx specie ID c emsgrd the species emission in the grid c c Output arguments: c emssum emission summed over grid c emsbas base emission c emsoth "otherwise" emission c emslft leftover emission c emstot total emission c lemit flag to determine if tracer class is emitted c include "camx.prm" c integer numcols integer numrows integer numlays integer nspmod integer nsptrac real emssum(nspmod,nsptrac) real emsgrd(numcols,numrows,numlays) real emsbas(nspmod,nsptrac) real emsoth(nspmod,nsptrac) real*8 emslft(numcols,numrows,nspmod) real*8 emstot(numcols,numrows,nspmod) logical lemit(*) integer ipart real frac c logical luse c c --- Entry point --- c c --- make sure this species is used --- c luse = .FALSE. do icls=1,ntrcls if( trspmap(idx,icls) .NE. 0. .OR. & yhratmap(idx,icls) .NE. 0. .OR. & ylratmap(idx,icls) .NE. 0. ) then if( trspmap(idx,icls) .NE. 0. ) lemit(icls) = .TRUE. luse = .TRUE. endif enddo if( .NOT. luse ) goto 9999 c c --- sum up the emissions excluding the boundary for this grid --- c do 40 j=2,nrow(igrd)-1 jcrs = (j - 2)/nmesh(igrd) + j1(igrd) if( igrd .eq. 1 ) jcrs = j do 50 i=2,ncol(igrd)-1 c c --- calculate the coarse grid offset --- c icrs = (i - 2)/nmesh(igrd) + i1(igrd) if( igrd .eq. 1 ) icrs = i c c --- skip cell if this grid has a child in this cell --- c ijcl = i + (j-1)*ncol(igrd) if( idfin(iptr2d(igrd)-1+ijcl) .NE. 0 ) goto 50 c c --- get the region for this cell from mapping array, c the grid cell should be the coarse grid ---- c do ipart=1,npartial(igroup,igrd) imap = igrmap(igroup,ipart,igrd,i,j) frac = frcmap(igroup,ipart,igrd,i,j) if( (imap .LE. 0 .AND. frac .GT. 0.) .OR. imap .GT. nregin ) goto 50 c c --- calculate the index into the tracer species for this gruoup/region --- c if( ngroup .GT. 0 ) then c c --- if group is base emissions, add to "leftover" group ---- c if( igroup .EQ. 0 ) then if( leftovr ) then do icls=1,ntrcls if( trspmap(idx,icls) .NE. 0. .OR. & yhratmap(idx,icls) .NE. 0. .OR. & ylratmap(idx,icls) .NE. 0. ) then ipt = iemcls(icls)-1 + imap+ngroup*nregin do k=1,numlays emsbas(idx,ipt) = emsbas(idx,ipt) + emsgrd(i,j,k) * frac enddo endif enddo endif do icls=1,ntrcls if( trspmap(idx,icls) .NE. 0. .OR. & yhratmap(idx,icls) .NE. 0. .OR. & ylratmap(idx,icls) .NE. 0. ) then do k=1,numlays emstot(icrs,jcrs,idx) = & emstot(icrs,jcrs,idx) + emsgrd(i,j,k) * frac enddo endif enddo c c --- otherwise, add to this group/region and subtract from "leftover" --- c else do icls=1,ntrcls if( trspmap(idx,icls) .NE. 0. .OR. & yhratmap(idx,icls) .NE. 0. .OR. & ylratmap(idx,icls) .NE. 0. ) then ipt = iemcls(icls)-1 + imap+(igroup-1)*nregin do k=1,numlays emssum(idx,ipt) = emssum(idx,ipt) + emsgrd(i,j,k) * frac if( leftovr ) then ipt = iemcls(icls)-1 + imap+ngroup*nregin emsoth(idx,ipt) = emsoth(idx,ipt) + emsgrd(i,j,k) * frac endif enddo endif enddo do icls=1,ntrcls if( trspmap(idx,icls) .NE. 0. .OR. & yhratmap(idx,icls) .NE. 0. .OR. & ylratmap(idx,icls) .NE. 0. ) then do k=1,numlays emslft(icrs,jcrs,idx) = & emslft(icrs,jcrs,idx) + emsgrd(i,j,k) * frac enddo endif enddo endif c c --- only using regular model emissions --- c else do icls=1,ntrcls if( trspmap(idx,icls) .NE. 0. .OR. & yhratmap(idx,icls) .NE. 0. .OR. & ylratmap(idx,icls) .NE. 0. ) then ipt = iemcls(icls) - 1 + imap do k=1,numlays emssum(idx,ipt) = emssum(idx,ipt) + emsgrd(i,j,k) * frac enddo endif enddo endif enddo 50 continue 40 continue c 9999 continue return end