emission_nh3.F90 24 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698
  1. !
  2. #define TRACEBACK write (gol,'("in ",a," (",a,", line",i5,")")') rname, __FILE__, __LINE__; call goErr
  3. #define IF_NOTOK_RETURN(action) if (status/=0) then; TRACEBACK; action; return; end if
  4. #define IF_ERROR_RETURN(action) if (status> 0) then; TRACEBACK; action; return; end if
  5. !
  6. #include "tm5.inc"
  7. !
  8. !-----------------------------------------------------------------------------
  9. ! TM5 !
  10. !-----------------------------------------------------------------------------
  11. !BOP
  12. !
  13. ! !MODULE: EMISSION_NH3
  14. !
  15. ! !DESCRIPTION: Perform NH3 emissions needed for TM5 CBM4 version.
  16. !\\
  17. !\\
  18. ! !INTERFACE:
  19. !
  20. MODULE EMISSION_NH3
  21. !
  22. ! !USES:
  23. !
  24. use GO, only : gol, goErr, goPr
  25. use tm5_distgrid, only : dgrid, get_distgrid, scatter, gather
  26. use dims, only : nregions, idate, okdebug
  27. use global_types, only : emis_data, d3_data
  28. use emission_read, only : used_providers, has_emis
  29. implicit none
  30. private
  31. !
  32. ! !PUBLIC MEMBER FUNCTIONS:
  33. !
  34. public :: Emission_NH3_init ! allocate
  35. public :: Emission_nh3_declare ! read monthly input
  36. public :: Emission_nh3_apply ! distribute & add emissions to tracer array
  37. public :: Emission_nh3_done ! deallocate
  38. !
  39. ! !PRIVATE DATA MEMBERS:
  40. !
  41. character(len=*), parameter :: mname = 'emission_nh3'
  42. type(emis_data), dimension(:,:), allocatable :: nh3_emis_2d
  43. type(d3_data), dimension(:,:), allocatable :: nh3_emis_3d
  44. integer :: nh3_3dsec, nh3_2dsec
  45. logical, allocatable :: has_data_3d(:), has_data_2d(:)
  46. !
  47. ! !REVISION HISTORY:
  48. ! 1 Oct 2010 - Achim Strunk - overhaul for AR5
  49. ! 1 Dec 2011 - Narcisa Banda - added EDGAR 4
  50. ! 25 Jun 2012 - P. Le Sager - adapted for lon-lat MPI domain decomposition
  51. !
  52. ! !REMARKS:
  53. !
  54. !EOP
  55. !------------------------------------------------------------------------
  56. CONTAINS
  57. !--------------------------------------------------------------------------
  58. ! TM5 !
  59. !--------------------------------------------------------------------------
  60. !BOP
  61. !
  62. ! !IROUTINE: EMISSION_NH3_INIT
  63. !
  64. ! !DESCRIPTION: Allocate space needed to handle the emissions
  65. !\\
  66. !\\
  67. ! !INTERFACE:
  68. !
  69. SUBROUTINE EMISSION_NH3_INIT( status )
  70. !
  71. ! !USES:
  72. !
  73. use dims, only : lm
  74. use emission_read, only : providers_def, numb_providers, ed42_nsect_nh3
  75. use emission_data, only : LAR5BMB
  76. use emission_read, only : n_ar5_ant_sec, n_ar5_shp_sec, n_ar5_air_sec, n_ar5_bmb_sec
  77. use emission_read, only : ar5_cat_ant, ar5_cat_shp, ar5_cat_air, ar5_cat_bmb
  78. !
  79. ! !OUTPUT PARAMETERS:
  80. !
  81. integer, intent(out) :: status
  82. !
  83. ! !REVISION HISTORY:
  84. ! 1 Oct 2010 - Achim Strunk - v0
  85. ! 25 Jun 2012 - P. Le Sager - adapted for lon-lat MPI domain decomposition
  86. !
  87. !EOP
  88. !------------------------------------------------------------------------
  89. !BOC
  90. character(len=*), parameter :: rname = mname//'/Emission_NH3_Init'
  91. integer :: region
  92. integer :: lmr, lsec, lprov, i1, i2, j1, j2
  93. ! --- begin --------------------------------------
  94. status = 0
  95. if(.not. has_emis) return
  96. ! nb of sectors
  97. nh3_2dsec = 0
  98. nh3_3dsec = 0
  99. do lprov = 1, numb_providers
  100. if (count(used_providers.eq.providers_def(lprov)%name)/=0) then
  101. if (trim(providers_def(lprov)%name) .eq. 'AR5') then
  102. ! nb of available sectors in AR5 depends on category
  103. nh3_2dsec = nh3_2dsec + n_ar5_ant_sec*count('NH3'.eq.ar5_cat_ant) + &
  104. n_ar5_shp_sec*count('NH3'.eq.ar5_cat_shp)
  105. if (LAR5BMB) nh3_2dsec = nh3_2dsec + n_ar5_bmb_sec*count('NH3'.eq.ar5_cat_bmb)
  106. nh3_3dsec = nh3_3dsec + n_ar5_air_sec*count('NH3'.eq.ar5_cat_air)
  107. elseif (trim(providers_def(lprov)%name) .eq. 'ED42') then
  108. nh3_2dsec = nh3_2dsec + ed42_nsect_nh3
  109. ! no 3d sectors in EDGAR 4.2
  110. else
  111. nh3_2dsec = nh3_2dsec + providers_def(lprov)%nsect2d
  112. nh3_3dsec = nh3_3dsec + providers_def(lprov)%nsect3d
  113. endif
  114. endif
  115. enddo
  116. ! basic check
  117. if (nh3_2dsec == 0) then
  118. write(gol,*) "WARNING - there is no 2D sectors for NH3 !"; call goPr
  119. end if
  120. if (nh3_3dsec == 0) then
  121. write(gol,*) "WARNING - there is no 3D sectors for NH3 !"; call goPr
  122. end if
  123. allocate( nh3_emis_2d( nregions, nh3_2dsec ) )
  124. allocate( nh3_emis_3d( nregions, nh3_3dsec ) )
  125. allocate( has_data_2d(nh3_2dsec)) ; has_data_2d=.false.
  126. allocate( has_data_3d(nh3_3dsec)) ; has_data_3d=.false.
  127. ! allocate information arrays (2d and 3d)
  128. do region=1,nregions
  129. CALL GET_DISTGRID( dgrid(region), I_STRT=i1, I_STOP=i2, J_STRT=j1, J_STOP=j2 )
  130. lmr = lm(region)
  131. do lsec=1,nh3_2dsec
  132. allocate( nh3_emis_2d(region,lsec)%surf(i1:i2,j1:j2) )
  133. end do
  134. do lsec=1,nh3_3dsec
  135. allocate( nh3_emis_3d(region,lsec)%d3(i1:i2,j1:j2,lmr) )
  136. end do
  137. enddo
  138. ! ok
  139. status = 0
  140. END SUBROUTINE EMISSION_NH3_INIT
  141. !EOC
  142. !--------------------------------------------------------------------------
  143. ! TM5 !
  144. !--------------------------------------------------------------------------
  145. !BOP
  146. !
  147. ! !IROUTINE: EMISSION_NH3_DONE
  148. !
  149. ! !DESCRIPTION: Free space after handling of the emissions
  150. !\\
  151. !\\
  152. ! !INTERFACE:
  153. !
  154. SUBROUTINE EMISSION_NH3_DONE( status )
  155. !
  156. ! !OUTPUT PARAMETERS:
  157. !
  158. integer, intent(out) :: status
  159. !
  160. ! !REVISION HISTORY:
  161. ! 1 Oct 2010 - Achim Strunk - v0
  162. !
  163. !EOP
  164. !------------------------------------------------------------------------
  165. !BOC
  166. character(len=*), parameter :: rname = mname//'/Emission_NH3_Done'
  167. integer :: region, lsec
  168. ! --- begin ---------------------------------
  169. status = 0
  170. if(.not. has_emis) return
  171. do region = 1, nregions
  172. do lsec=1,nh3_2dsec
  173. deallocate( nh3_emis_2d(region,lsec)%surf )
  174. end do
  175. do lsec=1,nh3_3dsec
  176. deallocate( nh3_emis_3d(region,lsec)%d3 )
  177. end do
  178. end do
  179. deallocate( nh3_emis_2d, nh3_emis_3d )
  180. deallocate( has_data_2d, has_data_3d )
  181. status = 0
  182. END SUBROUTINE EMISSION_NH3_DONE
  183. !EOC
  184. !--------------------------------------------------------------------------
  185. ! TM5 !
  186. !--------------------------------------------------------------------------
  187. !BOP
  188. !
  189. ! !IROUTINE: EMISSION_NH3_DECLARE
  190. !
  191. ! !DESCRIPTION: Opens, reads and evaluates input files (per month).
  192. ! Provides emissions on 2d/3d-arrays which are then added
  193. ! to tracers in routine *apply.
  194. !\\
  195. !\\
  196. ! !INTERFACE:
  197. !
  198. SUBROUTINE EMISSION_NH3_DECLARE( status )
  199. !
  200. ! !USES:
  201. !
  202. use toolbox, only : coarsen_emission
  203. use partools, only : isRoot, par_broadcast
  204. use dims, only : im, jm, lm, idate, sec_month, nlon360, nlat180, iglbsfc
  205. use chem_param, only : xmnh3
  206. use emission_data, only : msg_emis, LAR5BMB
  207. ! ---------------- AR5 - EDGAR 4 - ETC. --------------------
  208. use emission_data, only : emis_input_year_nh3, emis_input_year_nat
  209. use emission_data, only : emis_input_dir_mac
  210. use emission_data, only : emis_input_dir_retro
  211. use emission_data, only : emis_input_dir_gfed
  212. use emission_data, only : emis_input_dir_ed4
  213. use emission_read, only : emission_ar5_regrid_aircraft
  214. use emission_read, only : emission_cmip6_ReadSector
  215. use emission_read, only : emission_cmip6bmb_ReadSector
  216. use emission_read, only : emission_ar5_ReadSector
  217. use emission_read, only : emission_macc_ReadSector
  218. use emission_read, only : emission_ed4_ReadSector
  219. use emission_read, only : emission_gfed_ReadSector
  220. use emission_read, only : emission_retro_ReadSector
  221. use emission_read, only : sectors_def, numb_sectors
  222. use emission_read, only : ar5_dim_3ddata
  223. use emission_read, only : ed42_nh3_sectors
  224. !
  225. ! !OUTPUT PARAMETERS:
  226. !
  227. integer, intent(out) :: status
  228. !
  229. ! !REVISION HISTORY:
  230. ! 1 Oct 2010 - Achim Strunk - adapted for AR5
  231. ! 1 Dec 2011 - Narcisa Banda - added EDGAR 4
  232. ! 25 Jun 2012 - P. Le Sager - adapted for lon-lat MPI domain decomposition
  233. !
  234. !EOP
  235. !------------------------------------------------------------------------
  236. !BOC
  237. character(len=*), parameter :: rname = mname//'/emission_nh3_declare'
  238. integer :: region, hasData
  239. integer,parameter :: add_field=0
  240. integer,parameter :: amonth=2
  241. integer :: imr, jmr, lmr, lsec, i1, i2, j1, j2
  242. ! AR5
  243. real,dimension(:,:,:), allocatable :: field3d, field3d2
  244. type(d3_data), dimension(nregions) :: emis3d, work, work3d
  245. type(emis_data) :: wrk2D(nregions)
  246. integer :: seccount2d, seccount3d
  247. ! --- begin -----------------------------------------
  248. status = 0
  249. if(.not. has_emis) return
  250. write(gol,'(" EMISS-INFO ------------- read NH3 emissions -------------")'); call goPr
  251. ! reset arrays
  252. do region = 1, nregions
  253. do lsec=1,nh3_2dsec
  254. nh3_emis_2d(region,lsec)%surf = 0.0
  255. end do
  256. do lsec=1,nh3_3dsec
  257. nh3_emis_3d(region,lsec)%d3 = 0.0
  258. end do
  259. CALL GET_DISTGRID( dgrid(region), I_STRT=i1, I_STOP=i2, J_STRT=j1, J_STOP=j2 )
  260. lmr = lm(region)
  261. allocate( work3d(region)%d3 (i1:i2,j1:j2, ar5_dim_3ddata) ) ; work3d(region)%d3 = 0.0
  262. allocate( emis3d(region)%d3 (i1:i2,j1:j2, lmr ) ) ; emis3d(region)%d3 = 0.0
  263. end do
  264. ! global arrays for coarsening
  265. do region = 1, nregions
  266. if (isRoot)then
  267. allocate(work(region)%d3(im(region),jm(region),ar5_dim_3ddata))
  268. else
  269. allocate(work(region)%d3(1,1,1))
  270. end if
  271. enddo
  272. do region = 1, nregions
  273. wrk2D(region)%surf => work(region)%d3(:,:,1)
  274. end do
  275. ! --------------------------------
  276. ! do a loop over available sectors
  277. ! --------------------------------
  278. ! count 2d and 3d sectors
  279. seccount2d = 0
  280. seccount3d = 0
  281. ! always allocate here 3d data set (for 2d sectors it will be filled in first layer only)
  282. if (isRoot) then
  283. allocate( field3d( nlon360, nlat180, ar5_dim_3ddata ) ) ; field3d = 0.0
  284. else
  285. allocate( field3d( 1, 1, 1 ) )
  286. end if
  287. sec : do lsec = 1, numb_sectors
  288. if (count(used_providers.eq.sectors_def(lsec)%prov).eq.0) cycle
  289. if ((trim(sectors_def(lsec)%prov).eq.'ED42') .and. (count(ed42_nh3_sectors.eq.sectors_def(lsec)%name) .eq. 0)) cycle
  290. if (associated(sectors_def(lsec)%species)) then ! AR5 checks
  291. if (count('NH3'.eq.sectors_def(lsec)%species).eq.0) cycle
  292. if ((trim(sectors_def(lsec)%catname) .eq. 'biomassburning').and.(.not.LAR5BMB)) cycle
  293. endif
  294. field3d = 0.0
  295. if( sectors_def(lsec)%f3d ) then
  296. seccount3d = seccount3d + 1
  297. else
  298. seccount2d = seccount2d + 1
  299. end if
  300. if (isRoot) then ! READ
  301. select case( trim(sectors_def(lsec)%prov) )
  302. case( 'CMIP6' )
  303. call emission_cmip6_ReadSector( 'NH3', emis_input_year_nh3, idate(2), lsec, field3d, status )
  304. IF_NOTOK_RETURN(status=1;deallocate(field3d))
  305. case( 'CMIP6BMB' )
  306. call emission_cmip6bmb_ReadSector( 'NH3', emis_input_year_nh3, idate(2), lsec, field3d, status )
  307. IF_NOTOK_RETURN(status=1;deallocate(field3d))
  308. case( 'AR5' )
  309. ! Screen out solvent, waste and shipping sectors for NH3,
  310. ! because they are zero in the RCPs
  311. ! and not present in the historical files.
  312. if (trim(sectors_def(lsec)%name) .ne. 'emiss_slv' .and. &
  313. trim(sectors_def(lsec)%name) .ne. 'emiss_wst' .and. &
  314. trim(sectors_def(lsec)%name) .ne. 'emiss_shp') then
  315. call emission_ar5_ReadSector( 'NH3', emis_input_year_nh3, idate(2), lsec, field3d, status )
  316. IF_NOTOK_RETURN(status=1)
  317. endif
  318. case( 'MACC' )
  319. ! screen out 'nat', 'bio', 'air' sectors
  320. if ( ( .not. (trim(sectors_def(lsec)%name) .eq. 'emiss_nat')) .and. &
  321. ( .not. (trim(sectors_def(lsec)%name) .eq. 'emiss_bio')) .and. &
  322. ( .not. (trim(sectors_def(lsec)%name) .eq. 'emiss_air')) ) then
  323. if (trim(sectors_def(lsec)%catname) .eq. 'natural') then
  324. call emission_macc_ReadSector( emis_input_dir_mac, 'NH3', emis_input_year_nat, idate(2), &
  325. '0.5x0.5_kg.nc', sectors_def(lsec)%name, 'kg / s', field3d, status )
  326. IF_NOTOK_RETURN(status=1)
  327. else
  328. call emission_macc_ReadSector( emis_input_dir_mac, 'NH3', emis_input_year_nh3, idate(2), &
  329. '0.5x0.5_kg.nc', sectors_def(lsec)%name, 'kg / s', field3d, status )
  330. IF_NOTOK_RETURN(status=1)
  331. endif
  332. endif
  333. case( 'ED41' )
  334. select case(trim(sectors_def(lsec)%name))
  335. case ('1A3b_c_e')
  336. call emission_ed4_ReadSector( emis_input_dir_ed4, 'NH3', 'nh3', 2005, idate(2), &
  337. lsec, trim(sectors_def(lsec)%prov), 'kg / s', field3d, status )
  338. IF_NOTOK_RETURN(status=1)
  339. end select
  340. case( 'ED42' )
  341. ! biomass burning (GFED/RETRO/AR5BMB) and transport (ED41) are excluded through ED42_NH3_SECTORS definition
  342. call emission_ed4_ReadSector( emis_input_dir_ed4, 'NH3', 'nh3', emis_input_year_nh3, idate(2), &
  343. lsec, trim(sectors_def(lsec)%prov), 'kg / s', field3d, status )
  344. IF_NOTOK_RETURN(status=1)
  345. case('GFEDv3')
  346. call emission_gfed_ReadSector( emis_input_dir_gfed, 'nh3', emis_input_year_nh3, idate(2), &
  347. sectors_def(lsec)%name, 'kg / s', field3d(:,:,1), status )
  348. IF_NOTOK_RETURN(status=1)
  349. case('RETRO')
  350. call emission_retro_ReadSector( emis_input_dir_retro, 'NH3', emis_input_year_nh3, idate(2), &
  351. sectors_def(lsec)%name, 'kg / s', field3d(:,:,1), status )
  352. IF_NOTOK_RETURN(status=1)
  353. case('MEGAN')
  354. !
  355. ! No biogenic NH3 emissions available in MEGAN
  356. !
  357. case('DUMMY')
  358. case default
  359. write(gol,*) "Error in buidling list of providers USED_PROVIDERS"; call goErr
  360. status=1; TRACEBACK; return
  361. end select
  362. ! nothing found???
  363. if( sum(field3d) < 100.*TINY(1.0) ) then
  364. if (okdebug) then
  365. write(gol,'("EMISS-INFO - no NH3 emissions found for ",a," ",a," for month ",i2 )') &
  366. trim(sectors_def(lsec)%prov), trim(sectors_def(lsec)%name), idate(2) ; call goPr
  367. endif
  368. hasData=0
  369. else
  370. if (okdebug) then
  371. write(gol,'("EMISS-INFO - found NH3 emissions for ",a," ",a," for month ",i2 )') &
  372. trim(sectors_def(lsec)%prov), trim(sectors_def(lsec)%name), idate(2) ; call goPr
  373. endif
  374. ! scale from kg/s to kg/month
  375. field3d = field3d * sec_month ! kg / month
  376. hasData=1
  377. end if
  378. end if
  379. call Par_broadcast(hasData, status)
  380. IF_NOTOK_RETURN(status=1)
  381. if (hasData == 0) then
  382. cycle sec
  383. else
  384. if ( sectors_def(lsec)%f3d ) then
  385. has_data_3d(seccount3d)=.true.
  386. else
  387. has_data_2d(seccount2d)=.true.
  388. end if
  389. end if
  390. ! Distinguish 2d/3d sectors
  391. if( sectors_def(lsec)%f3d ) then
  392. ! ---------------------------------------
  393. ! 3d data (AIRCRAFT), available for CMIP6
  394. ! ---------------------------------------
  395. if (isRoot) then
  396. ! write some numbers
  397. call msg_emis( amonth, trim(sectors_def(lsec)%prov), sectors_def(lsec)%name, 'NH3', xmnh3, sum(field3d) )
  398. ! distribute to work arrays in regions
  399. call Coarsen_Emission( 'NH3 '//trim(sectors_def(lsec)%name), nlon360, nlat180, ar5_dim_3ddata, &
  400. field3d, work, add_field, status )
  401. IF_NOTOK_RETURN(status=1)
  402. end if
  403. ! scatter, sum up on target array
  404. do region = 1, nregions
  405. call scatter(dgrid(region), work3d(region)%d3, work(region)%d3, 0, status)
  406. IF_NOTOK_RETURN( status=1 )
  407. CALL GET_DISTGRID( dgrid(region), I_STRT=i1, J_STRT=j1)
  408. ! aircraft data: regrid vertically to model layers
  409. call emission_ar5_regrid_aircraft( region, i1, j1, work3d(region)%d3, emis3d(region)%d3, status )
  410. IF_NOTOK_RETURN( status=1 )
  411. nh3_emis_3d(region,seccount3d)%d3 = nh3_emis_3d(region,seccount3d)%d3 + emis3d(region)%d3
  412. end do
  413. else ! ar5_sector is 2d
  414. ! ---------------------------
  415. ! 2d data (Anthropogenic, Ships, Biomassburning)
  416. ! ---------------------------
  417. if (isRoot) then ! print total & regrid
  418. call msg_emis( amonth, trim(sectors_def(lsec)%prov), sectors_def(lsec)%name, 'NH3', xmnh3, sum(field3d(:,:,1)) )
  419. IF_NOTOK_RETURN(status=1)
  420. call coarsen_emission( 'NH3 '//sectors_def(lsec)%name, nlon360, nlat180, field3d(:,:,1), wrk2D, add_field, status)
  421. IF_NOTOK_RETURN(status=1)
  422. end if
  423. do region = 1, nregions
  424. call scatter(dgrid(region), nh3_emis_2d(region,seccount2d)%surf, work(region)%d3(:,:,1), 0, status)
  425. IF_NOTOK_RETURN(status=1)
  426. end do
  427. end if
  428. end do sec ! sectors
  429. deallocate( field3d )
  430. do region = 1, nregions
  431. if (associated(wrk2D(region)%surf)) nullify(wrk2D(region)%surf)
  432. deallocate( work(region)%d3 )
  433. deallocate( work3d(region)%d3 )
  434. deallocate( emis3d(region)%d3 )
  435. end do
  436. ! check sectors found
  437. if( seccount2d /= nh3_2dsec ) then
  438. write(gol,'(80("-"))') ; call goPr
  439. write(gol,'("ERROR: 2d sectors do not equal total number:",i4," /= ",i4," !")') seccount2d, nh3_2dsec ; call goErr
  440. write(gol,'(80("-"))') ; call goPr
  441. status=1; return
  442. end if
  443. if( seccount3d /= nh3_3dsec ) then
  444. write(gol,'(80("-"))') ; call goPr
  445. write(gol,'("ERROR: 3d sectors do not equal total number:",i4," /= ",i4," !")') seccount3d, nh3_3dsec ; call goErr
  446. write(gol,'(80("-"))') ; call goPr
  447. status=1; return
  448. end if
  449. status = 0
  450. END SUBROUTINE EMISSION_NH3_DECLARE
  451. !EOC
  452. !--------------------------------------------------------------------------
  453. ! TM5 !
  454. !--------------------------------------------------------------------------
  455. !BOP
  456. !
  457. ! !IROUTINE: EMISSION_NH3_APPLY
  458. !
  459. ! !DESCRIPTION: Take monthly emissions, and
  460. ! - split them vertically
  461. ! - apply time splitting factors
  462. ! - add them up (add_3d)
  463. !\\
  464. !\\
  465. ! !INTERFACE:
  466. !
  467. SUBROUTINE EMISSION_NH3_APPLY( region, status )
  468. !
  469. ! !USES:
  470. !
  471. use dims, only : itaur, nsrce, tref
  472. use dims, only : im, jm, lm
  473. use datetime, only : tau2date
  474. use emission_data, only : emission_vdist_by_sector, LAR5BMB
  475. use emission_data, only : do_add_3d, do_add_3d_cycle, bb_cycle
  476. use emission_data, only : emis_bb_trop_cycle
  477. use chem_param, only : inh3, xmnh3, xmn
  478. use emission_read, only : sectors_def, numb_sectors
  479. use emission_read, only : ed42_nh3_sectors
  480. !
  481. ! !INPUT PARAMETERS:
  482. !
  483. integer, intent(in) :: region
  484. !
  485. ! !OUTPUT PARAMETERS:
  486. !
  487. integer, intent(out) :: status
  488. !
  489. ! !REVISION HISTORY:
  490. ! 1 Oct 2010 - Achim Strunk - adapted for new vertical distribution
  491. ! 25 Jun 2012 - P. Le Sager - adapted for lon-lat MPI domain decomposition
  492. !
  493. !EOP
  494. !------------------------------------------------------------------------
  495. !BOC
  496. character(len=*), parameter :: rname = mname//'/emission_nh3_apply'
  497. integer, dimension(6) :: idater
  498. real :: dtime, fraction
  499. integer :: imr, jmr, lmr, lsec, i1, i2, j1, j2
  500. integer :: seccount2d, seccount3d
  501. type(d3_data) :: emis3d
  502. ! --- begin -----------------------------------------
  503. status = 0
  504. if(.not. has_emis) return
  505. if( okdebug ) then
  506. write(gol,*) 'start of emission_nh3_apply'; call goPr
  507. end if
  508. call tau2date(itaur(region),idater)
  509. dtime=float(nsrce)/(2*tref(region)) !emissions are added in two steps...XYZECCEZYX.
  510. if(okdebug) then
  511. write(gol,*) 'emission_nh3_apply in region ',region,' at date: ',idater, ' with time step:', dtime ; call goPr
  512. endif
  513. ! get a working structure for 3d emissions
  514. call get_distgrid( dgrid(region), I_STRT=i1, I_STOP=i2, J_STRT=j1, J_STOP=j2 )
  515. allocate( emis3d%d3(i1:i2,j1:j2,lm(region)) ) ; emis3d%d3 = 0.0
  516. ! count 2d and 3d sectors
  517. seccount2d = 0
  518. seccount3d = 0
  519. ! cycle over sectors
  520. do lsec = 1, numb_sectors
  521. if (count(used_providers.eq.sectors_def(lsec)%prov).eq.0) cycle
  522. if ((trim(sectors_def(lsec)%prov).eq.'ED42') .and. (count(ed42_nh3_sectors.eq.sectors_def(lsec)%name) .eq. 0)) cycle
  523. if (associated(sectors_def(lsec)%species)) then ! AR5 check
  524. if (count('NH3'.eq.sectors_def(lsec)%species).eq.0) cycle
  525. if ((trim(sectors_def(lsec)%catname) .eq. 'biomassburning').and.(.not.LAR5BMB)) cycle
  526. endif
  527. ! default: no additional splitting
  528. fraction = 1.0
  529. ! ----------------------------------------------------------------------------------------
  530. ! distinguish here between sectors and whether they should have additional splitting
  531. ! if( sectors_def(lsec)%catname == 'biomassburning' ) fraction = fraction * bb_frac etc...
  532. ! ----------------------------------------------------------------------------------------
  533. ! distinguish between 2d/3d sectors
  534. if( sectors_def(lsec)%f3d ) then
  535. seccount3d = seccount3d + 1
  536. if (.not.has_data_3d(seccount3d)) cycle
  537. emis3d%d3 = nh3_emis_3d(region,seccount3d)%d3
  538. else
  539. seccount2d = seccount2d + 1
  540. if (.not.has_data_2d(seccount2d)) cycle
  541. emis3d%d3 = 0.0
  542. ! vertically distribute according to sector
  543. call emission_vdist_by_sector( sectors_def(lsec)%vdisttype, 'NH3', region, nh3_emis_2d(region,seccount2d), emis3d, status)
  544. IF_NOTOK_RETURN(status=1;deallocate(emis3d%d3))
  545. end if
  546. ! add dataset according to sector and category
  547. if( emis_bb_trop_cycle .and. trim(sectors_def(lsec)%catname) == "biomassburning" ) then
  548. call do_add_3d_cycle( region, inh3, i1, j1, emis3d%d3, bb_cycle(region)%scalef, xmnh3, xmnh3, status, fraction )
  549. IF_NOTOK_RETURN(status=1)
  550. else
  551. call do_add_3d( region, inh3, i1, j1, emis3d%d3, xmnh3, xmnh3, status, fraction )
  552. IF_NOTOK_RETURN(status=1)
  553. end if
  554. end do
  555. deallocate( emis3d%d3 )
  556. if(okdebug) then
  557. write(gol,*) 'end of emission_nh3_apply'; call goPr
  558. endif
  559. ! OK
  560. status = 0
  561. end subroutine emission_nh3_apply
  562. !EOC
  563. END MODULE EMISSION_NH3