Line data Source code
1 : !------------------------------------------------------------------------------
2 : ! Harmonized Emissions Component (HEMCO) !
3 : !------------------------------------------------------------------------------
4 : !BOP
5 : !
6 : ! !MODULE: hcox_gc_RnPbBe_mod.F90
7 : !
8 : ! !DESCRIPTION: Defines the HEMCO extension for the GEOS-Chem Rn-Pb-Be
9 : ! specialty simulation.
10 : !\\
11 : !\\
12 : ! This extension parameterizes emissions of Rn and/or Pb based upon the
13 : ! literature given below. The emission fields become automatically added
14 : ! to the HEMCO emission array of the given species. It is possible to
15 : ! select only one of the two species (Rn or Pb) in the HEMCO configuration
16 : ! file. This may be useful if a gridded data inventory shall be applied to
17 : ! one of the species (through the standard HEMCO interface).
18 : !\\
19 : !\\
20 : ! !INTERFACE:
21 : !
22 : MODULE HCOX_GC_RnPbBe_Mod
23 : !
24 : ! !USES:
25 : !
26 : USE HCO_Error_Mod
27 : USE HCO_Diagn_Mod
28 : USE HCO_State_Mod, ONLY : HCO_State ! Derived type for HEMCO state
29 : USE HCOX_State_Mod, ONLY : Ext_State ! Derived type for External state
30 :
31 : IMPLICIT NONE
32 : PRIVATE
33 : !
34 : ! !PUBLIC MEMBER FUNCTIONS:
35 : !
36 : PUBLIC :: HcoX_GC_RnPbBe_Run
37 : PUBLIC :: HcoX_GC_RnPbBe_Init
38 : PUBLIC :: HcoX_Gc_RnPbBe_Final
39 : !
40 : ! !PRIVATE MEMBER FUNCTIONS:
41 : !
42 : PRIVATE :: Init_7Be_Emissions
43 : !
44 : ! !REMARKS:
45 : ! References:
46 : ! ============================================================================
47 : ! (1 ) Liu,H., D.Jacob, I.Bey, and R.M.Yantosca, Constraints from 210Pb
48 : ! and 7Be on wet deposition and transport in a global three-dimensional
49 : ! chemical tracer model driven by assimilated meteorological fields,
50 : ! JGR, 106, D11, 12,109-12,128, 2001.
51 : ! (2 ) Jacob et al.,Evaluation and intercomparison of global atmospheric
52 : ! transport models using Rn-222 and other short-lived tracers,
53 : ! JGR, 1997 (102):5953-5970
54 : ! (3 ) Dorothy Koch, JGR 101, D13, 18651, 1996.
55 : ! (4 ) Lal, D., and B. Peters, Cosmic ray produced radioactivity on the
56 : ! Earth. Handbuch der Physik, 46/2, 551-612, edited by K. Sitte,
57 : ! Springer-Verlag, New York, 1967.
58 : ! (5 ) Koch and Rind, Beryllium 10/beryllium 7 as a tracer of stratospheric
59 : ! transport, JGR, 103, D4, 3907-3917, 1998.
60 : !
61 : ! !REVISION HISTORY:
62 : ! 07 Jul 2014 - R. Yantosca - Initial version
63 : ! See https://github.com/geoschem/hemco for complete history
64 : !EOP
65 : !------------------------------------------------------------------------------
66 : !BOC
67 : !
68 : ! !PRIVATE TYPES:
69 : !
70 : TYPE :: MyInst
71 :
72 : ! Emissions indices etc.
73 : INTEGER :: Instance
74 : INTEGER :: ExtNr ! Main Extension number
75 : INTEGER :: ExtNrZhang ! ZHANG_Rn222 extension number
76 : INTEGER :: IDTRn222 ! Index # for Rn222
77 : INTEGER :: IDTBe7 ! Index # for Be7
78 : INTEGER :: IDTBe7Strat ! Index # for Be7Strat
79 : INTEGER :: IDTBe10 ! Index # for Be10
80 : INTEGER :: IDTBe10Strat ! Index # for Be10Strat
81 :
82 : ! For tracking Rn222, Be7, and Be10 emissions
83 : REAL(hp), POINTER :: EmissRn222 (:,: )
84 : REAL(hp), POINTER :: EmissBe7 (:,:,:)
85 : REAL(hp), POINTER :: EmissBe7Strat (:,:,:)
86 : REAL(hp), POINTER :: EmissBe10 (:,:,:)
87 : REAL(hp), POINTER :: EmissBe10Strat(:,:,:)
88 :
89 : ! For Lal & Peters 7Be emissions input data
90 : REAL(hp), POINTER :: LATSOU(: ) ! Array for latitudes
91 : REAL(hp), POINTER :: PRESOU(: ) ! Array for pressures
92 : REAL(hp), POINTER :: BESOU (:,: ) ! Array for 7Be emissions
93 :
94 : TYPE(MyInst), POINTER :: NextInst => NULL()
95 : END TYPE MyInst
96 :
97 : ! Pointer to instances
98 : TYPE(MyInst), POINTER :: AllInst => NULL()
99 : !
100 : ! !DEFINED PARAMETERS:
101 : !
102 : ! To convert kg to atoms
103 : REAL*8, PARAMETER :: XNUMOL_Rn = ( 6.022140857d23 / 222.0d-3 )
104 : REAL*8, PARAMETER :: XNUMOL_Be7 = ( 6.022140857d23 / 7.0d-3 )
105 : REAL*8, PARAMETER :: XNUMOL_Be10 = ( 6.022140857d23 / 10.0d-3 )
106 :
107 : CONTAINS
108 : !EOC
109 : !------------------------------------------------------------------------------
110 : ! Harmonized Emissions Component (HEMCO) !
111 : !------------------------------------------------------------------------------
112 : !BOP
113 : !
114 : ! !IROUTINE: HCOX_Gc_RnPbBe_run
115 : !
116 : ! !DESCRIPTION: Subroutine HcoX\_Gc\_RnPbBe\_Run computes emissions of 222Rn,
117 : ! 7Be, and 10Be for the GEOS-Chem Rn-Pb-Be specialty simulation.
118 : !\\
119 : !\\
120 : ! !INTERFACE:
121 : !
122 0 : SUBROUTINE HCOX_Gc_RnPbBe_Run( ExtState, HcoState, RC )
123 : !
124 : ! !USES:
125 : !
126 : USE HCO_Calc_Mod, ONLY : HCO_EvalFld
127 : USE HCO_FluxArr_Mod, ONLY : HCO_EmisAdd
128 : !
129 : ! !INPUT PARAMETERS:
130 : !
131 : TYPE(Ext_State), POINTER :: ExtState ! Options for Rn-Pb-Be sim
132 : TYPE(HCO_State), POINTER :: HcoState ! HEMCO state
133 : !
134 : ! !INPUT/OUTPUT PARAMETERS:
135 : !
136 : INTEGER, INTENT(INOUT) :: RC ! Success or failure?
137 : !
138 : ! !REMARKS:
139 : ! This code is based on routine EMISSRnPbBe in prior versions of GEOS-Chem.
140 : !
141 : ! !REVISION HISTORY:
142 : ! 07 Jul 2014 - R. Yantosca - Initial version
143 : ! See https://github.com/geoschem/hemco for complete history
144 : !EOP
145 : !------------------------------------------------------------------------------
146 : !BOC
147 : !
148 : ! !LOCAL VARIABLES:
149 : !
150 :
151 : ! Scalars
152 : INTEGER :: I, J, L, N
153 : INTEGER :: HcoID
154 : REAL*8 :: A_CM2, ADD_Rn, Add_Be7, Add_Be10
155 : REAL*8 :: Rn_LAND, Rn_WATER, DTSRCE
156 : REAL*8 :: Rn_TMP, LAT, F_LAND
157 : REAL*8 :: F_WATER, F_BELOW_70, F_BELOW_60, F_ABOVE_60
158 : REAL*8 :: DENOM
159 : REAL(hp) :: LAT_TMP, P_TMP, Be_TMP
160 : CHARACTER(LEN=255):: MSG, LOC
161 :
162 : ! Pointers
163 : TYPE(MyInst), POINTER :: Inst
164 0 : REAL(hp), POINTER :: Arr2D(:,: )
165 0 : REAL(hp), POINTER :: Arr3D(:,:,:)
166 :
167 : !=======================================================================
168 : ! HCOX_GC_RnPbBe_RUN begins here!
169 : !=======================================================================
170 0 : LOC = 'HCOX_GC_RnPbBe_RUN (HCOX_GC_RNPBBE_MOD.F90)'
171 :
172 : ! Return if extension not turned on
173 0 : IF ( ExtState%GC_RnPbBe <= 0 ) RETURN
174 :
175 : ! Enter
176 0 : CALL HCO_ENTER( HcoState%Config%Err, LOC, RC )
177 0 : IF ( RC /= HCO_SUCCESS ) THEN
178 0 : CALL HCO_ERROR( 'ERROR 0', RC, THISLOC=LOC )
179 0 : RETURN
180 : ENDIF
181 :
182 : ! Set error flag
183 : !ERR = .FALSE.
184 :
185 : ! Get instance
186 0 : Inst => NULL()
187 0 : CALL InstGet ( ExtState%GC_RnPbBe, Inst, RC )
188 0 : IF ( RC /= HCO_SUCCESS ) THEN
189 0 : WRITE(MSG,*) 'Cannot find GC_RnPbBe instance Nr. ', ExtState%GC_RnPbBe
190 0 : CALL HCO_ERROR(MSG,RC)
191 0 : RETURN
192 : ENDIF
193 :
194 : ! Emission timestep [s]
195 0 : DTSRCE = HcoState%TS_EMIS
196 :
197 : ! Nullify
198 0 : Arr2D => NULL()
199 0 : Arr3D => NULL()
200 :
201 : !=======================================================================
202 : ! Compute 222Rn emissions [kg/m2/s], according to the following:
203 : !
204 : ! (1) 222Rn emission poleward of 70 degrees = 0.0 [atoms/cm2/s]
205 : !
206 : ! (2) For latitudes 70S-60S and 60N-70N (both land & ocean),
207 : ! 222Rn emission is 0.005 [atoms/cm2/s]
208 : !
209 : ! (3) For latitudes between 60S and 60N,
210 : ! 222Rn emission is 1 [atoms/cm2/s] over land or
211 : ! 0.005 [atoms/cm2/s] over oceans
212 : !
213 : ! (4) For grid boxes where the surface temperature is below
214 : ! 0 deg Celsius, reduce 222Rn emissions by a factor of 3.
215 : !
216 : ! Reference: Jacob et al.,Evaluation and intercomparison of
217 : ! global atmospheric transport models using Rn-222 and other
218 : ! short-lived tracers, JGR, 1997 (102):5953-5970
219 : !=======================================================================
220 0 : IF ( Inst%IDTRn222 > 0 ) THEN
221 :
222 0 : IF ( Inst%ExtNrZhang > 0 ) THEN
223 :
224 : !------------------------------------------------------------------
225 : ! Use Zhang et al Rn222 emissions
226 : ! cf https://doi.org/10.5194/acp-21-1861-2021
227 : !------------------------------------------------------------------
228 : CALL HCO_EvalFld( HcoState, 'ZHANG_Rn222_EMIS', &
229 0 : Inst%EmissRn222, RC )
230 0 : IF ( RC /= HCO_SUCCESS ) THEN
231 0 : CALL HCO_Error( 'Could not read ZHANG_Rn222_EMIS!', RC )
232 0 : RETURN
233 : ENDIF
234 :
235 : ELSE
236 :
237 : !------------------------------------------------------------------
238 : ! Use default Rn222 emissions, based on Jacob et al 1997
239 : !------------------------------------------------------------------
240 : !$OMP PARALLEL DO &
241 : !$OMP DEFAULT( SHARED ) &
242 : !$OMP PRIVATE( I, J, LAT, DENOM ) &
243 : !$OMP PRIVATE( F_BELOW_70, F_BELOW_60, F_ABOVE_60, Rn_LAND ) &
244 : !$OMP PRIVATE( Rn_WATER, F_LAND, F_WATER, ADD_Rn ) &
245 : !$OMP SCHEDULE( DYNAMIC )
246 0 : DO J = 1, HcoState%Ny
247 0 : DO I = 1, HcoState%Nx
248 :
249 : ! Get ABS( latitude ) of the grid box
250 0 : LAT = ABS( HcoState%Grid%YMID%Val( I, J ) )
251 :
252 : ! Zero for safety's sake
253 0 : F_BELOW_70 = 0d0
254 0 : F_BELOW_60 = 0d0
255 0 : F_ABOVE_60 = 0d0
256 :
257 : ! Baseline 222Rn emissions
258 : ! Rn_LAND [kg/m2/s] = [1 atom 222Rn/cm2/s] / [atoms/kg]
259 : ! * [1d4 cm2/m2]
260 0 : Rn_LAND = ( 1d0 / XNUMOL_Rn ) * 1d4
261 :
262 : ! Baseline 222Rn emissions over water or ice [kg]
263 0 : Rn_WATER = Rn_LAND * 0.005d0
264 :
265 : ! Fraction of grid box that is land
266 0 : F_LAND = ExtState%FRCLND%Arr%Val(I,J)
267 :
268 : ! Fraction of grid box that is water
269 0 : F_WATER = 1d0 - F_LAND
270 :
271 : !--------------------
272 : ! 90S-70S or 70N-90N
273 : !--------------------
274 0 : IF ( LAT >= 70d0 ) THEN
275 :
276 : ! 222Rn emissions are shut off poleward of 70 degrees
277 : ADD_Rn = 0.0d0
278 :
279 : !--------------------
280 : ! 70S-60S or 60N-70N
281 : !--------------------
282 0 : ELSE IF ( LAT >= 60d0 ) THEN
283 :
284 0 : IF ( LAT <= 70d0 ) THEN
285 :
286 : ! If the entire grid box lies equatorward of 70 deg,
287 : ! then 222Rn emissions here are 0.005 [atoms/cm2/s]
288 : ADD_Rn = Rn_WATER
289 :
290 : ELSE
291 :
292 : ! N-S extent of grid box [degrees]
293 0 : DENOM = HcoState%Grid%YMID%Val( I, J+1 ) &
294 0 : - HcoState%Grid%YMID%Val( I, J )
295 :
296 : ! Compute the fraction of the grid box below 70 degrees
297 0 : F_BELOW_70 = ( 70.0d0 - LAT ) / DENOM
298 :
299 : ! If the grid box straddles the 70S or 70N latitude
300 : ! line, then only count 222Rn emissions equatorward of
301 : ! 70 degrees. 222Rn emissions here are 0.005
302 : ! [atoms/cm2/s].
303 0 : ADD_Rn = F_BELOW_70 * Rn_WATER
304 :
305 : ENDIF
306 :
307 : ELSE
308 :
309 : !--------------------
310 : ! 70S-60S or 60N-70N
311 : !--------------------
312 0 : IF ( LAT > 60d0 ) THEN
313 :
314 : ! N-S extent of grid box [degrees]
315 0 : DENOM = HcoState%Grid%YMID%Val( I, J+1 ) &
316 0 : - HcoState%Grid%YMID%Val( I, J )
317 :
318 : ! Fraction of grid box with ABS( lat ) below 60 degrees
319 0 : F_BELOW_60 = ( 60.0d0 - LAT ) / DENOM
320 :
321 : ! Fraction of grid box with ABS( lat ) above 60 degrees
322 0 : F_ABOVE_60 = F_BELOW_60
323 :
324 : ADD_Rn = &
325 : ! Consider 222Rn emissions equatorward of
326 : ! 60 degrees for both land (1.0 [atoms/cm2/s])
327 : ! and water (0.005 [atoms/cm2/s])
328 : F_BELOW_60 * &
329 : ( Rn_LAND * F_LAND ) + &
330 : ( Rn_WATER * F_WATER ) + &
331 :
332 : ! If the grid box straddles the 60 degree boundary
333 : ! then also consider the emissions poleward of 60
334 : ! degrees. 222Rn emissions here are 0.005
335 : ! [atoms/cm2/s].
336 0 : F_ABOVE_60 * Rn_WATER
337 :
338 : !--------------------
339 : ! 60S-60N
340 : !--------------------
341 : ELSE
342 :
343 : ! Consider 222Rn emissions equatorward of 60 deg for
344 : ! land (1.0 [atoms/cm2/s]) and water (0.005 [atoms/cm2/s])
345 0 : ADD_Rn = ( Rn_LAND * F_LAND ) + ( Rn_WATER * F_WATER )
346 :
347 : ENDIF
348 : ENDIF
349 :
350 : ! For boxes below freezing, reduce 222Rn emissions by 3x
351 0 : IF ( ExtState%T2M%Arr%Val(I,J) < 273.15 ) THEN
352 0 : ADD_Rn = ADD_Rn / 3d0
353 : ENDIF
354 :
355 : ! Save 222Rn emissions into an array [kg/m2/s]
356 0 : Inst%EmissRn222(I,J) = ADD_Rn
357 : ENDDO
358 : ENDDO
359 : !$OMP END PARALLEL DO
360 :
361 : ENDIF
362 :
363 : !------------------------------------------------------------------------
364 : ! Add 222Rn emissions to HEMCO data structure & diagnostics
365 : !------------------------------------------------------------------------
366 :
367 : ! Add emissions
368 0 : Arr2D => Inst%EmissRn222(:,:)
369 : CALL HCO_EmisAdd( HcoState, Arr2D, Inst%IDTRn222, &
370 0 : RC, ExtNr=Inst%ExtNr )
371 0 : Arr2D => NULL()
372 0 : IF ( RC /= HCO_SUCCESS ) THEN
373 : CALL HCO_ERROR( &
374 0 : 'HCO_EmisAdd error: EmissRn222', RC )
375 0 : RETURN
376 : ENDIF
377 :
378 : ENDIF ! IDTRn222 > 0
379 :
380 : !=======================================================================
381 : ! Compute 7Be and 10Be emissions [kg/m2/s]
382 : !
383 : ! Original units of 7Be and 10Be emissions are [stars/g air/sec],
384 : ! where "stars" = # of nuclear disintegrations of cosmic rays
385 : !
386 : ! Now interpolate from 33 std levels onto GEOS-CHEM levels
387 : !
388 : ! 7Be and 10Be have identical source distributions (Koch and Rind, 1998)
389 : !=======================================================================
390 0 : IF ( Inst%IDTBe7 > 0 .or. Inst%IDTBe10 > 0 ) THEN
391 : !$OMP PARALLEL DO &
392 : !$OMP DEFAULT( SHARED ) &
393 : !$OMP PRIVATE( I, J, L, LAT_TMP, P_TMP, Be_TMP, ADD_Be7, ADD_Be10 ) &
394 : !$OMP SCHEDULE( DYNAMIC )
395 0 : DO L = 1, HcoState%Nz
396 0 : DO J = 1, HcoState%Ny
397 0 : DO I = 1, HcoState%Nx
398 :
399 : ! Get absolute value of latitude, since we will assume that
400 : ! the 7Be distribution is symmetric about the equator
401 0 : LAT_TMP = ABS( HcoState%Grid%YMID%Val( I, J ) )
402 :
403 : ! Pressure at (I,J,L) [hPa]
404 : ! Now calculate from edge points (ckeller, 10/06/1014)
405 0 : P_TMP = ( HcoState%Grid%PEDGE%Val(I,J,L) + &
406 0 : HcoState%Grid%PEDGE%Val(I,J,L+1) ) / 200.0_hp
407 :
408 : ! Interpolate 7Be [stars/g air/sec] to GEOS-Chem levels
409 : CALL SLQ( Inst%LATSOU, Inst%PRESOU, Inst%BESOU, 10, 33, &
410 0 : LAT_TMP, P_TMP, Be_TMP )
411 :
412 : ! Be_TMP = [stars/g air/s] * [0.045 atom/star] *
413 : ! [kg air] * [1e3 g/kg] = 7Be/10Be emissions [atoms/s]
414 0 : Be_TMP = Be_TMP * 0.045e+0_hp * ExtState%AIR%Arr%Val(I,J,L) * 1.e+3_hp
415 :
416 : ! ADD_Be = [atoms/s] / [atom/kg] / [m2] = 7Be/10Be emissions [kg/m2/s]
417 0 : ADD_Be7 = ( Be_TMP / XNUMOL_Be7 ) / HcoState%Grid%AREA_M2%Val(I,J)
418 0 : ADD_Be10 = ( Be_TMP / XNUMOL_Be10 ) / HcoState%Grid%AREA_M2%Val(I,J)
419 :
420 : ! Save emissions into an array for use below
421 0 : Inst%EmissBe7 (I,J,L) = ADD_Be7
422 0 : Inst%EmissBe10(I,J,L) = ADD_Be10
423 0 : IF ( L > ExtState%TropLev%Arr%Val(I,J) ) THEN
424 0 : IF ( Inst%IDTBe7Strat > 0 ) THEN
425 0 : Inst%EmissBe7Strat (I,J,L) = Add_Be7
426 : ENDIF
427 0 : IF ( Inst%IDTBe10Strat > 0 ) THEN
428 0 : Inst%EmissBe10Strat(I,J,L) = Add_Be10
429 : ENDIF
430 : ELSE
431 0 : IF ( Inst%IDTBe7Strat > 0 ) THEN
432 0 : Inst%EmissBe7Strat (I,J,L) = 0d0
433 : ENDIF
434 0 : IF ( Inst%IDTBe10Strat > 0 ) THEN
435 0 : Inst%EmissBe10Strat(I,J,L) = 0d0
436 : ENDIF
437 : ENDIF
438 :
439 : ENDDO
440 : ENDDO
441 : ENDDO
442 : !$OMP END PARALLEL DO
443 :
444 : !------------------------------------------------------------------------
445 : ! Add Be7 and Be10 emissions to HEMCO data structure & diagnostics
446 : !------------------------------------------------------------------------
447 :
448 : ! Add emissions
449 0 : IF ( Inst%IDTBe7 > 0 ) THEN
450 0 : Arr3D => Inst%EmissBe7(:,:,:)
451 : CALL HCO_EmisAdd( HcoState, Arr3D, Inst%IDTBe7, &
452 0 : RC, ExtNr=Inst%ExtNr )
453 0 : Arr3D => NULL()
454 0 : IF ( RC /= HCO_SUCCESS ) THEN
455 : CALL HCO_ERROR( &
456 0 : 'HCO_EmisAdd error: EmissBe7', RC )
457 0 : RETURN
458 : ENDIF
459 : ENDIF
460 :
461 : ! Add emissions
462 0 : IF ( Inst%IDTBe7Strat > 0 ) THEN
463 0 : Arr3D => Inst%EmissBe7Strat(:,:,:)
464 : CALL HCO_EmisAdd( HcoState, Arr3D, Inst%IDTBe7Strat, &
465 0 : RC, ExtNr=Inst%ExtNr )
466 0 : Arr3D => NULL()
467 0 : IF ( RC /= HCO_SUCCESS ) THEN
468 : CALL HCO_ERROR( &
469 0 : 'HCO_EmisAdd error: EmissBe7Strat', RC )
470 0 : RETURN
471 : ENDIF
472 : ENDIF
473 :
474 : ! Add emissions
475 0 : IF ( Inst%IDTBe10 > 0 ) THEN
476 0 : Arr3D => Inst%EmissBe10(:,:,:)
477 : CALL HCO_EmisAdd( HcoState, Arr3D, Inst%IDTBe10, &
478 0 : RC, ExtNr=Inst%ExtNr )
479 0 : Arr3D => NULL()
480 0 : IF ( RC /= HCO_SUCCESS ) THEN
481 : CALL HCO_ERROR( &
482 0 : 'HCO_EmisAdd error: EmissBe10', RC )
483 0 : RETURN
484 : ENDIF
485 : ENDIF
486 :
487 : ! Add emissions
488 0 : IF ( Inst%IDTBe10Strat > 0 ) THEN
489 0 : Arr3D => Inst%EmissBe10Strat(:,:,:)
490 : CALL HCO_EmisAdd( HcoState, Arr3D, Inst%IDTBe10Strat, &
491 0 : RC, ExtNr=Inst%ExtNr )
492 0 : Arr3D => NULL()
493 0 : IF ( RC /= HCO_SUCCESS ) THEN
494 : CALL HCO_ERROR( &
495 0 : 'HCO_EmisAdd error: EmissBe10Strat', RC )
496 0 : RETURN
497 : ENDIF
498 : ENDIF
499 :
500 : ENDIF !IDTBe7 > 0 or IDTBe10 > 0
501 :
502 : !=======================================================================
503 : ! Cleanup & quit
504 : !=======================================================================
505 :
506 : ! Nullify pointers
507 0 : Inst => NULL()
508 :
509 : ! Return w/ success
510 0 : CALL HCO_LEAVE( HcoState%Config%Err,RC )
511 :
512 0 : END SUBROUTINE HCOX_Gc_RnPbBe_Run
513 : !EOC
514 : !------------------------------------------------------------------------------
515 : ! Harmonized Emissions Component (HEMCO) !
516 : !------------------------------------------------------------------------------
517 : !BOP
518 : !
519 : ! !IROUTINE: HCOX_Gc_RnPbBe_Init
520 : !
521 : ! !DESCRIPTION: Subroutine HcoX\_Gc\_RnPbBe\_Init initializes the HEMCO
522 : ! GC\_Rn-Pb-Be extension.
523 : !\\
524 : !\\
525 : ! !INTERFACE:
526 : !
527 0 : SUBROUTINE HCOX_Gc_RnPbBe_Init( HcoState, ExtName, ExtState, RC )
528 : !
529 : ! !USES:
530 : !
531 : USE HCO_ExtList_Mod, ONLY : GetExtNr
532 : USE HCO_ExtList_Mod, ONLY : GetExtOpt
533 : USE HCO_State_Mod, ONLY : HCO_GetExtHcoID
534 : !
535 : ! !INPUT PARAMETERS:
536 : !
537 : CHARACTER(LEN=*), INTENT(IN ) :: ExtName ! Extension name
538 : TYPE(Ext_State), POINTER :: ExtState ! Module options
539 : !
540 : ! !INPUT/OUTPUT PARAMETERS:
541 : !
542 : TYPE(HCO_State), POINTER :: HcoState ! Hemco state
543 : INTEGER, INTENT(INOUT) :: RC
544 :
545 : ! !REVISION HISTORY:
546 : ! 07 Jul 2014 - R. Yantosca - Initial version
547 : ! See https://github.com/geoschem/hemco for complete history
548 : !EOP
549 : !------------------------------------------------------------------------------
550 : !BOC
551 : !
552 : ! !LOCAL VARIABLES:
553 : !
554 : ! Scalars
555 : INTEGER :: N, nSpc, ExtNr, ExtNrZhang
556 : CHARACTER(LEN=255) :: MSG, LOC
557 :
558 : ! Arrays
559 0 : INTEGER, ALLOCATABLE :: HcoIDs(:)
560 0 : CHARACTER(LEN=31), ALLOCATABLE :: SpcNames(:)
561 :
562 : ! Pointers
563 : TYPE(MyInst), POINTER :: Inst
564 :
565 : !=======================================================================
566 : ! HCOX_GC_RnPbBe_INIT begins here!
567 : !=======================================================================
568 0 : LOC = 'HCOX_GC_RNPBBE_INIT (HCOX_GC_RNPBBE_MOD.F90)'
569 :
570 : ! Get the main extension number
571 0 : ExtNr = GetExtNr( HcoState%Config%ExtList, TRIM(ExtName) )
572 0 : IF ( ExtNr <= 0 ) RETURN
573 :
574 : ! Get the extension number for Zhang et al [2021] emissions
575 0 : ExtNrZhang = GetExtNr( HcoState%Config%ExtList, 'ZHANG_Rn222' )
576 :
577 : ! Enter
578 0 : CALL HCO_ENTER( HcoState%Config%Err, LOC, RC )
579 0 : IF ( RC /= HCO_SUCCESS ) THEN
580 0 : CALL HCO_ERROR( 'ERROR 1', RC, THISLOC=LOC )
581 0 : RETURN
582 : ENDIF
583 :
584 : ! Create Instance
585 0 : Inst => NULL()
586 0 : CALL InstCreate ( ExtNr, ExtState%GC_RnPbBe, Inst, RC )
587 0 : IF ( RC /= HCO_SUCCESS ) THEN
588 0 : CALL HCO_ERROR ( 'Cannot create GC_RnPbBe instance', RC )
589 0 : RETURN
590 : ENDIF
591 : ! Also fill the extension numbers in the Instance object
592 0 : Inst%ExtNr = ExtNr
593 0 : Inst%ExtNrZhang = ExtNrZhang
594 :
595 : ! Set HEMCO species IDs
596 0 : CALL HCO_GetExtHcoID( HcoState, Inst%ExtNr, HcoIDs, SpcNames, nSpc, RC )
597 0 : IF ( RC /= HCO_SUCCESS ) THEN
598 0 : CALL HCO_ERROR( 'Could not set HEMCO species IDs', RC )
599 0 : RETURN
600 : ENDIF
601 :
602 : ! Verbose mode
603 0 : IF ( HcoState%amIRoot ) THEN
604 0 : MSG = 'Use gc_RnPbBe emissions module (extension module)'
605 0 : CALL HCO_MSG(HcoState%Config%Err,MSG )
606 :
607 0 : MSG = 'Use the following species (Name: HcoID):'
608 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
609 0 : DO N = 1, nSpc
610 0 : WRITE(MSG,*) TRIM(SpcNames(N)), ':', HcoIDs(N)
611 0 : CALL HCO_MSG(HcoState%Config%Err,MSG)
612 : ENDDO
613 : ENDIF
614 :
615 : ! Set up tracer and HEMCO indices
616 0 : DO N = 1, nSpc
617 0 : SELECT CASE( TRIM( SpcNames(N) ) )
618 : CASE( 'Rn', 'Rn222', '222Rn' )
619 0 : Inst%IDTRn222 = HcoIDs(N)
620 : CASE( 'Be', 'Be7', '7Be' )
621 0 : Inst%IDTBe7 = HcoIDs(N)
622 : CASE( 'Be7Strat', '7BeStrat' )
623 0 : Inst%IDTBe7Strat = HcoIDs(N)
624 : CASE( 'Be10', '10Be' )
625 0 : Inst%IDTBe10 = HcoIDs(N)
626 : CASE( 'Be10Strat', '10BeStrat' )
627 0 : Inst%IDTBe10Strat = HcoIDs(N)
628 : CASE DEFAULT
629 : ! Do nothing
630 : END SELECT
631 : ENDDO
632 :
633 : ! WARNING: Rn tracer is not found!
634 0 : IF ( Inst%IDTRn222 <= 0 .AND. HcoState%amIRoot ) THEN
635 : CALL HCO_WARNING( HcoState%Config%Err, &
636 0 : 'Cannot find Rn222 tracer in list of species!', RC )
637 : ENDIF
638 :
639 : ! WARNING: Be7 tracer is not found
640 0 : IF ( Inst%IDTBe7 <= 0 .AND. HcoState%amIRoot ) THEN
641 : CALL HCO_WARNING( HcoState%Config%Err, &
642 0 : 'Cannot find Be7 tracer in list of species!', RC )
643 : ENDIF
644 :
645 : ! WARNING: Be10 tracer is not found
646 0 : IF ( Inst%IDTBe10 <= 0 .AND. HcoState%amIRoot ) THEN
647 : CALL HCO_WARNING( HcoState%Config%Err, &
648 0 : 'Cannot find Be10 tracer in list of species!', RC )
649 : ENDIF
650 :
651 : ! ERROR: No tracer defined
652 0 : IF ( Inst%IDTRn222 <= 0 .AND. Inst%IDTBe7 <= 0 .AND. Inst%IDTBe10 <= 0) THEN
653 : CALL HCO_ERROR( &
654 0 : 'Cannot use RnPbBe extension: no valid species!', RC )
655 : ENDIF
656 :
657 : ! Activate met fields required by this extension
658 0 : ExtState%FRCLND%DoUse = .TRUE.
659 0 : ExtState%T2M%DoUse = .TRUE.
660 0 : ExtState%AIR%DoUse = .TRUE.
661 0 : ExtState%TropLev%DoUse = .TRUE.
662 :
663 : !=======================================================================
664 : ! Initialize data arrays
665 : !=======================================================================
666 :
667 0 : IF ( Inst%IDTRn222 > 0 ) THEN
668 0 : ALLOCATE( Inst%EmissRn222( HcoState%Nx, HcoState%NY ), STAT=RC )
669 0 : IF ( RC /= 0 ) THEN
670 : CALL HCO_ERROR ( &
671 0 : 'Cannot allocate EmissRn222', RC )
672 0 : RETURN
673 : ENDIF
674 : ENDIF
675 :
676 0 : IF ( Inst%IDTBe7 > 0 ) THEN
677 : ALLOCATE( Inst%EmissBe7( HcoState%Nx, HcoState%NY, HcoState%NZ ), &
678 0 : STAT=RC )
679 0 : IF ( RC /= 0 ) THEN
680 : CALL HCO_ERROR ( &
681 0 : 'Cannot allocate EmissBe7', RC )
682 0 : RETURN
683 : ENDIF
684 : IF ( RC /= 0 ) RETURN
685 :
686 : ! Array for latitudes (Lal & Peters data)
687 0 : ALLOCATE( Inst%LATSOU( 10 ), STAT=RC )
688 0 : IF ( RC /= 0 ) THEN
689 : CALL HCO_ERROR ( &
690 0 : 'Cannot allocate LATSOU', RC )
691 0 : RETURN
692 : ENDIF
693 :
694 : ! Array for pressures (Lal & Peters data)
695 0 : ALLOCATE( Inst%PRESOU( 33 ), STAT=RC )
696 0 : IF ( RC /= 0 ) THEN
697 : CALL HCO_ERROR ( &
698 0 : 'Cannot allocate PRESOU', RC )
699 0 : RETURN
700 : ENDIF
701 :
702 : ! Array for 7Be emissions ( Lal & Peters data)
703 0 : ALLOCATE( Inst%BESOU( 10, 33 ), STAT=RC )
704 0 : IF ( RC /= 0 ) THEN
705 : CALL HCO_ERROR ( &
706 0 : 'Cannot allocate BESOU', RC )
707 0 : RETURN
708 : ENDIF
709 :
710 : ! Initialize the 7Be emisisons data arrays
711 0 : CALL Init_7Be_Emissions( Inst )
712 : ENDIF
713 :
714 0 : IF ( Inst%IDTBe7Strat > 0 ) THEN
715 : ALLOCATE( Inst%EmissBe7Strat( HcoState%Nx, HcoState%NY, HcoState%NZ ), &
716 0 : STAT=RC )
717 0 : IF ( RC /= 0 ) THEN
718 : CALL HCO_ERROR ( &
719 0 : 'Cannot allocate EmissBe7Strat', RC )
720 0 : RETURN
721 : ENDIF
722 0 : Inst%EmissBe7Strat = 0.0_hp
723 : ENDIF
724 :
725 0 : IF ( Inst%IDTBe10 > 0 ) THEN
726 : ALLOCATE( Inst%EmissBe10( HcoState%Nx, HcoState%NY, HcoState%NZ ), &
727 0 : STAT=RC )
728 0 : IF ( RC /= 0 ) THEN
729 : CALL HCO_ERROR ( &
730 0 : 'Cannot allocate EmissBe10', RC )
731 0 : RETURN
732 : ENDIF
733 : ENDIF
734 :
735 0 : IF ( Inst%IDTBe10Strat > 0 ) THEN
736 : ALLOCATE( Inst%EmissBe10Strat( HcoState%Nx, HcoState%NY, HcoState%NZ ), &
737 0 : STAT=RC )
738 0 : IF ( RC /= 0 ) THEN
739 : CALL HCO_ERROR ( &
740 0 : 'Cannot allocate EmissBe10Strat', RC )
741 0 : RETURN
742 : ENDIF
743 0 : Inst%EmissBe10Strat = 0.0_hp
744 : ENDIF
745 :
746 : !=======================================================================
747 : ! Leave w/ success
748 : !=======================================================================
749 0 : IF ( ALLOCATED( HcoIDs ) ) DEALLOCATE( HcoIDs )
750 0 : IF ( ALLOCATED( SpcNames ) ) DEALLOCATE( SpcNames )
751 :
752 : ! Nullify pointers
753 0 : Inst => NULL()
754 :
755 0 : CALL HCO_LEAVE( HcoState%Config%Err,RC )
756 :
757 0 : END SUBROUTINE HCOX_Gc_RnPbBe_Init
758 : !EOC
759 : !------------------------------------------------------------------------------
760 : ! Harmonized Emissions Component (HEMCO) !
761 : !------------------------------------------------------------------------------
762 : !BOP
763 : !
764 : ! !IROUTINE: HCOX_Gc_RnPbBe_Final
765 : !
766 : ! !DESCRIPTION: Subroutine HcoX\_Gc\_RnPbBe\_Final finalizes the HEMCO
767 : ! extension for the GEOS-Chem Rn-Pb-Be specialty simulation. All module
768 : ! arrays will be deallocated.
769 : !\\
770 : !\\
771 : ! !INTERFACE:
772 : !
773 0 : SUBROUTINE HCOX_Gc_RnPbBe_Final( ExtState )
774 : !
775 : ! !INPUT PARAMETERS:
776 : !
777 : TYPE(Ext_State), POINTER :: ExtState ! Module options
778 : !
779 : ! !REVISION HISTORY:
780 : ! 13 Dec 2013 - C. Keller - Now a HEMCO extension
781 : ! See https://github.com/geoschem/hemco for complete history
782 : !EOP
783 : !------------------------------------------------------------------------------
784 : !BOC
785 :
786 : !=======================================================================
787 : ! HCOX_GC_RNPBBE_FINAL begins here!
788 : !=======================================================================
789 :
790 0 : CALL InstRemove ( ExtState%GC_RnPbBe )
791 :
792 0 : END SUBROUTINE HCOX_Gc_RnPbBe_Final
793 : !EOC
794 : !------------------------------------------------------------------------------
795 : ! Harmonized Emissions Component (HEMCO) !
796 : !------------------------------------------------------------------------------
797 : !BOP
798 : !
799 : ! !IROUTINE: Init_7Be_Emissions
800 : !
801 : ! !DESCRIPTION: Subroutine Init\_7Be\_Emissions initializes the 7Be emissions
802 : ! from Lal \& Peters on 33 pressure levels. This data used to be read from
803 : ! a file, but we have now hardwired it to facilitate I/O in the ESMF
804 : ! environment.
805 : !\\
806 : !\\
807 : ! !INTERFACE:
808 : !
809 0 : SUBROUTINE Init_7Be_Emissions( Inst )
810 : !
811 : ! !INPUT PARAMETERS:
812 : !
813 : TYPE(MyInst), POINTER :: Inst ! Instance
814 : !
815 : ! !REMARKS:
816 : ! (1) Reference: Lal, D., and B. Peters, Cosmic ray produced radioactivity
817 : ! on the Earth. Handbuch der Physik, 46/2, 551-612, edited by K. Sitte,
818 : ! Springer-Verlag, New York, 1967.
819 : ! .
820 : ! (2) In prior versions of GEOS-Chem, this routine was named READ_7BE, and
821 : ! it read the ASCII file "7Be.Lal". Because this data set is not placed
822 : ! on a lat/lon grid, ESMF cannot regrid it. To work around this, we now
823 : ! hardwire this data in module arrays rather than read it from disk.
824 : ! .
825 : ! (3) Units of 7Be emissions are [stars/g air/s].
826 : ! Here, "stars" = # of nuclear disintegrations of cosmic rays
827 : ! .
828 : ! (4) Original data from Lal & Peters (1967), w/ these modifications:
829 : ! (a) Replace data at (0hPa, 70S) following Koch 1996:
830 : ! (i ) old value = 3000
831 : ! (ii) new value = 1900
832 : ! (b) Copy data from 70S to 80S and 90S at all levels
833 : ! .
834 : ! !REVISION HISTORY:
835 : ! 07 Aug 2002 - H. Liu - Initial version
836 : ! See https://github.com/geoschem/hemco for complete history
837 : !EOP
838 : !------------------------------------------------------------------------------
839 : !BOC
840 :
841 : ! Define latitudes [degrees North]
842 : Inst%LATSOU = (/ 0.0_hp, 10.0_hp, 20.0_hp, 30.0_hp, &
843 : 40.0_hp, 50.0_hp, 60.0_hp, 70.0_hp, &
844 0 : 80.0_hp, 90.0_hp /)
845 :
846 : ! Define pressures [hPa]
847 : Inst%PRESOU = (/ 0.0_hp, 50.0_hp, 70.0_hp, 90.0_hp, &
848 : 110.0_hp, 130.0_hp, 150.0_hp, 170.0_hp, &
849 : 190.0_hp, 210.0_hp, 230.0_hp, 250.0_hp, &
850 : 270.0_hp, 290.0_hp, 313.0_hp, 338.0_hp, &
851 : 364.0_hp, 392.0_hp, 420.0_hp, 451.0_hp, &
852 : 485.0_hp, 518.0_hp, 555.0_hp, 592.0_hp, &
853 : 633.0_hp, 680.0_hp, 725.0_hp, 772.0_hp, &
854 : 822.0_hp, 875.0_hp, 930.0_hp, 985.0_hp, &
855 0 : 1030.0_hp /)
856 :
857 : ! Define 7Be emissions [stars/g air/s]
858 : ! 1 "star" = 1 nuclear disintegration via cosmic rays
859 : !
860 : ! NOTE: These statements were defined from printout of the file
861 : ! and need to be multiplied by 1d-5 below.
862 0 : Inst%BESOU(:,1) = (/ 150.0_hp, 156.0_hp, 188.0_hp, 285.0_hp, &
863 : 500.0_hp, 910.0_hp, 1700.0_hp, 1900.0_hp, &
864 0 : 1900.0_hp, 1900.0_hp /)
865 :
866 0 : Inst%BESOU(:,2) = (/ 280.0_hp, 310.0_hp, 390.0_hp, 590.0_hp, &
867 : 880.0_hp, 1390.0_hp, 1800.0_hp, 1800.0_hp, &
868 0 : 1800.0_hp, 1800.0_hp /)
869 :
870 0 : Inst%BESOU(:,3) = (/ 310.0_hp, 330.0_hp, 400.0_hp, 620.0_hp, &
871 : 880.0_hp, 1280.0_hp, 1450.0_hp, 1450.0_hp, &
872 0 : 1450.0_hp, 1450.0_hp /)
873 :
874 0 : Inst%BESOU(:,4) = (/ 285.0_hp, 310.0_hp, 375.0_hp, 570.0_hp, &
875 : 780.0_hp, 1100.0_hp, 1180.0_hp, 1180.0_hp, &
876 0 : 1180.0_hp, 1180.0_hp /)
877 :
878 0 : Inst%BESOU(:,5) = (/ 255.0_hp, 275.0_hp, 330.0_hp, 510.0_hp, &
879 : 680.0_hp, 950.0_hp, 1000.0_hp, 1000.0_hp, &
880 0 : 1000.0_hp, 1000.0_hp /)
881 :
882 0 : Inst%BESOU(:,6) = (/ 230.0_hp, 245.0_hp, 292.0_hp, 450.0_hp, &
883 : 600.0_hp, 820.0_hp, 875.0_hp, 875.0_hp, &
884 0 : 875.0_hp, 875.0_hp /)
885 :
886 0 : Inst%BESOU(:,7) = (/ 205.0_hp, 215.0_hp, 260.0_hp, 400.0_hp, &
887 : 530.0_hp, 730.0_hp, 750.0_hp, 750.0_hp, &
888 0 : 750.0_hp, 750.0_hp /)
889 :
890 0 : Inst%BESOU(:,8) = (/ 182.0_hp, 195.0_hp, 235.0_hp, 355.0_hp, &
891 : 480.0_hp, 630.0_hp, 650.0_hp, 650.0_hp, &
892 0 : 650.0_hp, 650.0_hp /)
893 :
894 0 : Inst%BESOU(:,9) = (/ 160.0_hp, 173.0_hp, 208.0_hp, 315.0_hp, &
895 : 410.0_hp, 543.0_hp, 550.0_hp, 550.0_hp, &
896 0 : 550.0_hp, 550.0_hp /)
897 :
898 0 : Inst%BESOU(:,10) = (/ 148.0_hp, 152.0_hp, 185.0_hp, 280.0_hp, &
899 : 370.0_hp, 480.0_hp, 500.0_hp, 500.0_hp, &
900 0 : 500.0_hp, 500.0_hp /)
901 :
902 0 : Inst%BESOU(:,11) = (/ 130.0_hp, 139.0_hp, 167.0_hp, 250.0_hp, &
903 : 320.0_hp, 425.0_hp, 430.0_hp, 430.0_hp, &
904 0 : 430.0_hp, 430.0_hp /)
905 :
906 0 : Inst%BESOU(:,12) = (/ 116.0_hp, 123.0_hp, 148.0_hp, 215.0_hp, &
907 : 285.0_hp, 365.0_hp, 375.0_hp, 375.0_hp, &
908 0 : 375.0_hp, 375.0_hp /)
909 :
910 0 : Inst%BESOU(:,13) = (/ 104.0_hp, 110.0_hp, 130.0_hp, 198.0_hp, &
911 : 250.0_hp, 320.0_hp, 330.0_hp, 330.0_hp, &
912 0 : 330.0_hp, 330.0_hp /)
913 :
914 0 : Inst%BESOU(:,14) = (/ 93.0_hp, 99.0_hp, 118.0_hp, 170.0_hp, &
915 : 222.0_hp, 280.0_hp, 288.0_hp, 288.0_hp, &
916 0 : 288.0_hp, 288.0_hp /)
917 :
918 0 : Inst%BESOU(:,15) = (/ 80.0_hp, 84.0_hp, 100.0_hp, 145.0_hp, &
919 : 190.0_hp, 235.0_hp, 250.0_hp, 250.0_hp, &
920 0 : 250.0_hp, 250.0_hp /)
921 :
922 0 : Inst%BESOU(:,16) = (/ 72.0_hp, 74.0_hp, 88.0_hp, 129.0_hp, &
923 : 168.0_hp, 210.0_hp, 218.0_hp, 218.0_hp, &
924 0 : 218.0_hp, 218.0_hp /)
925 :
926 0 : Inst%BESOU(:,17) = (/ 59.5_hp, 62.5_hp, 73.5_hp, 108.0_hp, &
927 : 138.0_hp, 171.0_hp, 178.0_hp, 178.0_hp, &
928 0 : 178.0_hp, 178.0_hp /)
929 :
930 0 : Inst%BESOU(:,18) = (/ 50.0_hp, 53.0_hp, 64.0_hp, 90.0_hp, &
931 : 115.0_hp, 148.0_hp, 150.0_hp, 150.0_hp, &
932 0 : 150.0_hp, 150.0_hp /)
933 :
934 0 : Inst%BESOU(:,19) = (/ 45.0_hp, 46.5_hp, 52.5_hp, 76.0_hp, &
935 : 98.0_hp, 122.0_hp, 128.0_hp, 128.0_hp, &
936 0 : 128.0_hp, 128.0_hp /)
937 :
938 0 : Inst%BESOU(:,20) = (/ 36.5_hp, 37.5_hp, 45.0_hp, 61.0_hp, &
939 : 77.0_hp, 98.0_hp, 102.0_hp, 102.0_hp, &
940 0 : 102.0_hp, 102.0_hp /)
941 :
942 0 : Inst%BESOU(:,21) = (/ 30.8_hp, 32.0_hp, 37.5_hp, 51.5_hp, &
943 : 65.0_hp, 81.0_hp, 85.0_hp, 85.0_hp, &
944 0 : 85.0_hp, 85.0_hp /)
945 :
946 0 : Inst%BESOU(:,22) = (/ 25.5_hp, 26.5_hp, 32.0_hp, 40.5_hp, &
947 : 54.0_hp, 67.5_hp, 69.5_hp, 69.5_hp, &
948 0 : 69.5_hp, 69.5_hp /)
949 :
950 0 : Inst%BESOU(:,23) = (/ 20.5_hp, 21.6_hp, 25.5_hp, 33.0_hp, &
951 : 42.0_hp, 53.5_hp, 55.0_hp, 55.0_hp, &
952 0 : 55.0_hp, 55.0_hp /)
953 :
954 0 : Inst%BESOU(:,24) = (/ 16.8_hp, 17.3_hp, 20.0_hp, 26.0_hp, &
955 : 33.5_hp, 41.0_hp, 43.0_hp, 43.0_hp, &
956 0 : 43.0_hp, 43.0_hp /)
957 :
958 0 : Inst%BESOU(:,25) = (/ 13.0_hp, 13.8_hp, 15.3_hp, 20.5_hp, &
959 : 26.8_hp, 32.5_hp, 33.5_hp, 33.5_hp, &
960 0 : 33.5_hp, 33.5_hp /)
961 :
962 0 : Inst%BESOU(:,26) = (/ 10.1_hp, 10.6_hp, 12.6_hp, 15.8_hp, &
963 : 20.0_hp, 24.5_hp, 25.8_hp, 25.8_hp, &
964 0 : 25.8_hp, 25.8_hp /)
965 :
966 0 : Inst%BESOU(:,27) = (/ 7.7_hp, 8.15_hp, 9.4_hp, 11.6_hp, &
967 : 14.8_hp, 17.8_hp, 18.5_hp, 18.5_hp, &
968 0 : 18.5_hp, 18.5_hp /)
969 :
970 0 : Inst%BESOU(:,28) = (/ 5.7_hp, 5.85_hp, 6.85_hp, 8.22_hp, &
971 : 11.0_hp, 13.1_hp, 13.2_hp, 13.2_hp, &
972 0 : 13.2_hp, 13.2_hp /)
973 :
974 0 : Inst%BESOU(:,29) = (/ 3.9_hp, 4.2_hp, 4.85_hp, 6.0_hp, &
975 : 7.6_hp, 9.0_hp, 9.2_hp, 9.2_hp, &
976 0 : 9.2_hp, 9.2_hp /)
977 :
978 0 : Inst%BESOU(:,30) = (/ 3.0_hp, 3.05_hp, 3.35_hp, 4.2_hp, &
979 : 5.3_hp, 5.9_hp, 6.25_hp, 6.25_hp, &
980 0 : 6.25_hp, 6.25_hp /)
981 :
982 0 : Inst%BESOU(:,31) = (/ 2.05_hp, 2.1_hp, 2.32_hp, 2.9_hp, &
983 : 3.4_hp, 3.9_hp, 4.1_hp, 4.1_hp, &
984 0 : 4.1_hp, 4.1_hp /)
985 :
986 0 : Inst%BESOU(:,32) = (/ 1.45_hp, 1.43_hp, 1.65_hp, 2.03_hp, &
987 : 2.4_hp, 2.75_hp, 2.65_hp, 2.65_hp, &
988 0 : 2.65_hp, 2.65_hp /)
989 :
990 0 : Inst%BESOU(:,33) = (/ 1.04_hp, 1.08_hp, 1.21_hp, 1.5_hp, &
991 : 1.68_hp, 1.8_hp, 1.8_hp, 1.8_hp, &
992 0 : 1.8_hp, 1.8_hp /)
993 :
994 : ! All the numbers of BESOU need to be multiplied by 1e-5 in order to put
995 : ! them into the correct data range. NOTE: This multiplication statement
996 : ! needs to be preserved here in order to ensure identical output to the
997 : ! prior code! (bmy, 7/7/14)
998 0 : Inst%BESOU = Inst%BESOU * 1.e-5_hp
999 :
1000 0 : END SUBROUTINE Init_7Be_Emissions
1001 : !EOC
1002 : !------------------------------------------------------------------------------
1003 : ! Harmonized Emissions Component (HEMCO) !
1004 : !------------------------------------------------------------------------------
1005 : !BOP
1006 : !
1007 : ! !IROUTINE: SLQ
1008 : !
1009 : ! !DESCRIPTION: Subroutine SLQ is an interpolation subroutine from a
1010 : ! Chinese reference book (says Hongyu Liu).
1011 : !\\
1012 : !\\
1013 : ! !INTERFACE:
1014 : !
1015 0 : SUBROUTINE SLQ( X, Y, Z, N, M, U, V, W )
1016 : !
1017 : ! !INPUT PARAMETERS:
1018 : !
1019 : INTEGER :: N ! First dimension of Z
1020 : INTEGER :: M ! Second dimension of Z
1021 : REAL(hp) :: X(N) ! X-axis coordinate on original grid
1022 : REAL(hp) :: Y(M) ! Y-axis coordinate on original grid
1023 : REAL(hp) :: Z(N,M) ! Array of data on original grid
1024 : REAL(hp) :: U ! X-axis coordinate for desired interpolated value
1025 : REAL(hp) :: V ! Y-axis coordinate for desired interpolated value
1026 : !
1027 : ! !OUTPUT PARAMETERS:
1028 : !
1029 : REAL(hp) :: W ! Interpolated value of Z array, at coords (U,V)
1030 : !
1031 : ! !REMARKS:
1032 : ! This routine was taken from the old RnPbBe_mod.F.
1033 : !
1034 : ! !REVISION HISTORY:
1035 : ! 17 Mar 1998 - H. Liu - Initial version
1036 : ! See https://github.com/geoschem/hemco for complete history
1037 : !EOP
1038 : !------------------------------------------------------------------------------
1039 : !BOC
1040 : !
1041 : ! !LOCAL VARIABLES:
1042 : !
1043 : REAL(hp) :: B(3), HH
1044 : INTEGER :: NN, IP, I, J, L, IQ, K, MM
1045 :
1046 : !=======================================================================
1047 : ! SLQ begins here!
1048 : !=======================================================================
1049 0 : NN=3
1050 0 : IF(N.LE.3) THEN
1051 : IP=1
1052 : NN=N
1053 0 : ELSE IF (U.LE.X(2)) THEN
1054 : IP=1
1055 0 : ELSE IF (U.GE.X(N-1)) THEN
1056 0 : IP=N-2
1057 : ELSE
1058 : I=1
1059 : J=N
1060 0 : 10 IF (IABS(I-J).NE.1) THEN
1061 0 : L=(I+J)/2
1062 0 : IF (U.LT.X(L)) THEN
1063 : J=L
1064 : ELSE
1065 0 : I=L
1066 : END IF
1067 : GOTO 10
1068 : END IF
1069 0 : IF (ABS(U-X(I)).LT.ABS(U-X(J))) THEN
1070 0 : IP=I-1
1071 : ELSE
1072 : IP=I
1073 : END IF
1074 : END IF
1075 0 : MM=3
1076 0 : IF (M.LE.3) THEN
1077 : IQ=1
1078 : MM=N
1079 0 : ELSE IF (V.LE.Y(2)) THEN
1080 : IQ=1
1081 0 : ELSE IF (V.GE.Y(M-1)) THEN
1082 0 : IQ=M-2
1083 : ELSE
1084 : I=1
1085 : J=M
1086 0 : 20 IF (IABS(J-I).NE.1) THEN
1087 0 : L=(I+J)/2
1088 0 : IF (V.LT.Y(L)) THEN
1089 : J=L
1090 : ELSE
1091 0 : I=L
1092 : END IF
1093 : GOTO 20
1094 : END IF
1095 0 : IF (ABS(V-Y(I)).LT.ABS(V-Y(J))) THEN
1096 0 : IQ=I-1
1097 : ELSE
1098 : IQ=I
1099 : END IF
1100 : END IF
1101 0 : DO 50 I=1,NN
1102 0 : B(I)=0.0
1103 0 : DO 40 J=1,MM
1104 0 : HH=Z(IP+I-1,IQ+J-1)
1105 0 : DO 30 K=1,MM
1106 0 : IF (K.NE.J) THEN
1107 0 : HH=HH*(V-Y(IQ+K-1))/(Y(IQ+J-1)-Y(IQ+K-1))
1108 : END IF
1109 0 : 30 CONTINUE
1110 0 : B(I)=B(I)+HH
1111 0 : 40 CONTINUE
1112 0 : 50 CONTINUE
1113 0 : W=0.0
1114 0 : DO 70 I=1,NN
1115 0 : HH=B(I)
1116 0 : DO 60 J=1,NN
1117 0 : IF (J.NE.I) THEN
1118 0 : HH=HH*(U-X(IP+J-1))/(X(IP+I-1)-X(IP+J-1))
1119 : END IF
1120 0 : 60 CONTINUE
1121 0 : W=W+HH
1122 0 : 70 CONTINUE
1123 :
1124 0 : END SUBROUTINE SLQ
1125 : !EOC
1126 : !------------------------------------------------------------------------------
1127 : ! Harmonized Emissions Component (HEMCO) !
1128 : !------------------------------------------------------------------------------
1129 : !BOP
1130 : !
1131 : ! !IROUTINE: InstGet
1132 : !
1133 : ! !DESCRIPTION: Subroutine InstGet returns a poiner to the desired instance.
1134 : !\\
1135 : !\\
1136 : ! !INTERFACE:
1137 : !
1138 0 : SUBROUTINE InstGet ( Instance, Inst, RC, PrevInst )
1139 : !
1140 : ! !INPUT PARAMETERS:
1141 : !
1142 : INTEGER :: Instance
1143 : TYPE(MyInst), POINTER :: Inst
1144 : INTEGER :: RC
1145 : TYPE(MyInst), POINTER, OPTIONAL :: PrevInst
1146 : !
1147 : ! !REVISION HISTORY:
1148 : ! 18 Feb 2016 - C. Keller - Initial version
1149 : ! See https://github.com/geoschem/hemco for complete history
1150 : !EOP
1151 : !------------------------------------------------------------------------------
1152 : !BOC
1153 : TYPE(MyInst), POINTER :: PrvInst
1154 :
1155 : !=================================================================
1156 : ! InstGet begins here!
1157 : !=================================================================
1158 :
1159 : ! Get instance. Also archive previous instance.
1160 0 : PrvInst => NULL()
1161 0 : Inst => AllInst
1162 0 : DO WHILE ( ASSOCIATED(Inst) )
1163 0 : IF ( Inst%Instance == Instance ) EXIT
1164 0 : PrvInst => Inst
1165 0 : Inst => Inst%NextInst
1166 : END DO
1167 0 : IF ( .NOT. ASSOCIATED( Inst ) ) THEN
1168 0 : RC = HCO_FAIL
1169 0 : RETURN
1170 : ENDIF
1171 :
1172 : ! Pass output arguments
1173 0 : IF ( PRESENT(PrevInst) ) PrevInst => PrvInst
1174 :
1175 : ! Cleanup & Return
1176 0 : PrvInst => NULL()
1177 0 : RC = HCO_SUCCESS
1178 :
1179 : END SUBROUTINE InstGet
1180 : !EOC
1181 : !------------------------------------------------------------------------------
1182 : ! Harmonized Emissions Component (HEMCO) !
1183 : !------------------------------------------------------------------------------
1184 : !BOP
1185 : !
1186 : ! !IROUTINE: InstCreate
1187 : !
1188 : ! !DESCRIPTION: Subroutine InstCreate creates a new instance.
1189 : !\\
1190 : !\\
1191 : ! !INTERFACE:
1192 : !
1193 0 : SUBROUTINE InstCreate ( ExtNr, Instance, Inst, RC )
1194 : !
1195 : ! !INPUT PARAMETERS:
1196 : !
1197 : INTEGER, INTENT(IN) :: ExtNr
1198 : !
1199 : ! !OUTPUT PARAMETERS:
1200 : !
1201 : INTEGER, INTENT( OUT) :: Instance
1202 : TYPE(MyInst), POINTER :: Inst
1203 : !
1204 : ! !INPUT/OUTPUT PARAMETERS:
1205 : !
1206 : INTEGER, INTENT(INOUT) :: RC
1207 : !
1208 : ! !REVISION HISTORY:
1209 : ! 18 Feb 2016 - C. Keller - Initial version
1210 : ! See https://github.com/geoschem/hemco for complete history
1211 : !EOP
1212 : !------------------------------------------------------------------------------
1213 : !BOC
1214 : TYPE(MyInst), POINTER :: TmpInst
1215 : INTEGER :: nnInst
1216 :
1217 : !=================================================================
1218 : ! InstCreate begins here!
1219 : !=================================================================
1220 :
1221 : ! ----------------------------------------------------------------
1222 : ! Generic instance initialization
1223 : ! ----------------------------------------------------------------
1224 :
1225 : ! Initialize
1226 0 : Inst => NULL()
1227 :
1228 : ! Get number of already existing instances
1229 0 : TmpInst => AllInst
1230 0 : nnInst = 0
1231 0 : DO WHILE ( ASSOCIATED(TmpInst) )
1232 0 : nnInst = nnInst + 1
1233 0 : TmpInst => TmpInst%NextInst
1234 : END DO
1235 :
1236 : ! Create new instance
1237 0 : ALLOCATE(Inst)
1238 0 : Inst%Instance = nnInst + 1
1239 0 : Inst%ExtNr = ExtNr
1240 :
1241 : ! Attach to instance list
1242 0 : Inst%NextInst => AllInst
1243 0 : AllInst => Inst
1244 :
1245 : ! Update output instance
1246 0 : Instance = Inst%Instance
1247 :
1248 : ! ----------------------------------------------------------------
1249 : ! Type specific initialization statements follow below
1250 : ! ----------------------------------------------------------------
1251 :
1252 : ! Return w/ success
1253 0 : RC = HCO_SUCCESS
1254 :
1255 0 : END SUBROUTINE InstCreate
1256 : !EOC
1257 : !------------------------------------------------------------------------------
1258 : ! Harmonized Emissions Component (HEMCO) !
1259 : !------------------------------------------------------------------------------
1260 : !BOP
1261 : !BOP
1262 : !
1263 : ! !IROUTINE: InstRemove
1264 : !
1265 : ! !DESCRIPTION: Subroutine InstRemove creates a new instance.
1266 : !\\
1267 : !\\
1268 : ! !INTERFACE:
1269 : !
1270 0 : SUBROUTINE InstRemove ( Instance )
1271 : !
1272 : ! !INPUT PARAMETERS:
1273 : !
1274 : INTEGER :: Instance
1275 : !
1276 : ! !REVISION HISTORY:
1277 : ! 18 Feb 2016 - C. Keller - Initial version
1278 : ! See https://github.com/geoschem/hemco for complete history
1279 : !EOP
1280 : !------------------------------------------------------------------------------
1281 : !BOC
1282 : INTEGER :: RC
1283 : TYPE(MyInst), POINTER :: PrevInst
1284 : TYPE(MyInst), POINTER :: Inst
1285 :
1286 : !=================================================================
1287 : ! InstRemove begins here!
1288 : !=================================================================
1289 :
1290 : ! Init
1291 0 : PrevInst => NULL()
1292 0 : Inst => NULL()
1293 :
1294 : ! Get instance. Also archive previous instance.
1295 0 : CALL InstGet ( Instance, Inst, RC, PrevInst=PrevInst )
1296 :
1297 : ! Instance-specific deallocation
1298 0 : IF ( ASSOCIATED(Inst) ) THEN
1299 :
1300 : !---------------------------------------------------------------------
1301 : ! Deallocate fields of Inst before popping Inst off the list
1302 : ! in order to avoid memory leaks (Bob Yantosca, 17 Aug 2020)
1303 : !---------------------------------------------------------------------
1304 0 : IF ( ASSOCIATED( Inst%EmissRn222 ) ) THEN
1305 0 : DEALLOCATE( Inst%EmissRn222 )
1306 : ENDIF
1307 0 : Inst%EmissRn222 => NULL()
1308 :
1309 0 : IF ( ASSOCIATED( Inst%EmissBe7 ) ) THEN
1310 0 : DEALLOCATE( Inst%EmissBe7 )
1311 : ENDIF
1312 0 : Inst%EmissBe7 => NULL()
1313 :
1314 0 : IF ( ASSOCIATED( Inst%EmissBe7Strat ) ) THEN
1315 0 : DEALLOCATE( Inst%EmissBe7Strat )
1316 : ENDIF
1317 0 : Inst%EmissBe7Strat => NULL()
1318 :
1319 0 : IF ( ASSOCIATED( Inst%EmissBe10 ) ) THEN
1320 0 : DEALLOCATE(Inst%EmissBe10 )
1321 : ENDIF
1322 0 : Inst%EmissBe10 => NULL()
1323 :
1324 0 : IF ( ASSOCIATED( Inst%EmissBe10Strat ) ) THEN
1325 0 : DEALLOCATE( Inst%EmissBe10Strat )
1326 : ENDIF
1327 0 : Inst%EmissBe10Strat => NULL()
1328 :
1329 0 : IF ( ASSOCIATED( Inst%LATSOU ) ) THEN
1330 0 : DEALLOCATE( Inst%LATSOU )
1331 : ENDIF
1332 0 : Inst%LATSOU => NULL()
1333 :
1334 0 : IF ( ASSOCIATED( Inst%PRESOU ) ) THEN
1335 0 : DEALLOCATE(Inst%PRESOU )
1336 : ENDIF
1337 0 : Inst%PRESOU => NULL()
1338 :
1339 0 : IF ( ASSOCIATED( Inst%BESOU ) ) THEN
1340 0 : DEALLOCATE( Inst%BESOU )
1341 : ENDIF
1342 0 : Inst%BESOU => NULL()
1343 :
1344 : !---------------------------------------------------------------------
1345 : ! Pop off instance from list
1346 : !---------------------------------------------------------------------
1347 0 : IF ( ASSOCIATED(PrevInst) ) THEN
1348 0 : PrevInst%NextInst => Inst%NextInst
1349 : ELSE
1350 0 : AllInst => Inst%NextInst
1351 : ENDIF
1352 0 : DEALLOCATE(Inst)
1353 :
1354 : ENDIF
1355 :
1356 : ! Free pointers before exiting
1357 0 : PrevInst => NULL()
1358 0 : Inst => NULL()
1359 :
1360 0 : END SUBROUTINE InstRemove
1361 : !EOC
1362 0 : END MODULE HCOX_GC_RnPbBe_Mod
|