#define TRACEBACK write (gol,'("in ",a," (",a,", line",i5,")")') rname, __FILE__, __LINE__; call goErr #define IF_NOTOK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if #define IF_ERROR_RETURN(action) if (status> 0) then; TRACEBACK; action; return; end if ! #include "tm5.inc" ! !----------------------------------------------------------------------------- ! TM5 ! !----------------------------------------------------------------------------- !BOP ! ! !MODULE: EMISSION_NMVOC ! ! !DESCRIPTION: hold data and methods for NMVOC emissions. ! ! Non-methane VOC's : ! nmhc(ncb4) = (/ipar,ieth,iole,iald2,imgly,ich2o/) !\\ !\\ ! !INTERFACE: ! MODULE EMISSION_NMVOC ! ! !USES: ! use GO, only : gol, goPr, goErr use tm5_distgrid, only : dgrid, get_distgrid, scatter use partools, only : isRoot, par_broadcast use dims, only : nregions, okdebug use global_types, only : emis_data, d3_data use chem_param, only : ncb4 use emission_read, only : used_providers, has_emis IMPLICIT NONE PRIVATE ! ! !PUBLIC MEMBER FUNCTIONS: ! public :: Emission_NMVOC_Init ! allocate memory public :: Emission_NMVOC_Done ! deallocate memory public :: Emission_NMVOC_Declare ! read input data public :: Emission_NMVOC_Apply ! add emissions to tracer array ! ! !PRIVATE DATA MEMBERS: ! character(len=*), parameter :: mname = 'emission_nmvoc' type( emis_data ),dimension(:,:,:),allocatable :: hc_emis_2d type( d3_data ),dimension(:,:,:),allocatable :: hc_emis_3d logical, allocatable :: has_data_3d(:,:), has_data_2d(:,:) integer :: hc_2dsec, hc_3dsec ! ! !REVISION HISTORY: ! 1 Oct 2010 - Achim Strunk - overhaul for AR5 ! 1 Dec 2011 - Narcisa Banda - added EDGAR 4 ! 29 Jun 2012 - Ph. Le Sager - adapted for lon-lat MPI domain decomposition ! ! !REMARKS: ! !EOP !------------------------------------------------------------------------ CONTAINS !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: EMISSION_NMVOC_INIT ! ! !DESCRIPTION: Allocate memory !\\ !\\ ! !INTERFACE: ! SUBROUTINE EMISSION_NMVOC_INIT( status ) ! ! !USES: ! use dims, only : lm use emission_read, only : providers_def, numb_providers use emission_read , only : ed42_nsect_hc ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REVISION HISTORY: ! 1 Oct 2010 - Achim Strunk - adapted for AR5 ! 29 Jun 2012 - Ph. Le Sager - adapted for lon-lat MPI domain decomposition ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/Emission_NMVOC_Init' integer :: region, lsec, icb4 integer :: lmr, lprov, i1, i2, j1, j2 ! --- begin -------------------------------------- status = 0 if(.not. has_emis) return ! nb of sectors hc_2dsec = 0 hc_3dsec = 0 do lprov = 1, numb_providers if (count(used_providers.eq.providers_def(lprov)%name)/=0) then if (trim(providers_def(lprov)%name) .eq. 'ED42') then hc_2dsec = hc_2dsec + ed42_nsect_hc ! no 3d sectors in EDGAR 4.2 else hc_2dsec = hc_2dsec + providers_def(lprov)%nsect2d hc_3dsec = hc_3dsec + providers_def(lprov)%nsect3d endif endif enddo allocate( hc_emis_2d( nregions, hc_2dsec, ncb4 ) ) allocate( hc_emis_3d( nregions, hc_3dsec, ncb4 ) ) allocate( has_data_2d(hc_2dsec, ncb4) ) ; has_data_2d=.false. allocate( has_data_3d(hc_3dsec, ncb4) ) ; has_data_3d=.false. ! allocate information arrays (2d and 3d) do region=1,nregions CALL GET_DISTGRID( dgrid(region), I_STRT=i1, I_STOP=i2, J_STRT=j1, J_STOP=j2 ) lmr = lm(region) do icb4 = 1, ncb4 do lsec=1,hc_2dsec allocate( hc_emis_2d(region,lsec,icb4)%surf(i1:i2, j1:j2) ) end do do lsec=1,hc_3dsec allocate( hc_emis_3d(region,lsec,icb4)%d3(i1:i2, j1:j2, lmr) ) end do end do enddo status = 0 END SUBROUTINE EMISSION_NMVOC_INIT !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: EMISSION_NMVOC_DONE ! ! !DESCRIPTION: Free memory !\\ !\\ ! !INTERFACE: ! SUBROUTINE EMISSION_NMVOC_DONE( status ) ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REVISION HISTORY: ! 1 Oct 2010 - Achim Strunk - adapted to new structures ! 29 Jun 2012 - Ph. Le Sager - adapted for lon-lat MPI domain decomposition ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/Emission_NMVOC_Done' integer :: region, lsec, icb4 ! --- begin -------------------------------------- status = 0 if(.not. has_emis) return do region = 1, nregions do icb4 = 1, ncb4 do lsec=1,hc_2dsec deallocate( hc_emis_2d(region,lsec,icb4)%surf ) end do do lsec=1,hc_3dsec deallocate( hc_emis_3d(region,lsec,icb4)%d3 ) end do end do end do deallocate( hc_emis_2d ) deallocate( hc_emis_3d ) deallocate( has_data_2d, has_data_3d) status = 0 END SUBROUTINE EMISSION_NMVOC_DONE !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: EMISSION_NMVOC_DECLARE ! ! !DESCRIPTION: Opens, reads and evaluates input files (per month). ! Provides emissions on 2d/3d-arrays which are then added ! to tracers in routine *apply. ! Fields are communicated to all procs. !\\ !\\ ! !INTERFACE: ! SUBROUTINE EMISSION_NMVOC_DECLARE( status ) ! ! !USES: ! use toolbox, only : coarsen_emission use dims, only : im, jm, lm, idate, sec_month, nlon360, nlat180, iglbsfc use chem_param, only : xmc, ncb4, nmhc, names use emission_data, only : msg_emis, LAR5BMB, LMEGAN ! ---------------- AR5 - EDGAR 4 - ETC. -------------------- use emission_data, only : emis_input_year use emission_data, only : emis_input_dir_mac use emission_data, only : emis_input_dir_megan use emission_data, only : emis_input_dir_retro use emission_data, only : emis_input_dir_gfed use emission_data, only : emis_input_dir_ed4 use emission_read, only : emission_ar5_regrid_aircraft use emission_read, only : emission_ar5_ReadSector use emission_read, only : emission_macc_ReadSector use emission_read, only : emission_ed4_ReadSector use emission_read, only : emission_gfed_ReadSector use emission_read, only : emission_megan_ReadSector use emission_read, only : emission_retro_ReadSector use emission_read, only : sectors_def, numb_sectors use emission_read, only : ar5_dim_3ddata use emission_read, only : emis_ar5_nvoc, emis_ar5_voc_name use emission_read, only : emis_ar5_voc2cbm4_default use emission_read, only : emis_ar5_voc2cbm4_biomassb use emission_read, only : emis_ar5_voc2cbm4_biogenic use emission_read, only : emis_macc_nvoc, emis_macc_voc_name use emission_read, only : emis_macc_voc2cbm4_default use emission_read, only : emis_macc_voc2cbm4_biomassb use emission_read, only : emis_macc_voc2cbm4_biogenic use emission_read, only : emis_megan_voc2cbm4_biogenic use emission_read, only : emis_megan_nvoc, emis_megan_voc_name use emission_read, only : emis_gfed_nvoc, emis_gfed_voc_name use emission_read, only : emis_retro_voc_name use emission_read, only : ed42_hc_sectors ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REVISION HISTORY: ! 1 Oct 2010 - Achim Strunk - revamped for AR5 ! 1 Dec 2011 - Narcisa Banda - added EDGAR 4 ! 29 Jun 2012 - Ph. Le Sager - adapted for lon-lat MPI domain decomposition ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/emission_nmvoc_declare' ! --- local --------------------------------------- integer :: region logical :: hasData(ncb4) integer, parameter :: add_field = 0 integer, parameter :: amonth = 2 integer :: imr, jmr, lmr, i1, i2, j1, j2 integer :: lsec, ivoc, icb4 ! AR5 real,dimension(:,:,:), allocatable :: field3d real,dimension(:,:,:,:),allocatable :: field4d type(d3_data) :: emis3d, work(nregions) type(emis_data) :: wrk2D(nregions) integer :: seccount2d, seccount3d real,dimension(:,:), allocatable :: voc2cbm4 ! --- begin ---------------------------------------- status = 0 if(.not. has_emis) return write(gol,'(" EMISS-INFO ------------- read NMVOC emissions -------------")'); call goPr ! reset arrays do region = 1, nregions do icb4 = 1, ncb4 do lsec=1,hc_2dsec hc_emis_2d(region,lsec,icb4)%surf = 0.0 end do do lsec=1,hc_3dsec hc_emis_3d(region,lsec,icb4)%d3 = 0.0 end do end do end do ! global arrays for coarsening do region = 1, nregions if (isRoot)then allocate(work(region)%d3(im(region),jm(region),lm(region))) else allocate(work(region)%d3(1,1,1)) end if enddo do region = 1, nregions wrk2D(region)%surf => work(region)%d3(:,:,1) end do ! count 2d and 3d sectors seccount2d = 0 seccount3d = 0 ! always allocate here 3D/4D data set (for 2d sectors it will be filled in first layer only) if (isRoot) then allocate( field3d( nlon360, nlat180, ar5_dim_3ddata ) ) ; field3d = 0.0 allocate( field4d( nlon360, nlat180, ar5_dim_3ddata, ncb4 ) ) ; field4d = 0.0 else allocate( field3d( 1, 1, 1 ) ) allocate( field4d( 1, 1, 1, 1 ) ) end if ! -------------------------------- ! do a loop over available sectors ! -------------------------------- sec : do lsec = 1, numb_sectors if (count(used_providers.eq.sectors_def(lsec)%prov).eq.0) cycle if ((trim(sectors_def(lsec)%prov).eq.'ED42') .and. (count(ed42_hc_sectors.eq.sectors_def(lsec)%name) .eq. 0)) cycle if( sectors_def(lsec)%f3d ) then seccount3d = seccount3d + 1 else seccount2d = seccount2d + 1 end if field3d = 0.0 field4d = 0.0 if (isRoot) then ! READ select case( trim(sectors_def(lsec)%prov) ) case( 'AR5' ) ! screen out AR5 biomass burning if not wanted if ( .not. ((trim(sectors_def(lsec)%catname) .eq. 'biomassburning').and.(.not.LAR5BMB)) ) then ! get appropriate array of splitting values from input to cbm4 allocate( voc2cbm4(emis_ar5_nvoc,ncb4) ) ! Changing the tables here in order to get ALD and PAR etc from Biomassburning voc2cbm4 = reshape( emis_ar5_voc2cbm4_default, (/emis_ar5_nvoc,ncb4/) ) ! -------------------------------- ! do a loop over available constituents (25) ! -------------------------------- vocAR5: do ivoc = 1, emis_ar5_nvoc ! skip missing categories if (count(trim(emis_ar5_voc_name(ivoc)).eq.sectors_def(lsec)%species).eq.0) cycle call emission_ar5_ReadSector( trim(emis_ar5_voc_name(ivoc)), emis_input_year, idate(2), lsec, field3d, status ) IF_NOTOK_RETURN(status=1) do icb4 = 1, ncb4 field4d(:,:,:,icb4) = field4d(:,:,:,icb4) + field3d(:,:,:) * voc2cbm4(ivoc,icb4) end do end do vocAR5 deallocate( voc2cbm4 ) end if case( 'MACC' ) ! screen out biomass burning (a/k/a emiss_bb), and 'soil', 'nat' and 'air' sectors (no NMVOC) ! skip 'bio' source if already provided by MEGAN if ( ( .not. (trim(sectors_def(lsec)%catname) .eq. 'biomassburning') ) .and. & ( .not. (trim(sectors_def(lsec)%name) .eq. 'emiss_soil') ) .and. & ( .not. (trim(sectors_def(lsec)%name) .eq. 'emiss_nat') ) .and. & ( .not. (trim(sectors_def(lsec)%name) .eq. 'emiss_air') ) .and. & ( .not. (LMEGAN .and. (trim(sectors_def(lsec)%name) .eq. 'emiss_bio'))) ) then ! get appropriate array of splitting values from input to cbm4 allocate( voc2cbm4(emis_macc_nvoc,ncb4) ) select case( trim(sectors_def(lsec)%catname) ) case( 'anthropogenic', 'ships', 'aircraft' ) voc2cbm4 = reshape( emis_macc_voc2cbm4_default, (/emis_macc_nvoc,ncb4/) ) case( 'natural' ) voc2cbm4 = reshape( emis_macc_voc2cbm4_biogenic, (/emis_macc_nvoc,ncb4/) ) case default write(gol,'(80("-"))') ; call goPr write(gol,'("ERROR: wrong category name `",a,"`!")') sectors_def(lsec)%catname ; call goErr write(gol,'(80("-"))') ; call goPr end select ! -------------------------------- ! do a loop over available constituents (14) ! -------------------------------- do ivoc = 1, emis_macc_nvoc call emission_macc_ReadSector( emis_input_dir_mac, trim(emis_macc_voc_name(ivoc)), emis_input_year, idate(2), & '0.5x0.5_kg.nc', sectors_def(lsec)%name, 'kg / s', field3d, status ) IF_NOTOK_RETURN(status=1;deallocate(field3d,field4d)) do icb4 = 1, ncb4 field4d(:,:,:,icb4) = field4d(:,:,:,icb4) + field3d(:,:,:) * voc2cbm4(ivoc,icb4) end do end do deallocate( voc2cbm4 ) endif case( 'ED41' ) select case(trim(sectors_def(lsec)%name)) case ('1A3b_c_e','1A3d_SHIP','1A3d1') ! AR5 NMVOC emissions and were used to split EDGAR NMVOC totals into separate (AR5) NMVOC species ! get appropriate array of splitting values from input to cbm4 allocate( voc2cbm4(emis_ar5_nvoc,ncb4) ) ! Changing the tables here in order to get ALD and PAR etc from Biomassburning voc2cbm4 = reshape( emis_ar5_voc2cbm4_default, (/emis_ar5_nvoc,ncb4/) ) ! -------------------------------- ! do a loop over available constituents (25) ! -------------------------------- vocED41: do ivoc = 1, emis_ar5_nvoc ! screen out missing dataset if ((ivoc==10).or.(ivoc==11)) cycle vocED41 if ( trim(sectors_def(lsec)%name) /= '1A3b_c_e') then if ((ivoc==1).or.(ivoc>=18)) cycle vocED41 endif if (((ivoc==1).or.(ivoc==24)).and.(emis_input_year<2005)) cycle vocED41 ! kludge (waiting for NB input) call emission_ed4_ReadSector( emis_input_dir_ed4, trim(emis_ar5_voc_name(ivoc)), trim(emis_ar5_voc_name(ivoc)),& emis_input_year, idate(2), lsec, trim(sectors_def(lsec)%prov), 'kg / s', field3d,& status ) IF_NOTOK_RETURN(status=1) do icb4 = 1, ncb4 field4d(:,:,:,icb4) = field4d(:,:,:,icb4) + field3d(:,:,:) * voc2cbm4(ivoc,icb4) end do end do vocED41 deallocate( voc2cbm4 ) end select case( 'ED42' ) ! Biomass burning (GFED/RETRO/AR5BMB) and transport (ED41) are excluded through ED42_HC_SECTORS definition ! Same constituents as AR5 NMVOC are used ! get appropriate array of splitting values from input to cbm4 allocate( voc2cbm4(emis_ar5_nvoc,ncb4) ) voc2cbm4 = reshape( emis_ar5_voc2cbm4_default, (/emis_ar5_nvoc,ncb4/) ) ! -------------------------------- ! do a loop over available constituents (25) ! -------------------------------- vocED42: do ivoc = 1, emis_ar5_nvoc ! screen out missing dataset if ((ivoc==10).or.(ivoc==11)) cycle vocED42 if ( trim(sectors_def(lsec)%name) == '3') then if (count(ivoc.eq.(/2,3,4,5,7,8,9,12,13,16,21,22,24/)).eq.1) cycle vocED42 endif if ( trim(sectors_def(lsec)%name) == '1A4') then if (count(ivoc.eq.(/1,24/)).eq.1) cycle vocED42 endif if ( trim(sectors_def(lsec)%name) == '4F') then if (count(ivoc.eq.(/16,17,18,19,20,25/)).eq.1) cycle vocED42 endif if ( ( trim(sectors_def(lsec)%name) == '1A1a') .or. & ( trim(sectors_def(lsec)%name) == '1A1b_c_1B_2C1_2C2') .or. & ( trim(sectors_def(lsec)%name) == '1A2') .or. & ( trim(sectors_def(lsec)%name) == '2A_B_D_E_F_G') .or. & ( trim(sectors_def(lsec)%name) == '7A') ) then if (count(ivoc.eq.(/18,19,20/)).eq.1) cycle vocED42 endif call emission_ed4_ReadSector( emis_input_dir_ed4, trim(emis_ar5_voc_name(ivoc)), & trim(emis_ar5_voc_name(ivoc)), emis_input_year, idate(2), lsec, & trim(sectors_def(lsec)%prov), 'kg / s', field3d, status ) IF_NOTOK_RETURN(status=1) do icb4 = 1, ncb4 field4d(:,:,:,icb4) = field4d(:,:,:,icb4) + field3d(:,:,:) * voc2cbm4(ivoc,icb4) end do end do vocED42 deallocate( voc2cbm4 ) case( 'GFEDv3' ) ! We use the MACC voc split, since GFED3 contains the same species, ! except for the last 3 species - Acetone, Acetaldehyde and MEK - which are not provided in GFED3 ! get appropriate array of splitting values from input to cbm4 allocate( voc2cbm4(emis_macc_nvoc,ncb4) ) voc2cbm4 = reshape( emis_macc_voc2cbm4_biomassb, (/emis_macc_nvoc,ncb4/) ) ! -------------------------------- ! do a loop over available constituents (11) ! -------------------------------- do ivoc = 1, emis_gfed_nvoc call emission_gfed_ReadSector( emis_input_dir_gfed, trim(emis_gfed_voc_name(ivoc)), emis_input_year, idate(2), & sectors_def(lsec)%name, 'kg / s', field3d(:,:,1), status ) IF_NOTOK_RETURN(status=1;deallocate(field3d,field4d)) do icb4 = 1, ncb4 field4d(:,:,:,icb4) = field4d(:,:,:,icb4) + field3d(:,:,:) * voc2cbm4(ivoc,icb4) end do end do deallocate( voc2cbm4 ) case( 'RETRO' ) allocate( voc2cbm4(emis_ar5_nvoc,ncb4) ) voc2cbm4 = reshape( emis_ar5_voc2cbm4_biomassb, (/emis_ar5_nvoc,ncb4/) ) ! -------------------------------- ! do a loop over available constituents (25) ! -------------------------------- do ivoc = 1, emis_ar5_nvoc if (trim(emis_retro_voc_name(ivoc)).eq.'not provided') cycle call emission_retro_ReadSector( emis_input_dir_retro, trim(emis_retro_voc_name(ivoc)), emis_input_year, idate(2), & sectors_def(lsec)%name, 'kg / s', field3d(:,:,1), status ) IF_NOTOK_RETURN(status=1;deallocate(field3d)) do icb4 = 1, ncb4 field4d(:,:,:,icb4) = field4d(:,:,:,icb4) + field3d(:,:,:) * voc2cbm4(ivoc,icb4) end do end do deallocate( voc2cbm4 ) case( 'MEGAN' ) allocate( voc2cbm4(emis_megan_nvoc,ncb4) ) voc2cbm4 = reshape( emis_megan_voc2cbm4_biogenic, (/emis_megan_nvoc,ncb4/) ) ! -------------------------------- ! do a loop over available constituents (25) ! -------------------------------- do ivoc = 1, emis_megan_nvoc if (trim(emis_megan_voc_name(ivoc)).eq.'not provided') cycle call emission_megan_ReadSector( emis_input_dir_megan, trim(emis_megan_voc_name(ivoc)), emis_input_year, idate(2), & sectors_def(lsec)%name, 'kg / s', field3d(:,:,1), status ) IF_NOTOK_RETURN(status=1;deallocate(field3d)) do icb4 = 1, ncb4 field4d(:,:,:,icb4) = field4d(:,:,:,icb4) + field3d(:,:,:) * voc2cbm4(ivoc,icb4) end do end do deallocate( voc2cbm4 ) case('DUMMY') case default write(gol,*) "Error in buidling list of providers USED_PROVIDERS"; call goErr status=1; TRACEBACK; return END SELECT ! nothing found? do icb4 = 1, ncb4 if( sum(field4d(:,:,:,icb4)) < 100.*TINY(1.0) ) then if (okdebug) then write(gol,'("EMISS-INFO - no NMVOC emissions found for ",a," ",a," for month ",i2 )') & trim(sectors_def(lsec)%prov), trim(sectors_def(lsec)%name), idate(2) ; call goPr endif hasData(icb4)=.false. else if (okdebug) then write(gol,'("EMISS-INFO - found NMVOC emissions for ",a," ",a," for month ",i2 )') & trim(sectors_def(lsec)%prov), trim(sectors_def(lsec)%name), idate(2) ; call goPr endif field4d(:,:,:,icb4) = field4d(:,:,:,icb4) * sec_month ! from kg/s to kg/month hasData(icb4)=.true. end if enddo end if call Par_broadcast(hasData, status) IF_NOTOK_RETURN(status=1) ! if (.not.(any(hasData))) cycle sec ! early exit? if ( sectors_def(lsec)%f3d ) then has_data_3d(seccount3d,:)=hasData else has_data_2d(seccount2d,:)=hasData end if ! Loop over cb4 components and distinguish b/w 2d/3d sectors do icb4 = 1, ncb4 if( sectors_def(lsec)%f3d ) then ! --------------------------- ! 3d data (AIRCRAFT) ! --------------------------- if (has_data_3d(seccount3d,icb4)) then write(gol,'("EMISS-ERROR - Unexpected 3D data - implement")'); call goErr status=1; TRACEBACK; return endif else ! --------------------------- ! 2d data (Anthropogenic, Ships, Biomassburning) ! --------------------------- if (has_data_2d(seccount2d,icb4)) then if (isRoot) then ! print total & regrid call msg_emis( amonth, trim(sectors_def(lsec)%prov),sectors_def(lsec)%name, & trim(names(nmhc(icb4))), xmc, sum(field4d(:,:,1,icb4)) ) call coarsen_emission( trim(names(nmhc(icb4)))//sectors_def(lsec)%name, & nlon360, nlat180, field4d(:,:,1,icb4), wrk2D, add_field, status ) IF_NOTOK_RETURN(status=1) end if do region = 1, nregions call scatter(dgrid(region), hc_emis_2d(region,seccount2d,icb4)%surf, work(region)%d3(:,:,1), 0, status) IF_NOTOK_RETURN(status=1) end do endif endif ! 2D/3D enddo end do sec ! sectors deallocate( field3d, field4d ) do region = 1, nregions if (associated(wrk2D(region)%surf)) nullify(wrk2D(region)%surf) deallocate( work(region)%d3 ) end do ! check sectors found if( seccount2d /= hc_2dsec ) then write(gol,'(80("-"))') ; call goPr write(gol,'("ERROR: 2d sectors do not equal total number:",i4," /= ",i4," !")') seccount2d, hc_2dsec ; call goErr write(gol,'(80("-"))') ; call goPr status=1; return end if if( seccount3d /= hc_3dsec ) then write(gol,'(80("-"))') ; call goPr write(gol,'("ERROR: 3d sectors do not equal total number:",i4," /= ",i4," !")') seccount3d, hc_3dsec ; call goErr write(gol,'(80("-"))') ; call goPr status=1; return end if status = 0 end subroutine emission_nmvoc_declare !EOC !-------------------------------------------------------------------------- ! TM5 ! !-------------------------------------------------------------------------- !BOP ! ! !IROUTINE: EMISSION_NMVOC_APPLY ! ! !DESCRIPTION: Take monthly emissions, and ! - split them vertically ! - apply time splitting factors ! - add them up (add_3d) !\\ !\\ ! !INTERFACE: ! SUBROUTINE EMISSION_NMVOC_APPLY( region, status ) ! ! !USES: ! use dims, only : idate, itaur, nsrce, tref use dims, only : im, jm, lm use chem_param, only : xmcb4, xmc, ntracet, nmhc, names use datetime, only : tau2date use emission_data, only : emission_vdist_by_sector use emission_data, only : do_add_3d, do_add_3d_cycle, bb_cycle use emission_data, only : emis_bb_trop_cycle use emission_read, only : sectors_def, numb_sectors use emission_read, only : ed42_hc_sectors ! ! !INPUT PARAMETERS: ! integer, intent(in) :: region ! ! !OUTPUT PARAMETERS: ! integer, intent(out) :: status ! ! !REVISION HISTORY: ! 1 Oct 2010 - Achim Strunk - rewritten for AR5 ! 29 Jun 2012 - Ph. Le Sager - adapted for lon-lat MPI domain decomposition ! !EOP !------------------------------------------------------------------------ !BOC character(len=*), parameter :: rname = mname//'/emission_nmvoc_apply' ! --- local --------------------------------------- integer,dimension(6) :: idater real :: dtime, fraction integer :: imr, jmr, lmr, lsec, icb4, i1, i2, j1, j2 integer :: seccount2d, seccount3d type(d3_data) :: emis3d ! --- begin ----------------------------------------- status = 0 if(.not. has_emis) return if( okdebug ) then write(gol,*) 'start of emission_nmvoc_apply'; call goPr end if call tau2date(itaur(region),idater) dtime=float(nsrce)/(2*tref(region)) !emissions are added in two steps...XYZECCEZYX. ! get a working structure for 3d emissions call get_distgrid( dgrid(region), I_STRT=i1, I_STOP=i2, J_STRT=j1, J_STOP=j2 ) allocate( emis3d%d3(i1:i2,j1:j2,lm(region)) ) ; emis3d%d3 = 0.0 ! count 2d and 3d sectors seccount2d = 0 seccount3d = 0 ! cycle over sectors do lsec = 1, numb_sectors if (count(used_providers.eq.sectors_def(lsec)%prov).eq.0) cycle if ((trim(sectors_def(lsec)%prov).eq.'ED42') .and. (count(ed42_hc_sectors.eq.sectors_def(lsec)%name) .eq. 0)) cycle if( sectors_def(lsec)%f3d ) then ! count seccount3d = seccount3d + 1 else seccount2d = seccount2d + 1 end if fraction = 1.0 ! default: no additional splitting ! ---------------------------------------------------------------------------------------- ! distinguish here between sectors and whether they should have additional splitting ! if( sectors_def(lsec)%catname == 'biomassburning' ) fraction = fraction * bb_frac etc... ! ---------------------------------------------------------------------------------------- cb05: do icb4=1,ncb4 if( nmhc(icb4).gt. ntracet ) cycle cb05 ! only transported species, skip short lived species ! distinguish between 2d/3d sectors if( sectors_def(lsec)%f3d ) then if (.not.has_data_3d(seccount3d,icb4)) cycle cb05 emis3d%d3 = hc_emis_3d(region,seccount3d,icb4)%d3 else if (.not.has_data_2d(seccount2d,icb4)) cycle cb05 ! vertically distribute according to sector emis3d%d3 = 0.0 call emission_vdist_by_sector( sectors_def(lsec)%vdisttype, trim(names(nmhc(icb4))), region, & hc_emis_2d(region,seccount2d,icb4), emis3d, status ) IF_NOTOK_RETURN(status=1) endif ! add dataset according to sector and category if( emis_bb_trop_cycle .and. trim(sectors_def(lsec)%catname) == "biomassburning" ) then call do_add_3d_cycle( region, nmhc(icb4), i1, j1, emis3d%d3, bb_cycle(region)%scalef, & xmcb4(icb4), xmcb4(icb4), status, fraction ) IF_NOTOK_RETURN(status=1) else call do_add_3d( region, nmhc(icb4), i1, j1, emis3d%d3, xmcb4(icb4), xmcb4(icb4), status, fraction ) IF_NOTOK_RETURN(status=1) endif enddo cb05 enddo ! sectors deallocate( emis3d%d3 ) if(okdebug) then write(gol,*) 'end of emission_nmvoc_apply'; call goPr end if status = 0 END SUBROUTINE EMISSION_NMVOC_APPLY !EOC END MODULE EMISSION_NMVOC